Handle NA gracefully in geom_sf (#3546)

Author: thomasp85

NEWS.md

@@ -1,5 +1,8 @@
 # ggplot2 (development version)
 
+* `geom_sf()` now removes rows that can't be plotted due to `NA` aesthetics 
+  (#3546, @thomasp85)
+
 * A new scale type has been added, that allows binning of aesthetics at the 
   scale level. It has versions for both position and non-position aesthetics and
   comes with two new guides (`guide_bins` and `guide_coloursteps`) (@thomasp85, #3096)
@@ -82,8 +85,6 @@
 
 * `stat_density2d()` can now take an `adjust` parameter to scale the default bandwidth. (#2860, @haleyjeppson)
 
-* `geom_sf()` now removes rows that contain missing `shape`/`size`/`colour` (#3483, @yutannihilation)
-
 * Fix a bug when `show.legend` is a named logical vector (#3461, @yutannihilation).
 
 * Increase the default `nbin` of `guide_colourbar()` to place the ticks more precisely (#3508, @yutannihilation).

R/geom-sf.R

@@ -86,28 +86,27 @@ NULL
 #' @usage NULL
 #' @format NULL
 GeomSf <- ggproto("GeomSf", Geom,
-                  required_aes = "geometry",
-                  default_aes = aes(
-                    shape = NULL,
-                    colour = NULL,
-                    fill = NULL,
-                    size = NULL,
-                    linetype = 1,
-                    alpha = NA,
-                    stroke = 0.5
-                  ),
+  required_aes = "geometry",
+  default_aes = aes(
+    shape = NULL,
+    colour = NULL,
+    fill = NULL,
+    size = NULL,
+    linetype = 1,
+    alpha = NA,
+    stroke = 0.5
+  ),
 
-  non_missing_aes = c("size", "shape", "colour"),
-                  
   draw_panel = function(data, panel_params, coord, legend = NULL,
-                        lineend = "butt", linejoin = "round", linemitre = 10) {
+                        lineend = "butt", linejoin = "round", linemitre = 10,
+                        na.rm = TRUE) {
     if (!inherits(coord, "CoordSf")) {
       stop("geom_sf() must be used with coord_sf()", call. = FALSE)
     }
 
     # 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)
+    sf_grob(coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre, na.rm = na.rm)
   },
 
   draw_key = function(data, params, size) {
@@ -132,17 +131,36 @@ default_aesthetics <- function(type) {
   }
 }
 
-sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10) {
-  # Need to extract geometry out of corresponding list column
-  geometry <- x$geometry
-  type <- sf_types[sf::st_geometry_type(geometry)]
-  is_point <- type %in% "point"
-  type_ind <- match(type, c("point", "line", "other"))
+sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, na.rm = TRUE) {
+  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(GeomPolygon$required_aes, GeomPolygon$non_missing_aes))[is_other]
+  if (any(remove)) {
+    if (!na.rm) {
+      warning_wrap(
+        "Removed ", sum(remove), " rows containing missing values (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(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35"))
   )
+  defaults[[4]] <- modify_list(
+    defaults[[3]],
+    rename(GeomPoint$default_aes, c(size = "point_size", fill = "point_fill"))
+  )
   default_names <- unique(unlist(lapply(defaults, names)))
   defaults <- lapply(setNames(default_names, default_names), function(n) {
     unlist(lapply(defaults, function(def) def[[n]] %||% NA))
@@ -153,16 +171,17 @@ sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10) {
   fill <- x$fill %||% defaults$fill[type_ind]
   fill <- alpha(fill, alpha)
   size <- x$size %||% defaults$size[type_ind]
+  point_size <- ifelse(is_collection, x$size %||% defaults$point_size[type_ind], size)
   stroke <- (x$stroke %||% defaults$stroke[1]) * .stroke / 2
-  fontsize <- size * .pt + stroke
+  fontsize <- point_size * .pt + stroke
   lwd <- ifelse(is_point, stroke, size * .pt)
   pch <- x$shape %||% defaults$shape[type_ind]
   lty <- x$linetype %||% defaults$linetype[type_ind]
   gp <- gpar(
     col = col, fill = fill, fontsize = fontsize, lwd = lwd, lty = lty,
     lineend = lineend, linejoin = linejoin, linemitre = linemitre
   )
-  sf::st_as_grob(geometry, pch = pch, gp = gp)
+  sf::st_as_grob(x$geometry, pch = pch, gp = gp)
 }
 
 #' @export
@@ -280,7 +299,7 @@ geom_sf_text <- function(mapping = aes(), data = NULL,
 
 sf_types <- c(GEOMETRY = "other", POINT = "point", LINESTRING = "line",
               POLYGON = "other", MULTIPOINT = "point", MULTILINESTRING = "line",
-              MULTIPOLYGON = "other", GEOMETRYCOLLECTION = "other",
+              MULTIPOLYGON = "other", GEOMETRYCOLLECTION = "collection",
               CIRCULARSTRING = "line", COMPOUNDCURVE = "other", CURVEPOLYGON = "other",
               MULTICURVE = "other", MULTISURFACE = "other", CURVE = "other",
               SURFACE = "other", POLYHEDRALSURFACE = "other", TIN = "other",

R/utilities.r

@@ -97,20 +97,13 @@ remove_missing <- function(df, na.rm = FALSE, vars = names(df), name = "",
                            finite = FALSE) {
   stopifnot(is.logical(na.rm))
 
-  vars <- intersect(vars, names(df))
-  if (name != "") name <- paste(" (", name, ")", sep = "")
-
-  if (finite) {
-    missing <- !cases(df[, vars, drop = FALSE], is_finite)
-    str <- "non-finite"
-  } else {
-    missing <- !cases(df[, vars, drop = FALSE], is_complete)
-    str <- "missing"
-  }
+  missing <- detect_missing(df, vars, finite)
 
   if (any(missing)) {
     df <- df[!missing, ]
     if (!na.rm) {
+      if (name != "") name <- paste(" (", name, ")", sep = "")
+      str <- if (finite) "non-finite" else "missing"
       warning_wrap(
         "Removed ", sum(missing), " rows containing ", str, " values", name, "."
       )
@@ -119,6 +112,10 @@ remove_missing <- function(df, na.rm = FALSE, vars = names(df), name = "",
 
   df
 }
+detect_missing <- function(df, vars, finite = FALSE) {
+  vars <- intersect(vars, names(df))
+  !cases(df[, vars, drop = FALSE], if (finite) is_finite else is_complete)
+}
 
 # Returns a logical vector of same length as nrow(x). If all data on a row
 # is finite (not NA, NaN, Inf, or -Inf) return TRUE; otherwise FALSE.