Skip to content

Instantly share code, notes, and snippets.

@rCarto

rCarto/st_aggregate.R

Last active September 9, 2024 12:49
Show Gist options
  • Save rCarto/bb47aff0a02e808d2bf64f2d8c5db7d8 to your computer and use it in GitHub Desktop.
Save rCarto/bb47aff0a02e808d2bf64f2d8c5db7d8 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. rCarto revised this gist Sep 9, 2024. 1 changed file with 22 additions and 1 deletion.
    23 changes: 22 additions & 1 deletion st_aggregate.R
    View file
    Original file line number Diff line number Diff line change
    @@ -1,3 +1,24 @@
    #' 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)
    @@ -20,4 +41,4 @@ add_args <- function(x){
    fx$n = 1
    formals(rx) <- fx
    rx
    }
    }
  2. rCarto revised this gist Sep 9, 2024. 1 changed file with 10 additions and 22 deletions.
    32 changes: 10 additions & 22 deletions st_aggregate.R
    View file
    Original file line number Diff line number Diff line change
    @@ -1,35 +1,23 @@
    #' 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 <- 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]], fun[[i]], n = 1, na.rm = TRUE)
    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
    }
  3. rCarto created this gist Sep 9, 2024.
    35 changes: 35 additions & 0 deletions st_aggregate.R
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,35 @@
    #' 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 <- 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]], 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
    }