How to compute the automorphisms of graphs with multiple edges?

Question

I try to compute the Automorphisms of graphs with multiple edges from its AdjacencyMatrix but failed. The following code shows how to compute the Automorphisms of graphs without multiple edges:

Block[{$ContextPath}, Needs["Combinatorica`"];
Needs["GraphUtilities`"]]
m = ({
{0, 1, 1, 1},
{1, 0, 1, 1},
{1, 1, 0, 1},
{1, 1, 1, 0}
});
g = AdjacencyGraph[m];
Combinatorica`Automorphisms@GraphUtilities`ToCombinatoricaGraph[g]//Lenght (*24*)

As I have tried, AdjacencyGraph, IncidenceGraph will fail to convert a matrix into a graph. And

Graph[{1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 2}]

will fail also. But if I plot the graph as a figure directly Automorphisms will fail at that figure of graph. Other software will do this work, for example Sage.

So, how to compute the Automorphisms of graphs with multiple edges in Mathematica?

Answer 1

I hope the following is helpful:

Firstly, consider this example:

gr = System`Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 3 <-> 5}];
sysm = System`AdjacencyMatrix[gr];
com = Combinatorica`FromAdjacencyMatrix[Normal@sysm];
aut = Combinatorica`Automorphisms[com];
ex = System`Graph[EdgeList[gr], 
    VertexLabels -> Table[j -> Placed[#[[j]], Center], {j, 5}], 
    VertexSize -> 0.4, VertexLabelStyle -> Directive[20, White]] & /@ 
  aut

Automating (this is not pretty but a start):

fun[mat_] := Module[{sg, sgel, cg, au},
  Needs["Combinatorica`"];
  sg = System`AdjacencyGraph[mat];
  sgel = EdgeList[sg];
  cg = Combinatorica`FromAdjacencyMatrix[mat];
  au = Combinatorica`Automorphisms[cg];
  System`Graph[sgel, 
     VertexLabels -> 
      Table[j -> Placed[#[[j]], Center], {j, VertexCount@sg}], 
     VertexSize -> 0.4, VertexLabelStyle -> Directive[12, White]] & /@
    au]

Applying to your complete graph (which necessarily has 4!=24 automorphisms) and visualizing:

m = ({{0, 1, 1, 1}, {1, 0, 1, 1}, {1, 1, 0, 1}, {1, 1, 1, 0}});
gg = GraphicsGrid[Partition[fun[m], 6], Frame -> All, 
  ImageSize -> 500]

Answer 2

We can use the graph colouring functionality of IGraph/M to compute the automorphisms of a multigraph, as described here. The simple way is to rely on edge colouring and colour each edge by its multiplicity.

But then we must use the VF2 algorithm from igraph, which can simply list all automorphisms, but it is unable to find the generators of the automorphism group (and is thus slow for graphs with many automorphisms).

We can instead use the much faster Bliss algorithm. Bliss currently only supports vertex colouring, not edge colouring. To encode the edge multiplicities into vertex colours, we subdivide each edge and insert a vertex in the middle with a colour corresponding to the edge multiplicity.

Here's how it goes. Let's start with this graph:

g = Graph[{1 <-> 2, 1 <-> 2, 3 <-> 2, 3 <-> 2, 2 <-> 4, 4 <-> 5, 4 <-> 6}]

In the general case it is convenient to make sure that vertex names are the same as vertex indices.

g = SetProperty[IndexGraph[g], VertexLabels -> "Name"]

Now rules = Normal@Counts[Sort /@ EdgeList[g]] will give a rule list the assigns each edge its multiplicity.

rules = Normal@Counts[Sort /@ EdgeList[g]]

(* {1 <-> 2 -> 2, 2 <-> 3 -> 2, 2 <-> 4 -> 1, 4 <-> 5 -> 1, 4 <-> 6 -> 1} *)

Create the subdivision and the colouring:

i = VertexCount[g];
{subdivision, {colors}} = Reap@Graph[
   VertexList[g], Replace[
    rules,
    HoldPattern[s_ <-> t_ -> m_] :> 
     With[{v = ++i}, Sow[v -> m]; 
      Unevaluated@Sequence[s <-> v, v <-> t]],
    {1}
    ]
   ];

Now compute the automorphism group of the subdivision, and discard the part which corresponds to the newly added vertices. These will be vertices with index larger than VertexCount[g].

Take[#, VertexCount[g]] & /@ 
 IGBlissAutomorphismGroup[{subdivision, 
   "VertexColors" -> Association[colors]}]

(* {{3, 2, 1, 4, 5, 6}, {1, 2, 3, 4, 6, 5}} *)

The result if the generators of the automorphism group:

PermutationGroup[%]
(* PermutationGroup[{{3, 2, 1, 4, 5, 6}, {1, 2, 3, 4, 6, 5}}] *)

GroupOrder[%]
(* 4 *)

GroupElements[%%]
(* {Cycles[{}], Cycles[{{5, 6}}], Cycles[{{1, 3}}], 
 Cycles[{{1, 3}, {5, 6}}]} *)

PermutationList[#, VertexCount[g]] & /@ %
(* {{1, 2, 3, 4, 5, 6}, {1, 2, 3, 4, 6, 5}, {3, 2, 1, 4, 5, 
  6}, {3, 2, 1, 4, 6, 5}} *)

Answer 3

Came across this question while looking for something else, but it looks like the graph functions in Mathematica 10 and higher can do this trivially now:

m = ({{0, 1, 1, 1}, {1, 0, 1, 1}, {1, 1, 0, 1}, {1, 1, 1, 0}});
g = AdjacencyGraph[m];
FindGraphIsomorphism[g, g, All];
% // Length (* 24 *)
%%[[5]] // Normal (* {1 -> 1, 2 -> 4, 3 -> 2, 4 -> 3} *)

Just be wary of closed cycles of length two, they don't work in versions < 10.3:

g = {UndirectedEdge[1, 2], UndirectedEdge[2, 3], UndirectedEdge[2, 3],
    UndirectedEdge[3, 4]};
FindGraphIsomorphism[%, %, All]
(* FindGraphIsomorphism::ngen:
   "The generalized \!\(\*FrameBox[\"\\\"FindGraphIsomorphism[Graph[<4>, <4>], Graph[<4>, <4>], All]\\\"\", BoxFrame->False, FrameMargins->{{False, False}, {False, False}}]\) is not implemented. " *)