# How to remove redundant vertices from a graph?

I'm trying to generate tree-level graphs (no cycles or loops) with 3-point vertices only starting from a single vertex graph. I'm defining

f[a_, b_, c_] :=
{a -> Subscript[v, a], b -> Subscript[v, a], c <-> Subscript[v, a]}


then Graph[f[1, 2, 3], VertexLabels -> "Name"] generates

but when I try

Graph[Join @@ {f[1, 2, a], f[3, 4, a]}, VertexLabels -> "Name"]


I get

with the vertex a being what I call redundant, and similarly by joining more graphs. The Join part contains

a <-> Subscript[v, 1], a <-> Subscript[v, 3]


so I'd need to replace this with Subscript[v, 1] <-> Subscript[v, 3].

I want to know how to do this for any number of joined graphs, e.g.

Join @@ {f[1, 2, a], f[3, a, b], f[4, b, c], f[5, 6, c]}


and so on.

## Update

As suggested in the comments, VertexContract[] is meant to do the job, but it does not work for me (Mathematica 10) when using subscripts; I'm using this notation because it promise to be helpful when trying to generalize. I found a workaround that also does the trick with SimpleGraph and VertexReplace, e.g. for the second case in my original question:

SimpleGraph[VertexReplace[Join @@ {f[1, 2, a], f[3, 4, a]},
a -> Subscript[v, 1]], VertexLabels -> "Name"]


but then I'd need a way to go through the edges with redundant vertices to know what vertex replacements should be done!

• Have you seen VertexContract[]? – J. M. is away Aug 3 '16 at 3:27
• @J.M. Thanks, that does the trick, although it seems to be in conflict with the subscript notation for the vertices – Cal Gibson Aug 3 '16 at 9:30
• @Kuba By tree-level I meant with no cycles or loops, I'll specify in the question. – Cal Gibson Aug 3 '16 at 9:31
• @CalGibson Ah, sorry, missed that. – Kuba Aug 3 '16 at 9:31

## 1 Answer

f[a_, b_, c_] := {
DirectedEdge[a, Subscript[v, a]],
DirectedEdge[b, Subscript[v, a]],
UndirectedEdge[c, Subscript[v, a]]}

edges = Join[f[1, 2, a], f[3, a, b], f[4, b, c], f[5, 6, c]];

graph = Graph[edges,
VertexLabels -> "Name",
ImageSize -> Medium]


Vertex pairs to connect (brute force):

connect = Cases[
Subsets[VertexList[graph], {2}], {u_, v_} /;
Module[{
p = FindShortestPath[graph, u, v],
r = FindShortestPath[graph, v, u]},
Or[
Length[p] == 3 && VertexDegree[graph, p[[2]]] == 2,
Length[r] == 3 && VertexDegree[graph, r[[2]]] == 2]]];

(* {{Subscript[v, 1], Subscript[v, 3]},
{Subscript[v, 3], Subscript[v, 4]},
{Subscript[v, 4], Subscript[v, 5]}} *)


Vertices to remove:

remove = FindShortestPath[graph, ##][[2]] & @@@ connect;

(* {a, b, c} *)

EdgeAdd[graph, UndirectedEdge @@@ connect]~VertexDelete~remove


# Update: speed-up

Finding connecting pairs doesn't scale well. Better check only particular pairs, those with graph distance two, instead of all. So you can replace that Subset expression with list.

dm = GraphDistanceMatrix[graph];

list = Map[
VertexList[graph][[#]] &,
Position[UpperTriangularize@dm, 2]];

• I tried with f[1, 2, a], f[3, a, b], f[b, c, e], f[6, c, d], f[4, 5, d], f[7, e, g], f[8, 9, g] but it misses one vertex; the reason seems to be that it connects to the other two through both directed edges. – Cal Gibson Aug 4 '16 at 8:56
• @CalGibson Why do you say the procedure misses it? It seems that c is not redundant here. – BoLe Aug 4 '16 at 11:28
• The edges contain c -> Subscript[v, 6], c -> Subscript[v, b], so I'd need this to be replaced with Subscript[v, 6] <-> Subscript[v, b], which it does not seem to do (Directed or Undirected is ultimately irrelevant, I just need at least one internal edge -I think- to be Undirected so that the graph looks like a Feynman diagram) – Cal Gibson Aug 4 '16 at 11:41
• @CalGibson Can edges produced by f be all of UndirectedEdge? This would of course help remove c. – BoLe Aug 4 '16 at 12:18
• No, I need the vertices with numbers to be connected through directed edges – Cal Gibson Aug 4 '16 at 13:55