Skip to content

Commit cee57e1

Browse files
schochasticsschochastics
authored
fix!: Subset assignment of a graph avoids addition of double edges and ignores loops unless the new loops argument is set to TRUE (#1661)
1 parent 368f087 commit cee57e1

File tree

2 files changed

+158
-26
lines changed

2 files changed

+158
-26
lines changed

‎R/indexing.R‎

Lines changed: 33 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
21
## IGraph library.
32
## Copyright (C) 2010-2012 Gabor Csardi <csardi.gabor@gmail.com>
43
## 334 Harvard street, Cambridge, MA 02139 USA
@@ -329,14 +328,27 @@ length.igraph <- function(x) {
329328
vcount(x)
330329
}
331330

331+
expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) {
332+
grid <- vctrs::vec_expand_grid(i = i, j = j)
333+
if (!directed) {
334+
grid <- vctrs::vec_unique(data.frame(
335+
i = pmin(grid$i, grid$j),
336+
j = pmax(grid$i, grid$j)
337+
))
338+
}
339+
if (!loops) {
340+
grid <- grid[grid[, 1] != grid[, 2], ]
341+
}
342+
grid
343+
}
344+
332345
#' @method [<- igraph
333346
#' @family functions for manipulating graph structure
334347
#' @export
335348
`[<-.igraph` <- function(x, i, j, ..., from, to,
336349
attr = if (is_weighted(x)) "weight" else NULL,
350+
loops = FALSE,
337351
value) {
338-
## TODO: rewrite this in C to make it faster
339-
340352
################################################################
341353
## Argument checks
342354
if ((!missing(from) || !missing(to)) &&
@@ -373,16 +385,16 @@ length.igraph <- function(x) {
373385
(is.logical(value) && !value) ||
374386
(is.null(attr) && is.numeric(value) && value == 0)) {
375387
## Delete edges
376-
todel <- x[from = from, to = to, ..., edges = TRUE]
388+
todel <- get_edge_ids(x, c(rbind(from, to)))
377389
x <- delete_edges(x, todel)
378390
} else {
379391
## Addition or update of an attribute (or both)
380-
ids <- x[from = from, to = to, ..., edges = TRUE]
392+
ids <- get_edge_ids(x, c(rbind(from, to)))
381393
if (any(ids == 0)) {
382394
x <- add_edges(x, rbind(from[ids == 0], to[ids == 0]))
383395
}
384396
if (!is.null(attr)) {
385-
ids <- x[from = from, to = to, ..., edges = TRUE]
397+
ids <- get_edge_ids(x, c(rbind(from, to)))
386398
x <- set_edge_attr(x, attr, ids, value = value)
387399
}
388400
}
@@ -391,37 +403,35 @@ length.igraph <- function(x) {
391403
(is.null(attr) && is.numeric(value) && value == 0)) {
392404
## Delete edges
393405
if (missing(i) && missing(j)) {
394-
todel <- unlist(x[[, , ..., edges = TRUE]])
406+
todel <- seq_len(ecount(x))
395407
} else if (missing(j)) {
396-
todel <- unlist(x[[i, , ..., edges = TRUE]])
408+
todel <- unlist(incident_edges(x, v = i, mode = "out"))
397409
} else if (missing(i)) {
398-
todel <- unlist(x[[, j, ..., edges = TRUE]])
410+
todel <- unlist(incident_edges(x, v = j, mode = "in"))
399411
} else {
400-
todel <- unlist(x[[i, j, ..., edges = TRUE]])
412+
edge_pairs <- expand.grid(i, j)
413+
edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2])))
414+
todel <- edge_ids[edge_ids != 0]
401415
}
402416
x <- delete_edges(x, todel)
403417
} else {
404418
## Addition or update of an attribute (or both)
405419
i <- if (missing(i)) as.numeric(V(x)) else as_igraph_vs(x, i)
406420
j <- if (missing(j)) as.numeric(V(x)) else as_igraph_vs(x, j)
407421
if (length(i) != 0 && length(j) != 0) {
408-
## Existing edges, and their endpoints
409-
exe <- lapply(x[[i, j, ..., edges = TRUE]], as.vector)
410-
exv <- lapply(x[[i, j, ...]], as.vector)
411-
toadd <- unlist(lapply(seq_along(exv), function(idx) {
412-
to <- setdiff(j, exv[[idx]])
413-
if (length(to != 0)) {
414-
rbind(i[idx], setdiff(j, exv[[idx]]))
415-
} else {
416-
numeric()
417-
}
418-
}))
419-
## Do the changes
422+
edge_pairs <- expand.grid.unordered(i, j, loops = loops, directed = is_directed(x))
423+
424+
edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2])))
425+
toadd <- c(rbind(edge_pairs[edge_ids == 0, 1], edge_pairs[edge_ids == 0, 2]))
426+
420427
if (is.null(attr)) {
428+
if (value > 1) {
429+
cli::cli_abort("value greater than one but graph is not weighted and no attribute was specified.")
430+
}
421431
x <- add_edges(x, toadd)
422432
} else {
423433
x <- add_edges(x, toadd, attr = structure(list(value), names = attr))
424-
toupdate <- unlist(exe)
434+
toupdate <- edge_ids[edge_ids != 0]
425435
x <- set_edge_attr(x, attr, toupdate, value)
426436
}
427437
}

‎tests/testthat/test-indexing2.R‎

Lines changed: 125 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,7 @@ test_that("[ can set weights and delete weighted edges", {
3434
A[1, 2] <- g[1, 2] <- 3
3535
expect_equal(canonicalize_matrix(g[]), A)
3636

37-
A[1:2, 2:3] <- g[1:2, 2:3] <- -1
37+
A[1:2, 2:3] <- g[1:2, 2:3, loops = TRUE] <- -1
3838
expect_equal(canonicalize_matrix(g[]), A)
3939

4040
g[1, 2] <- NULL
@@ -52,12 +52,12 @@ test_that("[ can add edges and ste weights via vertex names", {
5252
A["b", "c"] <- g["b", "c"] <- TRUE
5353
expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A))
5454

55-
A[c("a", "f"), c("f", "a")] <- g[c("a", "f"), c("f", "a")] <- TRUE
55+
A[c("a", "f"), c("f", "a")] <- g[c("a", "f"), c("f", "a"), loops = TRUE] <- TRUE
5656
expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A))
5757

5858
A[A == 1] <- NA
5959
A[c("a", "c", "h"), c("a", "b", "c")] <-
60-
g[c("a", "c", "h"), c("a", "b", "c"), attr = "weight"] <- 3
60+
g[c("a", "c", "h"), c("a", "b", "c"), attr = "weight", loops = TRUE] <- 3
6161
expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A))
6262
})
6363

@@ -105,3 +105,125 @@ test_that("[ and from-to with multiple values", {
105105
)
106106
expect_equal(canonicalize_matrix(g[]), canonicalize_matrix(A))
107107
})
108+
109+
test_that("[ manipulation works as intended for unweighted", {
110+
# see issue https://github.com/igraph/rigraph/issues/1662
111+
g1 <- make_empty_graph(n = 10, directed = FALSE)
112+
A1 <- matrix(0, 10, 10)
113+
A1[1:5, ] <- A1[, 1:5] <- g1[1:5, ] <- 1
114+
diag(A1) <- 0
115+
expect_equal(canonicalize_matrix(g1[]), A1)
116+
117+
g2 <- make_empty_graph(n = 10, directed = FALSE)
118+
A2 <- matrix(0, 10, 10)
119+
A2[1:5, ] <- A2[, 1:5] <- g2[, 1:5] <- 1
120+
diag(A2) <- 0
121+
expect_equal(canonicalize_matrix(g2[]), A2)
122+
123+
g3 <- make_empty_graph(n = 10, directed = TRUE)
124+
A3 <- matrix(0, 10, 10)
125+
A3[1:5, ] <- g3[1:5, ] <- 1
126+
diag(A3) <- 0
127+
expect_equal(canonicalize_matrix(g3[]), A3)
128+
129+
g4 <- make_empty_graph(n = 10, directed = TRUE)
130+
A4 <- matrix(0, 10, 10)
131+
A4[, 1:5] <- g4[, 1:5] <- 1
132+
diag(A4) <- 0
133+
expect_equal(canonicalize_matrix(g4[]), A4)
134+
135+
g5 <- make_empty_graph(n = 10, directed = TRUE)
136+
A5 <- matrix(0, 10, 10)
137+
g5[1, 2] <- g5[2, 1] <- A5[1, 2] <- A5[2, 1] <- 1
138+
expect_equal(canonicalize_matrix(g5[]), A5)
139+
140+
g6 <- make_empty_graph(n = 10, directed = FALSE)
141+
A6 <- matrix(0, 10, 10)
142+
A6[6:10, 1:5] <- A6[1:5, 6:10] <- g6[6:10, 1:5] <- 1
143+
expect_equal(canonicalize_matrix(g6[]), A6)
144+
145+
g7 <- make_empty_graph(n = 10, directed = TRUE)
146+
A7 <- matrix(0, 10, 10)
147+
g7[6:10, 1:5] <- A7[6:10, 1:5] <- 1
148+
diag(A7) <- 0
149+
expect_equal(canonicalize_matrix(g7[]), A7)
150+
151+
g8 <- make_empty_graph(n = 10, directed = TRUE)
152+
A8 <- matrix(0, 10, 10)
153+
g8[1:5, 6:10] <- A8[1:5, 6:10] <- 1
154+
diag(A8) <- 0
155+
expect_equal(canonicalize_matrix(g8[]), A8)
156+
})
157+
158+
test_that("[ manipulation works as intended for weighted", {
159+
# see issue https://github.com/igraph/rigraph/issues/1662
160+
161+
g1 <- make_empty_graph(n = 10, directed = FALSE)
162+
A1 <- matrix(0, 10, 10)
163+
A1[1:5, 1:5] <- g1[1:5, 1:5, attr = "weight"] <- 2
164+
diag(A1) <- 0
165+
expect_equal(canonicalize_matrix(g1[]), A1)
166+
167+
g2 <- make_empty_graph(n = 10, directed = FALSE)
168+
E(g2)$weight <- 1
169+
A2 <- matrix(0, 10, 10)
170+
A2[1:3, 1:3] <- g2[1:3, 1:3] <- -2
171+
diag(A2) <- 0
172+
expect_equal(canonicalize_matrix(g2[]), A2)
173+
})
174+
175+
test_that("[ manipulation handles errors properly", {
176+
g1 <- make_empty_graph(n = 10, directed = FALSE)
177+
expect_error(g1[1:5, ] <- 2)
178+
})
179+
180+
test_that("[ deletion works as intended", {
181+
# see issue https://github.com/igraph/rigraph/issues/1662
182+
g1 <- make_full_graph(n = 10, directed = FALSE)
183+
A1 <- matrix(1, 10, 10)
184+
diag(A1) <- 0
185+
A1[1:5, ] <- A1[, 1:5] <- g1[1:5, ] <- 0
186+
expect_equal(canonicalize_matrix(g1[]), A1)
187+
188+
g2 <- make_full_graph(n = 10, directed = FALSE)
189+
A2 <- matrix(1, 10, 10)
190+
diag(A2) <- 0
191+
A2[1:5, ] <- A2[, 1:5] <- g2[, 1:5] <- 0
192+
expect_equal(canonicalize_matrix(g2[]), A2)
193+
194+
g3 <- make_full_graph(n = 10, directed = TRUE)
195+
A3 <- matrix(1, 10, 10)
196+
diag(A3) <- 0
197+
A3[1:5, ] <- g3[1:5, ] <- 0
198+
expect_equal(canonicalize_matrix(g3[]), A3)
199+
200+
g4 <- make_full_graph(n = 10, directed = TRUE)
201+
A4 <- matrix(1, 10, 10)
202+
diag(A4) <- 0
203+
A4[, 1:5] <- g4[, 1:5] <- 0
204+
expect_equal(canonicalize_matrix(g4[]), A4)
205+
206+
g5 <- make_full_graph(n = 10, directed = TRUE)
207+
A5 <- matrix(1, 10, 10)
208+
diag(A5) <- 0
209+
g5[1, 2] <- g5[2, 1] <- A5[1, 2] <- A5[2, 1] <- 0
210+
expect_equal(canonicalize_matrix(g5[]), A5)
211+
212+
g6 <- make_full_graph(n = 10, directed = FALSE)
213+
A6 <- matrix(1, 10, 10)
214+
diag(A6) <- 0
215+
A6[6:10, 1:5] <- A6[1:5, 6:10] <- g6[6:10, 1:5] <- 0
216+
expect_equal(canonicalize_matrix(g6[]), A6)
217+
218+
g7 <- make_full_graph(n = 10, directed = TRUE)
219+
A7 <- matrix(1, 10, 10)
220+
diag(A7) <- 0
221+
g7[6:10, 1:5] <- A7[6:10, 1:5] <- 0
222+
expect_equal(canonicalize_matrix(g7[]), A7)
223+
224+
g8 <- make_full_graph(n = 10, directed = TRUE)
225+
A8 <- matrix(1, 10, 10)
226+
diag(A8) <- 0
227+
g8[1:5, 6:10] <- A8[1:5, 6:10] <- 0
228+
expect_equal(canonicalize_matrix(g8[]), A8)
229+
})

0 commit comments

Comments
 (0)