R/hf_survey.R

In kbvernon/hiker: Model Hiking Paths Over Costly Terrains

#' Accumulated travel time
#'
#' Survey entire landscape to calculate accumulated cost of travel from one or
#' more start points.
#'
#' @param x a cost `terrain` generated by `hf_terrain()`.
#' @param from an `sf` specifying start locations, must be POINT or MULTIPOINT.
#'
#' @return a `SpatRaster` with accumulated travel costs from each start point.
#' @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)),
#'                                 st_point(c(434000, 4518000)),
#'                                 crs = 26912))
#'
#' terrain <- hf_terrain(red_butte_dem)
#'
#' cost_surface <- hf_survey(terrain, from)
#'
#' plot(cost_surface)
#' plot(st_geometry(from), pch = 19, col = "red2", add = TRUE)
#'
hf_survey <- function(x, from) {

  stop_if_not_terrain(x)

  stop_if_not_sf(from)

  stop_if_not_point(from)

  stop_if_not_crs_equal(x$crs, from)

  from_xy <- sf::st_coordinates(from)[, 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 <- unique(as.integer(x$conductance@j)) + 1

  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 matrix: row for each start point, column for each end point
  # to get the cost surface from all of them, we take the minimum from each start
  cost <- igraph::distances(graph, from_cells, to_cells, mode = "out")

  rr[to_cells] <- apply(cost, 2, min)

  return(rr)

}