R/overlap.R

In kongdd/extract2: What the Package Does (One Line, Title Case)

#' Get the detailed information of overlapped grids
#'
#' @param r Raster, RasterBrick, SpatialPixelsDataFrame or SpatialGridDataFrame object
#' @param geoms WKB objects, e.g.
#' `sf::st_as_binary(sf::st_geometry(basins), EWKB=TRUE)`
#' 
#' @return `blocks`
#' - `fraction`: fraction percentage
#' - `area`: area in km^2
#' - `row`,`col`: begining `row` and `col` of the overlapped region
#' - `nrow`,`ncol`: number of the rows and columns of the overlapped region
#' 
#' @importFrom plyr llply
#' @export
overlap <- function(r, geoms, return.id = FALSE) {
    r %<>% check_raster()
    area <- raster::area(r)
    geoms %<>% check_wkb() # convert to wkbs

    blocks <- llply(geoms, function(wkb) {
        ret <- exactextractr:::CPP_exact_extract(r, wkb)
        names(ret)[3] <- "fraction"
        dim <- dim(ret$fraction)
        ret$nrow <- dim[1]
        ret$ncol <- dim[2]
        ret$fraction <- as.vector(t(ret$fraction))
        ret$area <- raster::getValuesBlock(area,
            row = ret$row,
            col = ret$col,
            nrow = ret$nrow, ncol = ret$ncol
        )
        ret
    }, .progress = "text")
    if (return.id) {
        getBlockValues(r, blocks)
    } else {
        blocks
    }
}

#' @rdname overlap
#' @importFrom data.table data.table
#' @export
getBlockValues <- function(r, blocks, .progress = "none") {
    r %<>% check_raster()
    res <- llply(blocks, function(ret) {
        vals <- raster::getValuesBlock(r,
            row = ret$row,
            col = ret$col,
            nrow = ret$nrow, ncol = ret$ncol
        ) %>% as.data.table()
        d <- vals %>% cbind(ret[c("fraction", "area")] %>% as.data.table())
        d %>% subset(fraction > 0)

    }, .progress = .progress)
    res
}

check_raster <- function(r) {
    if ("SpatialPixelsDataFrame" %in% class(r) || "SpatialGridDataFrame" %in% class(r)) 
        r %<>% brick()
    r
}

#' check_overlap
#' @param inheritParams extract2
#' @rdname overlap
#' @export
check_overlap <- function(geoms, r) {
    geoms %<>% check_wkb()
    if ("WKB" %in% class(geoms)) {
        b <- raster(r[[1]]) %>% readAll()
        geoms <- overlap(b, geoms, return.id = FALSE)
    }
    geoms
}

check_wkb <- function(geoms) {
    if ("SpatialPolygonsDataFrame" %in% class(geoms)) {
        geoms %<>% sf::st_as_sf()
    }
    if ("sf" %in% class(geoms)) {
        names <- geoms[[1]]
        geoms <- sf::st_as_binary(sf::st_geometry(geoms), EWKB = TRUE) %>% 
            set_names(names)
    }
    geoms
}