Skip to content

Commit

Permalink
fix!: Subset assignment of a graph avoids addition of double edges an…
Browse files Browse the repository at this point in the history 
…d ignores loops unless the new `loops` argument is set to `TRUE` (#1661)
  • Loading branch information
@schochastics
schochastics authored Jan 23, 2025
1 parent 368f087 commit cee57e1
Show file tree
Hide file tree
Showing 2 changed files with 158 additions and 26 deletions.
56 changes: 33 additions & 23 deletions R/indexing.R
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@

## IGraph library.
## Copyright (C) 2010-2012 Gabor Csardi <csardi.gabor@gmail.com>
## 334 Harvard street, Cambridge, MA 02139 USA
Expand Down Expand Up @@ -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)) &&
Expand Down Expand Up @@ -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)
}
}
Expand All @@ -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)
}
}
Expand Down
128 changes: 125 additions & 3 deletions tests/testthat/test-indexing2.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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))
})

Expand Down Expand Up @@ -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)
})

0 comments on commit cee57e1

Please sign in to comment.