I have 2 lists: list 1 is a list of vertices of a graph, says, {1,2,3,4,5} and list 2 keeps track of edges (i.e which vertex connects to which) such as {{1,2}, {2,3},{3,4},{4,1},{2,5}}. Now I want to remove some vertices in list 1 and I want that any edges in list 2 that have an end same as one of the removed vertices will also be removed. What would be the best way to do this in Mathematica? (I can do this easily in other languages like vb.net, but I still am trying to get my head on Mathematica)
4 Answers
These are done easily with graph functions:
g = Graph[Range[5], {1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 1, 2 <-> 5}];
g2 = VertexDelete[g, 1];
EdgeList[g2]
(*
{2 <-> 3, 3 <-> 4, 2 <-> 5}
*)
Of course this works as well if you want to delete more than one vertex, e.g., vertices 1 and 5:
g2 = VertexDelete[g, {1, 5}];
Although using Graph
and VertexDelete
is tempting (and every sane person would try that first), it is by no means an efficient way of doing this. Here is a method that circumvents Graph
and works directly on sparse adjacency matrices:
edges = {{1, 2}, {2, 3}, {3, 4}, {4, 1}, {2, 5}};
vertdel = {1, 4};
A = SparseArray[edges -> 1, {1, 1} Max[edges]];
a = DiagonalMatrix[SparseArray[Partition[vertdel, 1] -> 0, {Length[A]}, 1]];
SparseArray[a.A.a]["NonzeroPositions"]
{{2, 3}, {2, 5}}
Here A
is the (nonsymmetric) adjacency matrix of the underlying graph and a
is the diagonal matrix carrying the indicator function of the new index set on the diagonal. Then a.A.a
is the (nonsymmetric) adjacency matrix of the resulting graph; we need to wrap it with SparseArray
in order to enforce recomputation of the sparse array pattern so that the list of nonzero positions of the matrix corresponds to edges of the new graph.
(For those who are interested: The undocumented "SparseArray`"
context contains many graph-related algorithms that work directly on (weighted) adjacency matrices and that are usually much faster than the Graph
-based implementations.)
With a timing example, it is easier to realize that this is more efficient than applying MemberQ
or to use Graph
(and that Graph
is so slow should be utterly embarassing for WRI).
Of course, using SparseArray
for the adjacency matrix, I assume that the adjacency matrix is sparse...
Let's create the edge set of a random graph:
n = 10000;
m = 100000;
ndel = 1000;
G = RandomGraph[{n, m}];
edges = Developer`ToPackedArray[List @@@ EdgeList[G]];
vertdel = RandomSample[Span[1, n], ndel];
Here are the timings:
First@AbsoluteTiming[
MemberQedges = Complement[edges, Flatten[Select[edges, MemberQ[#]] & /@ vertdel, 1]];
]
131.84
First@AbsoluteTiming[
g = Graph[Range[n], UndirectedEdge @@@ edges];
gedges = EdgeList[VertexDelete[g, vertdel]];
]
9.80492
First@AbsoluteTiming[
A = SparseArray[edges -> 1, {1, 1} Max[edges]];
a = DiagonalMatrix[ SparseArray[Partition[vertdel, 1] -> 0, {Length[A]}, 1]];
spedges = SparseArray[a.A.a]["NonzeroPositions"];
]
0.006572
Of course, we have to check whether all methods return essentially the same result:
Sort[spedges] == Sort[MemberQedges] == Sort[List @@@ gedges]
True
Actually, already constructing the (old) graph g
takes 20 times(!) longer than computing the edges of the new graph with the sparse matrix method...
Finally, as in all Graph
-related threads, it is almost obligatory to mention Szabolcs' "IGraphM`"
package. There we find the function IGWeightedVertexDelete
that accomplishes the task with more acceptable speed. It may be slower than the SparseArray
method but it preserves also a lot of structure of the old graph; this may be very useful in practice and comes -- of course -- at a certain cost.
Needs["IGraphM`"]
First@AbsoluteTiming[
g2 = IGWeightedVertexDelete[g, vertdel];
]
EdgeList[g2] == gedges
0.0746
True
-
2$\begingroup$ @chris Thanks for the reminder. I wrote that in -- as J.M. would say -- gedanken Mathematica. $\endgroup$ Jan 1, 2019 at 15:09
-
$\begingroup$ This solution makes me realize how much there is to learn about Wolfram this year $\endgroup$– FredrikDJan 1, 2019 at 15:14
-
$\begingroup$ As someone who hadn't quite understood the purpose of sparse arrays (until now) this is fascinating. $\endgroup$– geordieJan 1, 2019 at 23:05
-
$\begingroup$ This answer is quite instructive. I came here because I was looking to see if anyone had mentioned that the functions for
Graph
are slow. I am finding that just using list manipulation on the edge list is quicker than usingVertexDelete
orVertexContract
on simple graphs with like 6-4 vertices . Would you confirm that Graph is still slow ? Are there any functions that have a reasonable speed ? I do not understand whyGraph
is atomic if it is not that efficient. Maybe it is is efficient in memory more than speed ? $\endgroup$ Dec 7, 2022 at 22:15 -
1$\begingroup$ "I do not understand why Graph is atomic if it is not that efficient." Yes, me neither. For small graphs, in is maybe more efficient to directly work on the (dense!) adjacency matrix. For larger, but sparse graphs one can do quite a lot with their adjacency matrix represented by a
SparseArray
. However, manipulations that change the nonzero structure of sparse matrix are typically also not very efficient. In general, the most suitable data structure depends on the type of graph and on what you want to do with it. $\endgroup$ Dec 9, 2022 at 20:17
Update: An alternative way to use SparseArray
with a better speed:
Using Henrik's timing setup
First@AbsoluteTiming[A2 = SparseArray[edges -> 1, {1, 1} Max[edges]];
A2[[All, vertdel]] = A2[[vertdel, All]] = 0;
spedges2 = A2["NonzeroPositions"];]
0.00570508
versus
First@AbsoluteTiming[A = SparseArray[edges -> 1, {1, 1} Max[edges]];
a = DiagonalMatrix[SparseArray[Partition[vertdel, 1] -> 0, {Length[A]}, 1]];
spedges = SparseArray[a.A.a]["NonzeroPositions"];]
0.0119241
spedges == spedges2
True
Original answer:
edges = {{1, 2}, {2, 3}, {3, 4}, {4, 1}, {2, 5}};
A few more alternatives:
Select[edges, FreeQ[1]]
Pick[edges, FreeQ[1] /@ edges]
DeleteCases[edges, {_, 1} | {1, _}]
List @@@ EdgeList[VertexDelete[edges, 1]]
all give
{{2, 3}, {3, 4}, {2, 5}}
The following works for removing several vertices and corresponding edges:
verts = {1, 2, 3, 4, 5};
edges = {{1, 2}, {2, 3}, {3, 4}, {4, 1}, {2, 5}};
vertdel = {1, 4}
verts2 = Complement[verts, vertdel]
edges2 = Complement[edges, Flatten[Select[edges, MemberQ[#]] & /@ vertdel, 1]]
{1, 4}
{2, 3, 5}
{{2, 3}, {2, 5}}