How to remove vertices from a graph?

Question

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)

Answer 1

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}];

Answer 2

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

Answer 3

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

Answer 4

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