/
distance.R
97 lines (86 loc) · 3.17 KB
/
distance.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
#' Distance between grid square codes
#'
#' If `grid` and `grid_to` are both vectors, the distance between
#' `grid` and `grid_to` is calculated.
#' If `grid` is a list, The path distance of each element is calculated.
#'
#' @param grid A `grid` vector or a list of `grid` vector.
#' @param grid_to A `grid` vector.
#' @param close Should the path of each element be closed when `grid` is a list?
#' @param type How is the NA grid treated when `grid` is a list?
#' `"skip_na"` skips the `NA` grid and connects the paths.
#' `"keep_na"` by default.
#'
#' @return A double vector.
#'
#' @export
grid_distance <- function(grid,
grid_to = NULL,
close = FALSE,
type = c("keep_na", "ignore_na", "skip_na")) {
if (is_grid(grid)) {
if (!is_grid(grid_to)) {
cli_abort("{.arg grid_to} must be a vector with type {.cls grid}.")
}
grid_size <- grid_size(grid)
if (grid_size != grid_size(grid_to)) {
cli_abort("The grid size of {.arg grid} and {.arg grid_to} must be the same.")
}
grid <- tibble::tibble(diff_n_X = field(grid_to, "n_X") - field(grid, "n_X"),
n_Y = field(grid, "n_Y"),
n_Y_to = field(grid_to, "n_Y"))
length_X <- grid_size / 80000L
length_Y <- length_X / 1.5
distance <- vec_unique(grid)
distance <- vec_slice(distance,
!is.na(distance$diff_n_X) &
!is.na(distance$n_Y) &
!is.na(distance$n_Y_to))
diff_X <- length_X * distance$diff_n_X
Y <- length_Y * (distance$n_Y + .5)
Y_to <- length_Y * (distance$n_Y_to + .5)
distance$distance <- distance_by_element(X_from = 0,
Y_from = Y,
X_to = diff_X,
Y_to = Y_to)
grid |>
dplyr::left_join(distance,
by = c("diff_n_X", "n_Y", "n_Y_to")) |>
purrr::chuck("distance")
} else {
if (!is.list(grid)) {
cli_abort("{.arg grid} must be a {.cls list}.")
}
if (!is.null(grid_to)) {
cli_abort("If {.arg grid} is a {.cls list}, {.arg grid_to} must be {.var NULL}.")
}
type <- arg_match(type, c("keep_na", "ignore_na", "skip_na"))
grid |>
purrr::modify(\(grid) {
if (type == "skip_na") {
grid <- grid |>
vec_slice(!is.na(grid))
}
if (close) {
grid_to <- c(utils::tail(grid, -1L), grid[1L])
} else {
grid_to <- utils::tail(grid, -1L)
grid <- utils::head(grid, -1L)
}
grid_distance(grid, grid_to) |>
sum(na.rm = type == "ignore_na")
})
}
}
distance_by_element <- function(X_from, Y_from, X_to, Y_to) {
from <- tibble::tibble(X_from = X_from,
Y_from = Y_from) |>
sf::st_as_sf(coords = c("X_from", "Y_from"),
crs = 4326)
to <- tibble::tibble(X_to = X_to,
Y_to = Y_to) |>
sf::st_as_sf(coords = c("X_to", "Y_to"),
crs = 4326)
sf::st_distance(from, to,
by_element = TRUE)
}