R/cch.R

In cppRouting: Algorithms for Routing and Solving the Traffic Assignment Problem

# CCH objects are deliberately kept as plain R lists. They can be saved with
# saveRDS() and reused later, which is important for traffic assignment models
# that run many congestion iterations on the same road topology.

cch_topology_fields <- function(){
  c("rank", "tail", "head", "first_out", "adj_head", "adj_arc",
    "rank_first_out", "rank_adj_head", "rank_adj_arc",
    "input_arc", "input_forward", "elimination_tree_parent")
}

resolve_cch_weight_column <- function(CCH, name){
  if (length(name) != 1 || is.na(name)) stop("weights must be a single column name when given as a string")
  data <- CCH$original$data
  if (name %in% colnames(data)) {
    if (!is.numeric(data[[name]])) stop(sprintf("column '%s' is not a numeric weight column", name))
    return(data[[name]])
  }
  aux <- CCH$original$attrib$aux
  if (is.data.frame(aux) && name %in% colnames(aux)) return(aux[[name]])
  available <- c("dist", if (is.data.frame(aux)) colnames(aux) else character(0))
  if (is.null(aux)) {
    stop(sprintf("weights '%s' is not a known column. Available weight columns: %s. Import additional weights with makegraph(aux = data.frame(<name> = ...)).", name, paste(available, collapse = ", ")))
  }
  stop(sprintf("weights '%s' is not a known column. Available weight columns: %s. The graph was built with an unnamed aux vector; rebuild it with makegraph(aux = data.frame(<name> = ...)) to select it by name.", name, paste(available, collapse = ", ")))
}

validate_cch_for_graph <- function(cch, Graph){
  if (!inherits(cch, "cppRouting_cch")) stop("cch must be generated by cpp_contract() with customizable = TRUE")
  if (cch$nbnode != Graph$nbnode) stop("cch was prepared for a graph with a different number of nodes")
  if (nrow(cch$original$data) != nrow(Graph$data)) stop("cch was prepared for a graph with a different number of edges")
  if (!all(cch$original$data$from == Graph$data$from) || !all(cch$original$data$to == Graph$data$to)) {
    stop("cch must be prepared from the same graph topology")
  }

  missing_fields <- setdiff(cch_topology_fields(), names(cch))
  if (length(missing_fields) > 0) {
    stop("cch was prepared with an older CCH format. Regenerate it with cpp_contract(customizable = TRUE).")
  }

  TRUE
}

#' Customize a CCH with edge weights
#'
#' @description
#' Update a prepared CCH with the edge weights that should be used for shortest
#' path queries. Customization is much cheaper than preparing the CCH topology,
#' so it is the step to repeat when congestion changes travel times.
#'
#' @param CCH An object generated by \link{cpp_contract} with \code{customizable = TRUE}.
#' @param weights Optional edge weights. Defaults to the original graph cost.
#' Give a single column name (\code{"dist"} or a column imported with
#' \code{makegraph(aux = ...)}) to select a stored weight, or one numeric value
#' per edge of \code{CCH$original$data}.
#' @return A customized CCH metric object usable by \link{get_distance_pair},
#' \link{get_distance_matrix} and \link{get_aon}.
#' @details
#' The recommended way to customize a CCH is to import the weights up front with
#' \code{\link{makegraph}} using the \code{aux} argument and select them by column
#' name, e.g. \code{cpp_customize(cch, weights = "time")}. This is safer than
#' writing a raw vector at query time: the edge table stored in the CCH doubles
#' when the graph was built with \code{directed = FALSE}, so a raw vector is easy
#' to get the wrong length or order for, and a mismatch is silently accepted.
#' A raw numeric vector must then hold one value per edge of
#' \code{CCH$original$data}, in that exact order. It is discouraged except for
#' traffic assignment (\link{assign_traffic}), where congested travel times are
#' computed at runtime and are not available at \code{makegraph} time.
#' @examples
#' RcppParallel::setThreadOptions(numThreads = 1)
#'
#' # Travel time as the main cost, road length as an auxiliary weight
#' edges <- data.frame(from_vertex = c(0, 0, 1, 1, 2),
#'                     to_vertex = c(1, 2, 2, 3, 3),
#'                     cost = c(1, 4, 1, 2, 1))
#' graph <- makegraph(edges, directed = TRUE,
#'                    aux = data.frame(length = c(1, 3, 2, 4, 2)))
#' cch <- cpp_contract(graph, customizable = TRUE)
#'
#' # First customization with the travel time (the default)
#' metric_time <- cpp_customize(cch)
#' get_distance_pair(metric_time, from = c(0, 1), to = c(3, 3))
#'
#' # Second customization with the road length, selected by column name
#' metric_length <- cpp_customize(cch, weights = "length")
#' get_distance_pair(metric_length, from = c(0, 1), to = c(3, 3))
#' @export
cpp_customize <- function(CCH, weights = NULL){
  if (!inherits(CCH, "cppRouting_cch")) stop("Input should be generated by cpp_contract() with customizable = TRUE")
  if (length(setdiff(cch_topology_fields(), names(CCH))) > 0) {
    stop("CCH was prepared with an older CCH format. Regenerate it with cpp_contract(customizable = TRUE).")
  }

  if (is.character(weights)) weights <- resolve_cch_weight_column(CCH, weights)
  if (is.null(weights)) weights <- CCH$original$data$dist
  weights <- as.numeric(weights)
  if (length(weights) != nrow(CCH$original$data)) stop("weights must have one value per original edge")
  if (any(is.na(weights))) stop("NAs are not allowed in weights")
  if (any(weights < 0)) stop("Negative weights are not allowed")

  metric <- cppcchcustomize(CCH$original$data$from,
                            CCH$original$data$to,
                            weights,
                            CCH$nbnode,
                            CCH$rank,
                            CCH$tail,
                            CCH$head,
                            CCH$rank_first_out,
                            CCH$rank_adj_head,
                            CCH$rank_adj_arc,
                            CCH$input_arc,
                            CCH$input_forward)

  CCH$weight <- metric
  CCH$weights <- weights
  structure(CCH,
            class = "cppRouting_cch_metric")
}