R/villeneuve.R

#' @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) )
}

Try the rsppfp package in your browser

Any scripts or data that you put into this service are public.

rsppfp documentation built on May 1, 2019, 10:27 p.m.