fix!: Subset assignment of a graph avoids addition of double edges and ignores loops unless the new loops argument is set to TRUE

R/indexing.R

@@ -1,4 +1,3 @@
-
 ## IGraph library.
 ## Copyright (C) 2010-2012  Gabor Csardi <csardi.gabor@gmail.com>
 ## 334 Harvard street, Cambridge, MA 02139 USA
@@ -329,14 +328,27 @@ length.igraph <- function(x) {
   vcount(x)
 }
 
+expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) {
+  grid <- vctrs::vec_expand_grid(i = i, j = j)
+  if (!directed) {
+    grid <- vctrs::vec_unique(data.frame(
+      i = pmin(grid$i, grid$j),
+      j = pmax(grid$i, grid$j)
+    ))
+  }
+  if (!loops) {
+    grid <- grid[grid[, 1] != grid[, 2], ]
+  }
+  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) {
-  ## TODO: rewrite this in C to make it faster
-
   ################################################################
   ## Argument checks
   if ((!missing(from) || !missing(to)) &&
@@ -373,16 +385,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,37 +403,35 @@ 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_edges(x, v = i, mode = "out"))
     } else if (missing(i)) {
-      todel <- unlist(x[[, j, ..., edges = TRUE]])
+      todel <- unlist(incident_edges(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 {
     ## Addition or update of an attribute (or both)
     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.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) {
+          cli::cli_abort("value greater than one but graph is not weighted and no attribute was specified.")
+        }
         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)
       }
     }

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)
+})