w make_constructor
# library(australians)
geom_states_wo_crs <- make_constructor(GeomSf, stat = StatAuStates)
geom_states <- function(...){list(geom_states0(...), coord_sf(crs = crs_au_states))}
geom_states_text <- make_constructor(GeomText, stat = StatAuStates)
geom_sf
## function (mapping = aes(), data = NULL, stat = "sf", position = "identity",
## na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
## {
## c(layer_sf(geom = GeomSf, data = data, mapping = mapping,
## stat = stat, position = position, show.legend = show.legend,
## inherit.aes = inherit.aes, params = list2(na.rm = na.rm,
## ...)), coord_sf(default = TRUE))
## }
## <bytecode: 0x7f77ea9071d8>
## <environment: namespace:ggplot2>
ggplot(au_states) +
aes(state_name = state,
fill = pop) +
geom_states()# +
## Error in geom_states0(...): could not find function "geom_states0"
# geom_states_text()
last_plot() +
coord_sf(crs = crs_au_states) # you would want to have this tucked in though.
# geom_states_text()
NULL
## NULL
geom_sf
## function (mapping = aes(), data = NULL, stat = "sf", position = "identity",
## na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
## {
## c(layer_sf(geom = GeomSf, data = data, mapping = mapping,
## stat = stat, position = position, show.legend = show.legend,
## inherit.aes = inherit.aes, params = list2(na.rm = na.rm,
## ...)), coord_sf(default = TRUE))
## }
## <bytecode: 0x7f77ea9071d8>
## <environment: namespace:ggplot2>
sf_oz <- ozmap("states") |> rename(state = NAME)
crs_au_states <- sf::st_crs(sf_oz)
layer_coord_sf <- function(ref_data, geom = GeomSf, keep = NULL, drop = NULL, required_aes = Stat$required_aes, stamp = FALSE, ...){
ref_data |>
ggplot2::StatSf$compute_panel(coord = ggplot2::CoordSf) |>
ggplot2::StatSfCoordinates$compute_group(coord = ggplot2::CoordSf) ->
ref_data_plus_sf
ref_data_plus_sf$id_col <- ref_data_plus_sf[,1][[1]]
if(!is.null(keep)){ref_data_plus_sf <- ref_data_plus_sf |> filter(id_col %in% keep)}
if(!is.null(drop)){ref_data_plus_sf <- ref_data_plus_sf |> filter(!(id_col %in% drop))}
# layer_county w/ inner join
compute_panel_ref_data <- function(data, scales){
if(stamp){
ref_data_plus_sf
}else{
ref_data_plus_sf |>
inner_join(data)
}
}
StatTemp <- ggproto(NULL, Stat,
compute_panel = compute_panel_ref_data,
default_aes = aes(label = after_stat(id_col)),
required_aes = required_aes
)
if(stamp){
# x = NULL; y = NULL; xmin = NULL; xmax = NULL;
# ymin = NULL; ymax = NULL; xend = NULL; yend = NULL; na.rm = FALSE
#
# position <- compact(list(x = x, xmin = xmin, xmax = xmax,
# xend = xend, y = y, ymin = ymin, ymax = ymax, yend = yend))
# aesthetics <- c(position, list(...))
# lengths <- lengths(aesthetics)
# n <- ggplot2:::unique0(lengths)
# if (length(n) > 1L) {
# n <- setdiff(n, 1L)
# }
# if (length(n) > 1L) {
# bad <- lengths != 1L
# details <- paste0(names(aesthetics)[bad], " (", lengths[bad],
# ")")
# cli::cli_abort("Unequal parameter lengths: {details}")
# }
# data <- ggplot2:::data_frame0(!!!position) #, .size = n
c(layer_sf(geom = geom, stat = StatTemp, position = "identity", #mapping = aes_all(names(data)),
params = list(...)),
coord_sf(crs = sf::st_crs(ref_data)))
}else{
c( layer_sf(geom = geom, stat = StatTemp, position = "identity", params = list(...)),
coord_sf(crs = sf::st_crs(ref_data)))
}
}
geom_state <- function(...){layer_coord_sf(sf_oz, ...)}
geom_state_text <- function(...){layer_coord_sf(sf_oz, GeomText, ...)}
stamp_state <- function(...){layer_coord_sf(sf_oz, stamp = TRUE, ...)}
au_states |>
ggplot() +
aes(state = state) +
geom_state() +
geom_state_text() +
aes(fill = pop) +
geom_state(keep = "Northern Territory",
fill = "green") +
geom_state_text()
## Warning in st_point_on_surface.sfc(sf::st_zm(x)): st_point_on_surface may not
## give correct results for longitude/latitude data
## Warning in st_point_on_surface.sfc(sf::st_zm(x)): st_point_on_surface may not
## give correct results for longitude/latitude data
## Coordinate system already present.
## ℹ Adding new coordinate system, which will replace the existing one.
## Warning in st_point_on_surface.sfc(sf::st_zm(x)): st_point_on_surface may not
## give correct results for longitude/latitude data
## Coordinate system already present.
## ℹ Adding new coordinate system, which will replace the existing one.
## Warning in st_point_on_surface.sfc(sf::st_zm(x)): st_point_on_surface may not
## give correct results for longitude/latitude data
## Coordinate system already present.
## ℹ Adding new coordinate system, which will replace the existing one.
## Joining with `by = join_by(state)`
## Joining with `by = join_by(state)`
## Joining with `by = join_by(state)`
## Joining with `by = join_by(state)`
ggplot() +
stamp_state()
## Warning in st_point_on_surface.sfc(sf::st_zm(x)): st_point_on_surface may not
## give correct results for longitude/latitude data
###### us states ###########
usmapdata::us_map() |>
select(state = full, geometry = geom, everything()) ->
states
geom_state <- function(...){layer_coord_sf(states, ...)}
geom_state_text <- function(...){layer_coord_sf(states, GeomText)}
USArrests |>
rownames_to_column(var = "state") |>
ggplot() +
aes(state = state,
fill = Rape) +
geom_state() +
geom_state_text() +
aes(label = after_stat(abbr))
## Coordinate system already present.
## ℹ Adding new coordinate system, which will replace the existing one.
## Joining with `by = join_by(state)`
## Joining with `by = join_by(state)`
library(rlang)
## Warning: package 'rlang' was built under R version 4.4.1
##
## Attaching package: 'rlang'
## The following objects are masked from 'package:purrr':
##
## %@%, flatten, flatten_chr, flatten_dbl, flatten_int, flatten_lgl,
## flatten_raw, invoke, splice
make_constructor <- function(x, ...) {
UseMethod("make_constructor")
}
layer_coord_sf <- function (mapping = aes(), data = NULL, geom = GeomSf, stat = "sf", position = "identity",
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ..., crs)
{
c(layer_sf(geom = geom, data = data, mapping = mapping,
stat = stat, position = position, show.legend = show.legend,
inherit.aes = inherit.aes, params = list2(na.rm = na.rm,
...)), coord_sf(crs = crs))
}
make_constructor.Geom <- function(x, ..., checks = exprs(), omit = character(),
env = rlang::caller_env()) {
# Check that we can independently find the geom
geom <- gsub("^geom_", "", ggplot2:::snake_class(x))
ggplot2:::validate_subclass(geom, "Geom", env = env)
# Split additional arguments into required and extra ones
args <- enexprs(...)
fixed_fmls_names <- c("mapping", "data", "stat", "position", "...",
"na.rm", "show.legend", "inherit.aes")
extra_args <- setdiff(names(args), fixed_fmls_names)
if ("geom" %in% extra_args) {
cli::cli_abort("{.arg geom} is a reserved argument.")
}
# Fill in values for parameters from draw functions
known_params <-
unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics(), omit))
missing_params <- setdiff(x$parameters(), known_params)
if (length(missing_params) > 0) {
draw_args <- ggplot2:::ggproto_formals(x$draw_panel)
if ("..." %in% names(draw_args)) {
draw_args <- ggproto_formals(x$draw_group)
}
params <- intersect(missing_params, names(draw_args))
extra_args <- c(extra_args, params)
for (param in params) {
if (!identical(draw_args[[param]], quote(expr = ))) {
args[param] <- draw_args[param]
}
}
extra_args <- intersect(extra_args, names(args))
missing_params <- setdiff(missing_params, names(args))
if (length(missing_params) > 0) {
cli::cli_warn(
"In {.fn geom_{geom}}: please consider providing default values for: \\
{missing_params}."
)
}
}
# Build function formals
fmls <- rlang::pairlist2(
mapping = args$mapping,
data = args$data,
stat = args$stat %||% "identity",
position = args$position %||% "identity",
`...` = rlang::missing_arg(),
!!!args[extra_args],
na.rm = args$na.rm %||% FALSE,
show.legend = args$show.legend %||% NA,
inherit.aes = args$inherit.aes %||% TRUE
)
# Construct call for the 'layer(params)' argument
params <- rlang::exprs(!!!syms(c("na.rm", extra_args)), .named = TRUE)
params <- rlang::call2("list2", !!!params, quote(...))
# Construct rest of 'layer()' call
layer_args <- syms(setdiff(fixed_fmls_names, c("...", "na.rm")))
layer_args <- append(layer_args, list(geom = geom), after = 2)
layer_args <- rlang::exprs(!!!layer_args, params = !!params, .named = TRUE)
body <- rlang::call2("layer_coord_sf", !!!layer_args)
# Prepend any checks
if (length(exprs) > 0) {
lang <- vapply(checks, is_call, logical(1))
if (!all(lang)) {
cli::cli_abort(
"{.arg checks} must be a list of calls, such as one constructed \\
with {.fn rlang::exprs}."
)
}
}
body <- rlang::call2("{", !!!checks, body)
# We encapsulate rlang::list2
new_env <- new_environment(list(list2 = list2), env)
new_function(fmls, body, new_env)
}
geom_states <- make_constructor(GeomSf, stat = StatAuStates, crs = crs_au_states)
geom_states
## function (mapping = NULL, data = NULL, stat = StatAuStates, position = "identity",
## ..., crs = crs_au_states, legend = NULL, lineend = "butt",
## linejoin = "round", linemitre = 10, arrow = NULL, arrow.fill = NULL,
## na.rm = FALSE, show.legend = NA, inherit.aes = TRUE)
## {
## layer_coord_sf(mapping = mapping, data = data, geom = "sf",
## stat = stat, position = position, show.legend = show.legend,
## inherit.aes = inherit.aes, params = list2(na.rm = na.rm,
## crs = crs, legend = legend, lineend = lineend, linejoin = linejoin,
## linemitre = linemitre, arrow = arrow, arrow.fill = arrow.fill,
## ...))
## }
## <environment: 0x7f77d202da88>
ggplot(au_states) +
aes(state_name = state,
fill = pop) +
geom_states()
## Warning in layer_sf(geom = geom, data = data, mapping = mapping, stat = stat, :
## Ignoring unknown parameters: `params`
## Error in layer_coord_sf(mapping = mapping, data = data, geom = "sf", stat = stat, : argument "crs" is missing, with no default
