How to implement the formula for the number of undirected $k$-cycles in a graph $G$?

Question

This Wolfram MathWorld page said that,

Giscard et al. "A General Purpose Algorithm for Counting Simple Cycles and Simple Paths of Any Length." 16 Dec 2016. gave the formula for the number of undirected $k$-cycles in a graph $G$ as

$$ c_k=\frac{(-1)^k}{2 k} \sum_{H<\mathrm{conn} G}\left(\begin{array}{l} |N(H)| \\ k-|H| \end{array}\right)(-1)^{|H|} \operatorname{Tr}\left(\mathrm{A}_H^k\right) $$

where the sum is over connected induced subgraphs $H$ of $G$, $N(H)$ denotes the number of the neighbors of $H$ in $G$ (namely vertices $v$ of $G$ which are not in $H$ and such that there exists at least one edge from $v$ to a vertex of $H$), $\operatorname{Tr} (\mathbf{A})$ denotes the matrix trace, and $\mathbf{A}_H^k$ is the $k$th matrix power of the adjacency matrix of the graph $H$.

---

My question is:

How to implement the formula using Mathematica?

Any help would be appreciated.

---

UPDATE

I implement one snippet of Mathematica code by myself. But the code fails on some test cases. Can you correct the code? Any help would be appreciated.

Answer 1

I implement one by myself.

Clear["Global`*"];
Needs["IGraphM`"]


count1Cycles[g_Graph] := 
 List @@@ EdgeList[g] // Count[#, _?(#[[1]] == #[[2]] &)] &

count2Cycles[g_Graph] := 
 Map[#[[2]] &, EdgeList[g] // Tally] // Select[# >= 2 &] // 
   Map[Binomial[#, 2] &, #] & // Total

count3Cycles[g_Graph] := Tr[MatrixPower[AdjacencyMatrix[g], 3]]/6;

count4Cycles[g_Graph] := 
  Module[{A = 
     AdjacencyMatrix[g]}, (Tr[MatrixPower[A, 4]] + 
      Tr[MatrixPower[A, 2]] - 2*Total[VertexDegree[g]^2])/8];


count5Cycles[g_Graph] := 
 Module[{A = Normal@AdjacencyMatrix[g], A3, n = VertexCount[g]}, 
  A3 = MatrixPower[A, 
    3]; (Tr[MatrixPower[A, 5]] - 5*Tr[MatrixPower[A, 3]] - 
     5*Sum[(Sum[A[[i, j]], {j, 1, n}] - 2)*A3[[i, i]], {i, 1, n}])/10]

KhomenkoandGolovkoUndirectedKCycles[g_Graph, k_Integer] := 
 Module[{n, vertices, subsets, As, traceSum, i, binomialCoefficient, 
   sumOverI},
  
  If[k == 1, Return[count1Cycles[g]]];
  If[k == 2, Return[count2Cycles[g]]];
  n = VertexCount[g];
  vertices = VertexList[g];
  sumOverI = 0;
  For[i = 2, i <= k && i <= n, i++, 
   subsets = Subsets[vertices, {n - i}];
   traceSum = Sum[binomialCoefficient = Binomial[n - i, n - k];
     As = Normal@AdjacencyMatrix[g];
     As = DeleteRowsColumns[As, SubsetToIndices[vertices, subset]];
     binomialCoefficient*Tr[MatrixPower[As, k]], {subset, subsets}];
   sumOverI += ((-1)^(k - i))*traceSum;];
  sumOverI/(2*k)]

(*Helper function to delete rows and columns from a matrix*)

DeleteRowsColumns[matrix_, indices_] := 
  Module[{tempMatrix}, tempMatrix = matrix;
   (*Delete rows*)tempMatrix = Delete[tempMatrix, List /@ indices];
   (*Delete columns,transpose needed for column deletion*)
   tempMatrix = 
    Transpose[Delete[Transpose[tempMatrix], List /@ indices]];
   tempMatrix];

(*Helper function to convert a subset to indices based on the full \
set*)
SubsetToIndices[fullSet_, subset_] := 
 Flatten[Position[fullSet, #] & /@ subset]

GiscardetalUndirectedKCycles[graph_Graph, k_Integer] :=
 Module[{H, tr, numNeighbors, adjacencyMatrix, subgraphs, vertices, n},
  vertices = VertexList[graph];
  n = VertexCount[graph];
  adjacencyMatrix = AdjacencyMatrix[graph];
  subgraphs = Select[Subsets[vertices, {1, n}], ConnectedGraphQ[Subgraph[graph, #]] &];
  tr[A_, power_] := Tr[MatrixPower[A, power]];
  numNeighbors[H_] := Length@Complement[vertices, VertexList[H], Flatten[VertexList /@ NeighborhoodGraph[graph, #] & /@ VertexList[H]]];

  Switch[k,
   1, (* If k == 1*)
   count1Cycles[graph],
   
   2, (* If k == 2*)
   count2Cycles[graph],

   3, (* If k == 3*)
   count3Cycles[graph],

   4, (* If k == 4*)
   count4Cycles[graph],

   5, (* If k == 5*)
   count5Cycles[graph],
   
   _, (* Otherwise, use the formula *)
   Total[
    ((-1)^k / (2*k)) *
     Table[
      With[{H = Subgraph[graph, sg]},
       Binomial[numNeighbors[H], k - VertexCount[H]] *
        (-1)^VertexCount[H] *
        tr[AdjacencyMatrix[H], k]
       ], {sg, subgraphs}]
    ]
   ]
  ]

I have verified the Mathematica code , it has passed these following test cases:

n = 5;
g = CompleteGraph[n]
GiscardetalUndirectedKCycles[g, #] & /@ Range[1, n, 1]
KhomenkoandGolovkoUndirectedKCycles[g, #] & /@ Range[1, n, 1]


(* https://oeis.org/A284947 *)


Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]

n = 3;
g = CompleteGraph[{n,n}]
GiscardetalUndirectedKCycles[g, #] & /@ Range[1, 2*n, 1]
KhomenkoandGolovkoUndirectedKCycles[g, #] & /@ Range[1, 2*n, 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]

n = 3;
g = CompleteGraph[{n, n, n}]
GiscardetalUndirectedKCycles[g, #] & /@ Range[1, 3*n, 1]
KhomenkoandGolovkoUndirectedKCycles[g, #] & /@ Range[1, 3*n, 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]

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

GiscardetalUndirectedKCycles[g, #] & /@ Range[1, 10 , 1]
KhomenkoandGolovkoUndirectedKCycles[g, #] & /@ Range[1, 10 , 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]

---

$$ \color{red}{\textbf{But the code fails on these test cases.}} \\ \color{red}{\textbf{Can you correct the code? Any help would be appreciated.}} $$

n = 2;
g = GridGraph[{n, n, n}]
GiscardetalUndirectedKCycles[g, #] & /@ Range[1, n^3, 1]
KhomenkoandGolovkoUndirectedKCycles[g, #] & /@ Range[1, n^3, 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]

n = 3;
g = GridGraph[{n, n}]
GiscardetalUndirectedKCycles[g, #] & /@ Range[1, n^2, 1]
KhomenkoandGolovkoUndirectedKCycles[g, #] & /@ Range[1, n^2, 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]

n = 7;
g = WheelGraph[n]
GiscardetalUndirectedKCycles[g, #] & /@ Range[1, n, 1]
KhomenkoandGolovkoUndirectedKCycles[g, #] & /@ Range[1, n, 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #] & /@ FindCycle[g, Infinity, All]