From c191996c0bd65ed240aab3d480d25e673becfb72 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 12:13:13 +0200 Subject: [PATCH 1/3] migrate removing missing values to `GeomSf$handle_na` --- R/geom-sf.R | 50 ++++++++++++++++++++++------------- tests/testthat/test-geom-sf.R | 2 +- 2 files changed, 32 insertions(+), 20 deletions(-) diff --git a/R/geom-sf.R b/R/geom-sf.R index c0541cf369..c7ae22f886 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -198,7 +198,7 @@ GeomSf <- ggproto("GeomSf", Geom, # 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, arrow.fill = arrow.fill, na.rm = na.rm) + arrow = arrow, arrow.fill = arrow.fill) }, draw_key = function(data, params, size) { @@ -210,6 +210,35 @@ GeomSf <- ggproto("GeomSf", Geom, } else { draw_key_polygon(data, params, size) } + }, + + handle_na = function(self, data, params) { + remove <- rep(FALSE, nrow(data)) + + types <- sf_types[sf::st_geometry_type(data$geometry)] + types <- split(seq_along(remove), types) + + get_missing <- function(geom) { + detect_missing(data, c(geom$required_aes, geom$non_missing_aes)) + } + + remove[types$point] <- get_missing(GeomPoint)[types$point] + remove[types$line] <- get_missing(GeomPath)[types$line] + remove[types$other] <- get_missing(GeomPolygon)[types$other] + + remove <- remove | get_missing(self) + + if (any(remove)) { + data <- vec_slice(data, !remove) + if (!isTRUE(params$na.rm)) { + cli::cli_warn( + "Removed {sum(remove)} row{?s} containing missing values or values \\ + outside the scale range ({.fn {snake_class(self)}})." + ) + } + } + + data } ) @@ -224,28 +253,11 @@ default_aesthetics <- function(type) { } sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, arrow.fill = NULL, na.rm = TRUE) { + arrow = NULL, arrow.fill = NULL, ...) { 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) { - 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] - } alpha <- x$alpha %||% NA fill <- fill_alpha(x$fill %||% NA, alpha) diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index d79146ff73..496880dad6 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -158,7 +158,7 @@ test_that("errors are correctly triggered", { ), linewidth = c(1, NA) ) - expect_snapshot_warning(sf_grob(pts, na.rm = FALSE)) + expect_snapshot_warning(GeomSf$handle_na(pts, list(na.rm = FALSE))) }) # Visual tests ------------------------------------------------------------ From ffb2452a9ba2d5398816633b2ac115ef91ecd522 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 13:34:06 +0200 Subject: [PATCH 2/3] handle grob wrapping in `GeomSf$draw_panel()` --- R/geom-sf.R | 34 ++++++++++++++++++++++++++++++---- 1 file changed, 30 insertions(+), 4 deletions(-) diff --git a/R/geom-sf.R b/R/geom-sf.R index c7ae22f886..728aa90d0f 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -195,10 +195,36 @@ GeomSf <- ggproto("GeomSf", Geom, cli::cli_abort("{.fn {snake_class(self)}} can only be used with {.fn coord_sf}.") } - # 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, arrow.fill = arrow.fill) + data <- coord$transform(data, panel_params) + + type <- sf_types[sf::st_geometry_type(data$geometry)] + is_point <- type == "point" + is_line <- type == "line" + is_collection <- type == "collection" + + 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]) + + point_size <- data$size + point_size[!(is_point | is_collection)] <- + data$linewidth[!(is_point | is_collection)] + + stroke <- data$stroke * .stroke / 2 + font_size <- point_size * .pt + stroke + + linewidth <- data$linewidth * .pt + linewidth[is_point] <- stroke[is_point] + + gp <- gpar( + col = colour, fill = fill, fontsize = font_size, lwd = linewidth, + lineend = lineend, linejoin = linejoin, linemitre = linemitre + ) + + sf::st_as_grob(data$geometry, pch = data$shape, gp = gp, arrow = arrow) }, draw_key = function(data, params, size) { From 6da0fe1dbdd6c6a2bb7f814c47beb05d63a68433 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 13:34:19 +0200 Subject: [PATCH 3/3] remove `sf_grob()` --- R/geom-sf.R | 32 -------------------------------- 1 file changed, 32 deletions(-) diff --git a/R/geom-sf.R b/R/geom-sf.R index 728aa90d0f..0365d8b976 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -278,38 +278,6 @@ default_aesthetics <- function(type) { } } -sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, arrow.fill = NULL, ...) { - type <- sf_types[sf::st_geometry_type(x$geometry)] - is_point <- type == "point" - is_line <- type == "line" - is_collection <- type == "collection" - - alpha <- x$alpha %||% NA - fill <- fill_alpha(x$fill %||% NA, alpha) - fill[is_line] <- arrow.fill %||% fill[is_line] - col <- x$colour %||% NA - col[is_point | is_line] <- alpha(col[is_point | is_line], alpha[is_point | is_line]) - - size <- x$size %||% 0.5 - linewidth <- x$linewidth %||% 0.5 - point_size <- ifelse( - is_collection, - x$size, - ifelse(is_point, size, linewidth) - ) - stroke <- (x$stroke %||% 0) * .stroke / 2 - fontsize <- point_size * .pt + stroke - lwd <- ifelse(is_point, stroke, linewidth * .pt) - pch <- x$shape - lty <- x$linetype - gp <- gpar( - col = col, fill = fill, fontsize = fontsize, lwd = lwd, lty = lty, - lineend = lineend, linejoin = linejoin, linemitre = linemitre - ) - sf::st_as_grob(x$geometry, pch = pch, gp = gp, arrow = arrow) -} - #' @export #' @rdname ggsf #' @inheritParams geom_point