R/api_bbox.R

In e-sensing/sits: Satellite Image Time Series Analysis for Earth Observation Data Cubes

#' @title Check if bboxs are equal
#' @name .bbox_equal
#' @keywords internal
#' @noRd
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#'
#' @param bbox1          Bounding box for a region of interest.
#' @param bbox2          Bounding box for a region of interest.
#' @param tolerance      Tolerance (numerical value)
#' @return               A logical value
#'
.bbox_equal <- function(bbox1, bbox2, tolerance = 0) {
    .is_eq(unlist(bbox1[.bbox_cols]), unlist(bbox2[.bbox_cols]),
        tolerance = tolerance
    )
}
#' @title Bounding box API
#' @noRd
#'
#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br}
#'
#' @description
#' A bounding box represents a rectangular geographical region in a certain
#' projection. A \code{bbox} is any \code{list} or \code{tibble} containing
#' \code{xmin}, \code{xmax}, \code{ymin}, \code{ymax}, and \code{crs} fields.
#' A \code{bbox} may contains multiple entries.
#'
#' @param x      Any object to extract a \code{bbox}.
#' @param ...    Parameters to be evaluated accordingly to input object.
#'
#' @examples
#' if (sits_run_examples()) {
#'     x <- list(a = 0, z = 0)
#'     .bbox(x) # NULL
#'     x <- list(
#'         a = 0, xmin = 1:3, xmax = 2:4, ymin = 3:5, ymax = 4:6,
#'         crs = 4326, z = 0
#'     )
#'     .bbox(x)
#'     .bbox_as_sf(x) # 3 features
#'     .bbox_as_sf(x, as_crs = "EPSG:3857")
#' }
NULL
# bbox fields
.bbox_cols <- c("xmin", "xmax", "ymin", "ymax")
#' @title Check if an object contains a bbox
#' @noRd
#' @returns A logical indicating if an object contains a bbox.
.has_bbox <- function(x) {
    all(.bbox_cols %in% names(x))
}
#' @title Check if an object is a bbox
#' @noRd
#' @returns A logical indicating if an object is a bbox.
.is_bbox <- function(x) {
    setequal(names(x), c(.bbox_cols, "crs"))
}
#' @title Get the type of object containing a bbox
#' @noRd
#' @returns A bbox type (One of 'sf', 'tbl', or 'point').
.bbox_type <- function(x) {
    if (inherits(x, c("sf", "sfc"))) {
        "sf"
    } else if (.has_bbox(x)) {
        "tbl"
    } else if (.is_point(x)) {
        "point"
    } else {
        stop("cannot extract bbox from object of class ", class(x))
    }
}
#' @title Switch bbox type
#' @noRd
#' @returns One of the arguments passed in `...` according to a bbox type.
.bbox_switch <- function(x, ...) {
    switch(.bbox_type(x),
        ...
    )
}
#' @title Extract a bbox
#' @noRd
#' @param default_crs  If no CRS is present in `x`, which CRS should be
#'   used? If `NULL`, default CRS will be 'EPSG:4326'.
#' @param as_crs  A CRS to project bbox. Useful if bbox has multiples CRS.
#' @returns A bbox from any given object.
.bbox <- function(x, default_crs = NULL, as_crs = NULL, by_feature = FALSE) {
    x <- .bbox_switch(
        x = x,
        sf = .bbox_from_sf(x),
        tbl = .bbox_from_tbl(x = x, default_crs = default_crs),
        point = .bbox_from_point(x)
    )
    # Convert to sf and get bbox
    geom <- .bbox_as_sf(bbox = x, as_crs = as_crs)
    bbox <- .bbox_from_sf(geom, by_feature = by_feature)
    # Update crs
    if (.has(as_crs)) {
        .crs(bbox) <- as_crs
    }
    # Return bbox
    bbox
}
#' @title Extract a bbox from a sf object
#' @noRd
#' @returns A \code{bbox} from any given \code{sf}.
.bbox_from_sf <- function(x, by_feature = FALSE) {
    bbox <- if (by_feature) {
        slider::slide_dfr(x, function(y) {
            tibble::as_tibble_row(c(sf::st_bbox(y)))
        })
    } else {
        tibble::as_tibble_row(c(sf::st_bbox(x)))
    }
    bbox <- bbox[.bbox_cols]
    .crs(bbox) <- sf::st_crs(x)[["wkt"]]
    # Return bbox
    bbox
}
#' @title Extract a bbox from a tibble object
#' @noRd
#' @param default_crs  If no CRS is present in `x`, which CRS should be
#'   used? If `NULL`, default CRS will be 'EPSG:4326'.
#' @returns a \code{bbox} from any given \code{tibble}.
.bbox_from_tbl <- function(x, default_crs = NULL) {
    xmin <- .xmin(x)
    xmax <- .xmax(x)
    ymin <- .ymin(x)
    ymax <- .ymax(x)
    if ("crs" %in% names(x)) {
        crs <- .crs(x)
    } else {
        crs <- .default(default_crs, default = {
            if (.check_warnings()) {
                warning("object has no crs, assuming 'EPSG:4326'",
                    call. = FALSE
                )
            }
            "EPSG:4326"
        })
    }
    # Create a bbox
    bbox <- .common_size(
        xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, crs = crs
    )
    # Fix inconsistencies
    xmin <- pmin(.xmin(bbox), .xmax(bbox))
    xmax <- pmax(.xmin(bbox), .xmax(bbox))
    ymin <- pmin(.ymin(bbox), .ymax(bbox))
    ymax <- pmax(.ymin(bbox), .ymax(bbox))
    # Compute final bbox
    .xmin(bbox) <- xmin
    .xmax(bbox) <- xmax
    .ymin(bbox) <- ymin
    .ymax(bbox) <- ymax
    # Return bbox
    bbox
}
#' @title Extract a bbox from a set of points
#' @noRd
#' @returns A bbox from any given set of points.
.bbox_from_point <- function(point) {
    # Create bbox
    bbox <- .common_size(
        xmin = min(.lon(point)), xmax = max(.lon(point)),
        ymin = min(.lat(point)), ymax = max(.lat(point)),
        crs = .crs(point)
    )
    # Return bbox
    bbox
}
#' @title Convert a bbox into a sf object
#' @noRd
#' @param bbox    A bbox.
#' @param as_crs  A CRS to project bbox. Useful if bbox has multiples CRS.
#' @returns A sf polygon object from a bbox.
.bbox_as_sf <- function(bbox, as_crs = NULL) {
    # Check for a valid bbox
    .check_bbox(bbox)
    # Check if there are multiple CRS in bbox
    if (length(.crs(bbox)) > 1 && is.null(as_crs)) {
        if (.check_warnings()) {
            warning("object has multiples CRS values, reprojecting to ",
                "'EPSG:4326'\n", "(use 'as_crs' to reproject to a ",
                "different CRS)",
                call. = FALSE
            )
        }
        as_crs <- "EPSG:4326"
    }
    # Convert to sf object and return it
    geom <- purrr::pmap_dfr(bbox, function(xmin, xmax, ymin, ymax, crs, ...) {
        geom_elem <- sf::st_sf(
            geometry = sf::st_sfc(sf::st_polygon(list(
                rbind(
                    c(xmin, ymax), c(xmax, ymax), c(xmax, ymin),
                    c(xmin, ymin), c(xmin, ymax)
                )
            ))), crs = crs
        )
        # Project CRS
        if (!is.null(as_crs)) {
            geom_elem <- sf::st_transform(geom_elem, crs = as_crs)
        }
        # Return geometry
        geom_elem
    })
    # Return geom
    geom
}
#' @title Compute the intersection of two bbox
#' @noRd
#' @param x,y  A bbox.
#' @returns  An intersected bbox.
.bbox_intersection <- function(x, y) {
    # Check for a valid bbox
    .check_bbox(x)
    .check_bbox(y)
    # Transform y projection according with x
    as_crs <- .crs(x)
    y <- .bbox_as_sf(bbox = y, as_crs = as_crs)
    x <- .bbox_as_sf(bbox = x)
    # Do intersection
    if (!.intersects(x, y)) {
        return(NULL)
    }
    geom <- sf::st_intersection(x, y)
    bbox <- .bbox(geom)
    # Return bbox
    bbox
}
#' @title Convert WKT projection name no PROJ4 name
#' @name .crs_wkt_to_proj4
#' @noRd
#' @param wkt_crs  CRS in WKT name
#' @returns  CRS in PROJ4 name
.crs_wkt_to_proj4 <- function(wkt_crs) {
    # Convert WKT to sf CRS object
    crs_sf <- sf::st_crs(wkt_crs)
    # Convert sf CRS object to PROJ4 string
    proj4string <- crs_sf$proj4string
    return(proj4string)
}