R/bbox.R

In brazil-data-cube/eocubes.R: Web Data Cubes Service client for R

#### S3 generic function eo_bbox ####

#' @title bbox functions
#'
#' @param x      A \code{numeric} object representing a bound box.
#' @param ...    Other parameters to construct bbox.
#'
#' @examples
#' b1 <- eo_bbox(-55, -10, -53, -8)
#' x <- c(-5559744, -996120.8, -5443916, -880292.8)
#' b2 <- eo_bbox(x)
#'
#' @export
eo_bbox <- function(x, ...) {

  if (missing(x))
    return(NULL)

  UseMethod("eo_bbox")
}

##### implementation eo_bbox #####

#' @describeIn eo_bbox This function converts a numeric array
#' into an bound box. The array must have length four (xmin, xmax, ymin, ymax).
#' Other way to create an bbox is passing each value as an argument.
#'
#' @return A \code{eo_bbox} object.
#'
#' @export
eo_bbox.numeric <- function(x, ...) {

  if (!is.numeric(x))
    stop("Invalid `numeric` value.", call. = FALSE)

  x <- c(x, unlist(list(...)))

  if (any(is.na(x)) || length(x) != 4)
    stop("Invalid bbox value.", call. = FALSE)

  res <- c(x[[1]], x[[2]], x[[3]], x[[4]])
  class(res) <- "eo_bbox"

  return(res)
}

##### eo_bbox functions #####

.bbox_as_geom <- function(bbox, densify) {

  if (densify < 0)
    stop("Invalid `densify` parameter.", call. = TRUE)

  geom <- bbox[c(1,3,3,1,1,2,2,4,4,2)]

  geom <- mapply(seq, geom[1:9], geom[2:10],
                 MoreArgs = list(length.out = densify + 1),
                 SIMPLIFY = TRUE)

  res <- matrix(c(geom[1:(nrow(geom) - 1), 1:4], geom[1, 1],
                  geom[1:(nrow(geom) - 1), 6:9], geom[1, 6]),
                ncol = 2, byrow = FALSE)
  return(res)
}

.bbox_as_sfc <- function(bbox, crs, densify = 1) {

  if (!requireNamespace("sf", quietly = TRUE))
    stop("You need `sf` package to run this function.", call. = FALSE)

  if (!inherits(bbox, "eo_bbox"))
    stop("Invalid `eo_bbox` value.", call. = FALSE)

  geom <- .bbox_as_geom(bbox = bbox, densify = densify)
  res <- sf::st_sfc(sf::st_polygon(list(geom)), crs = crs)

  return(res)
}

.bbox_as_polygon <- function(bbox, densify = 1) {

  if (!requireNamespace("sf", quietly = TRUE))
    stop("You need `sf` package to run this function.", call. = FALSE)

  if (!inherits(bbox, "eo_bbox"))
    stop("Invalid `eo_bbox` value.", call. = TRUE)

  geom <- sf::st_coordinates(sf::st_transform(
    .bbox_as_sfc(bbox = bbox, densify = densify),
    crs = "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))

  res <- list(type = "Polygon",
              coordinates = lapply(seq_len(nrow(geom)), function(j) geom[j, c(1, 2)]))

  return(res)
}

.bbox_intersects <- function(bbox1, bbox2) {

  if (is.null(bbox1) || is.null(bbox2))
    return(FALSE)

  if (!inherits(bbox1, "eo_bbox"))
    stop("Invalid `eo_bbox` value.", call. = FALSE)

  if (!inherits(bbox2, "eo_bbox"))
    stop("Invalid `eo_bbox` value.", call. = FALSE)

  res <- .intersects(bbox1, bbox2) && !.touches(bbox1, bbox2)

  return(res)
}

#' @export
as.character.eo_bbox <- function(x, ...) {

  if (!inherits(x, "eo_bbox"))
    stop("Invalid `eo_bbox` value.", call. = FALSE)

  res <- paste0(unclass(x), collapse = ",")
  return(res)
}

##### spatial functions #####

.between_lon <- function(a, b, c) {

  return(((a <= c) && (a <= b && b <= c)) || ((a > c) && (a <= b || b <= c)))
}

.between_lat <- function(a, b, c) {

  return(a <= b && b <= c)
}

.intersects <- function(b1, b2) {

  res <-
    (.between_lon(b2[[1]], b1[[1]], b2[[3]]) ||
       .between_lon(b2[[1]], b1[[3]], b2[[3]]) ||
       .between_lon(b1[[1]], b2[[1]], b1[[3]]) ||
       .between_lon(b1[[1]], b2[[3]], b1[[3]])) &&
    (.between_lat(b2[[2]], b1[[2]], b2[[4]]) ||
       .between_lat(b2[[2]], b1[[4]], b2[[4]]) ||
       .between_lat(b1[[2]], b2[[2]], b1[[4]]) ||
       .between_lat(b1[[2]], b2[[4]], b1[[4]]))

  return(res)
}

.touches <- function(b1, b2) {

  res <- .intersects(b1, b2) &&
    b1[[1]] == b2[[3]] || b1[[3]] == b2[[1]] ||
    b1[[2]] == b2[[4]] || b1[[4]] == b2[[2]]

  return(res)
}