Merge pull request #50 from CityRiverSpaces/bbox-fn

Unify bbox

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 export(add_weights)
+export(as_bbox)
 export(as_network)
 export(clean_network)
 export(corridor)

R/osmdata.R

@@ -4,13 +4,14 @@
 #'
 #' @param key A character string with the key to filter the data
 #' @param value A character string with the value to filter the data
-#' @param bb A matrix with the bounding box (rows for "x", "y", columns for
-#'           "min", "max")
+#' @param bb A bounding box, provided either as a matrix (rows for "x", "y",
+#'   columns for "min", "max") or as a vector ("xmin", "ymin", "xmax", "ymax")
 #'
 #' @return An sf object with the retrieved OpenStreetMap data
 #' @export
 osmdata_as_sf <- function(key, value, bb) {
-  bb |>
+  bbox <- as_bbox(bb)
+  bbox |>
     osmdata::opq() |>
     osmdata::add_osm_feature(key = key, value = value) |>
     osmdata::osmdata_sf()
@@ -27,10 +28,7 @@ osmdata_as_sf <- function(key, value, bb) {
 #' get_osm_bb("Bucharest")
 get_osm_bb <- function(city_name) {
   bb <- osmdata::getbb(city_name)
-  bb <- bb |> as.vector()
-  names(bb) <- c("xmin", "ymin", "xmax", "ymax")
-  bb <- sf::st_bbox(bb, crs = 4326)
-  return(bb)
+  return(as_bbox(bb))
 }
 
 #' Retrieve OpenStreetMap data for a given location
@@ -180,7 +178,7 @@ get_osm_river <- function(river_name, bb, crs) {
 
 #' Get OpenStreetMap streets
 #'
-#' @param bb Boundary box
+#' @param bb Bounding box of class `bbox`
 #' @param crs Coordinate reference system as EPSG code
 #' @param highway_values A character vector with the highway values to retrieve.
 #'             If left NULL, the function retrieves the following values:
@@ -221,7 +219,7 @@ get_osm_streets <- function(bb, crs, highway_values = NULL) {
 
 #' Get OpenStreetMap railways
 #'
-#' @param bb Bounding box
+#' @param bb Bounding box of class `bbox`
 #' @param crs Coordinate reference system as EPSG code
 #'
 #' @return An sf object with the railways

R/utils.R

@@ -21,11 +21,30 @@ set_units_like <- function(x, y) {
 #' @return The EPSG of the UTM zone
 #' @export
 get_utm_zone <- function(x) {
-  bb <- sf::st_bbox(x)
+  bb <- as_bbox(x)
 
   centroid_long <- (bb[["xmin"]] + bb[["xmax"]]) / 2
   centroid_lat <- (bb[["ymin"]] + bb[["ymax"]]) / 2
   base <- if (centroid_lat >= 0) 32600 else 32700
   epsg_code <- base + floor((centroid_long + 180) / 6) + 1
   return(epsg_code)
 }
+
+#' Get the bounding box from the x object. If the x does not have a CRS, WGS84
+#' is assumed.
+#'
+#' @param x Simple feature object or a bounding box, provided either as a
+#'   matrix (with x, y as rows and min, max as columns) or as a vector (xmin,
+#'   ymin, xmax, ymax)
+#' @return A bounding box as returned by [`sf::st_bbox()`]
+#' @export
+as_bbox <- function(x) {
+  if (inherits(x, c("numeric", "matrix"))) {
+    x <- as.vector(x)
+    names(x) <- c("xmin", "ymin", "xmax", "ymax")
+  }
+  bbox <- sf::st_bbox(x)
+  crs <- sf::st_crs(bbox)
+  if (is.na(crs)) sf::st_crs(bbox) <- sf::st_crs(4326)
+  return(bbox)
+}

R/valley.R

@@ -1,6 +1,7 @@
-#'Load dem from a STAC endpoint
+#' Load dem from a STAC endpoint
 #'
-#' @param bb bounding box of aoi for which to retrieve dem.
+#' @param bb A bounding box, provided either as a matrix (rows for "x", "y",
+#'   columns for "min", "max") or as a vector ("xmin", "ymin", "xmax", "ymax")
 #' @param resource from which to source dem. Can be "STAC".
 #' if "STAC" the parameters the following parameters
 #' must be supplied as named parameters. If omitted defaults
@@ -12,19 +13,19 @@
 #' @return dem
 #' @export
 get_dem <- function(bb, resource = "STAC", ...) {
+  bbox <- as_bbox(bb)
   args <- list(...)
   if (resource == "STAC") {
     if (length(args) && !is.null(...)) {
       endpoint <- args$endpoint
       collection <- args$collection
-      asset_urls <- get_stac_asset_urls(
-                                        bb,
+      asset_urls <- get_stac_asset_urls(bbox,
                                         endpoint = endpoint,
                                         collection = collection)
     } else {
-      asset_urls <- get_stac_asset_urls(bb)
+      asset_urls <- get_stac_asset_urls(bbox)
     }
-    dem <- load_raster(bb, asset_urls)
+    dem <- load_raster(bbox, asset_urls)
     return(dem)
   } else {
     stop(sprintf("Resource %s unknown", resource))
@@ -56,13 +57,11 @@ get_valley <- function(dem, river, crs) {
   return(valley)
 }
 
-
-
-#'Retrieve asset urls for the intersection of a bounding box with a
-#'remote STAC endpoint
+#' Retrieve asset urls for the intersection of a bounding box with a
+#' remote STAC endpoint
 #'
-#' @param bb A bounding box (compliant with CRiSp,
-#' i.e. as a matrix with 4 elements: xmin, ymin, xmax, ymax)
+#' @param bb A bounding box, provided either as a matrix (rows for "x", "y",
+#'   columns for "min", "max") or as a vector ("xmin", "ymin", "xmax", "ymax")
 #' @param endpoint url of (remote) STAC endpoint
 #' @param collection STAC collection to be queried
 #'
@@ -73,31 +72,33 @@ get_stac_asset_urls <- function(
     bb,
     endpoint = "https://earth-search.aws.element84.com/v1",
     collection = "cop-dem-glo-30") {
+  bbox <- as_bbox(bb)
   it_obj <- rstac::stac(endpoint) |>
-    rstac::stac_search(collections = collection, bbox = as.vector(bb)) |>
+    rstac::stac_search(collections = collection, bbox = bbox) |>
     rstac::get_request()
   asset_urls <- rstac::assets_url(it_obj)
   return(asset_urls)
 }
 
-#' retrieve STAC records (of a DEM) corresponding to a list of asset urls,
+#' Retrieve STAC records (of a DEM) corresponding to a list of asset urls,
 #' crop and merge with a specified bounding box to create a dem of the
 #' specified region
 #'
-#' @param bb A bounding box (compliant with CRiSp,
-#' i.e. as a matrix with 4 elements: xmin, ymin, xmax, ymax)
+#' @param bb A bounding box, provided either as a matrix (rows for "x", "y",
+#'   columns for "min", "max") or as a vector ("xmin", "ymin", "xmax", "ymax")
 #' @param raster_urlpaths a list of STAC records to be retrieved
 #'
 #' @return A a merged dem from retrieved assets cropped to the bounding box
 #' @export
 load_raster <- function(bb, raster_urlpaths) {
+  bbox <- as_bbox(bb)
   raster_urlpaths |>
     lapply(terra::rast) |>
-    lapply(terra::crop, as.vector(t(bb))) |>
+    lapply(terra::crop, terra::ext(bbox)) |>
     do.call(terra::merge, args = _)
 }
 
-#'Write dem to cloud optimized GeoTiff file as specified location
+#' Write dem to cloud optimized GeoTiff file as specified location
 #'
 #' @param dem to write to file
 #' @param fpath filepath for output. If no output directory is specified
@@ -123,11 +124,6 @@ dem_to_cog <- function(dem, fpath, output_directory = NULL) {
                      overwrite = TRUE)
 }
 
-
-
-
-
-
 #' Reproject a raster or vector dataset to the specified
 #' coordinate reference system (CRS)
 #'
@@ -147,7 +143,7 @@ reproject <- function(x, crs, ...) {
   }
 }
 
-#' spatially smooth dem by (window) filtering
+#' Spatially smooth dem by (window) filtering
 #'
 #' @param dem raster data of dem
 #' @param method smoothing function to be used, e.g. "median".

tests/testthat/test-utils.R

@@ -52,3 +52,40 @@ test_that("both bbox and sf objects can be used to find UTM zone", {
   utm_epsg_geom <- get_utm_zone(geom)
   expect_equal(utm_epsg_bbox, utm_epsg_geom)
 })
+
+test_that("a matrix is correctly converted to a bbox", {
+  bb <- matrix(data = c(0, 1, 2, 3),
+               nrow = 2,
+               ncol = 2,
+               dimnames = list(c("x", "y"), c("min", "max")))
+  bbox <- as_bbox(bb)
+  expect_true(inherits(bbox, "bbox"))
+  expect_true(all(as.vector(bbox) == c(0, 1, 2, 3)))
+  expect_equal(sf::st_crs(bbox), sf::st_crs(4326))
+})
+
+test_that("a vector is correctly converted to a bbox", {
+  bb <- c(0, 1, 2, 3)
+  names(bb) <- c("xmin", "ymin", "xmax", "ymax")
+  bbox <- as_bbox(bb)
+  expect_true(inherits(bbox, "bbox"))
+  expect_true(all(as.vector(bbox) == c(0, 1, 2, 3)))
+  expect_equal(sf::st_crs(bbox), sf::st_crs(4326))
+})
+
+test_that("a sf object is correctly converted to a bbox", {
+  linestring <- sf::st_linestring(matrix(c(0, 1, 2, 3), ncol = 2, byrow = TRUE))
+  bbox <- as_bbox(linestring)
+  expect_true(inherits(bbox, "bbox"))
+  expect_true(all(as.vector(bbox) == c(0, 1, 2, 3)))
+  expect_equal(sf::st_crs(bbox), sf::st_crs(4326))
+})
+
+test_that("a bbox object does not change class", {
+  crs <- 3285
+  bb <- sf::st_bbox(c(xmin = 0, ymin = 1, xmax = 2, ymax = 3), crs = crs)
+  bbox <- as_bbox(bb)
+  expect_true(inherits(bbox, "bbox"))
+  expect_true(all(as.vector(bbox) == c(0, 1, 2, 3)))
+  expect_equal(sf::st_crs(bbox), sf::st_crs(crs))
+})