Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

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?

share|improve this question
1  
I show one way with IGraph/M here. I'll post another way shortly/ – Szabolcs Oct 22 '15 at 11:15
up vote 5 down vote accepted

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

enter image description here

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]

enter image description here

share|improve this answer
1  
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.

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"]

Mathematica graphics

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}} *)
share|improve this answer

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. " *)
share|improve this answer
    
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 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 2 days ago

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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