Skip to content

Commit

Permalink
fix: correct issue w/ get_dist when to is character
Browse files Browse the repository at this point in the history
- fix: correct issue w/ get_dist when to is character
- refactor: simplify logic for number_features
- test: expand number_features and sort_features tests
- test: add new test for st_square
  • Loading branch information
elipousson committed Feb 17, 2023
1 parent 2181d8e commit 5dbd9b3
Show file tree
Hide file tree
Showing 5 changed files with 86 additions and 25 deletions.
1 change: 0 additions & 1 deletion NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
40 changes: 30 additions & 10 deletions R/get_measurements.R
Original file line number Diff line number Diff line change
Expand Up @@ -76,15 +76,15 @@ 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)
}

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"

Expand All @@ -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)
}

Expand Down Expand Up @@ -137,18 +137,29 @@ 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)
)

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)) {
Expand All @@ -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,
Expand Down
28 changes: 15 additions & 13 deletions R/number_features.R
Original file line number Diff line number Diff line change
Expand Up @@ -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",
Expand Down Expand Up @@ -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,
Expand All @@ -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,
Expand All @@ -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 <-
Expand Down
40 changes: 39 additions & 1 deletion tests/testthat/test-number_features.R
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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(
Expand All @@ -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)
)
})
2 changes: 2 additions & 0 deletions tests/testthat/test-st_misc.R
Original file line number Diff line number Diff line change
@@ -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")
Expand Down

0 comments on commit 5dbd9b3

Please sign in to comment.