feat: add is_wgs84 + as_wgs84

- feat: add is_wgs84 + as_wgs84
- docs: add examples for as_sf + is_sf

NAMESPACE

@@ -17,6 +17,7 @@ export(as_sf_class)
 export(as_sf_list)
 export(as_sfc)
 export(as_startpoint)
+export(as_wgs84)
 export(as_xy)
 export(bind_units_col)
 export(check_coords)
@@ -68,6 +69,7 @@ export(is_sfc)
 export(is_sfg)
 export(is_shorter)
 export(is_sp)
+export(is_wgs84)
 export(list_data_files)
 export(lonlat_to_sfc)
 export(make_filename)

R/as_sf.R

@@ -26,9 +26,10 @@
 #' @param ... Additional parameters passed to [sf::st_bbox()] when calling
 #'   [as_bbox()] or passed to [sf::st_sf()], [sf::st_as_sf()], or [df_to_sf()]
 #'   for [as_sf()] (depending on class of x)
+#' @example examples/as_sf.R
 #' @export
-#' @importFrom sf st_sf st_as_sfc st_bbox st_as_sf st_geometry
-#' @importFrom dplyr bind_rows rename
+#' @importFrom dplyr case_when bind_rows
+#' @importFrom sf st_sf st_sfc st_as_sfc st_bbox st_as_sf st_geometry
 as_sf <- function(x,
                   crs = NULL,
                   sf_col = "geometry",
@@ -129,7 +130,8 @@ as_bbox <- function(x, crs = NULL, ext = TRUE, ...) {
 #' @name as_sfc
 #' @rdname as_sf
 #' @export
-#' @importFrom sf st_geometry st_as_sfc
+#' @importFrom dplyr case_when
+#' @importFrom sf st_geometry st_sfc st_as_sfc
 as_sfc <- function(x, crs = NULL, ext = TRUE, ...) {
   if (is_sfc(x)) {
     return(transform_sf(x, crs = crs))
@@ -170,7 +172,11 @@ as_sfc <- function(x, crs = NULL, ext = TRUE, ...) {
 #' @export
 #' @importFrom dplyr summarize group_keys group_nest
 #' @importFrom janitor make_clean_names
-as_sf_list <- function(x, nm = "data", col = NULL, crs = NULL, clean_names = TRUE) {
+as_sf_list <- function(x,
+                       nm = "data",
+                       col = NULL,
+                       crs = NULL,
+                       clean_names = TRUE) {
   check_null(x)
   check_string(col, allow_null = TRUE)
 
@@ -239,7 +245,13 @@ as_sf_list <- function(x, nm = "data", col = NULL, crs = NULL, clean_names = TRU
 #' @inheritParams as_sf_list
 #' @export
 #' @importFrom dplyr mutate
-make_sf_grid_list <- function(x, style = "rect", ncol = 2, nrow = 2, .id = "grid_id", crs = NULL, ...) {
+make_sf_grid_list <- function(x,
+                              style = "rect",
+                              ncol = 2,
+                              nrow = 2,
+                              .id = "grid_id",
+                              crs = NULL,
+                              ...) {
   grid <- st_make_grid_ext(x, style = style, ncol = ncol, nrow = nrow, .id = .id, ...)
 
   x <- st_join_ext(x, grid, largest = TRUE)
@@ -267,7 +279,11 @@ make_sf_grid_list <- function(x, style = "rect", ncol = 2, nrow = 2, .id = "grid
 #' @name as_sf_class
 #' @rdname as_sf
 #' @export
-as_sf_class <- function(x, class = NULL, allow_null = TRUE, call = caller_env(), ...) {
+as_sf_class <- function(x,
+                        class = NULL,
+                        allow_null = TRUE,
+                        call = caller_env(),
+                        ...) {
   if (is.null(class) && is_true(allow_null)) {
     return(x)
   }
@@ -316,6 +332,18 @@ as_crs <- function(crs = NULL, check = FALSE, call = parent.frame()) {
   )
 }
 
+#' @name as_crs
+#' @rdname as_sf
+#' @export
+as_wgs84 <- function(x) {
+  if (is_wgs84(x)) {
+    return(x)
+  }
+
+  st_transform_ext(x, 4326)
+}
+
+
 #' Convert data to a data frame with X/Y coordinate pairs
 #'
 #' Wraps [as_points()], [as_sfc()], and [sf_bbox_point()] to allow the

R/is_sf.R

@@ -15,10 +15,11 @@
 #' - [is_raster]: is x a `Raster` class object?
 #' - [is_sp]: is x a `Spatial` class object of any type?
 #' - [is_geo_coords]: is x likely a geodetic coordinate pair (a length 2 numeric vector, with a max absolute value less than or equal to 180)?
+#' - [is_wgs84]: is x using the [WSG84](https://en.wikipedia.org/wiki/World_Geodetic_System) coordinate reference system?
 #' - [is_same_crs]: do x and y have the same coordinate reference system?
 #'
+#' @example examples/is_sf.R
 #' @export
-#' @md
 is_sf <- function(x, ext = FALSE, allow_null = FALSE, allow_list = FALSE) {
   classes <- "sf"
 
@@ -116,10 +117,19 @@ is_geo_coords <- function(x, allow_null = FALSE) {
   is.numeric(x) && (length(x) == 2) && (max(abs(x)) <= 180)
 }
 
+#' @name is_wgs84
+#' @rdname  is_sf
+#' @export
+is_wgs84 <- function(x) {
+  is_same_crs(x, 4326)
+}
+
 #' @name is_same_crs
 #' @rdname  is_sf
 #' @importFrom sf st_crs
 #' @export
 is_same_crs <- function(x, y) {
-  sf::st_crs(x) == sf::st_crs(y)
+  crs_x <- sf::st_crs(x)
+  crs_y <- sf::st_crs(y)
+  (crs_x == crs_y) || (crs_x$input == crs_y$input)
 }

examples/as_sf.R

@@ -0,0 +1,12 @@
+nc <- read_sf_ext(system.file("shape/nc.shp", package = "sf"))
+nc[["category"]] <- sample(c("A", "B", "C", "D", "E"), nrow(nc), replace = TRUE)
+
+as_sf(nc$geometry)
+
+as_bbox(nc)
+
+as_sf_list(nc, col = "category")
+
+as_crs(nc)
+
+as_xy(nc[1,])

examples/is_sf.R

@@ -0,0 +1,13 @@
+nc <- read_sf_ext(system.file("shape/nc.shp", package = "sf"))
+
+is_sf(nc)
+
+is_sfc(nc$geometry)
+
+is_sf_list(list(nc[1, ], nc[2, ]))
+
+is_bbox(sf::st_bbox(nc))
+
+is_wgs84(sf::st_transform(nc, 4326))
+
+is_same_crs(nc, 4267)