R/get_aon.R

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

#' Given an origin-destination matrix, compute All-or-Nothing assignment.
#'
#' @param Graph  An object generated by \link{makegraph}, or \link{cpp_contract} function.
#' @param from A vector of origins
#' @param to A vector of destinations.
#' @param demand A vector describing the flow between each origin-destination pair.
#' @param algorithm character. For contracted network : \code{phast} or \code{bi}. Otherwise : \code{d}, \code{bi} or \code{nba}. Default to \code{bi}. See details.
#' @param constant numeric. Constant to maintain the heuristic function admissible in NBA* algorithm. Default to 1, when cost is expressed in the same unit than coordinates. See details
#' @return A \code{data.frame} containing edges attributes, including flow.
#' @note 'from', 'to' and 'demand' must be the same length.
#' @details All-or-Nothing assignment (AON) is the simplest method to load flow on a network, since it assume there is no congestion effects.
#' The assignment algorithm itself is the procedure that loads the origin-destination matrix to the shortest path trees and produces the flows.
#' Origin-destination matrix is represented via 3 vectors : \code{from}, \code{to} and \code{demand}.
#'
#' There is two variants of algorithms, depending the \strong{sparsity} of origin-destination matrix : \itemize{
#' \item recursive one-to-one : Bidirectional search (\code{bi}) and Bidirectional A* (\code{nba}). Optimal for high sparsity.
#' \item recursive one-to-many : Dijkstra (\code{d}) and PHAST (\code{phast}). Optimal for dense matrix.
#' }
#' For large network and/or large OD matrix, this function is a lot faster on a contracted network.
#' In New Bidirectional A star algorithm, euclidean distance is used as heuristic function.
#' To understand the importance of constant parameter, see the package description : \url{https://github.com/vlarmet/cppRouting/blob/master/README.md}
#'
#' All algorithms are \strong{multithreaded.} Please use \code{RcppParallel::setThreadOptions()} to set the number of threads.
#'
#' @seealso \link{cpp_contract}, \link{assign_traffic}
#' @examples
#' #Choose number of cores used by cppRouting
#' RcppParallel::setThreadOptions(numThreads = 1)
#'
#' #Data describing edges of the graph
#' edges<-data.frame(from_vertex=c(0,0,1,1,2,2,3,4,4),
#'                   to_vertex=c(1,3,2,4,4,5,1,3,5),
#'                   cost=c(9,2,11,3,5,12,4,1,6))
#'
#' # Origin-destination trips
#' trips <- data.frame(from = c(0,0,0,0,1,1,1,1,2,2,2,3,3,4,5,5,5,5,5),
#'                     to = c(1,2,5,3,2,5,2,4,2,5,2,3,5,2,0,0,3,5,1),
#'                     flow = c(10,30,15,5,5,2,3,6,4,15,20,2,3,6,2,1,4,5,3))
#'
#' #Construct graph
#' graph<-makegraph(edges,directed=TRUE)
#'
#'
#' # Compute All-or-Nothing assignment
#' aon <- get_aon(Graph=graph, from=trips$from, to=trips$to, demand = trips$flow, algorithm = "d")
#' print(aon)

get_aon<-function(Graph, from, to, demand, algorithm = "bi",constant = 1){
  if ((length(from)!=length(to)) | (length(from) != length(demand))) stop("From, to and demand have not the same length")
  demand <- as.numeric(demand)
  if (any(is.na(data.frame(from,to, demand)))) stop("NAs are not allowed in origin/destination trips")


  from<-as.character(from)
  to<-as.character(to)

  allnodes<-c(from,to)
  if (sum(allnodes %in% Graph$dict$ref) < length(allnodes)) stop("Some nodes are not in the graph")

  from_id <- Graph$dict$id[match(from,Graph$dict$ref)]
  to_id <- Graph$dict$id[match(to,Graph$dict$ref)]

  if (length(Graph) == 5){
    if (!algorithm %in% c("bi", "d", "nba")) stop("algorithm argument should be 'd', 'bi' or 'nba'")
    if (algorithm == "nba" & is.null(Graph$coords)) {
      algorithm <- "bi"
      message("nodes coordinates are not provided, running bidirectional search")
    }
    if (algorithm == "bi"){
      res <- cppaon(Graph$data$from, Graph$data$to, Graph$data$dist, Graph$nbnode,
                    c(0,0), c(0,0), 1, from_id, to_id, demand, 2)
    }
    if (algorithm == "nba"){
      if (constant == 1) warning("Are you sure constant is equal to 1 ?")

      res <- cppaon(Graph$data$from, Graph$data$to, Graph$data$dist, Graph$nbnode,
                    Graph$coords$X, Graph$coords$Y, constant, from_id, to_id, demand, 3)
    }

    if (algorithm == "d"){
      algo <- ifelse(length(unique(from_id)) <= length(unique(to_id)), 0, 1)
      res <- cppaon(Graph$data$from, Graph$data$to, Graph$data$dist, Graph$nbnode,
                    c(0,0), c(0,0), 1, from_id, to_id, demand, algo)
    }
  }

  if (length(Graph) == 6){
    if (!algorithm %in% c("bi", "phast")) stop("algorithm argument should be 'phast' or 'bi'")
    if (algorithm == "bi"){
      res <- cppaonC(Graph$original$data$from, Graph$original$data$to, Graph$original$data$dist,
                     Graph$data$from, Graph$data$to, Graph$data$dist, Graph$nbnode, Graph$rank,
                     Graph$shortcuts$shortf, Graph$shortcuts$shortt, Graph$shortcuts$shortc, FALSE,
                     from_id, to_id, demand, 2)
    }

    if (algorithm == "phast"){
      invrank <- Graph$nbnode - Graph$rank
      invrank2 <- data.frame(invrank = invrank, id = 0:(length(invrank)-1))
      invrank2 <- invrank2[order(invrank2$invrank),]
      algo <- ifelse(length(unique(from_id)) <= length(unique(to_id)), 0, 1)

      res <- cppaonC(invrank[Graph$original$data$from + 1], invrank[Graph$original$data$to + 1], Graph$original$data$dist,
                     invrank[Graph$data$from + 1], invrank[Graph$data$to + 1], Graph$data$dist, Graph$nbnode, Graph$rank,
                     invrank[Graph$shortcuts$shortf + 1], invrank[Graph$shortcuts$shortt + 1], invrank[Graph$shortcuts$shortc + 1], TRUE,
                     invrank[from_id + 1], invrank[to_id + 1], demand, algo)
      res[[1]] <- invrank2$id[res[[1]] + 1]
      res[[2]] <- invrank2$id[res[[2]] + 1]
    }
  }

  res <- as.data.frame(res, col.names = c("from", "to", "cost", "flow"))
  res$from <- Graph$dict$ref[match(res$from, Graph$dict$id)]
  res$to <- Graph$dict$ref[match(res$to, Graph$dict$id)]
  return (res)
}