2
$\begingroup$

So I have three graphs defined by the following nested list, I'm using this list notation instead <-> notation because it is more convenient for another part of my code (not written here):

   g[delta_] := {{{1, 2}, {1, 4}, {1, 5}, {1, 7}, {2, 3}, {2, 5}, {2, 
     6}, {2, 7}, {3, 4}, {3, 5}, {3, 6}, {3, 8}, {4, 5}, {4, 7}, {4, 
     8}, {6, 7}, {6, 8}, {7, 8}}, {{1, 2}, {1, 4}, {1, 5}, {1, 6}, {2,
      3}, {2, 5}, {2, 6}, {2, 7}, {2, 8}, {3, 4}, {3, 5}, {3, 7}, {4, 
     5}, {4, 6}, {4, 7}, {4, 8}, {6, 8}, {7, 8}}, {{1, 2}, {1, 4}, {1,
      7}, {1, 8}, {2, 3}, {2, 4}, {2, 5}, {3, 4}, {3, 5}, {3, 6}, {4, 
     8}, {5, 6}, {5, 7}, {6, 7}, {6, 8}, {7, 8}}}[[delta]]

so that I can get a list of graphs using

   f4graph[omega_] := 
Graph[g[omega], VertexLabels -> "Name"]

Table[f4graph[omega], {omega, 3}]

The code below finds all of triangle subgraphs (3-cycles) in each of the above graphs

h = CycleGraph[3];
    s[delta_] := 
      Subsets[Range[VertexCount[f4graph[delta]]], {VertexCount[h]}];
    p[delta_] := 
      Select[Subgraph[f4graph[delta], #] & /@ s[delta], 
       IsomorphicGraphQ[#, h] &];
    n[delta_] := Length[p[delta]];
o[alpha_, beta_] := VertexList[p[alpha][[beta]]];

so p defines a list of triangles (as graphs) for any of the given graphs above and o gives a list of the vertex numbers that form a triangle in each of the three graphs e.g. o[2,3] gives vertices for the 'third' triangle in graph 2.

Some context to my issue: some of the triangles in these graphs are redundant for what I am looking at, for example, in the first graph, the triangle formed by vertices {1,2,7} is 'equivalent' to the triangles {1,4,7}, {2,3,5}, {3,4,5} because I can geometrically get to one of the latter triangles by some kind of symmetry, in this case (possibly compositions) reflections. {1,2,7} is also 'equivalent' to {2,6,7}, {4,7,8}, {2,3,6},{3,4,8}, this can be seen by using Graph3D for the first graph, rotating the graph a bit and noting the 'equivalence' between edges 15 and edges 68. More examples of what I mean by 'equivalence' are written below.In the context of I gain no new information by looking at {1,4,7} if I've already looked at {1,2,7}. However, {1,2,7} is 'nonequivalent' the rest of the triangles of the graph, namely, {6,7,8}, {3,6,8}, {1,2,5}, {1,4,5} (which forms its own class of equivalent triangles of graph 1). I'm using the word '(non)equivalent' because I am not familiar with a term for this in graph theory.

It is easily seen in the second graph that there is only one triangle to consider, e.g. triangle {1,2,6}, we can rotate and/or reflect to get to all other triangles. In this case, I would like the list p[2] to reduce to just one of the triangles (any of them, as they are all 'equivalent').

So the upshot of my question is, how can I algorithmically reduce my list of triangles in p to give a list of triangle(s) that are 'nonequivalent' to each other. Quickly starting at graph 1, I'd expect 2 'nonequivalent' triangles from ALL of the triangles in p[1], for example triangles from the following vertices {1,2,7},{1,2,5} OR any 'equivalent' version of this, e.g. {2,3,6}, {1,4,5} OR {3,4,8}, {6,7,8}. Right now, p[1] consists of 12 triangles, I'd like the list to reduce to 2 'nonequivalent' triangles using this 'geometric' symmetry as a classification.

$\endgroup$
5
$\begingroup$

I believe what you mean by "equivalence" is Automorphism.

Your definitions (some of them changed a little):

f4graph[omega_] := System`Graph[g[omega]]
t = Table[f4graph[omega], {omega, 3}]
h = CycleGraph[3];
s[delta_] :=  Subsets[Range[VertexCount[f4graph[delta]]], {VertexCount[h]}];
p[delta_] :=  Select[Subgraph[f4graph[delta], #]&/@ s[delta], IsomorphicGraphQ[#, h] &];
n[delta_] := Length[p[delta]];
o[alpha_, beta_] := System`VertexList[p[alpha][[beta]]];

Then:

<< GraphUtilities`
n = 1;
t = Table[f4graph[omega], {omega, 3}];
tt = ToCombinatoricaGraph@t[[n]];
eqclasses = (Sort@Automorphisms@tt)[[All, System`VertexList@#]] & /@  p[n];
dd = DeleteDuplicates[eqclasses, Sort[Sort /@ #1] == Sort[Sort /@ #2] &][[All, 1]]

HighlightGraph[t[[1]], Subgraph[t[[1]], #], 
               GraphLayout -> "CircularEmbedding", 
               VertexLabels -> "Name"] & /@ dd

Mathematica graphics

If you wonder which are the equivalent (automorphic) vertex arrangements for this Graph:

SetProperty[
   t[[n]], {VertexLabels -> Thread[Rule[Range@System`VertexCount@t[[n]], #]], 
             GraphLayout -> "CircularEmbedding", 
            ImagePadding -> 10}] & /@  Sort@Automorphisms@tt

Mathematica graphics

$\endgroup$
  • $\begingroup$ This can be achieved with GraphAutomorphismGroup and GroupOrbits as well. But there's a problem which I think affects your answer too: there are 6 ways to write a triangle: 3 cyclic permutations and their reverse. The graph's automorphisms don't maps these into each other so some equivalences might be missed. But I might be missing something ... $\endgroup$ – Szabolcs Sep 21 '15 at 7:17

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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