R/stars.R

In UchidaMizuki/japanmesh: Functions for the Grid Square Codes in Japan

#' @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)
}