fix: Update GeomSfPattern to more closely match GeomSf (#148)

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: ggpattern
 Type: Package
 Title: 'ggplot2' Pattern Geoms
-Version: 1.3.2-2
+Version: 1.3.2-3
 Authors@R: c(person("Mike", "FC", role = "aut"),
              person("Trevor L.", "Davis", role = c("aut", "cre"),
                     email = "trevor.l.davis@gmail.com",

R/geom-sf.R

@@ -5,156 +5,89 @@
 GeomSfPattern <- ggproto("GeomSfPattern", GeomSf,
   required_aes = "geometry",
   default_aes = defaults(aes(
-	shape = NULL,
-	colour = NULL,
-	fill = NULL,
+    shape = NULL,
+    colour = NULL,
+    fill = NULL,
     size = NULL,
-	linewidth = NULL,
-	linetype = from_theme(linetype),
+    linewidth = NULL,
+    linetype = NULL,
     alpha = NA,
-	stroke = 0.5
+    stroke = 0.5
   ),
     pattern_aesthetics
   ),
 
   draw_panel = function(self, data, panel_params, coord, legend = NULL,
                         lineend = "butt", linejoin = "round", linemitre = 10,
-                        arrow = NULL, na.rm = TRUE) {
+                        arrow = NULL, arrow.fill = NULL, na.rm = TRUE) {
     if (!inherits(coord, "CoordSf")) {
       cli::cli_abort("{.fn {snake_class(self)}} can only be used with {.fn coord_sf}.")
     }
+    data$shape <- translate_shape_string(data$shape)
 
-    # Need to refactor this to generate one grob per geometry type
-    coord <- coord$transform(data, panel_params)
-    sf_grob(coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre,
-            arrow = arrow, na.rm = na.rm, panel_params)
-  },
+    data <- coord$transform(data, panel_params)
 
-  draw_key = function(data, params, size) {
-    data <- modify_list(default_aesthetics(params$legend), data)
-    if (params$legend == "point") {
-      draw_key_point(data, params, size)
-    } else if (params$legend == "line") {
-      draw_key_path(data, params, size)
-    } else {
-      draw_key_polygon_pattern(data, params, size)
-    }
-  }
-)
+    type <- sf_types[sf::st_geometry_type(data$geometry)]
+    is_point <- type == "point"
+    is_line  <- type == "line"
+    is_collection <- type == "collection"
 
-default_aesthetics <- function(type) {
-  if (type == "point") {
-    GeomPoint$default_aes
-  } else if (type == "line") {
-    GeomLine$default_aes
-  } else  {
-    modify_list(GeomPolygonPattern$default_aes, list(fill = "grey90", colour = "grey35"))
-  }
-}
+    fill <- fill_alpha(data$fill %||% rep(NA, nrow(data)), data$alpha)
+    fill[is_line] <- arrow.fill %||% fill[is_line]
 
+    colour <- data$colour
+    colour[is_point | is_line] <-
+      alpha(colour[is_point | is_line], data$alpha[is_point | is_line])
 
-# ggpattern note: panel params added to arguments
-sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10,
-                   arrow = NULL, na.rm = TRUE, panel_params) {
-  if (!requireNamespace("sf"))
-      abort(c("Suggested package {sf} must be installed",
-              i = 'Install using `install.packages("sf")`'))
-  type <- sf_types[sf::st_geometry_type(x$geometry)]
-  is_point <- type == "point"
-  is_line <- type == "line"
-  is_other <- type == "other"
-  is_collection <- type == "collection"
-  type_ind <- match(type, c("point", "line", "other", "collection"))
-  remove <- rep_len(FALSE, nrow(x))
-  remove[is_point] <- detect_missing(x, c(GeomPoint$required_aes, GeomPoint$non_missing_aes))[is_point]
-  remove[is_line] <- detect_missing(x, c(GeomPath$required_aes, GeomPath$non_missing_aes))[is_line]
-  remove[is_other] <- detect_missing(x, c(GeomPolygonPattern$required_aes, GeomPolygonPattern$non_missing_aes))[is_other]
-  if (any(remove)) {
-    if (!na.rm) {
-      cli::cli_warn(paste0(
-        "Removed {sum(remove)} row{?s} containing missing values or values ",
-        "outside the scale range ({.fn geom_sf})."
-      ))
-    }
-    x <- x[!remove, , drop = FALSE]
-    type_ind <- type_ind[!remove]
-    is_collection <- is_collection[!remove]
-  }
-  defaults <- list(
-    GeomPoint$default_aes,
-    GeomLine$default_aes,
-    modify_list(GeomPolygonPattern$default_aes, list(fill = "grey90", colour = "grey35", linewidth = 0.2))
-  )
-  defaults[[4]] <- modify_list(
-    defaults[[3]],
-    rename(GeomPoint$default_aes, c(size = "point_size", fill = "point_fill"))
-  )
-  default_names <- unique0(unlist(lapply(defaults, names)))
-  defaults <- lapply(setNames(default_names, default_names), function(n) {
-    unlist(lapply(defaults, function(def) def[[n]] %||% NA))
-  })
-  alpha <- x$alpha %||% defaults$alpha[type_ind]
-  col   <- x$colour %||% defaults$colour[type_ind]
-  col[is_point | is_line] <- alpha(col[is_point | is_line], alpha[is_point | is_line])
-  fill       <- x$fill %||% defaults$fill[type_ind]
-  fill       <- fill_alpha(fill, alpha)
-  size       <- x$size %||% defaults$size[type_ind]
-  linewidth <- x$linewidth %||% defaults$linewidth[type_ind]
-  point_size <- ifelse(
-                       is_collection,
-                       x$size %||% defaults$point_size[type_ind],
-                       ifelse(is_point, size, linewidth)
-  )
-  stroke     <- (x$stroke %||% defaults$stroke[1]) * .stroke / 2
-  fontsize   <- point_size * .pt + stroke
-  lwd        <- ifelse(is_point, stroke, linewidth * .pt)
-  pch        <- x$shape %||% defaults$shape[type_ind]
-  lty        <- x$linetype %||% defaults$linetype[type_ind]
+    point_size <- data$size
+    point_size[!(is_point | is_collection)] <-
+      data$linewidth[!(is_point | is_collection)]
 
+    stroke <- (data$stroke %||% rep(0.5, nrow(data))) * .stroke / 2
+    font_size <- point_size * .pt + stroke
 
-  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  # For each row in 'x',
-  #  - if x$geometry is a MULTIPOLYGON then
-  #       - treat x$geometry as the single item in the 'boundary_dfs' list
-  #       - treat everything else in this row as params
-  #       - create the pattern grobs for this isolated thing
-  # - accumulate all these pattern grobs into a grobTree
-  # - attach this grobTree to the final returned object
-  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  sf_vp <- sf::st_polygon(list(matrix(c(0, 0, 0, 1, 1, 1, 1, 0, 0, 0), byrow=TRUE, ncol=2)))
-  pattern_grobs_list <- list()
-  gp_boundary <- gpar(col = NA, lwd = 0, fill = "white")
-  for (idx in seq(nrow(x))) {
-    if (inherits(x$geometry[[idx]], 'MULTIPOLYGON') || inherits(x$geometry[[idx]], 'POLYGON')) {
-      boundary_grob      <- sf::st_as_grob(x$geometry[[idx]],
-                                           gp = gp_boundary,
-                                           default.units = "npc")
-      if (inherits(boundary_grob, "null"))
-          next
-      boundary_grobs     <- list(boundary_grob)
-      all_params         <- x[idx,]
-      pattern_grobs      <- create_pattern_grobs(all_params, boundary_grobs)
-      pattern_grobs_list <- append(pattern_grobs_list, list(pattern_grobs))
+    linewidth <- data$linewidth * .pt
+    linewidth[is_point] <- stroke[is_point]
+
+    # Render pattern grobs for polygon geometries
+    pattern_grobs_list <- list()
+    gp_boundary <- gpar(col = NA, lwd = 0, fill = "white")
+    for (idx in seq_len(nrow(data))) {
+      geom_obj <- data$geometry[[idx]]
+      if (inherits(geom_obj, 'MULTIPOLYGON') || inherits(geom_obj, 'POLYGON')) {
+        boundary_grob <- sf::st_as_grob(geom_obj, gp = gp_boundary, default.units = "npc")
+        if (inherits(boundary_grob, "null")) next
+        pattern_grobs_list <- append(
+          pattern_grobs_list,
+          list(create_pattern_grobs(data[idx, ], list(boundary_grob)))
+        )
+      }
     }
-  }
-  pattern_grobs <- do.call(grid::grobTree, pattern_grobs_list)
+    pattern_grobs <- do.call(grid::grobTree, pattern_grobs_list)
 
-  gp_fill <- gpar(
-    col = NA, fill = fill, fontsize = fontsize, lwd = 0, lty = lty,
-    lineend = lineend, linejoin = linejoin, linemitre = linemitre
-  )
-  gp_border <- gpar(
-    col = col, fill = NA, fontsize = fontsize, lwd = lwd, lty = lty,
-    lineend = lineend, linejoin = linejoin, linemitre = linemitre
-  )
-  grob_fill <- sf::st_as_grob(x$geometry, pch = pch, gp = gp_fill)
-  grob_border <- sf::st_as_grob(x$geometry, pch = pch, gp = gp_border)
-  grid::grobTree(
-    grob_fill,
-    pattern_grobs,
-    grob_border
-  )
-}
+    gp_fill <- gpar(
+      col = NA, fill = fill, fontsize = font_size, lwd = 0, lty = data$linetype,
+      lineend = lineend, linejoin = linejoin, linemitre = linemitre
+    )
+    gp_border <- gpar(
+      col = colour, fill = NA, fontsize = font_size, lwd = linewidth, lty = data$linetype,
+      lineend = lineend, linejoin = linejoin, linemitre = linemitre
+    )
+    grob_fill   <- sf::st_as_grob(data$geometry, pch = data$shape, gp = gp_fill)
+    grob_border <- sf::st_as_grob(data$geometry, pch = data$shape, gp = gp_border, arrow = arrow)
+
+    grid::grobTree(grob_fill, pattern_grobs, grob_border)
+  },
+
+  draw_key = function(data, params, size) {
+    switch(
+      params$legend %||% "other",
+      point = draw_key_point(data, params, size),
+      line  = draw_key_path(data, params, size),
+      draw_key_polygon_pattern(data, params, size)
+    )
+  }
+)
 
 #' @rdname geom-docs
 #' @export
@@ -170,7 +103,7 @@ geom_sf_pattern <- function(mapping = aes(), data = NULL, stat = "sf",
       position = position,
       show.legend = show.legend,
       inherit.aes = inherit.aes,
-      params = list(
+      params = list2(
         na.rm = na.rm,
         ...
       )