R/get_distance_mat.R

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

#' Compute all 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 algorithm Character. Only for contracted graph, \code{mch} for Many to many CH, \code{phast} for PHAST algorithm
#' @param aggregate_aux Logical. If \code{TRUE}, the additional weight is summed along shortest paths.
#' @param allcores Logical (deprecated). If \code{TRUE}, all cores are used.
#' @return Matrix of shortest distances.
#' @note It is not possible to aggregate auxiliary weights on a Graph object coming from \link{cpp_simplify} function.
#' @details If graph is not contracted, \code{get_distance_matrix()} recursively perform Dijkstra algorithm for each \code{from} nodes.
#' If graph is contracted, the user has the choice between : \itemize{
#'   \item many to many contraction hierarchies (\code{mch}) : optimal for square matrix.
#'   \item PHAST (\code{phast}) : outperform mch on rectangular matrix
#' }
#'
#' Shortest path is always computed according to the main edge weights, corresponding to the 3rd column of \code{df} argument in \code{makegraph()} function.
#' If \code{aggregate_aux} argument is \code{TRUE}, the values returned are the sum of auxiliary weights along shortest paths.
#'
#' All algorithms are \strong{multithreaded.} \code{allcores} argument is deprecated, please use \code{RcppParallel::setThreadOptions()} to set the number of threads.
#'
#' See details in package website : \url{https://github.com/vlarmet/cppRouting/blob/master/README.md}
#' @seealso \link{get_distance_pair}, \link{get_multi_paths}
#' @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),
#'                     time = 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 matrix of shortest times between all nodes : the result are in time unit
#' time_mat <- get_distance_matrix(graph, from = nodes, to = nodes)
#'
#' # Get matrix of distance according shortest times : the result are in distance unit
#' dist_mat <- get_distance_matrix(graph, from = nodes, to = nodes, aggregate_aux = TRUE)
#'
#' print(time_mat)
#' print(dist_mat)

get_distance_matrix<-function(Graph, from, to, algorithm="phast", aggregate_aux = FALSE, allcores=FALSE){
  if (any(is.na(from))) stop("NAs are not allowed in origin/destination nodes")
  if (any(is.na(to))) stop("NAs are not allowed in origin/destination nodes")
  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 (allcores) message("allcores argument is deprecated since v3.0. \nPlease use RcppParallel::setThreadOptions() to set the number of threads")


  # not contracted
  if (length(Graph) == 5){
    if (aggregate_aux & length(Graph$attrib$aux) == 0) stop("network don't have additional weight")

      if (length(from)< length(to)){
        if (aggregate_aux){
          res <- cpppadd(Graph$data[,1], Graph$data[,2], Graph$data[,3], Graph$attrib$aux, Graph$nbnode, from_id,to_id)
        } else{
          res <- cppdistmat(Graph$data[,1], Graph$data[,2], Graph$data[,3],Graph$nbnode, from_id,to_id)
        }


      }
      else {
        if (aggregate_aux){

          res <- cpppadd(Graph$data[,2], Graph$data[,1], Graph$data[,3], Graph$attrib$aux, Graph$nbnode, to_id,from_id)
        } else{
          res <- cppdistmat(Graph$data[,2], Graph$data[,1], Graph$data[,3],Graph$nbnode, to_id,from_id)
        }

      }

  }

  # contracted
  if (length(Graph) == 6){
    if (aggregate_aux & length(Graph$original$attrib$aux) == 0) stop("network don't have additional weight")
    invrank <- Graph$nbnode - Graph$rank
   # invrank2 <- data.frame(invrank = invrank, id = 0:(length(invrank)-1))
    #invrank2 <- invrank2[order(invrank2$invrank),]

    if (length(from) < length(to)){
      if (aggregate_aux){
        res <- cppaddC(invrank[Graph$original$data[,1] + 1], invrank[Graph$original$data[,2] + 1], Graph$original$data[,3], Graph$original$attrib$aux,
                       invrank[Graph$data[,1] + 1], invrank[Graph$data[,2] + 1], Graph$data[,3], 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], 1)
      } else{
        if (algorithm == "mch"){
          res <- cppdistmatC(Graph$data[,1], Graph$data[,2], Graph$data[,3], Graph$nbnode,
                             Graph$rank, Graph$shortcuts$shortf, Graph$shortcuts$shortt, Graph$shortcuts$shortc,
                             FALSE, from_id, to_id, 0)
        } else{
          res <- cppdistmatC(invrank[Graph$data[,1] + 1], invrank[Graph$data[,2] + 1], Graph$data[,3], 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], 1)
        }

      }


    } else{
      if (aggregate_aux){
        res <- cppaddC(invrank[Graph$original$data[,2] + 1], invrank[Graph$original$data[,1] + 1], Graph$original$data[,3], Graph$original$attrib$aux,
                       invrank[Graph$data[,2] + 1], invrank[Graph$data[,1] + 1], Graph$data[,3], Graph$nbnode, Graph$rank,
                       invrank[Graph$shortcuts$shortt + 1], invrank[Graph$shortcuts$shortf + 1], invrank[Graph$shortcuts$shortc + 1],
                       TRUE,
                       invrank[to_id + 1], invrank[from_id + 1], 1)
      } else{
        if (algorithm == "mch"){
          res <- cppdistmatC(Graph$data[,2], Graph$data[,1], Graph$data[,3], Graph$nbnode,
                             Graph$rank, Graph$shortcuts$shortf, Graph$shortcuts$shortt, Graph$shortcuts$shortc,
                             FALSE,  to_id, from_id, 0)
        } else{
          res <- cppdistmatC(invrank[Graph$data[,2] + 1], invrank[Graph$data[,1] + 1], Graph$data[,3], Graph$nbnode, Graph$rank,
                             invrank[Graph$shortcuts$shortt + 1], invrank[Graph$shortcuts$shortf + 1], invrank[Graph$shortcuts$shortc + 1],
                             TRUE, invrank[to_id + 1], invrank[from_id + 1], 1)
        }

      }
    }


  }


  if (!(length(from)< length(to))) res<-t(res)

  rownames(res)<-from
  colnames(res)<-to
  return(res)
}