#' Graph Modification
#'
#' shortestpath provides various graph modification functions that are used internally.
#'
#' @examples
#'
#' library(igraph)
#'
#' g <- random.graph.game(10, 0.5) %>%
#' setAlphabeticalVertexNames %>%
#' setRandomEdgeWeights()
#'
#' plot(g)
#' E(g)$weight
#'
#'
#' @param graph The original graph object. Will not be modified.
#' @param overwrite If \code{FALSE}, graphs with an existing attribute will not
#' be updated.
#' @return The updated graph object.
#' @name graphModification
#' @rdname graphModification
NULL
# This function does the actual object modification by calling igraph's [set_](graph|vertex|edge)_attr.
setAttr <- function(graph, type = c("graph", "vertex", "edge"), name, fun, overwrite) {
type <- match.arg(type)
current <- do.call(paste0(type, "_attr"), list(graph, name))
if (overwrite || is.null(current)) {
val <- fun(graph)
graph <- do.call(paste0("set_", type, "_attr"), list(graph, name, value = val))
}
graph
}
#' @describeIn graphModification Set the minimum distance matrix to infinity.
#' @export
setInfiniteMinDists <- function(graph, overwrite = TRUE) {
setAttr(graph, "graph", "min_dists", function(graph) {
n <- vcount(graph)
mat <- matrix(Inf, ncol = n, nrow = n)
diag(mat) <- c(0)
colnames(mat) <- V(graph)$name
rownames(mat) <- V(graph)$name
mat
}, overwrite)
}
#' @describeIn graphModification Set random vertex positions for euclidean algorithms.
#' @export
setRandomVertexCoordinates <- function(graph, overwrite = TRUE) {
graph %>%
setAttr("vertex", "x", function(graph) {
runif(vcount(graph), 0, 10)
}, overwrite) %>%
setAttr("vertex", "y", function(graph) {
runif(vcount(graph), 0, 10)
}, overwrite)
}
#' @describeIn graphModification Run the given layout algorithm,
#' and set the positioning suggested by the algorithm as vertex positions for euclidean algorithms.
#' @param layout An igraph layout function. See \code{igraph::\link[igraph]{layout}}.
#' @export
setVertexCoordinatesFromLayout <- function(graph, layout=nicely(), overwrite = TRUE) {
p <- layout_(graph, layout)
graph %>%
setAttr("vertex", "x", function(graph) {
p[,1]
}, overwrite) %>%
setAttr("vertex", "y", function(graph) {
p[,2]
}, overwrite)
}
#' @describeIn graphModification Set rounded euclidean edge weights.
#' @export
setEuclideanEdgeWeights <- function(graph, overwrite = TRUE) {
if(!has.vertex.coordinates(graph)){
stop("Cannot compute edge weights for graph without x,y coordinates.")
}
setAttr(graph, "edge", "weight", function(graph) {
vapply(E(graph), function(edge){
e <- ends(graph, edge)
ceiling(euclidean.vertex.distance(graph, e[1], e[2]))
}, 0)
}, overwrite)
}
#' @param dist.fun A function that accepts the required vector length as an argument
#' and returns a vector of weights of the given length.
#' @describeIn graphModification Set random edge weights.
#' @export
setRandomEdgeWeights <- function(graph, dist.fun = function(n) ceiling(runif(n, 0, 10)), overwrite = TRUE) {
setAttr(graph, "edge", "weight", function(graph) {
dist.fun(ecount(graph))
}, overwrite)
}
#' @describeIn graphModification Set each edge weight to 1.
#' @export
setUniformEdgeWeights <- function(graph, overwrite = TRUE) {
setAttr(graph, "edge", "weight", function(graph) {
rep(1, ecount(graph))
}, overwrite)
}
#' @describeIn graphModification Initialize an empty predecessor matrix.
#' @export
setEmptyShortestPathPredecessors <- function(graph, overwrite = TRUE) {
setAttr(graph, "graph", "shortest_path_predecessors", function(graph) {
n <- vcount(graph)
mat <- matrix(list(), ncol = n, nrow = n)
colnames(mat) <- V(graph)$name
rownames(mat) <- V(graph)$name
mat
}, overwrite)
}
#' @param from The graph's source vertex for single-source algorithms.
#' For all-shortest-paths algorithms, \code{FALSE} should be passed.
#' @param to The graph's target vertex for single-source algorithms.
#' For all-shortest-paths algorithms, \code{FALSE} should be passed.
#' @describeIn graphModification Set \code{from} and \code{to} and
#' truncate both \code{min_dists} and \code{shortest_path_predecessors}
#' matrices to the specified source.
#' @export
setRoute <- function(graph, from, to) {
if (from != FALSE) {
from <- get.vertex(graph, from)
graph %<>%
set_graph_attr("min_dists",
graph$min_dists[from, , drop = FALSE]) %>%
set_graph_attr("shortest_path_predecessors",
graph$shortest_path_predecessors[from, , drop = FALSE])
}
if (to != FALSE) {
to <- get.vertex(graph, to)
}
graph %>%
set_graph_attr("from", from) %>%
set_graph_attr("to", to)
}
#' @describeIn graphModification Initialize each vertex front as \code{val}.
#' @param val the default vertex set value.
#' @export
setVertexSets <- function(graph, val=NA, overwrite = TRUE) {
setAttr(graph, "vertex", "set", function(graph) {
rep(val, vcount(graph))
}, overwrite)
}
#' @describeIn graphModification Set vertex names as A-Z. For graphs with more than
#' 26 vertices, vertices will be numbered 1 to N (as characters).
#' @export
setAlphabeticalVertexNames <- function(graph, overwrite = TRUE) {
setAttr(graph, "vertex", "name", function(graph) {
n <- vcount(graph)
if (n > 26) {
as.character(1:n)
} else {
LETTERS[1:n]
}
}, overwrite)
}
#' @describeIn graphModification Permute both vertex and edge ids.
#' This is useful so that e.g. Bellman-Ford cannot exploit a graph's artifical structure.
#'
#' @export
permuteGraph <- function(graph) {
edges <- as_edgelist(graph)
edge_attributes <- edge.attributes(graph)
edge_permut <- sample(nrow(edges))
graph %<>%
delete_edges(., seq_len(ecount(.))) %>%
add_edges(as.vector(t(edges[edge_permut,]))) %>%
permute(., sample(vcount(.)))
edge.attributes(graph) <- lapply(edge_attributes, function(attr) attr[edge_permut])
graph
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.