R/custom_fuctions.R

In obrl-soil/h3jsr: Access Uber's H3 Library

#' Convert H3 cell indexes to a line
#'
#' Return line geometry for a sequence of H3 cell indexes in WGS84 coordinates.
#' @param input Character vector of 15-character indexes generated by H3, a
#'   list of such, or a data frame where the last column is a list-column of H3
#'   cell indexes (usually the output of
#'   \code{\link[h3jsr:grid_path]{h3jsr::grid_path()}}.
#' @param simple Logical; whether to return an \code{sfc_LINESTRING} object or
#'   an \code{sf} data frame containing both inputs and outputs.
#' @return An \code{sfc_LINESTRING} object containing a line for each vector of
#'   H3 cell indexes supplied. If \code{simple = FALSE}, an \code{sf} object
#'   including the input data.
#' @note This function can accept any arbitrary vector of cell indexes (including
#'   cells at multiple resolutions) but results may be unexpected. It is
#'   assumed that indexes are supplied in a pre-ordered fashion.
#' @import V8
#' @examples
#' # What is the cell index over the Brisbane Town Hall at resolution 10?
#' brisbane_hex_10 <- cell_to_polygon(input = '8abe8d12acaffff')
#'
#' # Give me a some nearby cells
#' hex_sample <- get_disk_list('8abe8d12acaffff', 4)[[1]][[4]][seq(1,18,3)]
#' hex_sample_polys <- cell_to_polygon(hex_sample)
#'
#' # find connecting paths
#' paths <- grid_path(rep('8abe8d12acaffff', 6), hex_sample)
#'
#' # make lines
#' lines <- cell_to_line(paths)
#'
#'\dontrun{
#' plot(hex_sample_polys, reset = FALSE)
#' plot(brisbane_hex_10, add = TRUE)
#' plot(lines, col = 'red', add = TRUE)
#' }
#'
#' @importFrom sf st_linestring st_sfc st_sf
#' @export
#'
cell_to_line <- function(input = NULL, simple = TRUE) {
  UseMethod('cell_to_line')
}

#' @rdname cell_to_line
#' @inherit cell_to_line return
#' @method cell_to_line data.frame
#' @export
#'
cell_to_line.data.frame <- function(input = NULL, simple = TRUE) {
  # last col taken to be source of addresses
  hex_points <- lapply(input[[ncol(input)]], cell_to_point, simple = TRUE)
  hex_lines <- lapply(hex_points, function(l) {
    interleaved <- rbind(l[1:(length(l) - 1)], l[2:length(l)])
    matrified <- lapply(interleaved, as.matrix, ncol = 2, byrow = T)
    rbound <- do.call('rbind', matrified)
    st_linestring(rbound)
  })

  if(simple == TRUE) {
    sf::st_sfc(hex_lines, crs = 4326)
  } else {
    sf::st_sf(input, 'geometry' = sf::st_sfc(hex_lines, crs = 4326))
  }
}

#' @rdname cell_to_line
#' @inherit cell_to_line return
#' @method cell_to_line list
#' @export
#'
cell_to_line.list <- function(input = NULL, simple = TRUE) {
  hex_points <- lapply(input, cell_to_point, simple = TRUE)
  hex_lines <- lapply(hex_points, function(l) {
    interleaved <- rbind(l[1:(length(l) - 1)], l[2:length(l)])
    matrified <- lapply(interleaved, as.matrix, ncol = 2, byrow = T)
    rbound <- do.call('rbind', matrified)
    st_linestring(rbound)
  })

  if(simple == TRUE) {
    sf::st_sfc(hex_lines, crs = 4326)
  } else {
    out <- sf::st_sf('geometry' = sf::st_sfc(hex_lines, crs = 4326))
    out$input <- input
    sf::st_sf(out)
  }
}

#' @rdname cell_to_line
#' @inherit cell_to_line return
#' @method cell_to_line character
#' @export
#'
cell_to_line.character <- function(input = NULL, simple = TRUE) {
    points <- cell_to_point(input, simple = TRUE)
    interleaved <- rbind(points[1:(length(points) - 1)],
                         points[2:length(points)])
    matrified <- lapply(interleaved, as.matrix, ncol = 2, byrow = T)
    rbound <- do.call('rbind', matrified)
    lined <- st_linestring(rbound)

  if(simple == TRUE) {
    sf::st_sfc(lined, crs = 4326)
  } else {
    out <- sf::st_sf('geometry' = sf::st_sfc(lined, crs = 4326))
    out$input <- list(input)
    sf::st_sf(out)
  }
}