R/hf_appraise.R

In kbvernon/hiker: Model Hiking Paths Over Costly Terrains

#' Travel cost between points
#'
#' Estimate the cost of traveling the "shortest" or least-cost path between
#' multiple start and end points. For each from-point, the cost of traveling
#' the shortest path to every to-point is calculated.
#'
#' @param x a cost `terrain` generated by `hf_terrain()`.
#' @param from an `sf` specifying start locations, must be POINT or MULTIPOINT.
#' @param to an `sf` specifying end locations, must be POINT or MULTIPOINT.
#'
#' @return a `data.frame` with three columns: from, to, and cost. Values
#'   in the from- and to-columns are `1:nrow(from)` and `1:nrow(to)`, respectively.
#' @export
#'
#' @examples
#' library(sf)
#' library(terra)
#'
#' fn <- system.file("extdata/red_butte_dem.tif", package = "hiker")
#' red_butte_dem <- rast(fn)
#'
#' from <- st_sf(geometry = st_sfc(st_point(c(432000, 4514000)),
#'                                 crs = 26912))
#'
#' to <- st_sf(geometry = st_sfc(st_point(c(431000, 4515000)),
#'                               st_point(c(436500, 4518500)),
#'                               crs = 26912))
#'
#' terrain <- hf_terrain(red_butte_dem)
#'
#' hf_appraise(terrain, from, to)
#'
hf_appraise <- function(x, from, to) {

  stop_if_not_terrain(x)

  stop_if_not_sf(from, to)

  stop_if_not_point(from, to)

  stop_if_not_crs_equal(x$crs, from, to)

  from_xy <- sf::st_coordinates(from)[, 1:2, drop = FALSE]
  to_xy   <- sf::st_coordinates(to)[, 1:2, drop = FALSE]

  rr <- terra::rast(
    nrow   = x$nrow,
    ncol   = x$ncol,
    extent = terra::ext(x$bb8),
    crs    = x$crs
  )

  from_cells <- terra::cellFromXY(rr, from_xy)
  to_cells   <- terra::cellFromXY(rr, to_xy)

  graph <- igraph::graph_from_adjacency_matrix(
    x$conductance,
    mode = "directed",
    weighted = TRUE
  )

  # invert conductance to get travel cost
  igraph::E(graph)$weight <- (1/igraph::E(graph)$weight)

  cost <- igraph::distances(graph, from_cells, to_cells, mode = "out")

  data.frame(
    from = rep(1:nrow(from_xy), each = nrow(to_xy)),
    to   = rep(1:nrow(to_xy), times = nrow(from_xy)),
    cost = c(t(cost)) # t() because c() goes does matrix columns
  )

}