Experimental Pattern - Stripe using {grid}

library(ggplot2)
library(ggpattern)
#> 
#> Attaching package: 'ggpattern'
#> The following objects are masked from 'package:ggplot2':
#> 
#>     flip_data, flipped_names, gg_dep, has_flipped_aes, remove_missing,
#>     should_stop, waiver

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a sf MULTIPOLYGON object where each polygon is an individual stripe.
#'
#' The stripes are created as polygons so that when clipped to rects/polygons,
#' the ends of the stripe are clipped correctly to the boundary.
#'
#' @inheritParams create_circles_grob
#'
#' @return `sf` multipolygon object
#'
#' @import sf
#' @importFrom utils tail
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_stripes_as_polygonGrob <- function(angle=45, spacing=0.1, density=0.3, xoffset=0, yoffset=0,
                                          aspect_ratio) {

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Clearly distinguise:
  #    - The user supplies the stripe angle.
  #    - We determine the spine angle
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  stripe_angle <- ( angle       %% 180)
  spine_angle  <- ((angle + 90) %% 180)
  angle        <- NULL

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Should the spine start at the bottom left or the bottom right?
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (spine_angle < 90) {
    spine_origin <- c(xoffset, yoffset)
  } else {
    spine_origin <- c(1 + xoffset, yoffset)
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Convert angles to radians
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  stripe_angle <- stripe_angle * pi/180
  spine_angle  <- spine_angle  * pi/180

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # aspect ratio will determine maximum line length
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (aspect_ratio < 1) {
    ll <- 1/aspect_ratio
  } else {
    ll <- aspect_ratio
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Hypotenuse
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ll <- sqrt(ll*ll + 1)


  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # We are going to create stripes that begin and end outside the viewport
  # no matter what the angle.  Make them long, and then we'll truncate them
  # later when we intersect with the area to be shaded
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  rib_offset <- c(ll * cos(stripe_angle), ll * aspect_ratio * sin(stripe_angle))

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Create a spine. As we walk along the spine we'll extend stripes out
  # at right angles.
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  spine_end   <- c(spine_origin[1] + ll * cos(spine_angle),
                   spine_origin[2] + ll * aspect_ratio * sin(spine_angle))

  Nribs <- ll/spacing

  spine_mat <- cbind(
    seq(spine_origin[1], spine_end[1], length.out = Nribs),
    seq(spine_origin[2], spine_end[2], length.out = Nribs)
  )


  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # One edge of the stripe is positioned x% of the way along, where this
  # percent is controlled by the pattern_density
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  spine_offset  <- c(density * spacing * cos(spine_angle),
                     density * spacing * sin(spine_angle) * aspect_ratio)

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # We have enough now to construct a polygon for each stripe element
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  stripe_corner_a <- t(t(spine_mat) + rib_offset)
  stripe_corner_b <- t(t(spine_mat) - rib_offset)
  stripe_corner_c <- t(t(spine_mat) - rib_offset + spine_offset)
  stripe_corner_d <- t(t(spine_mat) + rib_offset + spine_offset)

  stripe_coords_full <- lapply(seq(nrow(stripe_corner_a)), function(i) {
    coords <- rbind(
      stripe_corner_a[i,],
      stripe_corner_b[i,],
      stripe_corner_c[i,],
      stripe_corner_d[i,],
      stripe_corner_a[i,]
    )

    cbind(coords, i)
  })

  stripe_coords <- do.call(rbind, stripe_coords_full)

  grid::polygonGrob(
    x  = stripe_coords[,1],
    y  = stripe_coords[,2],
    id = stripe_coords[,3]
  )
}


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

  stripes_as_polygonGrob <- create_stripes_as_polygonGrob(
    angle   = params$pattern_angle,
    spacing = params$pattern_spacing,
    density = params$pattern_density,
    xoffset = params$pattern_xoffset,
    yoffset = params$pattern_yoffset,
    aspect_ratio = aspect_ratio
  )

  boundary_grob <- convert_polygon_df_to_polygon_grob(boundary_df)


  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Find the intersection of the boundary and the complete set of points
  # and convert it into matrix form
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  intersection_grob <- gridGeometry::polyclipGrob(
    boundary_grob, stripes_as_polygonGrob,
    gp = grid::gpar(
      fill = scales::alpha(params$pattern_fill  , params$pattern_alpha),
      col  = scales::alpha(params$pattern_colour, params$pattern_alpha),
      lwd  = params$pattern_lwd,
      lty  = params$pattern_linetype
    )
  )

  intersection_grob
}

library(ggplot2)
library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(ggpattern)

options(ggpattern_grid_funcs = list(gridstripes = create_pattern_stripes_via_grid))

plot_df <- mpg %>% filter(manufacturer %in% c('lincoln', 'mercury', 'audi'))
# plot_df <- mpg %>% filter(manufacturer %in% c('mercury'))

ggplot(plot_df, aes(x = manufacturer)) +
  geom_bar_pattern(
    aes(
      pattern_fill    = manufacturer
    ),
    pattern = 'gridstripes',
    fill            = 'white',
    colour          = 'black',
    pattern_density = 0.3,
    pattern_spacing = 0.01,
    pattern_alpha   = 0.3,
    pattern_colour  = NA,
    pattern_angle   = 60,
    # pattern_xoffset = 0.07,
    pattern_key_scale_factor = 1.2
  ) +
  theme_bw() +
  labs(title = "ggpattern::geom_bar_pattern()") +
  scale_pattern_density_discrete() +
  # scale_pattern_manual(values = c(lincoln = 'gridstripes', mercury = 'gridstripes', audi = 'gridstripes')) +
  theme(
    legend.position = 'none'
    # legend.justification = c(1, 1),
    # legend.position = c(1, 1),
    # legend.key.size = unit(3, 'cm')
  ) +
  coord_fixed(ratio = 1/8) +
  NULL

# system.time({
#   print(p)
# })
# 
# 
# system.time({
#   pdf("working/test-grid.pdf")
#   print(p)
#   dev.off()
# })