/
stars.R
70 lines (65 loc) · 2.17 KB
/
stars.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
#' @importFrom stars st_as_stars
#' @export
st_as_stars.grid <- function(.x, ...) {
tibble::tibble(grid = .x,
values = NA_real_) |>
grid_as_stars(...)
}
#' Converting data frame containing regional grids to stars
#'
#' @param x A data frame or a `grid`.
#' @param coords The column names or indices that form the cube dimensions.
#' @param crs Coordinate reference system.
#' @param grid_column_name A scalar character.
#' @param ... Passed on to [stars::st_as_stars()].
#'
#' @return A `stars` object.
#'
#' @export
grid_as_stars <- function(x,
coords = NULL,
crs = sf::NA_crs_,
grid_column_name = NULL, ...) {
if (is_grid(x)) {
x <- tibble::tibble(grid = x,
values = NA_real_)
grid_column_name <- "grid"
} else if (!is.data.frame(x)) {
cli_abort("{.arg x} must be a {.cls grid} or a data frame.")
}
if (is.null(grid_column_name)) {
i <- x |>
purrr::map_lgl(is_grid)
grid_column_name <- names(x) |>
vec_slice(i) |>
vec_slice(1L)
}
grid <- x[[grid_column_name]]
n_X <- field(grid, "n_X")
n_Y <- field(grid, "n_Y")
n_XY <- tidyr::expand_grid(n_X = min(n_X):(max(n_X) + 1L),
n_Y = min(n_Y):(max(n_Y) + 1L))
grid <- new_grid(grid_size = grid_size(grid),
n_X = n_XY$n_X,
n_Y = n_XY$n_Y)
coords_grid <- grid_to_coords(grid)
grid <- tibble::tibble(!!grid_column_name := grid,
X = coords_grid$X,
Y = coords_grid$Y)
coords <- coords[coords != grid_column_name]
x <- tidyr::expand_grid(grid,
vctrs::vec_unique(x[coords])) |>
dplyr::left_join(x,
by = c(grid_column_name, coords))
x <- x[names(x) != grid_column_name]
x <- stars::st_as_stars(x,
coords = c("X", "Y", coords),
y_decreasing = FALSE, ...) |>
sf::st_set_crs(crs)
dim_x <- dim(x)
x |>
dplyr::slice("X", 1L:(dim_x[["X"]] - 1L),
drop = FALSE) |>
dplyr::slice("Y", 1L:(dim_x[["Y"]] - 1L),
drop = FALSE)
}