# How to compute the automorphisms of graphs with multiple edges?

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}
});
CombinatoricaAutomorphisms@GraphUtilitiesToCombinatoricaGraph[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?

• I show one way with IGraph/M here. I'll post another way shortly/ – Szabolcs Oct 22 '15 at 11:15

I hope the following is helpful:

Firstly, consider this example:

gr = SystemGraph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 3 <-> 5}];
com = CombinatoricaFromAdjacencyMatrix[Normal@sysm];
aut = CombinatoricaAutomorphisms[com];
ex = SystemGraph[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 = SystemAdjacencyGraph[mat];
sgel = EdgeList[sg];
au = CombinatoricaAutomorphisms[cg];
SystemGraph[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] • Thanks so much! Your answer is very elegant and helpful but it is not the right one. The question is about graphs with multiple edges. – Eden Harder May 10 '14 at 7:21
• As I find, the code in your answer does not work for the matrix {{0, 1, 0, 0}, {1, 0, 1, 0}, {0, 1, 0, 1}, {0, 0, 1, 0}}. It is strange. – Eden Harder May 10 '14 at 7:35
• @EdenHarder sorry will look at when I get a chance – ubpdqn May 10 '14 at 9:26
• @EdenHarder not sure why fails for this class of graphs – ubpdqn May 10 '14 at 11:09

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.

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}} *)


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}});
FindGraphIsomorphism[g, g, All];
% // Length (* 24 *)
%%[] // 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. " *)

• As I understand, the OP is asking about handling graphs with multiple edges between the same two nodes. Version 10.0–10.4 cannot compute isomorphisms for such graphs. About FindGraphIsomorpshism, it is good to be aware that it is buggy in 10.4 and returns wrong results: mathematica.stackexchange.com/q/116349/12 In 10.3 it works fine. – Szabolcs Jun 21 '16 at 9:03
• I agree that FindGraphIsomorphisms doesn't compute isomorphisms for multiple edges between the same two nodes. But if the OP was asking for automorphisms of g = AdjacencyGraph[m];, I think what I posted addresses that, no? (Well, if FindGraphIsomorphisms is trustworthy on this particular example at least...) – jjstankowicz Jun 24 '16 at 23:40