Nothing
#' @export
#' @title Villeneuve and Desaulniers (2005) Algorithm
#'
#' @description It is an implementation of Villeneuve and Desaulniers' algorithm to transform
#' a digraph and a known set of forbidden paths, into a new graph that does not allow any
#' forbidden path as part of its solutions. This algorithm should only be used when there
#' is certainty that no forbidden path is a sub-path (or contains a sub-path) of another
#' forbidden path.
#'
#' @family Graph Transformation
#'
#' @seealso \url{https://doi.org/10.1016/j.ejor.2004.01.032}
#'
#' @param g The digraph to be transformed, written as a data frame where each row represents
#' a directed arc. The first two columns must be named \code{from} and \code{to}, and can be
#' of any data type. No cells can be \code{NULL} or \code{NA}.
#' @param f The set of forbidden paths, written as a data frame. Each row represents a path as
#' a sequence of nodes. Each row may be of different size, filling the empty cells with
#' \code{NA}. All nodes involved must be part of \code{g}, and no forbidden path can be of
#' size 2. This is because the latter is thought as an arc that should not exist in the first
#' place. Also, no forbidden path can be sub-path (or contain a sub-path) of another forbidden
#' path. The columns names are not relevant.
#' @param cores This algorithm can be run using R's parallel processing functions. This variable
#' represents the number of processing cores you want to assign for the transformation. The
#' default value is one single core. It is suggested to not assign all of your available cores
#' to the function.
#'
#' @return A new graph, generated following Villeneuve's prodcedure, in which no path
#' includes one of the forbidden subpaths. The graph is returned in a data frame format,
#' where each row represents a directed arc. However, regardless of the data type of the
#' original graph, nodes on the new graph are of type character. The new nodes names are
#' generated by incrementally concatenating the nodes on a forbidden path, but split by a
#' pipe character (\code{|}). The new graph includes all of the additional attributes
#' that the original graph had.
#'
#' @importFrom foreach %dopar%
#' @importFrom dplyr %>%
#' @importFrom parallel makeCluster
#' @importFrom doParallel registerDoParallel
#' @importFrom parallel stopCluster
#'
#' @examples
#' # Obtain a graph and its forbidden subpaths
#' graph <- data.frame(from = c("s", "s", "s", "u", "u", "w", "w", "x", "x", "v", "v",
#' "y", "y"),
#' to = c("u", "w", "x", "w", "v", "v", "y", "w", "y", "y", "t", "t", "u"),
#' cost = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L),
#' stringsAsFactors = FALSE)
#'
#' fpaths <- data.frame(V1 = c("s", "u"), V2 = c("u", "v"), V3 = c("v", "y"), V4 = c("t", "u"),
#' stringsAsFactors = FALSE)
#'
#' # Show the values
#' graph
#' fpaths
#'
#' # Call the function and store the result
#' modify_graph_vd(graph, fpaths)
#'
modify_graph_vd <- function(g, f, cores = 1L) {
# Modify G
g$from <- as.character(g$from)
g$to <- as.character(g$to)
# CHECKS
# Check that the graph starts with from and to column
if(any(colnames(g)[1:2] != c("from", "to"))) {
stop("The first two columns of g must be named 'from' and 'to'")
}
# Check that all nodes that are used in f appear in g, otherwise halt it
if(!.nodesExists(g, f)) {
stop("All nodes used in f must exists in g.")
}
# Check that there are no subpaths in f, otherwise halt the algo
if(.hasSubpaths(f)) {
stop("There are subpaths of some forbidden paths that belong to another forbidden paths. Use modify_graph_hsu() instead.")
}
# Number of columns
ncol <- ncol(g)
# Set up the parallel
cluster <- makeCluster(cores)
registerDoParallel(cluster)
# Stop Cluster
on.exit(parallel::stopCluster(cluster))
firstOutput <- foreach(i = 1:nrow(f), .combine = .comb, .multicombine = TRUE, .export = ".get_arc_attributes") %dopar% {
# Create a list of nodes and the new graph
tempNewArcs <- g[0,]
# Prepare a predecesor node
preNode <- f[i,1]
# Create a list of banned arcs
tempBannedArcs <- g[0,1:2]
# We are looping from the second to the penultimate item on the list.
# The last node is ignored because it is only temporal,
# So by ignoring it, we aim to reduce working time
for(level in 2:(length(f[i,]) - 1) ) {
# Create the new node name
nodeName <- paste0(as.character(f[i,])[1:level], collapse = "|")
# Add the link to the predecesor with the attributes
if(ncol > 2) {
tempNewArcs[nrow(tempNewArcs) + 1,] <- list(preNode, nodeName,
.get_arc_attributes(g, f[i, level-1], f[i, level]))
}
# Otherwise just add the values
else tempNewArcs[nrow(tempNewArcs) + 1,] <- list(preNode, nodeName)
# And update the predecesor
preNode <- nodeName
}
# Ban the next arc
tempBannedArcs[nrow(tempBannedArcs) + 1,] <- c(nodeName, f[i, level + 1])
# Delete arcs
tempDelete <- g[0,1:2]
tempDelete[1,] <- c(f[i,1], f[i,2])
# Return the temporal frame to mix it with the others
list(tempNewArcs, tempDelete, tempBannedArcs)
}
# Remove deleted arcs from here
g <- dplyr::anti_join(g, firstOutput[[2]], by = c("from", "to"))
# Now through the new nodes
newNodes <- firstOutput[[1]]$to
secondOutput <- foreach(nn = newNodes, .combine = rbind, .export = ".get_arc_attributes") %dopar% {
# Split by pipe and get the last element
nsName <- gsub(".*\\|(.*)", "\\1", nn)
# Get the outgoing arcs for the original node, that are not banned
toNodes <- setdiff(subset(g[,1:2], from == nsName)$to,
subset(firstOutput[[3]], from == nsName | from == nn)$to)
# Prepare the temporal frame
tempNewArcs <- g[0,]
# For each element
for(toNode in toNodes) {
# Evaluate if there is a
newTo <- newNodes[grepl(paste0(nsName, "\\|", toNode, "$"), newNodes)]
# If there is a value...
if(!identical(newTo, character(0))) {
# ...add it using the new node, if it needs attributes
if(ncol > 2) {
tempNewArcs[nrow(tempNewArcs) + 1,] <- list(nn, newTo, .get_arc_attributes(g, nsName, toNode))
}
# Or without the attributes
else tempNewArcs[nrow(tempNewArcs) + 1,] <- list(nn, newTo)
}
# Otherwise, if it is no match,
# ...and if the value with the original node is not banned
else if(! any(apply(
firstOutput[[3]], 1, function(x) paste(x, collapse="") == paste(c(nn,toNode), collapse="")) ) ) {
# Add the new link, but with the original node
if(ncol > 2) {
tempNewArcs[nrow(tempNewArcs) + 1,] <- list(nn, toNode, .get_arc_attributes(g, nsName, toNode))
}
# Or without the attributes
else tempNewArcs[nrow(tempNewArcs) + 1,] <- list(nn, toNode)
}
}
# Return the new value
tempNewArcs
}
# Now return the
return( rbind(g, firstOutput[[1]]) %>% rbind(secondOutput) )
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.