geom circle
Evangeline Reynolds
8/6/2022
R Markdown
library(ggplot2)
library(tidyverse)
my_setup <- function(data, params){
if(data$group[1] == -1){
nrows <- nrow(data)
data$group <- seq_len(nrows)
}
data
}
cars %>%
mutate(group = -1L) %>% # specifies
my_setup()
my_setup <- function(data, params) {
if (anyDuplicated(data$group)) {
data$group <- paste(data$group, seq_len(nrow(data)), sep = "-")
}
data
}
cars %>%
mutate(group = -1L) %>%
my_setup()
my_compute_panel <- function(data, scales, n = 5, r = 1){
angles <- seq(
from = 0,
to = 2*pi,
length.out = n + 1
)
nrows = nrow(data)
df <- data.frame()
for(i in 1:nrows){
bind_rows(df,
data.frame(
x = cos(angles) * data$r[i] + data$x0[i],
y = cos(angles) * data$r[i] + data$y0[i],
group = i
)
) ->
df
}
}
cars %>%
rename(x0 = dist) %>%
rename(y0 = speed) %>%
mutate(r = y0/12) %>%
my_compute_panel
StatCircle <- ggproto(`_class` = 'StatCircle',
`_inherit` = Stat,
setup_data = my_setup,
compute_panel = my_compute_panel,
required_aes = c('x0', 'y0', 'r'))
geom_circle <- function(mapping = NULL, data = NULL, stat = "circle",
position = "identity", ..., r = 1,
n = 50, 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(
r = r,
n = n,
arrow = arrow,
lineend = lineend,
linejoin = linejoin,
na.rm = na.rm,
...
)
)
}
ggplot(cars) +
aes(x = speed) +
aes(y = dist) +
geom_point() +
aes(r = dist, x0 = speed, y0 = dist) +
geom_circle()https://evamaerey.github.io/flipbooks/extending_ggplot2.html#86
library(ggplot2)
library(tidyverse)## ── Attaching core tidyverse packages ─────────────────── tidyverse 2.0.0.9000 ──
## ✔ dplyr 1.1.0 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ lubridate 1.9.2 ✔ tibble 3.2.1
## ✔ purrr 1.0.1 ✔ tidyr 1.3.0
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorscreate_circle <- function(x0, y0, r = 1, n = 100){
angels <- seq(
from = 0,
to = 2*pi,
length.out = n + 1
)
data.frame(
x = cos(angels) * r + x0,
y = sin(angels) * r + y0
)
}
the_compute_panel <- function(data, scales, r = 1, n = 50) {
cols_to_keep <- setdiff(names(data), c("x0", "y0"))
circles <- lapply(seq_len(nrow(data)), function(i) {
circles_path <- create_circle(data$x0[i], data$y0[i], data$r[i], n)
cbind(circles_path, unclass(data[i, cols_to_keep]))
})
do.call(rbind, circles)
}
cars %>%
.[1:2,] %>%
rename(x0 = speed) %>%
rename(y0 = dist) %>%
mutate(r = y0) %>%
mutate(group = row_number()) %>%
the_compute_panel(n = 5)## x y r group
## 1 6.000000 2.00000000 2 1
## 2 4.618034 3.90211303 2 1
## 3 2.381966 3.17557050 2 1
## 4 2.381966 0.82442950 2 1
## 5 4.618034 0.09788697 2 1
## 6 6.000000 2.00000000 2 1
## 7 14.000000 10.00000000 10 2
## 8 7.090170 19.51056516 10 2
## 9 -4.090170 15.87785252 10 2
## 10 -4.090170 4.12214748 10 2
## 11 7.090170 0.48943484 10 2
## 12 14.000000 10.00000000 10 2the_setup_data <- function(data, params) {
if (anyDuplicated(data$group)) {
data$group <- paste(data$group, seq_len(nrow(data)), sep = "-")
}
data
}
cars %>%
.[1:2,] %>%
mutate(group = row_number()) %>%
the_setup_data()## speed dist group
## 1 4 2 1
## 2 4 10 2StatCircle <- ggproto("StatCircle", Stat,
# setup_params = function(data, params) {
# if (is.null(params$r)) {
# params$r <- 1
# } else if (params$r == 0) {
# rlang::abort("Circles cannot be defined with a radius of 0")
# }
# if (is.null(params$n)) {
# params$n <- 50
# } else if (params$n <= 0) {
# rlang::abort("Circles must be defined with `n` greater than 0")
# }
# params
# },
setup_data = the_setup_data,
compute_panel = the_compute_panel,
required_aes = c("x0", "y0", "r")
)
geom_circle <- function(mapping = NULL, data = NULL, stat = "circle",
position = "identity", ..., r = 1,
n = 50, 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(
r = r,
n = n,
arrow = arrow,
lineend = lineend,
linejoin = linejoin,
na.rm = na.rm,
...
)
)
}
set.seed(1244)
cars %>%
.[1:5,] %>%
ggplot() +
aes(x = speed, y = dist) +
geom_point() +
aes(x0 = speed, y0 = dist, r = dist^.5) +
geom_circle(n = 3, alpha = .2) +
geom_circle(n = 13, alpha = .2) +
geom_circle(r = 2, alpha = .2) +
geom_circle(alpha = .2)## Warning in geom_circle(n = 3, alpha = 0.2): Ignoring unknown parameters:
## `arrow`## Warning in geom_circle(n = 13, alpha = 0.2): Ignoring unknown parameters:
## `arrow`## Warning in geom_circle(r = 2, alpha = 0.2): Ignoring unknown parameters:
## `arrow`## Warning in geom_circle(alpha = 0.2): Ignoring unknown parameters: `arrow`## Warning: Duplicated aesthetics after name standardisation: x and y
## Duplicated aesthetics after name standardisation: x and y
## 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
## Warning in validDetails.polygon(x): NAs introduced by coercion
## Warning in validDetails.polygon(x): NAs introduced by coercion
layer_data(last_plot(), 2)## Warning: Duplicated aesthetics after name standardisation: x and y## Warning: Duplicated aesthetics after name standardisation: x and y
## Duplicated aesthetics after name standardisation: x and y
## Duplicated aesthetics after name standardisation: x and y## x y r x.1 y.1 PANEL group colour fill linewidth
## 1 5.414214 2.0000000 1.414214 4 2 1 -1-1 NA grey20 0.5
## 2 3.292893 3.2247449 1.414214 4 2 1 -1-1 NA grey20 0.5
## 3 3.292893 0.7752551 1.414214 4 2 1 -1-1 NA grey20 0.5
## 4 5.414214 2.0000000 1.414214 4 2 1 -1-1 NA grey20 0.5
## 5 7.162278 10.0000000 3.162278 4 10 1 -1-2 NA grey20 0.5
## 6 2.418861 12.7386128 3.162278 4 10 1 -1-2 NA grey20 0.5
## 7 2.418861 7.2613872 3.162278 4 10 1 -1-2 NA grey20 0.5
## 8 7.162278 10.0000000 3.162278 4 10 1 -1-2 NA grey20 0.5
## 9 9.000000 4.0000000 2.000000 7 4 1 -1-3 NA grey20 0.5
## 10 6.000000 5.7320508 2.000000 7 4 1 -1-3 NA grey20 0.5
## 11 6.000000 2.2679492 2.000000 7 4 1 -1-3 NA grey20 0.5
## 12 9.000000 4.0000000 2.000000 7 4 1 -1-3 NA grey20 0.5
## 13 11.690416 22.0000000 4.690416 7 22 1 -1-4 NA grey20 0.5
## 14 4.654792 26.0620192 4.690416 7 22 1 -1-4 NA grey20 0.5
## 15 4.654792 17.9379808 4.690416 7 22 1 -1-4 NA grey20 0.5
## 16 11.690416 22.0000000 4.690416 7 22 1 -1-4 NA grey20 0.5
## 17 12.000000 16.0000000 4.000000 8 16 1 -1-5 NA grey20 0.5
## 18 6.000000 19.4641016 4.000000 8 16 1 -1-5 NA grey20 0.5
## 19 6.000000 12.5358984 4.000000 8 16 1 -1-5 NA grey20 0.5
## 20 12.000000 16.0000000 4.000000 8 16 1 -1-5 NA grey20 0.5
## linetype alpha
## 1 1 0.2
## 2 1 0.2
## 3 1 0.2
## 4 1 0.2
## 5 1 0.2
## 6 1 0.2
## 7 1 0.2
## 8 1 0.2
## 9 1 0.2
## 10 1 0.2
## 11 1 0.2
## 12 1 0.2
## 13 1 0.2
## 14 1 0.2
## 15 1 0.2
## 16 1 0.2
## 17 1 0.2
## 18 1 0.2
## 19 1 0.2
## 20 1 0.2