geom_diamond()
Evangeline Reynolds
8/6/2022
step 0: get it done with base ggplot2
create_diamond <- function(x0, y0, width = 1, height = 1){
data.frame(
x = c(x0 + width, x0, x0 - width, x0, x0 + width),
y = c(y0, y0 + height, y0, y0 - height , y0)
)
}
cars %>%
.[1:5,] %>%
mutate(diamond = purrr::map2(speed, dist, create_diamond)) %>%
mutate(group = row_number()) %>%
unnest() %>%
ggplot() +
geom_point(data = cars[1:5,], aes(x = speed, y = dist)) +
geom_path(aes(x = x, y = y, group = group))## Warning: `cols` is now required when using `unnest()`.
## ℹ Please use `cols = c(diamond)`.
step 1a: write set up data function
setup_data_diamonds <- function(data, params) {
if (anyDuplicated(data$group)) {
data$group <- paste(data$group, seq_len(nrow(data)), sep = "-")
}
data
}step 1b: test set up data function
cars %>%
.[1:2,] %>%
mutate(group = row_number()) %>%
setup_data_diamonds()## speed dist group
## 1 4 2 1
## 2 4 10 2step 2a: write compute panel function
step2a.01 write row processing function
in this case we write a function to process each row for the data
create_diamond <- function(x0, y0, width = 1, height = 1){
data.frame(
x = c(x0 + width, x0, x0 - width, x0, x0 + width),
y = c(y0, y0 + height, y0, y0 - height , y0)
)
}step2a.02 test row processing function
create_diamond(1, 2)## x y
## 1 2 2
## 2 1 3
## 3 0 2
## 4 1 1
## 5 2 2create_diamond(4, 5)## x y
## 1 5 5
## 2 4 6
## 3 3 5
## 4 4 4
## 5 5 5step 2a.03 the compute panel function
This function takes a full data frame, goes through each of the rows, and uses the row processing function on each, and returns a data frame
compute_panel_diamonds <- function(data, scales) {
cols_to_keep <- setdiff(names(data), c("x0", "y0"))
diamonds <- lapply(seq_len(nrow(data)), function(i) {
diamonds_path <- create_diamond(data$x0[i], data$y0[i])
cbind(diamonds_path, unclass(data[i, cols_to_keep]))
})
do.call(rbind, diamonds)
}
compute_panel_diamonds2 <- function(){
cols_to_keep <- setdiff(names(data), c("x0", "y0"))
data %>%
select(x0, y0) %>%
mutate(diamond = purrr::map2(x0, y0, create_diamond)) %>%
mutate(group = row_number()) %>%
unnest() %>%
ungroup() %>%
select(x, y, group)
}step 2b: Test the compute_panel
cars %>%
.[1:2,] %>%
rename(x0 = speed) %>%
rename(y0 = dist) %>%
mutate(group = row_number()) %>%
compute_panel_diamonds()## x y unclass(data[i, cols_to_keep])
## 1 5 2 1
## 2 4 3 1
## 3 3 2 1
## 4 4 1 1
## 5 5 2 1
## 6 5 10 2
## 7 4 11 2
## 8 3 10 2
## 9 4 9 2
## 10 5 10 2Step 3: write ggproto
StatDiamond <- ggproto("StatDiamond", Stat,
setup_data = setup_data_diamonds,
compute_panel = compute_panel_diamonds,
required_aes = c("x0", "y0")
)Step 4: write c
geom_diamond <- function(mapping = NULL,
data = NULL,
stat = "diamond",
position = "identity",
...,
width = 1,
height = 1,
arrow = NULL,
lineend = "butt",
linejoin = "round",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomPolygon,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
width = width,
height = height,
arrow = arrow,
lineend = lineend,
linejoin = linejoin,
na.rm = na.rm,
...
)
)
}Step 5: Enjoy!
set.seed(1244)
cars %>%
.[1:5,] %>%
ggplot() +
aes(x = speed, y = dist) +
geom_point() +
aes(x0 = speed, y0 = dist) +
geom_diamond(alpha = .2) +
aes(fill = speed > 6) +
geom_diamond(height = 2, alpha = 0, color = "black")## Warning in geom_diamond(alpha = 0.2): Ignoring unknown parameters: `width`,
## `height`, and `arrow`## Warning in geom_diamond(height = 2, alpha = 0, color = "black"): Ignoring
## unknown parameters: `width`, `height`, and `arrow`## Warning: Duplicated aesthetics after name standardisation: x and y
## Duplicated aesthetics after name standardisation: x and y## Warning in validDetails.polygon(x): NAs introduced by coercion
## Warning in validDetails.polygon(x): NAs introduced by coercion
Step 6: Post Mordem using layer_data
layer_data(last_plot(), 2)## Warning: Duplicated aesthetics after name standardisation: x and y
## Duplicated aesthetics after name standardisation: x and y## fill x y PANEL group colour linewidth linetype alpha
## 1 #F8766D 5 2 1 1-1 NA 0.5 1 0.2
## 2 #F8766D 4 3 1 1-1 NA 0.5 1 0.2
## 3 #F8766D 3 2 1 1-1 NA 0.5 1 0.2
## 4 #F8766D 4 1 1 1-1 NA 0.5 1 0.2
## 5 #F8766D 5 2 1 1-1 NA 0.5 1 0.2
## 6 #F8766D 5 10 1 1-2 NA 0.5 1 0.2
## 7 #F8766D 4 11 1 1-2 NA 0.5 1 0.2
## 8 #F8766D 3 10 1 1-2 NA 0.5 1 0.2
## 9 #F8766D 4 9 1 1-2 NA 0.5 1 0.2
## 10 #F8766D 5 10 1 1-2 NA 0.5 1 0.2
## 11 #00BFC4 8 4 1 2-3 NA 0.5 1 0.2
## 12 #00BFC4 7 5 1 2-3 NA 0.5 1 0.2
## 13 #00BFC4 6 4 1 2-3 NA 0.5 1 0.2
## 14 #00BFC4 7 3 1 2-3 NA 0.5 1 0.2
## 15 #00BFC4 8 4 1 2-3 NA 0.5 1 0.2
## 16 #00BFC4 8 22 1 2-4 NA 0.5 1 0.2
## 17 #00BFC4 7 23 1 2-4 NA 0.5 1 0.2
## 18 #00BFC4 6 22 1 2-4 NA 0.5 1 0.2
## 19 #00BFC4 7 21 1 2-4 NA 0.5 1 0.2
## 20 #00BFC4 8 22 1 2-4 NA 0.5 1 0.2
## 21 #00BFC4 9 16 1 2-5 NA 0.5 1 0.2
## 22 #00BFC4 8 17 1 2-5 NA 0.5 1 0.2
## 23 #00BFC4 7 16 1 2-5 NA 0.5 1 0.2
## 24 #00BFC4 8 15 1 2-5 NA 0.5 1 0.2
## 25 #00BFC4 9 16 1 2-5 NA 0.5 1 0.2layer_data(last_plot(), 3)## Warning: Duplicated aesthetics after name standardisation: x and y
## Duplicated aesthetics after name standardisation: x and y## fill x y PANEL group colour linewidth linetype alpha
## 1 #F8766D 5 2 1 1-1 black 0.5 1 0
## 2 #F8766D 4 3 1 1-1 black 0.5 1 0
## 3 #F8766D 3 2 1 1-1 black 0.5 1 0
## 4 #F8766D 4 1 1 1-1 black 0.5 1 0
## 5 #F8766D 5 2 1 1-1 black 0.5 1 0
## 6 #F8766D 5 10 1 1-2 black 0.5 1 0
## 7 #F8766D 4 11 1 1-2 black 0.5 1 0
## 8 #F8766D 3 10 1 1-2 black 0.5 1 0
## 9 #F8766D 4 9 1 1-2 black 0.5 1 0
## 10 #F8766D 5 10 1 1-2 black 0.5 1 0
## 11 #00BFC4 8 4 1 2-3 black 0.5 1 0
## 12 #00BFC4 7 5 1 2-3 black 0.5 1 0
## 13 #00BFC4 6 4 1 2-3 black 0.5 1 0
## 14 #00BFC4 7 3 1 2-3 black 0.5 1 0
## 15 #00BFC4 8 4 1 2-3 black 0.5 1 0
## 16 #00BFC4 8 22 1 2-4 black 0.5 1 0
## 17 #00BFC4 7 23 1 2-4 black 0.5 1 0
## 18 #00BFC4 6 22 1 2-4 black 0.5 1 0
## 19 #00BFC4 7 21 1 2-4 black 0.5 1 0
## 20 #00BFC4 8 22 1 2-4 black 0.5 1 0
## 21 #00BFC4 9 16 1 2-5 black 0.5 1 0
## 22 #00BFC4 8 17 1 2-5 black 0.5 1 0
## 23 #00BFC4 7 16 1 2-5 black 0.5 1 0
## 24 #00BFC4 8 15 1 2-5 black 0.5 1 0
## 25 #00BFC4 9 16 1 2-5 black 0.5 1 0