From b7d284d4ae4399e732ff848dae01ea74b231f7f1 Mon Sep 17 00:00:00 2001 From: schochastics Date: Fri, 17 Jan 2025 19:45:16 +0100 Subject: [PATCH 1/7] cleanup graph manipulation Part 1 --- R/indexing.R | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/R/indexing.R b/R/indexing.R index 83716da5ce6..f18cf830626 100644 --- a/R/indexing.R +++ b/R/indexing.R @@ -373,16 +373,16 @@ length.igraph <- function(x) { (is.logical(value) && !value) || (is.null(attr) && is.numeric(value) && value == 0)) { ## Delete edges - todel <- x[from = from, to = to, ..., edges = TRUE] + todel <- get_edge_ids(x, c(rbind(from, to))) x <- delete_edges(x, todel) } else { ## Addition or update of an attribute (or both) - ids <- x[from = from, to = to, ..., edges = TRUE] + ids <- get_edge_ids(x, c(rbind(from, to))) if (any(ids == 0)) { x <- add_edges(x, rbind(from[ids == 0], to[ids == 0])) } if (!is.null(attr)) { - ids <- x[from = from, to = to, ..., edges = TRUE] + ids <- get_edge_ids(x, c(rbind(from, to))) x <- set_edge_attr(x, attr, ids, value = value) } } @@ -391,13 +391,15 @@ length.igraph <- function(x) { (is.null(attr) && is.numeric(value) && value == 0)) { ## Delete edges if (missing(i) && missing(j)) { - todel <- unlist(x[[, , ..., edges = TRUE]]) + todel <- seq_len(ecount(x)) } else if (missing(j)) { - todel <- unlist(x[[i, , ..., edges = TRUE]]) + todel <- unlist(incident(x, v = i, mode = "out")) } else if (missing(i)) { - todel <- unlist(x[[, j, ..., edges = TRUE]]) + todel <- unlist(incident(x, v = j, mode = "in")) } else { - todel <- unlist(x[[i, j, ..., edges = TRUE]]) + edge_pairs <- expand.grid(i, j) + edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2]))) + todel <- edge_ids[edge_ids != 0] } x <- delete_edges(x, todel) } else { From d9154a5e7ebdc1f8b7fa466e8307777213f09748 Mon Sep 17 00:00:00 2001 From: schochastics Date: Fri, 17 Jan 2025 20:01:24 +0100 Subject: [PATCH 2/7] cleanup graph manipulation Part 2 --- R/indexing.R | 20 +++++--------------- 1 file changed, 5 insertions(+), 15 deletions(-) diff --git a/R/indexing.R b/R/indexing.R index f18cf830626..390e565c25b 100644 --- a/R/indexing.R +++ b/R/indexing.R @@ -335,8 +335,6 @@ length.igraph <- function(x) { `[<-.igraph` <- function(x, i, j, ..., from, to, attr = if (is_weighted(x)) "weight" else NULL, value) { - ## TODO: rewrite this in C to make it faster - ################################################################ ## Argument checks if ((!missing(from) || !missing(to)) && @@ -407,23 +405,15 @@ length.igraph <- function(x) { i <- if (missing(i)) as.numeric(V(x)) else as_igraph_vs(x, i) j <- if (missing(j)) as.numeric(V(x)) else as_igraph_vs(x, j) if (length(i) != 0 && length(j) != 0) { - ## Existing edges, and their endpoints - exe <- lapply(x[[i, j, ..., edges = TRUE]], as.vector) - exv <- lapply(x[[i, j, ...]], as.vector) - toadd <- unlist(lapply(seq_along(exv), function(idx) { - to <- setdiff(j, exv[[idx]]) - if (length(to != 0)) { - rbind(i[idx], setdiff(j, exv[[idx]])) - } else { - numeric() - } - })) - ## Do the changes + edge_pairs <- expand.grid(i, j) + edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2]))) + toadd <- c(rbind(edge_pairs[edge_ids == 0, 1], edge_pairs[edge_ids == 0, 2])) + if (is.null(attr)) { x <- add_edges(x, toadd) } else { x <- add_edges(x, toadd, attr = structure(list(value), names = attr)) - toupdate <- unlist(exe) + toupdate <- edge_ids[edge_ids != 0] x <- set_edge_attr(x, attr, toupdate, value) } } From 8b42e852ad7512734a0b6f4314fcee4b3d1aa322 Mon Sep 17 00:00:00 2001 From: schochastics Date: Sun, 19 Jan 2025 12:22:46 +0100 Subject: [PATCH 3/7] apply incident to all nodes of i or j --- R/indexing.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/indexing.R b/R/indexing.R index 390e565c25b..8d142d01fb4 100644 --- a/R/indexing.R +++ b/R/indexing.R @@ -1,4 +1,3 @@ - ## IGraph library. ## Copyright (C) 2010-2012 Gabor Csardi ## 334 Harvard street, Cambridge, MA 02139 USA @@ -391,9 +390,9 @@ length.igraph <- function(x) { if (missing(i) && missing(j)) { todel <- seq_len(ecount(x)) } else if (missing(j)) { - todel <- unlist(incident(x, v = i, mode = "out")) + todel <- unlist(sapply(i, function(id) incident(x, v = id, mode = "out"))) } else if (missing(i)) { - todel <- unlist(incident(x, v = j, mode = "in")) + todel <- unlist(sapply(j, function(id) incident(x, v = id, mode = "in"))) } else { edge_pairs <- expand.grid(i, j) edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2]))) From 7fcfea94d95c7572394b1b7417225317e440aa2c Mon Sep 17 00:00:00 2001 From: schochastics Date: Sun, 19 Jan 2025 20:12:48 +0100 Subject: [PATCH 4/7] switched from sapply to incident_edges --- R/indexing.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/indexing.R b/R/indexing.R index 8d142d01fb4..c5a1624be22 100644 --- a/R/indexing.R +++ b/R/indexing.R @@ -390,9 +390,9 @@ length.igraph <- function(x) { if (missing(i) && missing(j)) { todel <- seq_len(ecount(x)) } else if (missing(j)) { - todel <- unlist(sapply(i, function(id) incident(x, v = id, mode = "out"))) + todel <- unlist(incident_edges(x, v = i, mode = "out")) } else if (missing(i)) { - todel <- unlist(sapply(j, function(id) incident(x, v = id, mode = "in"))) + todel <- unlist(incident_edges(x, v = j, mode = "in")) } else { edge_pairs <- expand.grid(i, j) edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2]))) From f540d9fecff877c5e2d6bf8d2bc52475e0f511f2 Mon Sep 17 00:00:00 2001 From: schochastics Date: Sun, 19 Jan 2025 21:55:27 +0100 Subject: [PATCH 5/7] new manipulation rules implemented --- R/indexing.R | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/R/indexing.R b/R/indexing.R index c5a1624be22..3a3abcb41b4 100644 --- a/R/indexing.R +++ b/R/indexing.R @@ -328,11 +328,27 @@ length.igraph <- function(x) { vcount(x) } +expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { + grid <- expand.grid(i = i, j = j) + if (!directed) { + grid <- unique(data.frame( + i = pmin(grid$i, grid$j), + j = pmax(grid$i, grid$j) + )) + } + if (!loops) { + grid[grid[, 1] != grid[, 2], ] + } else { + grid + } +} + #' @method [<- igraph #' @family functions for manipulating graph structure #' @export `[<-.igraph` <- function(x, i, j, ..., from, to, attr = if (is_weighted(x)) "weight" else NULL, + loops = FALSE, value) { ################################################################ ## Argument checks @@ -404,11 +420,15 @@ length.igraph <- function(x) { i <- if (missing(i)) as.numeric(V(x)) else as_igraph_vs(x, i) j <- if (missing(j)) as.numeric(V(x)) else as_igraph_vs(x, j) if (length(i) != 0 && length(j) != 0) { - edge_pairs <- expand.grid(i, j) + edge_pairs <- expand.grid.unordered(i, j, loops = loops, directed = is_directed(x)) + edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2]))) toadd <- c(rbind(edge_pairs[edge_ids == 0, 1], edge_pairs[edge_ids == 0, 2])) if (is.null(attr)) { + if (value > 1) { + warning("value greater than one but graph is not weighted and no attribute was specified. Only unweighted edges are added.", call. = FALSE) + } x <- add_edges(x, toadd) } else { x <- add_edges(x, toadd, attr = structure(list(value), names = attr)) From 2b0d7f4ebeb496c8922f528d98b97b623fbf866d Mon Sep 17 00:00:00 2001 From: schochastics Date: Mon, 20 Jan 2025 21:13:10 +0100 Subject: [PATCH 6/7] resolved review comments --- R/indexing.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/R/indexing.R b/R/indexing.R index 3a3abcb41b4..a91c081b52a 100644 --- a/R/indexing.R +++ b/R/indexing.R @@ -329,18 +329,17 @@ length.igraph <- function(x) { } expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { - grid <- expand.grid(i = i, j = j) + grid <- vctrs::vec_expand_grid(i = i, j = j) if (!directed) { - grid <- unique(data.frame( + grid <- vctrs::vec_unique(data.frame( i = pmin(grid$i, grid$j), j = pmax(grid$i, grid$j) )) } if (!loops) { - grid[grid[, 1] != grid[, 2], ] - } else { - grid + grid <- grid[grid[, 1] != grid[, 2], ] } + grid } #' @method [<- igraph @@ -427,7 +426,7 @@ expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { if (is.null(attr)) { if (value > 1) { - warning("value greater than one but graph is not weighted and no attribute was specified. Only unweighted edges are added.", call. = FALSE) + cli::cli_abort("value greater than one but graph is not weighted and no attribute was specified.") } x <- add_edges(x, toadd) } else { From 5e041788b72034b1cc482ded4fbedbd7b76cc8f0 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 21 Jan 2025 10:57:08 +0100 Subject: [PATCH 7/7] added more tests and fixed old tests --- tests/testthat/test-indexing2.R | 128 +++++++++++++++++++++++++++++++- 1 file changed, 125 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-indexing2.R b/tests/testthat/test-indexing2.R index 03294063b3c..b771fff68ae 100644 --- a/tests/testthat/test-indexing2.R +++ b/tests/testthat/test-indexing2.R @@ -34,7 +34,7 @@ test_that("[ can set weights and delete weighted edges", { A[1, 2] <- g[1, 2] <- 3 expect_equal(canonicalize_matrix(g[]), A) - A[1:2, 2:3] <- g[1:2, 2:3] <- -1 + A[1:2, 2:3] <- g[1:2, 2:3, loops = TRUE] <- -1 expect_equal(canonicalize_matrix(g[]), A) g[1, 2] <- NULL @@ -52,12 +52,12 @@ test_that("[ can add edges and ste weights via vertex names", { A["b", "c"] <- g["b", "c"] <- TRUE expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A)) - A[c("a", "f"), c("f", "a")] <- g[c("a", "f"), c("f", "a")] <- TRUE + A[c("a", "f"), c("f", "a")] <- g[c("a", "f"), c("f", "a"), loops = TRUE] <- TRUE expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A)) A[A == 1] <- NA A[c("a", "c", "h"), c("a", "b", "c")] <- - g[c("a", "c", "h"), c("a", "b", "c"), attr = "weight"] <- 3 + g[c("a", "c", "h"), c("a", "b", "c"), attr = "weight", loops = TRUE] <- 3 expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A)) }) @@ -105,3 +105,125 @@ test_that("[ and from-to with multiple values", { ) expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A)) }) + +test_that("[ manipulation works as intended for unweighted", { + # see issue https://github.com/igraph/rigraph/issues/1662 + g1 <- make_empty_graph(n = 10, directed = FALSE) + A1 <- matrix(0, 10, 10) + A1[1:5, ] <- A1[, 1:5] <- g1[1:5, ] <- 1 + diag(A1) <- 0 + expect_equal(canonicalize_matrix(g1[]), A1) + + g2 <- make_empty_graph(n = 10, directed = FALSE) + A2 <- matrix(0, 10, 10) + A2[1:5, ] <- A2[, 1:5] <- g2[, 1:5] <- 1 + diag(A2) <- 0 + expect_equal(canonicalize_matrix(g2[]), A2) + + g3 <- make_empty_graph(n = 10, directed = TRUE) + A3 <- matrix(0, 10, 10) + A3[1:5, ] <- g3[1:5, ] <- 1 + diag(A3) <- 0 + expect_equal(canonicalize_matrix(g3[]), A3) + + g4 <- make_empty_graph(n = 10, directed = TRUE) + A4 <- matrix(0, 10, 10) + A4[, 1:5] <- g4[, 1:5] <- 1 + diag(A4) <- 0 + expect_equal(canonicalize_matrix(g4[]), A4) + + g5 <- make_empty_graph(n = 10, directed = TRUE) + A5 <- matrix(0, 10, 10) + g5[1, 2] <- g5[2, 1] <- A5[1, 2] <- A5[2, 1] <- 1 + expect_equal(canonicalize_matrix(g5[]), A5) + + g6 <- make_empty_graph(n = 10, directed = FALSE) + A6 <- matrix(0, 10, 10) + A6[6:10, 1:5] <- A6[1:5, 6:10] <- g6[6:10, 1:5] <- 1 + expect_equal(canonicalize_matrix(g6[]), A6) + + g7 <- make_empty_graph(n = 10, directed = TRUE) + A7 <- matrix(0, 10, 10) + g7[6:10, 1:5] <- A7[6:10, 1:5] <- 1 + diag(A7) <- 0 + expect_equal(canonicalize_matrix(g7[]), A7) + + g8 <- make_empty_graph(n = 10, directed = TRUE) + A8 <- matrix(0, 10, 10) + g8[1:5, 6:10] <- A8[1:5, 6:10] <- 1 + diag(A8) <- 0 + expect_equal(canonicalize_matrix(g8[]), A8) +}) + +test_that("[ manipulation works as intended for weighted", { + # see issue https://github.com/igraph/rigraph/issues/1662 + + g1 <- make_empty_graph(n = 10, directed = FALSE) + A1 <- matrix(0, 10, 10) + A1[1:5, 1:5] <- g1[1:5, 1:5, attr = "weight"] <- 2 + diag(A1) <- 0 + expect_equal(canonicalize_matrix(g1[]), A1) + + g2 <- make_empty_graph(n = 10, directed = FALSE) + E(g2)$weight <- 1 + A2 <- matrix(0, 10, 10) + A2[1:3, 1:3] <- g2[1:3, 1:3] <- -2 + diag(A2) <- 0 + expect_equal(canonicalize_matrix(g2[]), A2) +}) + +test_that("[ manipulation handles errors properly", { + g1 <- make_empty_graph(n = 10, directed = FALSE) + expect_error(g1[1:5, ] <- 2) +}) + +test_that("[ deletion works as intended", { + # see issue https://github.com/igraph/rigraph/issues/1662 + g1 <- make_full_graph(n = 10, directed = FALSE) + A1 <- matrix(1, 10, 10) + diag(A1) <- 0 + A1[1:5, ] <- A1[, 1:5] <- g1[1:5, ] <- 0 + expect_equal(canonicalize_matrix(g1[]), A1) + + g2 <- make_full_graph(n = 10, directed = FALSE) + A2 <- matrix(1, 10, 10) + diag(A2) <- 0 + A2[1:5, ] <- A2[, 1:5] <- g2[, 1:5] <- 0 + expect_equal(canonicalize_matrix(g2[]), A2) + + g3 <- make_full_graph(n = 10, directed = TRUE) + A3 <- matrix(1, 10, 10) + diag(A3) <- 0 + A3[1:5, ] <- g3[1:5, ] <- 0 + expect_equal(canonicalize_matrix(g3[]), A3) + + g4 <- make_full_graph(n = 10, directed = TRUE) + A4 <- matrix(1, 10, 10) + diag(A4) <- 0 + A4[, 1:5] <- g4[, 1:5] <- 0 + expect_equal(canonicalize_matrix(g4[]), A4) + + g5 <- make_full_graph(n = 10, directed = TRUE) + A5 <- matrix(1, 10, 10) + diag(A5) <- 0 + g5[1, 2] <- g5[2, 1] <- A5[1, 2] <- A5[2, 1] <- 0 + expect_equal(canonicalize_matrix(g5[]), A5) + + g6 <- make_full_graph(n = 10, directed = FALSE) + A6 <- matrix(1, 10, 10) + diag(A6) <- 0 + A6[6:10, 1:5] <- A6[1:5, 6:10] <- g6[6:10, 1:5] <- 0 + expect_equal(canonicalize_matrix(g6[]), A6) + + g7 <- make_full_graph(n = 10, directed = TRUE) + A7 <- matrix(1, 10, 10) + diag(A7) <- 0 + g7[6:10, 1:5] <- A7[6:10, 1:5] <- 0 + expect_equal(canonicalize_matrix(g7[]), A7) + + g8 <- make_full_graph(n = 10, directed = TRUE) + A8 <- matrix(1, 10, 10) + diag(A8) <- 0 + g8[1:5, 6:10] <- A8[1:5, 6:10] <- 0 + expect_equal(canonicalize_matrix(g8[]), A8) +})