st_aggregate.R

#' Aggregate sf objects
#' 
#' Geometries and attributes are aggregated. 
#' 
#' @param x sf object
#' @param by name of the variable of grouping elements
#' @param var name(s) of the variable(s) to aggregate
#' @param fun function(s) to compute the summary statistics
#'
#' @return An sf object is returned
#' @export
#'
#' @examples
#' library(sf)
#' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"))
#' nc$dummy <- "ZONE_A"
#' nc$dummy[25:50] <- "ZONE_B"
#' nc$dummy[51:100] <- "ZONE_C"
#' r <- st_aggregate(nc, "dummy", c("BIR74", "NWBIR74"), c("mean", "median"))
#' plot(nc)
#' plot(r)
st_aggregate <- function(x, by, var, fun){
  var = c(by, var)
  fun = c("head", fun)
  n <- length(var)
  l <- vector("list", n)
  for (i in 1:n){
    l[[i]] <- tapply(x[[var[i]]], x[[by]], add_args(fun[[i]]), n = 1, na.rm = TRUE)
  }
  names(l) <- var
  r <- sf::st_sf(do.call(data.frame, l), 
                 geometry = tapply(x[attr(x, "sf_column")], x[[by]], sf::st_union), 
                 crs = sf::st_crs(x)) 
  r
}

add_args <- function(x){
  rx <- get(x)
  fx <- formals(rx)
  fx$na.rm = TRUE
  fx$n = 1
  formals(rx) <- fx
  rx
}