Experimental Pattern - Hex (1)

suppressPackageStartupMessages({
  library(ggplot2)
  library(sf)
  library(grid)
  library(ggpattern)
})

Note: Experimental Patterns

This is a pattern which I have started to develop, but have not completed due to time constraints, dissatisfaction with the current state of it, or another roadblock to implementation.

You are welcome to fork/tinker/rewrite this pattern, and if you come up with a good, workable general solution, please let me know and it can become part of the official package!

Current issues with this hex pattern.

• intersection with border looks terrible at large lwd
• legends aren’t working great

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' @rdname create_pattern_none
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_pattern_hex <- function(params, boundary_df, aspect_ratio,
                               legend = FALSE) {

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Pre-scale boundary
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  boundary_df$y <- boundary_df$y /  aspect_ratio
  boundary_df   <- rotate_polygon_df(boundary_df, params$pattern_angle, aspect_ratio)


  boundary_sf        <- convert_polygon_df_to_polygon_sf(boundary_df)
  hex_sfc            <- st_make_grid(boundary_sf, cellsize = params$pattern_spacing, square = FALSE, flat_topped = FALSE)
  hex_within_area_sf <- st_intersection(hex_sfc, boundary_sf)

  polys <- lapply(
    seq_along(hex_within_area_sf),
    function(idx) {
      mat <- as.matrix(hex_within_area_sf[[idx]])
      mat <- head(mat, -1)
      cbind(mat, idx)
    }
  )
  polys <- do.call(rbind, polys)
  polys <- as.data.frame(polys)
  polys <- setNames(polys, c('x', 'y', 'id'))

  hex_within_area_df   <- polys


  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Calculate the linewidth to simulate increases in density.
  # convert the 'npc' cellsize into native coordinates, and then set the
  # linewidth to be a fraction of that size
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  cell_size <- as.numeric(grid::convertWidth(unit(params$pattern_spacing, 'npc'), 'native'))
  lwd <- params$pattern_density * cell_size

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Post-scale pattern
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  hex_within_area_df <- rotate_polygon_df(hex_within_area_df, -params$pattern_angle, aspect_ratio)
  hex_within_area_df$y <- hex_within_area_df$y * aspect_ratio

  if (is.null(hex_within_area_df) || nrow(hex_within_area_df) == 0) {
    return(grid::nullGrob())
  }

  hex_grob <- grid::polygonGrob(
    x = unit(hex_within_area_df$x, "npc"),
    y = unit(hex_within_area_df$y, "npc"),
    id = hex_within_area_df$id,
    gp = gpar(
      col     = scales::alpha(params$pattern_fill, params$pattern_alpha),
      fill    = NA,
      lwd     = lwd,
      lty     = params$pattern_linetype,
      lineend = 'square'
    )
  )

  hex_grob
}

options(ggpattern_grid_funcs = list(hex = create_pattern_hex))

df <- data.frame(trt = c("a", "b", "c"), outcome = c(2.3, 1.9, 3.2))

p <- ggplot(df, aes(trt, outcome, pattern_fill = trt)) +
  geom_col_pattern(pattern = 'hex', fill='white', pattern_spacing = 0.02, pattern_xoffset = 0.01,
                   pattern_angle = 0, pattern_density = 0.1, colour = NA,
                   pattern_alpha = 1) +
  theme_bw() +
  labs(title = "Experimental Pattern - Hex 1") +
  theme(legend.position = 'none') +
  coord_fixed(ratio = 1/2)

p