brain2 with sf manipulation

Example simple feature to data frame…

library(ggseg)
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

dk_geometries_frame <- ggseg::dk$data
aseg_geometries_frame <- ggseg::aseg$data


aseg_df <- ggseg::aseg$data
aseg_df$geometry <- NULL
aseg_df <- aseg_df %>% data.frame() %>% remove_missing()

## Warning: Removed 3 rows containing missing values.

aseg_df %>% count(label)

##                            label n
## 1                     Brain-Stem 1
## 2                    CC_Anterior 1
## 3                     CC_Central 1
## 4                CC_Mid_Anterior 1
## 5               CC_Mid_Posterior 1
## 6                   CC_Posterior 1
## 7                  Left-Amygdala 1
## 8                   Left-Caudate 1
## 9               Left-Hippocampus 1
## 10        Left-Lateral-Ventricle 1
## 11                 Left-Pallidum 1
## 12                  Left-Putamen 1
## 13          Left-Thalamus-Proper 1
## 14                Left-VentralDC 1
## 15                Right-Amygdala 1
## 16                 Right-Caudate 1
## 17       Right-Cerebellum-Cortex 1
## 18 Right-Cerebellum-White-Matter 1
## 19             Right-Hippocampus 1
## 20       Right-Lateral-Ventricle 1
## 21                Right-Pallidum 1
## 22                 Right-Putamen 1
## 23         Right-Thalamus-Proper 1
## 24               Right-VentralDC 1
## 25                x3rd-ventricle 1
## 26                x4th-ventricle 1

#

# imagine you only have nc_df

#' 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(mgroup)
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))
  
}
  


  
aseg_ggplot2_reference <- aseg_geometries_frame %>% 
  filter(!is.na(label)) %>% 
  geometries_frame_to_ggplot_reference()  

## Joining with `by = join_by(major_group)`
## 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_seg <- function(data, scales){
 
  data %>% 
    inner_join(aseg_ggplot2_reference, multiple = "all") 

}

Step 2: pass to ggproto

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

Step 3: write geom_* function

geom_polygon_seg <- function(
  mapping = NULL,
  data = NULL,
  position = "identity",
  na.rm = FALSE,
  show.legend = NA,
  inherit.aes = TRUE, ...) {
  ggplot2::layer(
    stat = StatSeg,  # 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!

aseg_df %>% #count(region)
  # mutate(label = label %>% as.factor()) %>% 
  ggplot(data = .) + 
  aes(label = label) +  # name indicates position instead of x and y 
  geom_sf(data = ggseg::aseg$data) +
  geom_polygon_seg() + 
  aes(fill = label) + 
  geom_polygon_seg(data = . %>% filter(str_detect(label, "Amygdala")), 
                                       color = "red") + 
  theme(legend.position = "none")

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

ggplot() + 
  geom_sf(data = ggseg::aseg$data)

ggplot() + 
  geom_sf(data = ggseg::dk$data)