R/hf_channel.R

In kbvernon/hiker: Model Hiking Paths Over Costly Terrains

#' Channel of reduced cost
#'
#' Reduces cost of travel along paths that cross through channels or
#' other aspects of a terrain that expedite travel. Examples include
#' hiking trails, sidewalks, and Einstein-Rosen bridges (otherwise
#' known as [stargates](https://en.wikipedia.org/wiki/Stargate_(device))).
#'
#' @param x a cost `terrain` generated by `hf_terrain()`.
#' @param channel an `sf` object.
#' @param .m a numeric between 0 and 1 applied as a weight to the cost of travel.
#'
#' @return a `terrain` representing cost of travel.
#'
#' @export
#'
#' @examples
#' library(sf)
#' library(terra)
#'
#' fn <- system.file("extdata/red_butte_dem.tif", package = "hiker")
#' red_butte_dem <- rast(fn)
#'
#' fn <- system.file("extdata/red_butte_road.geojson", package = "hiker")
#' red_butte_road <- read_sf(fn)
#'
#' terrain <- hf_terrain(red_butte_dem, hf = "tobler")
#'
#' terrain <- hf_channel(terrain,
#'                       channel = red_butte_road,
#'                       .m = 0.6)
#'
#' plot(terrain, main = "Travel Cost")
#' plot(st_geometry(red_butte_road),
#'      col = "red2",
#'      add = TRUE)
#'
hf_channel <- function(x, channel, .m = 1) {

  if ( .m < 0 || .m > 1 ) {

    stop("The weight, .m, for reducing travel cost must be between 0 and 1.", call. = FALSE)

  }

  stop_if_not_terrain(x)

  stop_if_not_sf(channel)

  stop_if_not_crs_equal(x$crs, channel)

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

  channel <- terra::vect(channel)

  cells <- terra::cells(rr, channel)[, 2]

  adj <- cbind(
    "from" = as.integer(x$conductance@i + 1),
    "to"   = as.integer(x$conductance@j + 1)
  )

  # find incident edges, from or to cells intersecting barrier
  i <- which(adj[, 1] %in% cells | adj[, 2] %in% cells)
  adj <- adj[i, ]

  # want to reduce time, which means dividing conductance by .m
  x$conductance[adj] <- (x$conductance[adj] / .m)

  x <- update_range(x)

  return(x)

}