Characteristic Polynomial

Author

Eric W. Weisstein
October 11, 2017

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Algebra/CharacteristicPolynomial.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/CharacteristicPolynomial.html.

©2017 Wolfram Research, Inc. except for portions noted otherwise

Matrices

2×2

Collect[Simplify[c2=CharacteristicPolynomial[a2=Array[a,{2,2}],x]],x]/.a[x__]:>Subscript[a,x]//TraditionalForm

Simplify[c2-(x^2-x Tr[a2]+Det[a2])]

3×3

MatrixForm[a3=Array[a,{3,3}]]

Expand[c3=CharacteristicPolynomial[a3=Array[a,{3,3}],x]]

Collect[c3,x]/.a[x__]:>Subscript[a,x]//TraditionalForm

Expand[c3-(-x^3+x^2 Tr[a3]+x Sum[(a[i,j]a[j,i]-a[i,i]a[j,j])/2,{i,3},{j,3}]+Det[a3])]

Det[a3-IdentityMatrix[3]x]-c3

gb=GroebnerBasis[{Coefficient[c3,x,#],TrA3-Tr[a3.a3.a3],TrA2-Tr[a3.a3],TrA-Tr[a3]},{TrA,TrA2},Flatten[Array[a,{3,3}]]]&/@Range[0,3]

coefs=((CoefficientList[c3,x])/(Flatten[gb]/.{TrA3->Tr[a3.a3.a3],TrA2->Tr[a3.a3],TrA->Tr[a3]}))//Factor

Flatten[gb].(x^Range[0,3] coefs)

c32=Expand[%/.{TrA3->Tr[a3.a3.a3],TrA2->Tr[a3.a3],TrA->Tr[a3]}]

Expand[c32-c3]

4×4

MatrixForm[a4=Array[a,{4,4}]]

Collect[Simplify[c4=CharacteristicPolynomial[a4=Array[a,{4,4}],x]],x]/.a[x__]:>Subscript[a,x]//TraditionalForm

gb=GroebnerBasis[{Coefficient[c4,x,#],TrA4-Tr[a4.a4.a4.a4],TrA3-Tr[a4.a4.a4],TrA2-Tr[a4.a4],TrA-Tr[a4]},{TrA,TrA2,TraA3},Flatten[Array[a,{4,4}]]]&/@Range[0,4]

Flatten[%].x^Range[0,4]//TraditionalForm

coefs=((CoefficientList[c4,x])/(Flatten[gb]/.{TrA4->Tr[a4.a4.a4.a4],TrA3->Tr[a4.a4.a4],TrA2->Tr[a4.a4],TrA->Tr[a4]}))//Factor

Flatten[gb].(x^Range[0,4] coefs)

c42=Expand[%/.{TrA4->Tr[a4.a4.a4.a4],TrA3->Tr[a4.a4.a4],TrA2->Tr[a4.a4],TrA->Tr[a4]}]

Expand[c42-c4]

Computation

Le Verrier

SpectralMoments[a_]:=Module[{n=Length[a]},Tr/@Rest[NestList[Dot[a,#]&,Developer`ToPackedArray[IdentityMatrix[n]],n]]]

fastCharacteristicPolynomial[g_,x_]:=Module[{a=SpectralMoments[AdjacencyMatrix[g]],n=V[g]},
-Polynomial[Prepend[LinearSolve[SparseArray[{{i_,i_}->i,{i_,j_}/;i>j:>a[[i-j]]},n{1,1}],a],-1],x]
]

Algorithm Case

a=SpectralMoments[AdjacencyMatrix[Graph["CubicalGraph"]]]

Normal@SparseArray[{{i_,i_}->i,{i_,j_}/;i>j:>a[[i-j]]},{8,8}]//TraditionalForm

LinearSolve[SparseArray[{{i_,i_}->i,{i_,j_}/;i>j:>a[[i-j]]},{8,8}],a]

GraphData["CubicalGraph","CharacteristicPolynomial"][x]

Polynomial[Prepend[{0,12,0,-30,0,28,0,-9},-1],x]//Expand//Factor

Check

ShowLabeledGraph[g=AddEdge[AddVertex[Cycle[4],{-2,0}],{2,5}]]

fastCharacteristicPolynomial[g,x]//Expand

CP[Graph["CubicalGraph"],x]//Factor

CP[Graph["DodecahedralGraph"],x]//Factor

c1=FastCharacteristicPolynomial[Graph["DodecahedralGraph"],x];//Timing

c2=CharacteristicPolynomial[AdjacencyMatrix[Graph["DodecahedralGraph"]],x];//Timing

c1=FastCharacteristicPolynomial[Graph[{"Square",10}],x];//Timing

c2=CharacteristicPolynomial[AdjacencyMatrix[Graph[{"Square",10}]],x];//Timing

Simplify[c1-c2]

Select[GraphData[;;10],Simplify[GraphData[#,"CharacteristicPolynomial"][x]-FastCharacteristicPolynomial[Graph[#],x]]≠0&]

Balasubramanian

fastCharacteristicPolynomial2[g_Graph,x_]:=Module[{A=AdjacencyMatrix[g],c,B,n=V[g]},
c[k_]:=c[k]=Tr[B[k-1]]/k;
B[k_]:=Developer`ToPackedArray[A.(B[k-1]-c[k]IdentityMatrix[n])];
B[0]=A;
-Polynomial[Prepend[c/@Range[n],-1],x]
]

fastCharacteristicPolynomial2[Graph["CubicalGraph"],x]//Factor

c1=fastCharacteristicPolynomial[Graph[{"Square",10}],x];//Timing

GraphData["CubicalGraph","CharacteristicPolynomial"][x]//Expand

Clear[c,B]

A=AdjacencyMatrix[Graph["CubicalGraph"]];

c[k_]:=Tr[B[k-1]]/k
B[k_]:=A.(B[k-1]-c[k]IdentityMatrix[Length[A]])
B[0]:=A

c/@Range[8]

-Polynomial[Prepend[%34,-1],x]//Factor

Graphs

Initialization

Nonisomorphic Graphs with the same characteristic polynomial

Counts

Timing[l1=Table[NumberOfGraphs[n],{n,9}]]

Timing[l2=Length/@Table[Union[CharacteristicPolynomial[ToAdjacencyMatrix[#],x]&/@Graphs[n]],{n,8}]]

Timing[l2=Length/@Table[Union[CharacteristicPolynomial[ToAdjacencyMatrix[#],x]&/@Graphs[n]],{n,9}]]

l1-{1,2,4,11,33,151,988,11453,247357}

Examples

u=Union[cp=CharacteristicPolynomial[ToAdjacencyMatrix[#],x]&/@Graphs[5]];
pos=Flatten[Position[u,#,{1},1]&/@cp]

First/@Select[Split[Sort[pos]],Length[#]>1&]

Flatten[Position[pos,9]]

CharacteristicPolynomial[ToAdjacencyMatrix[#],x]&/@(Graphs[5][[#]]&/@{5,14})

<<Typesetting`

ShowGraphArray[Graphs[5][[#]]&/@{5,14},VertexStyle->Disk[.05],VertexColor->Red,AspectRatio->Automatic,GraphicsSpacing->.5,PlotRange->All,PlotLabel->TraditionalForm[(Subscript[π, G])[x]==4 (x^3)-(x^5)]]

Large polynomial terms

l=Monitor[Reverse[Sort[{Max[Exponent[#,x]&/@First/@FactorList[GraphData[#,"CharacteristicPolynomial"][x]]],g=#}&/@GraphData[All]]],g];

Tally[First/@l]

Last/@Take[l,10]

Special Classes

Tetrahedral Graph

Factor@CharacteristicPolynomial[Edges[TetrahedralGraph],z]//TraditionalForm

Cubical Graph

Factor@CharacteristicPolynomial[Edges[CubicalGraph],z]//TraditionalForm

Octahedral Graph

Factor@CharacteristicPolynomial[Edges[OctahedralGraph],z]//TraditionalForm

Cyclic Graphs

Table[{n,Factor@CharacteristicPolynomial[Edges[Cycle[n]],z]},{n,2,5}]//ColumnForm//TraditionalForm

Complete Graphs

Table[{n,Factor@CharacteristicPolynomial[Edges[CompleteGraph[n]],z]},{n,2,5}]//ColumnForm//TraditionalForm

Wheel Graphs

Table[{n,Factor@CharacteristicPolynomial[Edges[Wheel[n]],z]},{n,4,6}]//ColumnForm//TraditionalForm