diff --git a/R/morphers.R b/R/morphers.R index 8a733b2..8112d54 100644 --- a/R/morphers.R +++ b/R/morphers.R @@ -255,15 +255,52 @@ to_simple <- function(graph, remove_multiples = TRUE, remove_loops = TRUE) { simple = simple ) } +#' @describeIn morphers Expand weighted links into multiple edges. Each link with +#' a weight equal to a natural number will be split into multiple edges. +#' @param weights The name of the column containing the weights. +#' @importFrom igraph is_directed +#' @importFrom rlang ensym +#' @export +to_multi <- function(graph, weights = "weight") { + weights <- rlang::ensym(weights) + edges <- as_tibble(graph, active = 'edges') + graph <- set_edge_attributes(graph, edges[, '.tidygraph_edge_index', drop = FALSE]) + + weights_col <- rlang::as_string(weights) + + if (!weights_col %in% colnames(edges)) { + stop("The specified weight column does not exist in the edges.") + } + + # Ensure weights are natural numbers + if (any(edges[[weights_col]] <= 0) | any(edges[[weights_col]] != floor(edges[[weights_col]]))) { + stop("All weights must be natural numbers (positive integers).") + } + + # Repeat edges according to their weight + expanded_edges <- tidyr::uncount(edges, weights = !!weights) + edges$.tidygraph_edge_index <- NULL + expanded_edges$.orig_data <- lapply(expanded_edges$.tidygraph_edge_index, function(i) edges[i, , drop = FALSE]) + + # Create a new graph with expanded edges + multi_edge_graph <- tbl_graph(nodes = as_tibble(graph, active = 'nodes'), + edges = expanded_edges, directed = is_directed(graph)) + multi_edge_graph <- set_edge_attributes(multi_edge_graph, expanded_edges) + + list( + multi_edge_graph = multi_edge_graph + ) +} #' @describeIn morphers Combine multiple nodes into one. `...` #' is evaluated in the same manner as `group_by`. When unmorphing all #' data will get merged back. -#' @param simplify Should edges in the contracted graph be simplified? Defaults -#' to `TRUE` +#' @param remove_multiples Should edges that run between the same nodes be +#' reduced to one +#' @param remove_loops Should edges that start and end at the same node be removed #' @importFrom tidyr nest_legacy #' @importFrom igraph contract #' @export -to_contracted <- function(graph, ..., simplify = TRUE) { +to_contracted <- function(graph, ..., remove_multiples = TRUE, remove_loops = TRUE) { nodes <- as_tibble(graph, active = 'nodes') nodes <- group_by(nodes, ...) ind <- group_indices(nodes) @@ -274,8 +311,8 @@ to_contracted <- function(graph, ..., simplify = TRUE) { nodes$.orig_data <- lapply(nodes$.orig_data, function(x) {x$.tidygraph_node_index <- NULL; x}) nodes$.tidygraph_node_index <- ind contracted <- set_node_attributes(contracted, nodes) - if (simplify) { - contracted <- to_simple(contracted)[[1]] + if (remove_multiples | remove_loops) { + contracted <- to_simple(contracted, remove_multiples = remove_multiples, remove_loops = remove_loops)[[1]] } list( contracted = contracted