/
union_sf.R
64 lines (56 loc) · 3.02 KB
/
union_sf.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
#' Aggregate Polygons in a \code{sf} Object
#'
#' The function aggregates polygons of geometry column of a \code{sf} data frame according to values of a single data column. It has outcome comparable to \code{unionSpatialPolygons} from \code{maptools} package, except that it works on \code{sf} and not \code{sp} objects.
#'
#' The function has data frame as the first argument, so it is pipe friendly. It retains only geometry and key value, dropping all other columns (they are easy to re-attach using tidyverse/dplyr workflow if required).
#'
#' During processing the sf data frame is temporarily transformed to planar coordinates and - to avoid artefacts (slivers) at the place of former boundaries - buffered; the default values of \code{planarCRS} and \code{tolerance} should cover most situations in the Czech Republic and near abroad.
#'
#' @param data sf data frame to be aggregated
#' @param key name of a single column to define the output objects
#' @param tolerance buffer size for avoiding artefacts (slivers); default is one meter
#' @param planar_CRS planar CRS for avoiding artefacts (slivers); default is EPSG:5514 = ing. Křovák
#'
#' @export
#' @importFrom magrittr %>%
#' @importFrom rlang :=
#'
#' @examples
#' \donttest{
#' # library(sf)
#'
#' NUTS3 <- union_sf(okresy(), "KOD_CZNUTS3")
#' # assembles NUTS3 regions from LAU1 regions of Czech Republic = equivalent to kraje() in geometry
#'
#' plot(NUTS3)
#' }
#'
union_sf <- function(data, key, tolerance = 1, planar_CRS = 5514) {
# give out a deprecation warning / unless in process of being tested
if (!identical(Sys.getenv("TESTTHAT"), "true")) .Deprecated(msg = "function union_sf is being moved to package sfhelp; it will be removed in a coming version")
if (missing(data)) stop("required argument `data` is missing")
if (missing(key)) stop("required argument `key` is missing")
if (length(key) != 1) stop("a single `key` value is required")
if (!inherits(data, "sf")) stop("`data` is not a {sf} object")
if (!is.element(key, colnames(data))) stop("`key` is not a recognized column of `data`")
wrk_crs <- sf::st_crs(data) # save the current CRS
data <- sf::st_transform(data, planar_CRS) # transform to a temporary metric CRS
ids <- dplyr::pull(data, key) %>% # key column values
unique() # unique only...
for (i in seq_along(ids)) {
vec <- sf::st_set_geometry(data[key], NULL) == ids[i] # rows matching current i
wrk <- data[vec, ] %>% # rows matching current i
sf::st_make_valid() %>% # make valid, just in case...
sf::st_buffer(tolerance) %>% # sparkle some magical dust
sf::st_union() %>% # unite!
sf::st_buffer(-tolerance) %>% # remove the magical dust to preserve area
sf::st_sf() %>% # extract geometry only
dplyr::mutate(!!key := ids[i]) # add key column
if (i == 1) { # is this the first row?
res <- wrk # assing current working data frame as result
} else {
res <- rbind(res, wrk) # append current working data frame to the result
}
}
sf::st_transform(res, wrk_crs) # return res in original CRS
}