R/get_distance_pair.R

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

#' Compute shortest distance between origin and destination nodes.
#'
#' @param Graph  An object generated by \link{makegraph}, \link{cpp_simplify} or \link{cpp_contract} function.
#' @param from A vector of one or more vertices from which distances are calculated (origin).
#' @param to A vector of one or more vertices (destination).
#' @param aggregate_aux Logical. If \code{TRUE}, the additional weight is summed along shortest paths.
#' @param algorithm character. \code{Dijkstra} for uni-directional Dijkstra, \code{bi} for bi-directional Dijkstra, \code{A*} for A star unidirectional search or \code{NBA} for New bi-directional A star .Default to \code{bi}
#' @param constant numeric. Constant to maintain the heuristic function admissible in \code{A*} and \code{NBA} algorithms.
#' Default to 1, when cost is expressed in the same unit than coordinates. See details
#' @param allcores Logical (deprecated). If \code{TRUE}, all cores are used.
#' @return Vector of shortest distances.
#' @note \code{from} and \code{to} must be the same length.
#' It is not possible to aggregate auxiliary weights on a Graph object coming from \link{cpp_simplify} function.
#'
#'
#' @details If graph is not contracted, the user has the choice between : \itemize{
#'   \item unidirectional Dijkstra (\code{Dijkstra})
#'   \item A star (\code{A*}) : projected coordinates should be provided
#'   \item bidirectional Dijkstra (\code{bi})
#'   \item New bi-directional A star (\code{NBA}) : projected coordinates should be provided
#' }
#' If the input graph has been contracted by \link{cpp_contract} function, the algorithm is a modified bidirectional search.
#'
#' Shortest path is always computed according to the main edge weights, corresponding to the 3rd column of \code{df} argument in \link{makegraph} function.
#' If \code{aggregate_aux} argument is \code{TRUE}, the values returned are the sum of auxiliary weights along shortest paths.
#'
#'
#' In A* and New Bidirectional A star algorithms, euclidean distance is used as heuristic function.
#'
#' All algorithms are \strong{multithreaded.} \code{allcores} argument is deprecated, please use \code{RcppParallel::setThreadOptions()} to set the number of threads.
#'
#' To understand how A star algorithm work, see \url{https://en.wikipedia.org/wiki/A*_search_algorithm}.
#' To understand the importance of constant parameter, see the package description : \url{https://github.com/vlarmet/cppRouting/blob/master/README.md}
#' @seealso \link{get_distance_matrix}, \link{get_path_pair}, \link{cpp_contract}
#' @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),
#'                   dist = c(5,3,4,7,5,5,5,8,7))
#'
#' #Construct directed  graph with travel time as principal weight, and distance as secondary weight
#' graph <- makegraph(edges[,1:3], directed=TRUE, aux = edges$dist)
#'
#' #Get all nodes IDs
#' nodes <- graph$dict$ref
#'
#' # Get shortest times between all nodes : the result are in time unit
#' time_mat <- get_distance_pair(graph, from = nodes, to = nodes)
#'
#' # Get distance according shortest times : the result are in distance unit
#' dist_mat <- get_distance_pair(graph, from = nodes, to = nodes, aggregate_aux = TRUE)
#'
#' print(time_mat)
#' print(dist_mat)

get_distance_pair<-function(Graph, from, to, aggregate_aux = FALSE, algorithm="bi", constant=1, allcores=FALSE){

  if (length(from)!=length(to)) stop("From and to have not the same length")

  if (any(is.na(cbind(from,to)))) stop("NAs are not allowed in origin/destination nodes")

  if (allcores) message("allcores argument is deprecated since v3.0. \nPlease use RcppParallel::setThreadOptions() to set the number of threads")
  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 (aggregate_aux & length(Graph$attrib$aux) == 0) stop("network don't have additional weight")
    if (!is.null(Graph$coords)){
      if (algorithm %in% c("NBA","A*","bi")){
        if (algorithm=="A*"){
          if (constant == 1) warning("Are you sure constant is equal to 1 ?")
          if (aggregate_aux){
            res <- cppdistadd(Graph$data$from, Graph$data$to ,Graph$data$dist , Graph$attrib$aux, Graph$nbnode,
                              Graph$coords[,2], Graph$coords[,3] ,constant,
                              from_id, to_id, 2)
          }else{
            res <- cppdist(Graph$data$from, Graph$data$to ,Graph$data$dist ,Graph$nbnode,
                           Graph$coords[,2], Graph$coords[,3] ,constant,
                           from_id, to_id, 2)
          }


        }
        if (algorithm=="NBA"){
          if (constant == 1) warning("Are you sure constant is equal to 1 ?")

          if (aggregate_aux){
            res <- cppdistadd(Graph$data$from, Graph$data$to ,Graph$data$dist , Graph$attrib$aux, Graph$nbnode,
                              Graph$coords[,2], Graph$coords[,3] ,constant,
                              from_id, to_id, 3)
          }else{
            res <- cppdist(Graph$data$from, Graph$data$to ,Graph$data$dist ,Graph$nbnode,
                           Graph$coords[,2], Graph$coords[,3] ,constant,
                           from_id, to_id, 3)
          }
        }


        if (algorithm=="bi"){

          if (aggregate_aux){
            res <- cppdistadd(Graph$data$from, Graph$data$to ,Graph$data$dist , Graph$attrib$aux, Graph$nbnode,
                              Graph$coords[,2], Graph$coords[,3] ,constant,
                              from_id, to_id, 1)
          }else{
            res <- cppdist(Graph$data$from, Graph$data$to ,Graph$data$dist ,Graph$nbnode,
                           Graph$coords[,2], Graph$coords[,3] ,constant,
                           from_id, to_id, 1)
          }
        }
      }else {

        if (aggregate_aux){
          res <- cppdistadd(Graph$data$from, Graph$data$to ,Graph$data$dist , Graph$attrib$aux, Graph$nbnode,
                            c(0,0), c(0,0) ,constant,
                            from_id, to_id, 0)
        }else{
          res <- cppdist(Graph$data$from, Graph$data$to ,Graph$data$dist ,Graph$nbnode,
                         c(0,0), c(0,0) ,constant,
                         from_id, to_id, 0)
        }
      }

    } else {
      if (algorithm=="bi"){

        if (aggregate_aux){
          res <- cppdistadd(Graph$data$from, Graph$data$to ,Graph$data$dist , Graph$attrib$aux, Graph$nbnode,
                            c(0,0), c(0,0) ,constant,
                            from_id, to_id, 1)
        }else{
          res <- cppdist(Graph$data$from, Graph$data$to ,Graph$data$dist ,Graph$nbnode,
                         c(0,0), c(0,0) ,constant,
                         from_id, to_id, 1)
        }} else {

          if (aggregate_aux){
            res <- cppdistadd(Graph$data$from, Graph$data$to ,Graph$data$dist , Graph$attrib$aux, Graph$nbnode,
                              c(0,0), c(0,0) ,constant,
                              from_id, to_id, 0)
          }else{
            res <- cppdist(Graph$data$from, Graph$data$to ,Graph$data$dist ,Graph$nbnode,
                           c(0,0), c(0,0) ,constant,
                           from_id, to_id, 0)
          }

        }
      }

  }


  if (length(Graph) == 6){
    if (aggregate_aux & length(Graph$original$attrib$aux) == 0) stop("network don't have additional weight")

    if (aggregate_aux){
      res <- cppdistaddC(Graph$original$data$from, Graph$original$data$to, Graph$original$data$dist, Graph$original$attrib$aux,
                         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, 0)
    }else{
      res <- cppdistC(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, 0)
  }


}

  return(res)


}