another experiment
Evangeline Reynolds
2026-10-12
Intro Thoughts
Status Quo
library(tidyverse)adapting the semantic positional aesthetic approach of scale_geometry() to non deterministic color translation
scale_fill_semantic <- function(data = NULL, id = NULL, fill_guide = "none", ...) {
transform <- new_fill_transform(data, id)
scale <- discrete_scale(
aesthetics = "fill",
...,
palette = scales::pal_identity(),
guide = fill_guide,
super = ScaleDiscreteSemantic
)
ggproto(NULL, scale, trans = transform)
}
ScaleDiscreteSemantic <- ggproto(
"ScaleDiscreteSemantic", ScaleDiscreteIdentity,
transform = function(self, x) {
self$trans(x)
}
)
new_fill_transform <- function(data, id, call = rlang::caller_call()) {
force(call)
# check_inherits(data, "sf")
ggplot2:::check_string(id)
columns <- colnames(data)
if (!id %in% columns) {
cli::cli_abort("{.arg id} must be a column in {.arg data}.", call = call)
}
geom_col <- which(names(data) == ".color")
if (is.integer(geom_col)) {
geom_col <- columns[geom_col]
}
if (!geom_col %in% columns) {
cli::cli_abort(
"{.arg data} must have a geometry column of type {.cls sfc}.",
call = call
)
}
if (identical(id, geom_col)) {
cli::cli_abort(
"{.arg id} cannot be the geometry column in {.arg data}.",
call = call
)
}
function(x) {
if (inherits(x, "sfc")) {
return(x)
}
matches <- vctrs::vec_locate_matches(x, data[[id]])
if (nrow(matches) < 1 || all(is.na(matches$haystack))) {
cli::cli_abort(
"No values match the {.var {id}} column in the spatial data.",
call = call
)
}
if (vctrs::vec_duplicate_any(matches$needles)) {
groups <- vctrs::vec_split(data[[geom_col]][matches$haystack], matches$needles)
vctrs::vec_c(!!!lapply(groups$val, sf::st_combine))
} else {
data[[geom_col]][matches$haystack] |> unique()
}
}
}# this is a placeholder, demo. But, what would happen instead would be the translation on x to colors via an LLM tool like MALL.
semantic_df <- tribble(~animal, ~.color,
"cat", "goldenrod",
"piglet", "pink",
"dolphin", "grey",
"peacock", "blue",
"dog", "brown")
tribble(~animal, ~count,
"cat", 1,
"peacock", 2,
"piglet", 3) |>
ggplot() +
aes(fill = animal,
x = animal,
y = count) +
geom_col()
last_plot() +
scale_fill_semantic(data = semantic_df, id = "animal") #neither argument would be required...
layer_data()## x y fill PANEL group flipped_aes ymin ymax xmin xmax colour linewidth
## 1 1 1 goldenrod 1 1 FALSE 0 1 0.55 1.45 NA 0.5
## 2 2 2 blue 1 2 FALSE 0 2 1.55 2.45 NA 0.5
## 3 3 3 pink 1 3 FALSE 0 3 2.55 3.45 NA 0.5
## linetype alpha width
## 1 1 NA 0.9
## 2 1 NA 0.9
## 3 1 NA 0.9p <- last_plot()
p <- last_plot()
last_plot() +
scale_fill_semantic(data = semantic_df, id = "animal", fill_guide = "legend")## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.
tribble(~animal,
"cat",
"peacock",
"piglet",
"cat") |>
ggplot() +
aes(fill = animal,
x = animal) +
geom_bar()
last_plot() +
scale_fill_semantic(data = semantic_df, id = "animal") ## Error in `[<-.data.frame`(`*tmp*`, names(transformed), value = list(fill = c("goldenrod", : replacement element 1 has 3 rows, need 4For reference the code verbatim https://github.com/tidyverse/ggplot2/blob/poc_geometry_scale/R/scale-geometry.R
scale_geometry_discrete <- function(data = NULL, id = NULL, ...) {
check_installed("sf")
transform <- new_geometry_transform(data, id)
scale <- discrete_scale(
aesthetics = "geometry",
...,
palette = pal_identity(),
guide = "none",
super = ScaleDiscreteGeometry
)
ggproto(NULL, scale, trans = transform)
}
ScaleDiscreteGeometry <- ggproto(
"ScaleGeometry", ScaleDiscreteIdentity,
transform = function(self, x) {
self$trans(x)
}
)
new_geometry_transform <- function(data, id, call = caller_call()) {
force(call)
check_inherits(data, "sf")
check_string(id)
columns <- colnames(data)
if (!id %in% columns) {
cli::cli_abort("{.arg id} must be a column in {.arg data}.", call = call)
}
geom_col <- geom_column(data)
if (is.integer(geom_col)) {
geom_col <- columns[geom_col]
}
if (!geom_col %in% columns) {
cli::cli_abort(
"{.arg data} must have a geometry column of type {.cls sfc}.",
call = call
)
}
if (identical(id, geom_col)) {
cli::cli_abort(
"{.arg id} cannot be the geometry column in {.arg data}.",
call = call
)
}
function(x) {
if (inherits(x, "sfc")) {
return(x)
}
matches <- vec_locate_matches(x, data[[id]])
if (nrow(matches) < 1 || all(is.na(matches$haystack))) {
cli::cli_abort(
"No values match the {.var {id}} column in the spatial data.",
call = call
)
}
if (vec_duplicate_any(matches$needles)) {
groups <- vec_split(data[[geom_col]][matches$haystack], matches$needles)
vec_c(!!!lapply(groups$val, sf::st_combine))
} else {
data[[geom_col]][matches$haystack]
}
}
}scale manual experiment: it feels like scale_manual() should almost handle this…?
tribble(~animal, ~count,
"cat", 1,
"peacock", 2,
"piglet", 3) |>
ggplot() +
aes(fill = animal,
x = animal,
y = count) +
geom_col() +
scale_fill_semantic(full_palette = c("green", "orange", "blue", "red", "pink"))pseudo code - if manual would do this translation
tribble(~animal, ~count,
"cat", 1,
"peacock", 2,
"piglet", 3) |>
ggplot() +
aes(fill = animal,
x = animal,
y = count) +
geom_col() +
scale_fill_manual(values = function(x){x |> }) # where x is discrete value to be represented by scale## Error in parse(text = input): <text>:10:47: unexpected '}'
## 9: geom_col() +
## 10: scale_fill_manual(values = function(x){x |> }
## ^data <- tribble(~animal, ~count,
"cat", 1,
"peacock", 2,
"piglet", 3)
ggplot(data) +
aes(fill = animal,
x = animal,
y = count) +
geom_col() +
scale_fill_manual(values = ifelse(data$animal == "piglet", "pink",
ifelse(data$animal == "peacock", "blue",
ifelse(data$animal == "cat", "yellow", NA))))
tribble(~animal, ~count,
"cat", 1,
"peacock", 2,
"piglet", 3) |>
ggplot() +
aes(fill = animal,
x = animal,
y = count) +
geom_col() +
scale_fill_manual(values = function(x){ifelse(x == "piglet", "pink",
ifelse(x == "peacock", "blue",
ifelse(x = "cat", "yellow", NA)))})## Error in `palette()`:
## ! Insufficient values in manual scale. 3 needed but only 1 provided.library(ggplot2)
scale_discrete_translate <- function(..., aesthetics = "fill", broad_palette = colors()) {
transform <- new_fill_transform(broad_palette)
scale <- discrete_scale(
aesthetics = aesthetics,
...,
palette = pal_identity(),
guide = "none",
super = ScaleDiscreteTranslate
)
ggproto(NULL, scale, trans = transform)
}
ScaleDiscreteTranslate <- ggproto(
"ScaleDiscreteTranslate", ScaleDiscreteIdentity,
transform = function(self, x) {
self$trans(x)
}
)
new_geometry_transform <- function(broad_palette = colors(), call = rlang::caller_call()) {
force(call)
function(x) {
if (inherits(x, "sfc")) {
return(x)
}
matches <- vec_locate_matches(x, data[[id]])
if (nrow(matches) < 1 || all(is.na(matches$haystack))) {
cli::cli_abort(
"No values match the {.var {id}} column in the spatial data.",
call = call
)
}
if (vec_duplicate_any(matches$needles)) {
groups <- vec_split(data[[geom_col]][matches$haystack], matches$needles)
vec_c(!!!lapply(groups$val, sf::st_combine))
} else {
data[[geom_col]][matches$haystack]
}
}
}