diff --git a/NAMESPACE b/NAMESPACE index 956230a..0d5a7b5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -264,7 +264,6 @@ importFrom(tibble,enframe) importFrom(units,as_units) importFrom(units,drop_units) importFrom(units,set_units) -importFrom(utils,as.roman) importFrom(utils,data) importFrom(utils,download.file) importFrom(utils,modifyList) diff --git a/R/get_measurements.R b/R/get_measurements.R index 479d60c..83951a1 100644 --- a/R/get_measurements.R +++ b/R/get_measurements.R @@ -76,7 +76,7 @@ get_length <- function(x, units = NULL, keep_all = TRUE, drop = FALSE, .id = "le condition = is_sf(x) | is_sfc(x) ) - if (is_point(x) | is_multipoint(x)) { + if (is_point(x) || is_multipoint(x)) { convert_geom_type_alert(x, to = "LINE", with = "as_lines") x <- as_lines(x) } @@ -84,7 +84,7 @@ get_length <- function(x, units = NULL, keep_all = TRUE, drop = FALSE, .id = "le longlat <- FALSE if (is_polygon(x)) { - is_pkg_installed("lwgeom") + rlang::check_installed("lwgeom") cli_inform("For objects with POLYGON geometry, {.fun get_length} uses {.fun lwgeom::st_perimeter} to return the object perimeter.") .id <- "perimeter" @@ -102,7 +102,7 @@ get_length <- function(x, units = NULL, keep_all = TRUE, drop = FALSE, .id = "le condition = !is_multipolygon(x) ) - if (is_line(x) | is_multiline(x)) { + if (is_line(x) || is_multiline(x)) { x_len <- sf::st_length(x) } @@ -137,7 +137,14 @@ st_length_ext <- get_length #' @family dist #' @export #' @importFrom sf st_crs st_distance -get_dist <- function(x, to, by_element = TRUE, units = NULL, drop = FALSE, keep_all = TRUE, .id = "dist", ...) { +get_dist <- function(x, + to, + by_element = TRUE, + units = NULL, + drop = FALSE, + keep_all = TRUE, + .id = "dist", + ...) { stopifnot( is_sf(x, ext = TRUE), is_sf(to, ext = TRUE) || is.character(to) @@ -145,10 +152,14 @@ get_dist <- function(x, to, by_element = TRUE, units = NULL, drop = FALSE, keep_ crs <- sf::st_crs(x) + if (!is_sf(x)) { + x <- as_sf(x) + } + + from <- x + if (!is_point(x)) { - from <- st_center(x, ext = TRUE)$sf - } else { - from <- x + from <- suppressWarnings(sf::st_centroid(x)) } if (is.character(to)) { @@ -161,14 +172,23 @@ get_dist <- function(x, to, by_element = TRUE, units = NULL, drop = FALSE, keep_ to <- sf_bbox_point(as_bbox(x), point = to) to <- as_sf(to, crs = crs) + by_element <- FALSE + } + + if (!is_sf(to)) { + to <- as_sf(to) } if (!is_point(to)) { - to <- st_center(to, ext = TRUE)$sf + to <- suppressWarnings(sf::st_centroid(to)) } - x_dist <- - sf::st_distance(from, to, by_element = by_element, ...) + x_dist <- sf::st_distance( + x = from, + y = to, + by_element = by_element, + ... + ) bind_units_col( x, diff --git a/R/number_features.R b/R/number_features.R index 371f932..14916bc 100644 --- a/R/number_features.R +++ b/R/number_features.R @@ -32,8 +32,7 @@ #' "number". #' @return A `sf` object with a number column ordered by sort values. #' @export -#' @importFrom dplyr mutate row_number everything -#' @importFrom utils as.roman +#' @importFrom dplyr relocate all_of everything number_features <- function(x, col = NULL, sort = "dist_xmin_ymax", @@ -103,9 +102,11 @@ sort_features <- function(x, minmax_opts <- c("xmin", "ymin", "xmax", "ymax") if (any(sort %in% c(latlon_opts, minmax_opts))) { - sort <- arg_match(sort, c(latlon_opts, minmax_opts), multiple = TRUE) + sort <- match.arg(sort, c(latlon_opts, minmax_opts), several.ok = TRUE) - if ((sort %in% latlon_opts) && !all(has_name(x, sort))) { + missing_sort_names <- !all(has_name(x, sort)) & !is.null(sort) + + if (all(c(sort %in% latlon_opts, missing_sort_names))) { x <- get_coords( x, @@ -114,7 +115,7 @@ sort_features <- function(x, keep_all = TRUE, drop = FALSE ) - } else if ((sort %in% minmax_opts) && !all(has_name(x, sort))) { + } else if (all(c(sort %in% minmax_opts, missing_sort_names))) { x <- get_minmax( x, @@ -134,15 +135,16 @@ sort_features <- function(x, "dist_xmid_ymid" ) - if (any(sort %in% c(dist_opts)) || !is.null(to)) { - if (is.null(to)) { - # FIXME: Shouldn't this split the sort string first and then match to the options? - sort <- arg_match(sort, dist_opts, multiple = FALSE) - to <- strsplit(sort, "_")[[1]][2:3] - } else if (any(sort %in% c(dist_opts))) { - cli_warn( - "If {.arg sort} and {.arg to} are both provided, the value of {.arg sort} ({.val {sort}}) is ignored." + if (any(c(sort %in% c(dist_opts), !is.null(to)))) { + if (!is.null(sort)) { + sort <- match.arg(sort, dist_opts) + + cli_warn_ifnot( + "{.arg sort} is ignored when {.arg sort} and {.arg to} + are both provided." = is.null(to) ) + + to <- strsplit(sort, "_")[[1]][2:3] } x <- diff --git a/tests/testthat/test-number_features.R b/tests/testthat/test-number_features.R index 4290706..239f446 100644 --- a/tests/testthat/test-number_features.R +++ b/tests/testthat/test-number_features.R @@ -1,7 +1,6 @@ test_that("number_features works", { nc <- read_sf_path(system.file("shape/nc.shp", package = "sf")) - skip_on_ci() expect_s3_class( number_features( nc @@ -16,6 +15,14 @@ test_that("number_features works", { ), "sf" ) + expect_s3_class( + number_features( + nc, + sort = "dist_xmin_ymax", + to = NULL + ), + "sf" + ) expect_equal( rlang::has_name( number_features( @@ -27,3 +34,34 @@ test_that("number_features works", { TRUE ) }) + +test_that("sort_features works", { + nc <- read_sf_path(system.file("shape/nc.shp", package = "sf")) + + sort_lonlat <- + sort_features( + nc, + sort = c("lon", "lat") + ) + + sort_minmax <- + sort_features( + nc, + sort = c("xmin", "ymin") + ) + + expect_s3_class( + sort_lonlat, + "sf" + ) + expect_s3_class( + sort_minmax, + "sf" + ) + expect_false( + identical(sort_lonlat, nc) + ) + expect_false( + identical(sort_minmax, nc) + ) +}) diff --git a/tests/testthat/test-st_misc.R b/tests/testthat/test-st_misc.R index e240a8c..99ba772 100644 --- a/tests/testthat/test-st_misc.R +++ b/tests/testthat/test-st_misc.R @@ -1,11 +1,13 @@ test_that("st_misc functions work", { nc <- sf::st_read(system.file("shape/nc.shp", package = "sf")) nc_6543 <- sf::st_transform(nc, 6543) + nc_latlon <- sf::st_transform(nc, 4326) expect_error(st_inscribed_square("x")) skip_on_ci() expect_s3_class(st_square(nc_6543), "sf") + expect_s3_class(st_square(nc_latlon), "sf") expect_s3_class(st_square(nc_6543, inscribed = FALSE), "sf") expect_s3_class(st_inscribed_square(nc_6543), "sf") expect_s3_class(st_circle(nc_6543, inscribed = TRUE), "sf")