Identity Graph

Author

Eric W. Weisstein
June 15, 2021

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/IdentityGraph.nb.

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

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

Counts

All

A003400

Total[Boole[Get[#]]]&/@FileNames["*.m",FileNameJoin[{$GraphDataDirectory,"Nodes","Identity"}]]

Table[Count[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","AutomorphismCount","AutomorphismCount"<>"_"<>If[n<10,"0",""]<>ToString[n]<>".m"}]],1],{n,10}]

Table[Total[Boole[IdentityGraphQ/@Graphs[n]]],{n,10}]//Timing

Table[Length@GraphData["Identity",n],{n,8}]

Connected

A124059

Table[Total[Boole[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","Identity","Identity_"<>If[n<10,"0",""]<>ToString[n]<>".m"}]][[ConnectedGraphIndices[n]]]]],{n,10}]

Table[Count[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","AutomorphismCount","AutomorphismCount"<>"_"<>If[n<10,"0",""]<>ToString[n]<>".m"}]][[ConnectedGraphIndices[n]]],1],{n,10}]

Table[Total[Boole[IdentityGraphQ/@ConnectedGraphs[n]]],{n,10}]//Timing

Table[Length@GraphData[{"Connected","Identity"},n],{n,8}]

Disconnected

A275867

Table[Total[Boole[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","Identity","Identity_"<>If[n<10,"0",""]<>ToString[n]<>".m"}]][[DisconnectedGraphIndices[n]]]]],{n,10}]

Table[Count[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","AutomorphismCount","AutomorphismCount"<>"_"<>If[n<10,"0",""]<>ToString[n]<>".m"}]][[DisconnectedGraphIndices[n]]],1],{n,10}]//Timing

Table[Length@GraphData[{"Disconnected","Identity"},n],{n,8}]

{1,0,0,0,0,8,152,3696}-{1,0,0,0,0,8,144,3552}

Take[{1,0,0,0,0,8,152,3696,135004,7971848,805364776,144123121972},11]-{1,0,0,0,0,8,144,3552,131452,7840396,797524380}

Edge counts

Discussed with Stan Wagon June 14–15, 2021

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Nodes/Identity"]

Length/@(identity=Get/@FileNames["*.m"])

Count[#,True]&/@identity

All

It seems likely that the not-necessarily connected identity graphs with smallest possible edge counts are trees + K_1 for n > 7

pos=Flatten[Position[#,True]]&/@identity;

TextGrid[Table[{n,Sort@Tally[EdgeCount/@Graphs[n][[pos[[n]]]]]},{n,10}],Dividers->All]

TextGrid[data=Table[{n,g=Graphs[n][[pos[[n]]]];
Pick[g,e=EdgeCount/@g,Min[e]]},{n,10}],Dividers->All]

TextGrid[{#,RecognizeGraph/@#2}&@@@data,Dividers->All]

TextGrid[{#,Map[RecognizeGraph,ConnectedGraphComponents/@#2,{2}]}&@@@data,Dividers->All]

Connected

It seems likely that the *connected* identity graphs with smallest edge counts are trees for n > 6 and (and that the smallest not-necessarily connected ones are trees + K_1 for n > 7).

I have all trees up to 12 nodes in recent GraphData, so I can extract them directly in the connected case:

Length/@(poscon=Table[Intersection[ConnectedGraphIndices[n],pos[[n]]],{n,10}])

TextGrid[Table[{n,Sort@Tally[EdgeCount/@Graphs[n][[poscon[[n]]]]]},{n,10}],Dividers->All]

TextGrid[data=Table[{n,g=Graphs[n][[poscon[[n]]]];Pick[g,e=EdgeCount/@g,Min[e]]},{n,10}],Dividers->All]

TextGrid[{#,RecognizeGraph/@#2}&@@@data,Dividers->All]

Identity trees:

TextGrid[Table[{n,gn=GraphData[{"Tree","Identity"},n];Length[smallest=Pick[gn,e=GraphData[#,"EdgeCount"]&/@gn,Min[e]]],smallest},{n,12}],Dividers->All]

Length/@Table[GraphData["Tree",n],{n,13}]

A000220

seq={1,0,0,0,0,0,1,1,3,6,15,29,67,139,310,667,1480,3244,7241,16104,36192,81435,184452,418870,955860,2187664,5025990,11580130,26765230,62027433,144133676,335731381,783859852,1834104934,4300433063,10102854473,23778351222};

s[n_,k_]:=s[n,k]=a[n+1-k]+If[n<2k,0,-s[n-k,k]];
a[1]=1;
a[n_]:=a[n]=Sum[a[i]s[n-1,i]i,{i,n-1}]/(n-1);
seq=Table[a[i]-Sum[a[j]a[i-j],{j,i/2}]+If[OddQ[i],0,(1/2)a[i/2](a[i/2]-1)],{i,100}]

FindGeneratingFunction[seq,x]//Head//Timing

FindSequenceFunction[seq,n]//Head//Timing

Figures

Smallest disconnected

GraphicsGrid[Partition[Show[GraphData[#]/.g_System`Graph:>SetProperty[g,{VertexSize->{"Scaled",.07},System`VertexStyle->Red,System`EdgeStyle->Black}],PlotLabel->Style[GraphData[#,"Name"],FontFamily->"Times"]]&/@GraphData[{"Disconnected","Identity"},7],UpTo[4]],Dividers->All,ImageSize->400]

Smallest (connected)

Length[GraphData["Identity",#]]&/@Range[9]

GraphData["Identity",6]

GraphicsGrid[Partition[Show[GraphData[#]/.g_System`Graph:>SetProperty[g,{VertexSize->{"Scaled",.07},System`VertexStyle->Red,System`EdgeStyle->Black}],PlotLabel->Style[GraphData[#,"Name"],FontFamily->"Times"]]&/@GraphData["Identity",6],UpTo[4]],Dividers->All,ImageSize->400]

GraphicsGrid[Partition[GraphPlot[GetGraph[#],Method->None]&/@id[[7]],15,15,{1,1},{}]]

Table

SortBy[GraphData["Identity"],GraphData[#,"V"]&]

l={"SingletonGraph","SelfDualGraph2","FruchtGraph",{"Incidence",{{10,3},4}},{"Snark",{20,2}},{"Snark",{20,3}},"KittellGraph","WaltherGraph",{"Paulus",{25,2}},{"Paulus",{25,4}},{"Paulus",{26,10}},{"CubicNonhamiltonian",{50,1}},{"CubicNonhamiltonian",{50,2}},{"CubicNonhamiltonian",{52,3}},{"Cage",{3,9},7},{"Cage",{3,9},9},{"Cage",{3,9},11},{"Cage",{3,9},13},"GardnerGraph"};

TableForm[GraphData[#,{"V","Name"}]&/@l,TableDepth->2]

GraphicsGrid[Partition[Show[GraphData[#],PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->95,TextAlignment->Center],BaseStyle->{FontSlant->Italic}]&/@l/.AbsolutePointSize[_]:>AbsolutePointSize[3],5,5,{1,1},{}],ImageSize->500]

Integral Identity Graphs

GraphData[#,{"V","#"}]&/@GraphData[{"Integral","Identity"}]

TextGrid[{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[GraphData[#,{"V","#"}]&/@GraphData[{"Integral","Identity"}]],First],Dividers->All,Alignment->{{Decimal,Left}}]

GraphData

GraphClassString

GraphClassString[GraphData["Identity"]]

GraphDataString

g=Graph[{{{1,2}},{{1,3}},{{1,4}},{{2,5}},{{2,6}},{{3,7}},{{3,10}},{{4,5}},{{4,7}},{{5,9}},{{6,8}},{{6,11}},{{7,10}},{{8,9}},{{8,11}},{{9,12}},{{10,12}},{{11,12}}},{{{0.5155000000000001,-1.2891000000000001}},{{0.6717000000000001,-0.6046}},{{0.9531000000000001,-1.8381}},{{1.0522,-1.1965000000000001}},{{1.2333,-0.9532}},{{1.3041,-0.2999}},{{1.3041,-1.5285}},{{1.486,-0.7312000000000001}},{{1.5186000000000002,-0.9177000000000001}},{{1.655,-1.8381}},{{1.9364000000000001,-0.6046}},{{2.0926,-1.2891000000000001}}}];

GraphDataString[g,{"IdentityGraph12","identity graph on 12 nodes","IdentityGraph"}]