1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
|
#' Change terminal nodes of edges
#'
#' The reroute verb lets you change the beginning and end node of edges by
#' specifying the new indexes of the start and/or end node(s). Optionally only
#' a subset of the edges can be rerouted using the subset argument, which should
#' be an expression that are to be evaluated in the context of the edge data and
#' should return an index compliant vector (either logical or integer).
#'
#' @param .data A tbl_graph or morphed_tbl_graph object. grouped_tbl_graph will
#' be ungrouped prior to rerouting
#' @param from,to The new indexes of the terminal nodes. If `NULL` nothing will
#' be changed
#' @param subset An expression evaluating to an indexing vector in the context
#' of the edge data.
#'
#' @return An object of the same class as .data
#' @export
#'
#' @examples
#' # Switch direction of edges
#' create_notable('meredith') %>%
#' activate(edges) %>%
#' reroute(from = to, to = from)
#'
#' # Using subset
#' create_notable('meredith') %>%
#' activate(edges) %>%
#' reroute(from = 1, subset = to > 10)
reroute <- function(.data, from = NULL, to = NULL, subset = NULL) {
UseMethod('reroute')
}
#' @export
#' @importFrom rlang enquo eval_tidy
#' @importFrom igraph is.directed
reroute.tbl_graph <- function(.data, from = NULL, to = NULL, subset = NULL) {
.register_graph_context(.data)
expect_edges()
from <- enquo(from)
to <- enquo(to)
if (is.grouped_tbl_graph(.data)) {
message('Ungrouping prior to rerouting edges')
.data <- ungroup(.data)
}
edges <- as_tibble(.data, active = 'edges')
subset <- enquo(subset)
subset <- eval_tidy(subset, edges)
if (is.null(subset)) subset <- seq_len(nrow(edges))
edges_sub <- edges[subset, , drop = FALSE]
from <- eval_tidy(from, edges_sub)
if (!is.null(from)) edges$from[subset] <- rep(from, length.out = nrow(edges_sub))
to <- eval_tidy(to, edges_sub)
if (!is.null(to)) edges$to[subset] <- rep(to, length.out = nrow(edges_sub))
.data <- tbl_graph(
nodes = as_tibble(.data, active = 'nodes'),
edges = edges,
directed = is.directed(.data)
) %gr_attr% .data
active(.data) <- 'edges'
.data
}
#' @export
#' @importFrom rlang enquo
reroute.morphed_tbl_graph <- function(.data, from = NULL, to = NULL, subset = NULL) {
from <- enquo(from)
to <- enquo(to)
.data[] <- lapply(.data, reroute, from = !!from, to = !!to, subset = subset)
.data
}
|