Intro Thoughts

Status Quo

library(tidyverse)

Experiment

Gonna mix and match from base ggplot2 sf world and ggregions… definitions returned here for reference.

ggplot2::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: 0x117b2f200>
## <environment: namespace:ggplot2>
ggplot2::stat_sf
## function (mapping = NULL, data = NULL, geom = "rect", position = "identity", 
##     na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) 
## {
##     layer_sf(stat = StatSf, data = data, mapping = mapping, geom = geom, 
##         position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
##         params = list2(na.rm = na.rm, ...))
## }
## <bytecode: 0x11630d118>
## <environment: namespace:ggplot2>
ggplot2::StatSf
## <ggproto object: Class StatSf, Stat, gg>
##     aesthetics: function
##     compute_group: function
##     compute_layer: function
##     compute_panel: function
##     default_aes: ggplot2::mapping, uneval, gg, S7_object
##     dropped_aes: 
##     extra_params: na.rm
##     finish_layer: function
##     non_missing_aes: 
##     optional_aes: 
##     parameters: function
##     required_aes: geometry
##     retransform: TRUE
##     setup_data: function
##     setup_params: function
##     super:  <ggproto object: Class Stat, gg>
ggregions::StatRegion$compute_panel
## <ggproto method>
##   <Wrapper function>
##     function (...) 
## compute_panel(...)
## 
##   <Inner function (f)>
##     function (data, scales, ref_data, keep = NULL, drop = NULL, stamp = F, 
##     aes_name = "region") 
## {
##     ref_data$id <- ref_data[1][[1]]
##     if (!is.null(keep)) {
##         ref_data <- dplyr::filter(ref_data, .data$id %in% keep)
##     }
##     if (!is.null(drop)) {
##         ref_data <- dplyr::filter(ref_data, !(.data$id %in% drop))
##     }
##     if (!stamp) {
##         ref_data_long <- pivot_longer(mutate(ref_data, across(-geometry, 
##             as.character)), cols = -c(geometry, id), names_to = ".id_type", 
##             values_to = aes_name)
##         length(ref_data_long[, aes_name]) == length(unique(ref_data_long[, 
##             aes_name]))
##         ref_data_long <- ggplot2::StatSfCoordinates$compute_group(ggplot2::StatSf$compute_panel(ref_data_long, 
##             coord = ggplot2::CoordSf), coord = ggplot2::CoordSf)
##         out <- dplyr::inner_join(ref_data_long, data, by = aes_name)
##         inner_join(sf::st_drop_geometry(ref_data), out, by = join_by(id))
##     }
##     else {
##         ggplot2::StatSfCoordinates$compute_group(ggplot2::StatSf$compute_panel(ref_data, 
##             coord = ggplot2::CoordSf), coord = ggplot2::CoordSf)
##     }
## }
library(ggregions)
geom_region
## function (mapping = aes(), data = NULL, stat = StatRegion, position = "identity", 
##     na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ref_data = getOption("ggregions.regions", 
##         ref_data_us), aes_name = "region", ...) 
## {
##     c(layer_sf(geom = GeomSf, data = data, mapping = mapping, 
##         stat = stat, position = position, show.legend = show.legend, 
##         inherit.aes = inherit.aes, params = rlang::list2(na.rm = na.rm, 
##             ref_data = ref_data, aes_name = aes_name, ...)), 
##         coord_sf(crs = st_crs_mod(ref_data)))
## }
## <bytecode: 0x117dc5420>
## <environment: namespace:ggregions>
library(rlang)
## 
## Attaching package: 'rlang'
## The following objects are masked from 'package:purrr':
## 
##     flatten, flatten_chr, flatten_dbl, flatten_int, flatten_lgl,
##     flatten_raw, invoke, splice
st_crs_mod <- function(ref_data){

  crs <- sf::st_crs(ref_data)
  
  if(is.na(crs)){NULL}else{crs}

}

compute_panel_regions <- function (data, scales, ref_data = NULL, 
                                   keep = NULL, drop = NULL) {
  

    if (!is.null(ref_data)) {
    
          ref_data$id <- ref_data[1][[1]]
    
    if (!is.null(keep)) {
        ref_data <- dplyr::filter(ref_data, .data$id %in% keep)
    }

    if (!is.null(drop)) {
        ref_data <- dplyr::filter(ref_data, !(.data$id %in% drop))
    }
    
      data <- data |> rename(region = geometry)
    
          ref_data_long <- ref_data |> 
            mutate(across(-geometry, as.character)) |>
            pivot_longer(cols = -c(geometry, id), 
                         names_to = ".id_type", 
                         values_to = "region")

          # check unique in the future
          length(ref_data_long$region) ==
            length(unique(ref_data_long$region))
    
          ref_data_long <- ref_data_long |> 
            ggplot2::StatSf$compute_panel(
              coord = ggplot2::CoordSf) |>
            ggplot2::StatSfCoordinates$compute_group(
              coord = ggplot2::CoordSf)
        
          out <- dplyr::inner_join(ref_data_long, 
                                   data, 
                                   by = join_by(region)) 
          
          ref_data |> sf::st_drop_geometry() |>
            inner_join(out, by = join_by(id))
          
    }
    
    else {
      
        data |> 
            ggplot2::StatSf$compute_panel(coord = ggplot2::CoordSf) |>
            ggplot2::StatSfCoordinates$compute_group(coord = ggplot2::CoordSf)
      
    }
    
}


StatSfMod <- ggplot2::ggproto("StatSfMod", 
                               ggplot2::Stat,
                      compute_panel = compute_panel_regions,
                      # required_aes = "region",
                      default_aes = ggplot2::aes(#label = ggplot2::after_stat(id),
                                                 geometry = geometry))


geom_sfnew <- function (mapping = aes(), data = NULL, stat = StatSfMod, position = "identity", 
    na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ref_data = NULL, ...) 
{
    c(layer_sf(geom = GeomSf, data = data, mapping = mapping, 
        stat = stat, position = position, show.legend = show.legend, 
        inherit.aes = inherit.aes, params = rlang::list2(na.rm = na.rm, 
            ref_data = ref_data, ...)), 
      if(!is.null(ref_data)){
        coord_sf(crs = st_crs_mod(ref_data))
              } else {
                coord_sf(default = TRUE)})
}

# Step 1. Prepare reference data
us_states_ref <- usmapdata::us_map() |>
  select( 
    state_name = full, # first variable will also be 'id' var, keep and drop
    state_abbr = abbr, 
    state_fips = fips,
    geometry = geom # one column 'geometry' is required
         )  


tribble(~state, ~info,
        "Texas", TRUE,
        "NC",    FALSE) |>
  ggplot() + 
  aes(geometry = state,
      fill = info) + 
  geom_sfnew(ref_data = us_states_ref)

# This not working yet and of course it should, friends 😛
usmapdata::us_map() |>
  rename(geometry = geom) |>
  ggplot() +
  aes(fill = fips |> as.numeric()) +
  geom_sfnew()

usmapdata::us_map() |>
  rename(geometry = geom) |>
  ggplot() +
  aes(fill = fips |> as.numeric(),
      geometry = geometry) +
  geom_sfnew()

usmapdata::us_map() |>
  ggplot() +
  aes(fill = fips |> as.numeric(), 
      geometry = geom) +
  geom_sfnew()