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

enter image description here

but when I try

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

I get

enter image description here

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.


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!

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

1 Answer 1

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]

Starting graph

Vertex pairs to connect (brute force):

connect = Cases[
  Subsets[VertexList[graph], {2}], {u_, v_} /;
     p = FindShortestPath[graph, u, v],
     r = FindShortestPath[graph, v, u]},
     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

enter image description here

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]];
  • $\begingroup$ 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. $\endgroup$
    – Cal Gibson
    Aug 4, 2016 at 8:56
  • $\begingroup$ @CalGibson Why do you say the procedure misses it? It seems that c is not redundant here. $\endgroup$
    – BoLe
    Aug 4, 2016 at 11:28
  • $\begingroup$ 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) $\endgroup$
    – Cal Gibson
    Aug 4, 2016 at 11:41
  • $\begingroup$ @CalGibson Can edges produced by f be all of UndirectedEdge? This would of course help remove c. $\endgroup$
    – BoLe
    Aug 4, 2016 at 12:18
  • $\begingroup$ No, I need the vertices with numbers to be connected through directed edges $\endgroup$
    – Cal Gibson
    Aug 4, 2016 at 13:55

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.