I want to delete adjacent vertices in a graph pairwise, i.e, if {a,b} are connected by an edge, I want both a and b to removed such that not only are the vertices themselves removed, but also all the incoming and outgoing edges connected to the vertices are removed.

This is what I've written so far.

deleteAdjacentVertices[G_] := 
Module[{vertices, deleted}, vertices = VertexList[G];
deleted = {};
While[Length[vertices] > 0, a = First[vertices];
 b = First[AdjacencyList[G, a]];
 If[MemberQ[AdjacencyList[G, b], a], 
  G = VertexDelete[G, a, "DeleteIncomingEdges" -> True, 
    "DeleteOutgoingEdges" -> True];
  G = VertexDelete[G, b, "DeleteIncomingEdges" -> True, 
    "DeleteOutgoingEdges" -> True];
  AppendTo[deleted, {a, b}]];
 vertices = VertexList[G];];

G = Graph[{1 -> 2, 2 -> 3}];
deletedVertices = deleteAdjacentVertices[G];
  • 1
    $\begingroup$ Can you tell us also what doesn't work in the code you wrote? Does it execute but return a wrong result in all cases? In some cases? Do you get errors? $\endgroup$
    – MarcoB
    Jun 3, 2023 at 11:56
  • 1
    $\begingroup$ Wouldn't this delete all edges? If you delete all vertex pairs {a,b} connected by an edge, then you're deleting every single edge, right? $\endgroup$
    – ydd
    Jun 3, 2023 at 18:30
  • $\begingroup$ try deleteConnectedVertices1[g_] := VertexList[g, v_ /; VertexDegree[g, v] == 0]? $\endgroup$
    – kglr
    Jun 3, 2023 at 20:39
  • $\begingroup$ also deleteConnectedVertices2[g_] := VertexDelete[g, VertexList@EdgeList[g]]? $\endgroup$
    – kglr
    Jun 3, 2023 at 20:40
  • $\begingroup$ try also deleteConnectedVertices3[g_] := Flatten@Select[Length@# == 1 &]@ConnectedComponents[g]? $\endgroup$
    – kglr
    Jun 3, 2023 at 20:46

1 Answer 1


This method finds pairs of adjacent vertices in a graph, and returns the list of pairs. First, make list of all vertexPairs from the list of edges. Starting with the first pair, check the rest of the pairs. If a pair does not include any vertex that's in the deleted list, add the pair to the list.

deleteAdjacentVertices[G_] := Module[{vertexPairs, deleted},
  vertexPairs = Sort[VertexList/@Graph/@EdgeList[G]];
  deleted = {First@vertexPairs};
    Flatten@deleted, Alternatives[Sequence@@#]], AppendTo[deleted,#]]&/@


G = Graph[{1->2, 2->3}];
deletedVertices = deleteAdjacentVertices[G]
(*{{1, 2}}*)

Use VertexDelete to remove the deleted vertex pairs (deletedVertices) from the graph. The new graph is a single vertex, 3).

VertexDelete[G, Flatten[deletedVertices]]

Here's a larger graph. The resulting graph has disconnected vertices 7 and 9.

G = RandomGraph[{10, 16}, DirectedEdges->True, VertexLabels->Automatic];
deletedVertices = deleteAdjacentVertices[G]
VertexDelete[G, Flatten[deletedVertices]]
(*{{1,3}, {2,8}, {5,4}, {10,6}}*)

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.