R/bbox_to_poly.R

In nominatimlite: Interface to the 'Nominatim' API

#' Coerce a bounding box to a [`sfc`][sf::st_sfc] `POLYGON` object
#'
#' @description
#' Create a [`sfc`][sf::st_sfc] object from the coordinates of a bounding box.
#'
#' @family spatial
#' @encoding UTF-8
#'
#' @param bbox Numeric vector of 4 elements representing the coordinates of the
#'   bounding box. Values should be `c(xmin, ymin, xmax, ymax)`.
#' @param xmin,ymin,xmax,ymax Alternatively, you can use these named parameters
#'   instead of `bbox`.
#'
#' @inheritParams sf::st_sf
#'
#' @details
#' Bounding boxes can be located using online tools such as
#' <https://boundingbox.klokantech.com/>.
#'
#' @return
#' A [`sfc`][sf::st_sfc] object of class `POLYGON` with the corresponding
#' coordinate reference system `crs`.
#'
#' @seealso
#' [sf::st_as_sfc()] and [sf::st_sfc()].
#'
#' @export
#'
#' @examplesIf nominatim_check_access()
#'
#' # Bounding box of Germany
#' bbox_GER <- c(5.86631529, 47.27011137, 15.04193189, 55.09916098)
#'
#' bbox_GER_sf <- bbox_to_poly(bbox_GER)
#'
#' library(ggplot2)
#'
#' ggplot(bbox_GER_sf) +
#'   geom_sf()
#' \donttest{
#' # Extract the bounding box of an sf object
#' sfobj <- geo_lite_sf("seychelles", points_only = FALSE)
#'
#' sfobj
#'
#' # Require at least one non-empty object
#' if (!all(sf::st_is_empty(sfobj))) {
#'   bbox <- sf::st_bbox(sfobj)
#'
#'   bbox
#'
#'   bbox_sfobj <- bbox_to_poly(bbox)
#'
#'   ggplot(bbox_sfobj) +
#'     geom_sf(fill = "lightblue", alpha = 0.5) +
#'     geom_sf(data = sfobj, fill = "wheat")
#' }
#' }
bbox_to_poly <- function(
  bbox = NA,
  xmin = NA,
  ymin = NA,
  xmax = NA,
  ymax = NA,
  crs = 4326
) {
  if (!anyNA(bbox) && length(bbox) != 4) {
    stop(
      "`bbox` must have 4 elements. The provided value has ",
      length(bbox),
      "."
    )
  }

  # If `bbox` is missing, use explicit x and y values.
  if (anyNA(bbox)) {
    bbox <- as.double(c(xmin, ymin, xmax, ymax))

    if (anyNA(bbox)) {
      stop(
        "`xmin`, `ymin`, `xmax` and `ymax` cannot be NA when `bbox` is ",
        "not provided."
      )
    }
  }

  bbox_double <- as.double(bbox)
  names(bbox_double) <- c("xmin", "ymin", "xmax", "ymax")
  class(bbox_double) <- "bbox"

  bbox_sf <- sf::st_as_sfc(bbox_double)
  sf::st_crs(bbox_sf) <- sf::st_crs(crs)

  bbox_sf
}