brain2 with sf manipulation

Example simple feature to data frame…

library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.0     ✔ readr     2.1.4
## ✔ forcats   1.0.0     ✔ stringr   1.5.0
## ✔ ggplot2   3.4.1     ✔ tibble    3.1.8
## ✔ lubridate 1.9.2     ✔ tidyr     1.3.0
## ✔ purrr     1.0.1     
## ── 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 errors

library(sf)

## Linking to GEOS 3.10.2, GDAL 3.4.2, PROJ 8.2.1; sf_use_s2() is TRUE

#> Linking to GEOS 3.8.1, GDAL 3.2.1, PROJ 7.2.1

fips_geometries <- readRDS(url("https://wilkelab.org/SDS375/datasets/US_counties.rds")) %>%
  rename(FIPS = GEOID)

US_census <- read_csv("https://wilkelab.org/SDS375/datasets/US_census.csv",
                      col_types = cols(FIPS = "c")
          )

# works
fips_geometries %>%
  left_join(US_census, by = "FIPS") %>%
  ggplot() +
  geom_sf(aes(fill = home_ownership)) + 
  scale_fill_viridis_c()

# from Claus Wilke on ggplot2

#' Title
#'
#' @param geometries_frame 
#'
#' @return
#' @export
#'
#' @examples
#' geometries_frame_to_id_group()
geometries_frame_to_id_group <- function(geometries_frame){

    nsubgroup <- geometries_frame$geometry %>% purrr::map_dbl(.f = length)

    tibble(nsubgroup) %>% 
      mutate(major_group = 1:n()) %>% # row number 
      uncount(weights = nsubgroup) %>% 
      group_by(major_group) %>% 
      mutate(subgroup = 1:n()) %>% 
      mutate(major_and_minor = paste0(major_group,'.', subgroup)) %>% 
      ungroup() %>% 
      mutate(polygon = 1:n()) %>% 
      ungroup()

}



#' Title
#'
#' @param geometries_frame 
#'
#' @return
#' @export
#'
#' @examples
#' geometries_frame_to_df(nc) 
geometries_frame_to_df <- function(geometries_frame){

      polygons_flat <- data.frame()
    
      polygons <- geometries_frame$geometry %>% purrr::flatten() %>% purrr::flatten()
      
    for (i in 1:length(polygons)){
      
      temp <- polygons[[i]] %>% 
        data.frame() %>% 
        mutate(polygon = i)
      
      polygons_flat = bind_rows(polygons_flat, temp)
  

  }

  names(polygons_flat)[1] <- "x"
  names(polygons_flat)[2] <- "y"

  polygons_flat
  
}
  


#' Title
#'
#' @param geometries_frame 
#'
#' @return
#' @export
#'
#' @examples
#' geometries_frame_to_id_group(nc) %>% 
#' count(major_group)
geometries_frame_to_ggplot_reference <- function(geometries_frame = aseg_geometries_frame){
  
  keep_frame <- geometries_frame
  
  keep_frame$geometry = NULL
  
  keep_frame %>% 
    data.frame() %>% 
    janitor::clean_names() %>% 
    mutate(major_group = row_number()) %>% 
    left_join(geometries_frame_to_id_group(geometries_frame)) %>% 
    left_join(geometries_frame_to_df(geometries_frame))
  
}
  


  
fips_ggplot2_reference <- fips_geometries %>% remove_missing() %>% 
  geometries_frame_to_ggplot_reference()  

## Joining with `by = join_by(major_group)`

## Warning in left_join(., geometries_frame_to_id_group(geometries_frame)): Each row in `x` is expected to match at most 1 row in `y`.
## ℹ Row 114 of `x` matches multiple rows.
## ℹ If multiple matches are expected, set `multiple = "all"` to silence this
##   warning.

## Joining with `by = join_by(polygon)`

## Warning in left_join(., geometries_frame_to_df(geometries_frame)): Each row in `x` is expected to match at most 1 row in `y`.
## ℹ Row 1 of `x` matches multiple rows.
## ℹ If multiple matches are expected, set `multiple = "all"` to silence this
##   warning.

compute_county <- function(data, scales){
 
  data %>% 
    inner_join(fips_ggplot2_reference, multiple = "all") 

}

Step 2: pass to ggproto

StatCounty <- ggplot2::ggproto(`_class` = "StatCounty",
                                  `_inherit` = ggplot2::Stat,
                                  # required_aes = c("fips"),
                                  # setup_data = my_setup_data,
                                  compute_panel = compute_county,
                                  default_aes = aes(group = after_stat(polygon))
                                  )

Step 3: write geom_* function

geom_polygon_county <- function(
  mapping = NULL,
  data = NULL,
  position = "identity",
  na.rm = FALSE,
  show.legend = NA,
  inherit.aes = TRUE, ...) {
  ggplot2::layer(
    stat = StatCounty,  # proto object from step 2
    geom = ggplot2::GeomPolygon,  # inherit other behavior
    data = data,
    mapping = mapping,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

step 4: test geom_* function, celebrate!

us_census <- read_csv("https://wilkelab.org/SDS375/datasets/US_census.csv",
                      col_types = cols(FIPS = "c")
          )  

us_census %>% 
  ggplot() + 
  aes(fips = FIPS) +
  geom_polygon_county(linewidth = .02, color = "darkgrey") +
  aes(fill = mean_work_travel) + 
  scale_fill_viridis_c(option = "magma")

## Joining with `by = join_by(fips)`

fips_geometries %>%
  left_join(US_census, by = "FIPS") %>%
  ggplot() +
  geom_sf(aes(fill = mean_work_travel), linewidth = .1) + 
  scale_fill_viridis_c(option = "magma")