Cycles of length N in a graph

Question

If I have an undirected graph represented with an adjacency matrix, how can I find all the subgraphs which are a cycle of length N?

I don't really know the math nor the programming language well, so I find myself resorting to making a bunch of for loops to try traversing the graph. This is very slow, and I might as well just write it in C at that point. So I'm hoping to learn how to work better with mathematica here.

So far, I think I've found a way to tell me the number of such subgraphs. For example, I might be able to get the number of cycles of length 3 in the graph given by the matrix m by doing something like...

Digitize[matrix_] := Map[Sign[#]&,matrix,{2}] 
m=Digitize[m]; (* ensure it is normalized *)
ident = Table[KroneckerDelta[i,j],{i,1,Length[m]},{j,1,Length[m]}];
m1 = m*(1-ident); (* remove self-loops, giving steps away of length 1 *)
m2 = (m1.m1)*(1-ident); (* matrix of steps of length 2, with no repeats *)
m3 = (m2.m1); (* matrix of steps of length 3 *)
(* reading diagonal of m3 will tell how many paths lead back to the start? *)

This already looks a bit messy, and I'm not sure how much I can generalize it to larger N. And even then, it doesn't help me get the actual paths.

Help?

Clarification: Ideally I'd like to eventually write a module that given a length N and an adjacency matrix for an undirected graph, outputs a list of all the unique (up to cyclic reordering) lists of vertices which form a cyclic path of length N.

Do you allow repeated vertices in the cycles? What about repeated edges? — Szabolcs, Mar 08 '12 at 13:54

kglr · Accepted Answer · 2012-07-09T08:46:23.593

21

With the following obvious replacements for the two graphs: PetersenGraph[5, 2] --> yourgraph, and CycleGraph[5] --->CycleGraph[n] for general n where

  yourgraph=AdjacencyGraph[yourAdjacencyMatrix]

You can use the first example from the docs on SubGraph section Applications:

  {g, h} = {PetersenGraph[5, 2], CycleGraph[5]};
  Grid[{{g, h}}]

pict 1

Select the subgraphs isomorphic to CycleGraph[5]:

  s = Subsets[Range[VertexCount[g]], {VertexCount[h]}];
  Select[Subgraph[g, #] & /@ s, IsomorphicGraphQ[#, h] &];

and view

  Grid[Partition[
  HighlightGraph[g, #] & /@ 
  Select[Subgraph[g, #] & /@ s, IsomorphicGraphQ[#, h] &], {5}]]

highlighted subgraphs

EDIT: A function to select cyclic subgraphs with k vertices

 ClearAll[cyclicSubgraphs];
 cyclicSubgraphs[grph_Graph, k_Integer] := 
 Select[Subgraph[grph, #] & /@ Subsets[Range[VertexCount[grph]], {k}], 
 IsomorphicGraphQ[#, CycleGraph[k]] &]

Example:

Row[HighlightGraph[SetProperty[GraphData[{"Antiprism", 6}], {VertexLabels -> "Name", 
 VertexSize -> Medium, ImagePadding -> 20, ImageSize -> 300}], #] & /@ 
 cyclicSubgraphs[GraphData[{"Antiprism", 6}], 8])]

enter image description here

edited Jul 09 '12 at 08:46

answered Mar 08 '12 at 01:18

kglr

394,356
18
477
896

4

I find it interesting that you answer is taken almost verbatim from the docs. :) – rcollyer Mar 08 '12 at 19:59
@rcollyer, yes it is and it is the very first example in its section as noted -- I wish i could have added that SubGraph was among my first few search keywords too;) – kglr Mar 09 '12 at 03:49
IMO, it would be appropriate to give another example than what can be found in the Documentation, since this stack is supposed to be an alternative source of such information. (It turns out that I'm interested in such a problem, too :P) – CHM Mar 09 '12 at 19:53
Wonderful! Except that I get "Subsets::toomany: "The number of subsets (316399053474504) indicated by Subsets[{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,<<734>>},{6}] is too large; it must be a machine integer." – Ralph Dratman Jul 11 '12 at 17:37
1

@Ralph, for "large" graphs, even if you don't hit the @MaxMachineInteger wall, this method will be painfully slow. – kglr Jul 11 '12 at 22:00
This answer is, unfortunately, flawed. Try g = GridGraph[{3, 2}]; cyclicSubgraphs[g, 6] to see why. g is not isomorphic with CycleGraph[6]. – Szabolcs Sep 17 '15 at 12:02
However, your answer would be a perfect fit here, as that post is asking only for chordless cycles. – Szabolcs Sep 19 '15 at 14:45

Daniel Lichtblau · Answer 2 · 2012-03-12T18:05:50.017

Here is some code for computing k-cycles. The efficiency is no better than O(c*k*n) where c = #cycles and n = #vertices. In general it is probably worse, since it tries to build cycles from shorter paths and there might be many of those that eventually fail to become full cycles.

extendCycle[cyc_List, edges_List] := 
 Map[If[# > First[cyc] && ! MemberQ[cyc, #], Append[cyc, #], 
    Null /. Null :> Sequence[]] &, edges[[Last[cyc]]]]

cycles[mat_, k_] := 
 Module[{n = Length[mat], m2, cyc, cyclist}, 
  m2 = MapIndexed[#1*#2[[2]] &, mat, {2}] /. 0 :> Sequence[];
  cyclist = Flatten[Drop[MapIndexed[{#2[[1]], #1} &, m2, {2}], -k+1], 1];
  Do[cyclist = 
    Flatten[Map[extendCycle[#, m2] &, cyclist], 1], {k - 2}];
  Map[If[MemberQ[m2[[Last[#]]], First[#]], Append[#, First[#]], 
     Null /. Null :> Sequence[]] &, cyclist]
  ]

Here is an example. For a reasonably sparse graph it seems to work well. In this construction, "mat2" is the adjacency matrix we will use.

len = 20;
mat = RandomChoice[{.6, .4} -> {0, 1}, {len, len}];
Do[mat[[j, j]] = 0, {j, len}];
mat2 = Floor[(mat + Transpose[mat])/2];

First I show what this looks like, though in a sparse format. The first entry, {18,19}, means that vertex 1 is connected (only) to vertices 18 and 19.

mat3 = MapIndexed[#1*#2[[2]] &, mat2, {2}] /. 0 :> Sequence[]

Out[114]= {{18, 19}, {6, 7}, {9, 14, 15, 20}, {13, 20}, {6, 10, 11, 
  12, 14, 15, 20}, {2, 5, 8, 20}, {2, 14, 19}, {6}, {3, 12, 17},
  {5, 14}, {5, 13, 14, 15}, {5, 9}, {4, 11}, {3, 5, 7, 10, 11, 18},
  {3, 5, 11, 18}, {}, {9, 18, 19}, {1, 14, 15, 17}, {1, 7, 17}, {3, 4, 5, 6}}

Here is the result for finding all 6-cycles.

In[116]:= Timing[cycles[mat2, 6]]

Out[116]= {0.02, {{2, 6, 5, 10, 14, 7, 2}, {2, 6, 5, 11, 14, 7, 
   2}, {2, 6, 20, 3, 14, 7, 2}, {2, 6, 20, 5, 14, 7, 2}, {2, 7, 14, 3,
    20, 6, 2}, {2, 7, 14, 5, 20, 6, 2}, {2, 7, 14, 10, 5, 6, 2}, {2, 
   7, 14, 11, 5, 6, 2}, {3, 9, 12, 5, 6, 20, 3}, {3, 9, 12, 5, 10, 14,
    3}, {3, 9, 12, 5, 11, 14, 3}, {3, 9, 12, 5, 11, 15, 3}, {3, 9, 17,
    19, 7, 14, 3}, {3, 14, 7, 19, 17, 9, 3}, {3, 14, 10, 5, 6, 20, 
   3}, {3, 14, 10, 5, 11, 15, 3}, {3, 14, 10, 5, 12, 9, 3}, {3, 14, 
   11, 5, 6, 20, 3}, {3, 14, 11, 5, 12, 9, 3}, {3, 14, 11, 13, 4, 20, 
   3}, {3, 14, 11, 15, 5, 20, 3}, {3, 14, 18, 15, 5, 20, 3}, {3, 15, 
   11, 5, 6, 20, 3}, {3, 15, 11, 5, 10, 14, 3}, {3, 15, 11, 5, 12, 9, 
   3}, {3, 15, 11, 13, 4, 20, 3}, {3, 15, 11, 14, 5, 20, 3}, {3, 15, 
   18, 14, 5, 20, 3}, {3, 20, 4, 13, 11, 14, 3}, {3, 20, 4, 13, 11, 
   15, 3}, {3, 20, 5, 14, 11, 15, 3}, {3, 20, 5, 14, 18, 15, 3}, {3, 
   20, 5, 15, 11, 14, 3}, {3, 20, 5, 15, 18, 14, 3}, {3, 20, 6, 5, 10,
    14, 3}, {3, 20, 6, 5, 11, 14, 3}, {3, 20, 6, 5, 11, 15, 3}, {3, 
   20, 6, 5, 12, 9, 3}, {4, 13, 11, 5, 6, 20, 4}, {4, 13, 11, 14, 5, 
   20, 4}, {4, 13, 11, 15, 5, 20, 4}, {4, 20, 5, 14, 11, 13, 4}, {4, 
   20, 5, 15, 11, 13, 4}, {4, 20, 6, 5, 11, 13, 4}, {5, 10, 14, 18, 
   15, 11, 5}, {5, 11, 15, 18, 14, 10, 5}, {5, 12, 9, 17, 18, 14, 
   5}, {5, 12, 9, 17, 18, 15, 5}, {5, 14, 18, 17, 9, 12, 5}, {5, 15, 
   18, 17, 9, 12, 5}, {10, 5, 11, 15, 18, 14, 10}}}

Here is a denser example. In this instance, the sparse form of the adjacency matrhx is as below.

{{5, 6, 7, 10, 12, 13, 17, 19}, {3, 6, 9, 13, 14, 16, 17, 20}, {2, 4, 
  5, 6, 7, 8, 11}, {3, 9, 12, 13, 14, 15, 17, 19}, {1, 3, 7, 11, 12, 
  13, 15, 20}, {1, 2, 3, 8, 14, 16, 17, 18, 19, 20}, {1, 3, 5, 8, 9, 
  12, 16, 18}, {3, 6, 7, 9, 12, 13, 14, 16, 17, 18, 19}, {2, 4, 7, 8, 
  17}, {1, 11, 13}, {3, 5, 10, 14, 18}, {1, 4, 5, 7, 8}, {1, 2, 4, 5, 
  8, 10, 14, 15, 18, 20}, {2, 4, 6, 8, 11, 13, 16, 19}, {4, 5, 13, 17,
   18}, {2, 6, 7, 8, 14, 17, 18, 19}, {1, 2, 4, 6, 8, 9, 15, 16, 
  19}, {6, 7, 8, 11, 13, 15, 16, 20}, {1, 4, 6, 8, 14, 16, 17, 
  20}, {2, 5, 6, 13, 18, 19}}

In[124]:= Timing[Length[cycles[mat2, 6]]]

Out[124]= {0.55, 17105}

That worked very well for me. Thank you! – Ralph Dratman Jul 11 '12 at 17:58 — Ralph Dratman, Jul 11 '12 at 17:58

Szabolcs · Answer 3 · 2015-09-19T14:49:01.963

Update: I realized that version 10 now has FindCycle, which takes care of this easily, e.g. FindCycle[PetersenGraph[5,2], 5, All].

The solution of @kglr is unfortunately flawed: to look for 6-cycles in g = GridGraph[{3, 2}], it would look at whether CycleGraph[6] is isomorphic with g, which it is not. We need to test for subgraph isomorphism without requiring missing edges to match as well, not induced subgraph isomorphism.

Searching for cycles can be phrased as a subgraph isomorphism problem.

The igraph library has dedicated subgraph isomorphism functions, accessible through IGraph/M. This is of course better (faster) than brute forcing it, but it's not as good as a specialized cycle finder.

Here's counting cycles with IGraph/M 0.1.2, using the VF2 algorithm.

<<IGraphM`

g = PetersenGraph[5, 2];

countCycles[g_, k_] := IGVF2SubisomorphismCount[CycleGraph[k], g]/(2 k)

countCycles[g, 5]

(* 12 *)

Dividing by 2k was necessary because this is the number of automorphisms of a $k$-cycle, i.e. there are this many different ways to map a size $k$ cycle graph to itself.

What if we want to find the cycles? We can use IGVF2FindSubisomorphisms, but we will somehow need to get rid of the $2k$ duplicates in the result. For example:

cycles = Values /@ IGVF2FindSubisomorphisms[CycleGraph[5], g]

In this list each cycle appears $2\times 5 = 10$ times, with different representations. As a first step we remove those which are equivalent to a cyclic permutation:

canonicalize[cycle_] := 
 RotateLeft[cycle, First@Ordering[cycle, -1] - 1]

cycles = DeleteDuplicates[canonicalize /@ cycles]

After this we still have a reverse copy of each cycle, which I removed with a brute-force method:

cycles = DeleteDuplicates[cycles, #1 === canonicalize@Reverse[#2] &];

Now we have a unique copy of each of the 12 cycles in the list. Let's highlight them:

HighlightGraph[g, PathGraph[Append[#, First[#]]], GraphHighlightStyle -> "Thick"] & /@ cycles

Mathematica graphics

From IGraph/M 0.1.3 it will also be possible to use the (potentially faster) LAD algorithm through IGLADFindSubisomorphisms, which can also test for induced subgraph isomorphism.

Cycles of length N in a graph

3 Answers3

Linked