R/get_detour.R

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

#' Return the nodes that can be reached in a detour time set around the shortest path
#'
#' @param Graph  An object generated by \link{makegraph} or \link{cpp_simplify} function.
#' @param from A vector of one or more vertices from which shortest path are calculated (origin).
#' @param to A vector of one or more vertices (destination).
#' @param extra numeric. Additional cost
#' @param keep numeric or character. Vertices of interest that will be returned.
#' @param long logical. If \code{TRUE}, a long \code{data.frame} is returned instead of a list.
#' @return \code{list} or a \code{data.frame} of nodes that can be reached
#' @note \code{from} and \code{to} must be the same length.
#' @details Each returned nodes \emph{n} meet the following condition :
#'
#'  \strong{SP(o,n) + SP(n,d) < SP(o,d) + t}
#'
#'  with \emph{SP} shortest distance/time, \emph{o} the origin node, \emph{d} the destination node and \emph{t} the extra cost.
#'
#' Modified bidirectional Dijkstra algorithm is ran for each path.
#'
#' This algorithm is \strong{multithreaded.} Please use \code{RcppParallel::setThreadOptions()} to set the number of threads.
#'
#' @examples
#' #Choose number of cores used by cppRouting
#' RcppParallel::setThreadOptions(numThreads = 1)
#'
#' if(requireNamespace("igraph",quietly = TRUE)){
#'
#' #Generate fully connected graph
#' gf<- igraph::make_full_graph(400)
#' igraph::V(gf)$names<-1:400
#'
#' #Convert to data frame and add random weights
#' df<-igraph::as_long_data_frame(gf)
#' df$dist<-sample(1:100,nrow(df),replace = TRUE)
#'
#' #Construct cppRouting graph
#' graph<-makegraph(df[,c(1,2,5)],directed = FALSE)
#'
#' #Pick up random origin and destination node
#' origin<-sample(1:400,1)
#' destination<-sample(1:400,1)
#'
#' #Compute distance from origin to all nodes
#' or_to_all<-get_distance_matrix(graph,from=origin,to=1:400)
#'
#' #Compute distance from all nodes to destination
#' all_to_dest<-get_distance_matrix(graph,from=1:400,to=destination,)
#'
#' #Get all shortest paths from origin to destination, passing by each node of the graph
#' total_paths<-rowSums(cbind(t(or_to_all),all_to_dest))
#'
#' #Compute shortest path between origin and destination
#' distance<-get_distance_pair(graph,from=origin,to=destination)
#'
#' #Compute detour with an additional cost of 3
#' det<-get_detour(graph,from=origin,to=destination,extra=3)
#'
#' #Check result validity
#' length(unlist(det))
#' length(total_paths[total_paths < distance + 3])
#'
#' }

get_detour<-function(Graph,from,to,extra=NULL,keep=NULL,long=FALSE){
  if (length(Graph) != 5) stop("Input should be generated by makegraph() or cpp_simplify() function")
  if (length(from)!=length(to)) stop("From and to have not the same length")
  if (is.null(extra)) stop("No additional cost provided")
  if (length(extra)!=1) stop("extra should be one number")
  extra<-as.numeric(extra)
  if (extra<=0) stop("extra must be positive")
  if (any(is.na(cbind(from,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 (!is.null(keep)) {
    to_keep<-rep(0,Graph$nbnode)
    keep<-as.character(keep)
    to_keep[Graph$dict$ref %in% keep]<-1
  }else{
    to_keep<-rep(1,Graph$nbnode)
  }

  res <- cpppath(Graph$data$from,Graph$data$to,Graph$data$dist,Graph$nbnode,
                 c(0,0), c(0,0), 1, Graph$dict$ref, to_keep, from_id, to_id, extra , 5)


  if (long){
    names(res)<-paste0(from)
    too<-rep(to,times=sapply(res,length))
    res<-stack(setNames(res,names(res)))
    res$to<-too
    res$ind<-as.character(res$ind)
    res<-res[,c(2,3,1)]
    colnames(res)<-c("from","to","node")
    return(res)
  }else{
    names(res)<-paste0(from,"_",to)
    return(res)
  }

}