Status Quo
library(tidyverse)
compute_panel_radar <- function(data, scales, rating_norm = T){
data |>
mutate(cat_numeric = cat |> as.factor() |> as.numeric()) |>
mutate(around = -2*pi*(cat_numeric-1)/max(cat_numeric)+pi/2) |>
mutate(rating_norm = 100*rating/max(rating)) |>
mutate(x = cos(around) * (rating_norm),
y = sin(around) * (rating_norm))
}
compute_panel_web <- function(data, scales, rating_norm = 0:5*20){
marked_ratings_df <- data.frame(rating_norm = rating_norm)
data |>
mutate(cat_numeric = cat |> as.factor() |> as.numeric()) |>
mutate(around = -2*pi*(cat_numeric-1)/max(cat_numeric)+pi/2) |>
crossing(marked_ratings_df) |>
mutate(x = cos(around) * rating_norm,
y = sin(around) * rating_norm) ->
d
d |>
bind_rows(d |> filter(around == pi/2)) |>
arrange(rating_norm) |>
mutate(group = rating_norm)
}
compute_panel_web_spokes <- function(data, scales, rating_norm = 100){
data |>
mutate(cat_numeric = cat |> as.factor() |> as.numeric()) |>
mutate(around = -2*pi*(cat_numeric-1)/max(cat_numeric)+pi/2) |>
# mutate(rating_norm = (rating - min(rating))/(max(rating)-min(rating)) + .5) |>
mutate(x = cos(around) * rating_norm,
y = sin(around) * rating_norm) |>
mutate(xend = 0, yend = 0)
}
library(statexpress)
tribble(~cat, ~rating, ~group,
"geom_*", 20, "ggforce42",
"stat_*", 25, "ggforce42",
"theme_*", 15, "ggforce42",
"coord_*", 5, "ggforce42",
"facet_*", 12, "ggforce42",
"geom_*", 10, "cowplot33",
"stat_*", 15, "cowplot33",
"theme_*", 30, "cowplot33",
"coord_*", 12, "cowplot33",
"facet_*", 3, "cowplot33"
) |>
ggplot() +
labs(title = "toy data") +
aes(cat = cat, rating = rating, group = group, fill = group, color = group) +
# geom_radar_web
qlayer(stat = qstat_panel(compute_panel_web),
geom = GeomPath, alpha = .7, color = "grey") +
qlayer(stat = qstat_panel(compute_panel_web_spokes),
geom = GeomSegment, alpha = .7, color = "grey") +
# geom_radar_cats
qlayer(stat = qstat_panel(compute_panel_web,
default_aes = aes(label = after_stat(cat))),
geom = GeomLabel, rating_norm = 100, linewidth = 0,
fill = NA, vjust = "outward", hjust = "outward", color = "darkgrey") +
qlayer(stat = qstat_panel(compute_panel_web),
geom = GeomBlank, rating_norm = 170) +
coord_equal() +
theme_classic() +
# geom_radar
qlayer(stat = qstat_panel(compute_panel_radar),
geom = qproto_update(GeomPolygon,
aes(alpha = .2,
color = from_theme(ink)))) +
# geom_radar_point
qlayer(stat = qstat_panel(compute_panel_radar),
geom = GeomPoint)
last_plot() +
facet_wrap(~group) +
# geom_radar_label
qlayer(stat = qstat_panel(compute_panel_radar),
geom = GeomLabel, hjust = "outward", vjust = "outward", fill = NA, linewidth = 0,
aes(label = rating))
Experiment
#' stat_radar
#'
#' @param mapping []
#' @param data []
#' @param geom []
#' @param position []
#' @param na.rm []
#' @param show.legend []
#' @param inherit.aes []
#' @param ... []
#'
#' @return theme
#' @export
stat_radar <- function(
mapping = NULL,
data = NULL,
geom = "path",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
) {
ggplot2::layer(
stat = StatRadar,
data = data,
mapping = mapping,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
...
)
)
}
#' @rdname stat_radar
#' @export
geom_radar <- function(
mapping = NULL,
data = NULL,
geom = "point",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
) {
list(
stat_radar(
mapping = mapping,
data = data,
geom = "path",
position = "identity",
na.rm = na.rm,
show.legend = show.legend,
inherit.aes = inherit.aes,
...
),
stat_radar(
mapping = mapping,
data = data,
geom = "point",
position = "identity",
na.rm = TRUE,
show.legend = show.legend,
inherit.aes = inherit.aes,
...
)
)
}
#' @rdname stat_radar
#'
#' @format NULL
#' @usage NULL
#'
#' @export
StatRadar <- ggplot2::ggproto("StatRadar", ggplot2::Stat,
required_aes = c("x", "y"),
setup_data = function(data, params) {
max_x <- max(data$x)
data %>%
dplyr::mutate(
x = purrr::map_if(
.x = x,
.p = ~.x==1,
.f = ~c(.x, 13)
)
) %>%
tidyr::unnest() %>%
dplyr::arrange(x)
},
compute_group = function(data, scales, params) {
data
}
)
#' @rdname stat_radar
#'
#' @format NULL
#' @usage NULL
#'
#' @export
StatRadarMajor <- ggplot2::ggproto("StatRadarMajor", ggplot2::Stat,
required_aes = "y",
setup_params = function(data, params) {
if (is.null(params$ymax)) {
params$ymax <- max(data$y, na.rm = TRUE)
}
params
},
compute_group = function(data, scales, params, ymax) {
tmp <- scales::pretty_breaks(5)(c(0, ymax))
data.frame(yintercept = tmp)
}
)
#' @rdname stat_radar
#'
#' @format NULL
#' @usage NULL
#'
#' @export
StatRadarMinor <- ggplot2::ggproto("StatRadarMinor", ggplot2::Stat,
required_aes = "y",
setup_params = function(data, params) {
if (is.null(params$ymax)) {
params$ymax <- max(data$y, na.rm = TRUE)
}
params
},
compute_group = function(data, scales, params, ymax) {
tmp <- scales::pretty_breaks(5)(c(0, ymax))
data.frame(yintercept = tmp[-length(tmp)] + diff(tmp)/2)
}
)
#' annotation_radar
#'
#' @param mapping []
#' @param data []
#' @param na.rm []
#' @param inherit.aes []
#' @param abbreviate.month []
#' @param locale []
#' @param colour []
#' @param ymax []
#' @param ... []
#'
#' @return gg
#' @export
annotation_radar <- function(
mapping = NULL,
data = NULL,
na.rm = TRUE,
inherit.aes = TRUE,
abbreviate.month = TRUE,
locale = readr::locale(),
colour = "white",
ymax = NULL,
...
) {
list(
# ggplot2::layer(
# stat = StatRadarMajor,
# data = data,
# mapping = mapping[-grep("colo[u]*r", names(mapping))],
# geom = ggplot2::GeomHline,
# position = ggplot2::PositionIdentity,
# show.legend = FALSE,
# inherit.aes = inherit.aes,
# params = list(na.rm = na.rm, size = 0.4, ymax = ymax, colour = colour, ...)
# ),
# ggplot2::layer(
# stat = StatRadarMinor,
# data = data,
# mapping = mapping[-grep("colo[u]*r", names(mapping))],
# geom = ggplot2::GeomHline,
# position = ggplot2::PositionIdentity,
# show.legend = FALSE,
# inherit.aes = inherit.aes,
# params = list(na.rm = na.rm, size = 0.2, ymax = ymax, colour = colour, ...)
# ),
ggplot2::layer(
stat = ggplot2::StatIdentity,
data = data.frame(xintercept = 1:13),
mapping = ggplot2::aes_all("xintercept"),
geom = ggplot2::GeomVline,
position = ggplot2::PositionIdentity,
show.legend = FALSE,
inherit.aes = FALSE,
params = list(na.rm = na.rm, size = 0.4, colour = colour, ...)
),
ggplot2::coord_polar(theta = "x"),
ggplot2::theme(
axis.text.y = ggplot2::element_blank(),
axis.title = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank(),
axis.line = ggplot2::element_blank(),
panel.grid = ggplot2::element_blank(),
panel.border = ggplot2::element_blank()
),
ggplot2::scale_y_continuous(
limits = c(0, NA),
expand = ggplot2::expand_scale(mult = c(0, 0.05))
),
ggplot2::scale_x_continuous(
breaks = 1:12,
labels = if (abbreviate.month) locale$date_names$mon_ab else locale$date_names$mon,
expand = c(0, 0)
)
)
}
library(tidyverse)
tibble(x = rep(c(1,2,3), 2),
y = rep(c(1,2,3), 2),
id = c(1,1,1,2,2,2) ) |>
slice(1:3) |>
ggplot() +
aes(x = x, y = y) +
geom_radar() +
annotation_radar() +
stat_radar()
## 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: `expand_scale()` was deprecated in ggplot2 3.3.0.
## ℹ Please use `expansion()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
## Warning: `cols` is now required when using `unnest()`.
## ℹ Please use `cols = c(x)`.
## `cols` is now required when using `unnest()`.
## ℹ Please use `cols = c(x)`.
## `cols` is now required when using `unnest()`.
## ℹ Please use `cols = c(x)`.
