Merge pull request #2597 from courtiol/count.sf

Add explicit methods for `dplyr::count()` and `dplyr:tally()`

Author: edzer

DESCRIPTION

@@ -45,7 +45,11 @@ Authors@R:
       person(given = "Dewey",
              family = "Dunnington",
              role = "ctb",
-             comment = c(ORCID = "0000-0002-9415-4582"))
+             comment = c(ORCID = "0000-0002-9415-4582")),
+      person(given = "Alexandre",
+             family = "Courtiol",
+             role = "ctb",
+             comment = c(ORCID = "0000-0003-0637-2959"))
 			 )
 Description: Support for simple feature access, a standardized way to
     encode and analyze spatial vector data. Binds to 'GDAL' 

NEWS.md

@@ -1,5 +1,7 @@
 # version 1.1-1
 
+* `dplyr::count()` and `dplyr::tally()` no longer preserve geometries; #2596
+
 * better handle graticules crossing the antemeridian; #2561
 
 * add the option `by_element = TRUE` to binary geometry predicates, measures and transformers; #2594 and #2595 by @rariariari w. help from Claude

R/tidyverse.R

@@ -295,6 +295,9 @@ slice.sf <- function(.data, ..., .dots) {
 #'  nc.g |> summarise(mean(AREA))
 #'  nc.g |> summarise(mean(AREA)) |> plot(col = grey(3:6 / 7))
 #'  nc |> as.data.frame() |> summarise(mean(AREA))
+#'  # counting geometries (after duplicating each row):
+#'  nc.dupl <- nc[rep(seq_along(nc), each = 2), ]
+#'  nc.dupl |> summarise(n = n(), .by = "geometry")
 #' }
 summarise.sf <- function(.data, ..., .dots, do_union = TRUE, is_coverage = FALSE) {
 	sf_column = attr(.data, "sf_column")
@@ -341,6 +344,32 @@ summarise.sf <- function(.data, ..., .dots, do_union = TRUE, is_coverage = FALSE
 	st_as_sf(structure(ret, sf_column = NULL))
 }
 
+#' @name tidyverse
+#' @param wt see original function docs
+#' @param sort see original function docs
+#' @param name see original function docs
+#' @examples
+#' if (require(dplyr, quietly = TRUE)) {
+#'   nc$area_cl <- cut(nc$AREA, c(0, .1, .12, .15, .25))
+#'   nc |> count(area_cl)
+#'   nc |> group_by(area_cl) |> tally()
+#' }
+#' @details The functions \code{count} and \code{tally} drop all geometries.
+#' For counting geometries use \code{summarise(.data, n = n(), .by = "geometry")}.
+count.sf <- function(x, ..., wt = NULL, sort = FALSE, name = "n") {
+	x <- st_drop_geometry(x)
+	if (!requireNamespace("dplyr", quietly = TRUE))
+		stop("dplyr required: install that first") # nocov
+	NextMethod()
+}
+
+#' @name tidyverse
+tally.sf <- function(x, ..., wt = NULL, sort = FALSE, name = "n") {
+	x <- st_drop_geometry(x)
+	if (!requireNamespace("dplyr", quietly = TRUE))
+		stop("dplyr required: install that first") # nocov
+	NextMethod()
+}
 
 #' @name tidyverse
 #' @param .keep_all see corresponding function in dplyr
@@ -692,6 +721,8 @@ register_all_s3_methods = function() {
 	s3_register("dplyr::semi_join", "sf")
 	s3_register("dplyr::slice", "sf")
 	s3_register("dplyr::summarise", "sf")
+	s3_register("dplyr::count", "sf")
+	s3_register("dplyr::tally", "sf")
 	s3_register("dplyr::transmute", "sf")
 	s3_register("dplyr::ungroup", "sf")
 	s3_register("tidyr::drop_na", "sf")

man/sf-package.Rd

@@ -338,3 +338,23 @@ test_that("`pivot_wider()` works", {
 	expect_identical(st_geometry(nc2), st_geometry(nc2_wider))
 	expect_identical(st_drop_geometry(nc2), st_drop_geometry(nc2_wider))
 })
+
+test_that("`count()` works", {
+		skip_if_not_installed("dplyr")
+		nc$area_cl <- cut(nc$AREA, c(0, .1, .12, .15, .25))
+		unsorted <- count(nc, area_cl)
+		sorted_and_named <- count(nc, area_cl, sort = TRUE, name = "number")
+		expect_equal(unsorted$n, c(35, 15, 22, 28))
+		expect_equal(sorted_and_named$number, c(35, 28, 22, 15))
+		expect_false("sf" %in% class(unsorted))
+	})
+
+test_that("`tally()` works", {
+	skip_if_not_installed("dplyr")
+	nc$area_cl <- cut(nc$AREA, c(0, .1, .12, .15, .25))
+	unsorted <- tally(group_by(nc, area_cl))
+	sorted_and_named <- tally(group_by(nc, area_cl), sort = TRUE, name = "number")
+	expect_equal(unsorted$n, c(35, 15, 22, 28))
+	expect_equal(sorted_and_named$number, c(35, 28, 22, 15))
+	expect_false("sf" %in% class(unsorted))
+})