diff --git a/R/tidyverse.R b/R/tidyverse.R index 454959fb6..3e4344e0d 100644 --- a/R/tidyverse.R +++ b/R/tidyverse.R @@ -290,35 +290,35 @@ summarise.sf <- function(.data, ..., .dots, do_union = TRUE, is_coverage = FALSE precision = st_precision(.data) crs = st_crs(.data) geom = st_geometry(.data) + + if (!requireNamespace("dplyr", quietly = TRUE)) + stop("dplyr required: install that first") # nocov class(.data) = setdiff(class(.data), "sf") - ret = NextMethod() - if (!missing(do_union)) - ret$do_union = NULL - if (!missing(is_coverage)) - ret$is_coverage = NULL + .data$.rows = vctrs::vec_seq_along(.data) + ret = dplyr::summarise( + .data = .data, + ..., + .rows = list(.rows) + ) + .rows = ret$.rows + ret = ret[names(ret) != ".rows"] if (! any(sapply(ret, inherits, what = "sfc"))) { - geom = if (inherits(.data, "grouped_df") || inherits(.data, "grouped_dt")) { - if (!requireNamespace("dplyr", quietly = TRUE)) - stop("dplyr required: install that first") # nocov - i = dplyr::group_indices(.data) - # geom = st_geometry(.data) + geom = if (nrow(ret) > 1) { geom = if (do_union) - lapply(sort(unique(i)), function(x) { - if (x == 1) - st_union(geom[i == x], is_coverage = is_coverage) + lapply(.rows, function(x) { + if (1 %in% x) + st_union(geom[x], is_coverage = is_coverage) else - suppressMessages(st_union(geom[i == x], is_coverage = is_coverage)) + suppressMessages(st_union(geom[x], is_coverage = is_coverage)) }) else - lapply(sort(unique(i)), function(x) st_combine(geom[i == x])) + lapply(.rows, function(x) st_combine(geom[x])) geom = unlist(geom, recursive = FALSE) if (is.null(geom)) geom = list() #676 #nocov do.call(st_sfc, c(geom, crs = list(crs), precision = precision)) } else { # single group: - if (nrow(ret) > 1) - stop(paste0("when using .by, also add across(", sf_column, ", st_union) as argument")) # https://github.com/r-spatial/sf/issues/2207 if (do_union) st_union(geom, is_coverage = is_coverage) else diff --git a/tests/testthat/test_tidy.R b/tests/testthat/test_tidy.R index 151ecb410..39157f313 100644 --- a/tests/testthat/test_tidy.R +++ b/tests/testthat/test_tidy.R @@ -308,3 +308,42 @@ test_that("group_split.sf()` does not ignore `.keep` for grouped_df class", { expect_identical(names(nc_kept[[1]]), names(nc)) expect_identical(names(nc_notkept[[1]]), setdiff(names(nc), "CNTY_ID")) }) + +test_that("`summarise()` works", { + skip_if_not_installed("dplyr") + + nc$area_cl = cut(nc$AREA, c(0, .1, .12, .15, .25)) + + # When `do_union = TRUE` + unioned = nc %>% + group_by(area_cl) %>% + summarise(AREA = mean(AREA)) %>% + arrange(area_cl) + geom_unioned = lapply(sort(unique(nc$area_cl)), function(area_cl) { + st_union(nc$geometry[nc$area_cl == area_cl]) + }) %>% + vctrs::list_unchop() + expect_identical(unioned$geometry, geom_unioned) + + # When `do_union = FALSE` + combined = nc %>% + group_by(area_cl) %>% + summarise(AREA = mean(AREA), do_union = FALSE) %>% + arrange(area_cl) + geom_combined = lapply(sort(unique(nc$area_cl)), function(area_cl) { + st_combine(nc$geometry[nc$area_cl == area_cl]) + }) %>% + vctrs::list_unchop() + expect_identical(combined$geometry, geom_combined) + + # `.by` argument works (#2207) + unioned_by_1 = nc %>% + summarise(AREA = mean(AREA), .by = area_cl) %>% + arrange(area_cl) + unioned_by_2 = nc %>% + summarise(AREA = mean(AREA), across(geometry, st_union), .by = area_cl) %>% + arrange(area_cl) + + expect_identical(st_geometry(unioned_by_1), st_geometry(unioned)) + expect_identical(st_geometry(unioned_by_2), st_geometry(unioned)) +})