Chromatically Unique Graph

Author

Eric W. Weisstein
September 5, 2024

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

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

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

Counts

NonUnique[n_]:=#[[All,2]]&/@Select[Split[Sort[{GetGraphData[#,"ChromaticPolynomial"][N[Pi]],#}&/@RecognizeGraph/@Graphs[n]],First[#1]===First[#2]&],Length[#]>1&]

Do[Print[{n,non[n]=NonUnique[n]}//Timing],{n,8}]

Counts

A137567: Chromatically nonunique

c1=Table[Length[Flatten[non[n],1]],{n,8}]

A137568: Chromatically unique

c2=Table[Length[Graphs[n]]-Length[Flatten[non[n],1]],{n,8}]

c1+c2

Smallest

TableForm[GraphData[#,{"#","ChromaticPolynomial","CochromaticGraphNames"}]&/@Take[SortBy[GraphData["ChromaticallyNonunique"],GraphData[#,"V"]&],20]/.f_Function:>f[x],TableDepth->2]

noncu=Flatten[non/@Range[5],1]

p=GraphData[#,"ChromaticPolynomial"][x]&/@First/@noncu

GraphicsGrid[Partition[Show[#[[2]],PlotLabel->#[[1]]]&/@Transpose[{p,GraphicsGrid[{#}]&/@Map[Show[GraphPlot[Graph[#],Method->None],PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->80,TextAlignment->Center],BaseStyle->{FontSlant->"Italic",FontSize->9}]&,noncu,{2}]}],3,3,{1,1},{}],Dividers->All,Alignment->Top,ItemAspectRatio->.5,ImageSize->700]

Sort[DeleteCases[Flatten[non/@Range[8],2],{__Integer}|{"CompleteTree"|"CompleteTripartite"|"DutchWindmill"|"Fan"|"Lollipop"|"Polyiamond"|"Tadpole"|"Tree"|"Windmill",_}]]

Counts

From Pre-Computation

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

FileNames["*.m"]

FileByteCount/@%/10^6.

Co-chromatic

A137567

(counts=Table[Total[DeleteCases[Tally[Sort[ReadList["ChromaticPolynomial_"<>If[n<10,"0",""]<>ToString[n]<>".m","String"]]],{_,1}][[All,2]]],{n,10}])//Timing

{MemoryInUse[],MaxMemoryUsed[]}/10^9.GB

A137568

Chromatically unique

Table[NumberOfGraphs[n],{n,Length[counts]}]-counts

Compute 1-10 nodes

Compute

$GraphData10Nodes=GraphData[;;10];

(valid[#]=True)&/@$GraphData10Nodes;
valid[_]=False;

$GraphDataIndexRules=Association[(Cases[GraphData[#,"StandardNames"],{_Integer,_Integer}][[1]]->#)&/@$GraphData10Nodes];

ComputeCochromaticOld[n_]:=Module[
(* Import[...,"Lines"] takes > 50 GB on a 5 GB file, so use ReadList[..., String] *)
{groups={n,#}&/@#[[All,2]]&/@SplitBy[Sort[MapIndexed[{#,#2[[1]]}&,Hash/@ReadList[FileNameJoin[{$GraphDataDirectory,"Nodes","ChromaticPolynomial","ChromaticPolynomial_"<>If[n<10,"0",""]<>ToString[n]<>".m"}],String]]],First],
c,
indexedgroups,
definedindexedgroups
},
indexedgroups=(groups/.$GraphDataIndexRules);
definedindexedgroups=Pick[indexedgroups,If[Length[#]==1,valid[#],valid/@Or@@#]&/@indexedgroups];
Flatten[((First[#]->SortBy[Rest[#],First[Flatten[{#}]]&])&/@Pick[c=NestList[RotateRight,#,Length[#]-1],valid/@c[[All,1]]])&/@definedindexedgroups]
]

ComputeCochromatic[n_]:=Module[{groups={n,#}&/@#[[All,2]]&/@Select[SplitBy[Sort[MapIndexed[{#,#2[[1]]}&,Hash/@Import[FileNameJoin[{$GraphDataDirectory,"Nodes","ChromaticPolynomial","ChromaticPolynomial_"<>If[n<10,"0",""]<>ToString[n]<>".m"}],"Lines"]]],First],Length[#]>1&],
c,
indexedgroups,
definedindexedgroups
},
indexedgroups=(groups/.$GraphDataIndexRules);
definedindexedgroups=Pick[indexedgroups,valid/@Or@@#&/@indexedgroups];
Flatten[((First[#]->SortBy[Rest[#],First[Flatten[{#}]]&])&/@Pick[c=NestList[RotateRight,#,Length[#]-1],valid/@c[[All,1]]])&/@definedindexedgroups]
]

ComputeCochromatic[4]

(cochrom=Join@@Monitor[Table[ComputeCochromatic[n],{n,10}],n])//Length//Timing

cochrom[[All,1]]

CochromaticGraphNames

l={#1,{0,#3}}&@@@DeleteCases[{#1,GraphData[#1,"CochromaticGraphNames"],#2}&@@@cochrom,{_,x_,x_}]

PropertyReplace[l,"CochromaticGraphNames","14.2"]

RenameGraphFiles[]

ChromaticallyUnique === True

l2={#,{0,True}}&/@Select[Complement[GraphData[;;10],cochrom[[All,1]]],GraphData[#,"ChromaticallyUnique"]=!=True&]

MissingFillin[l2,"ChromaticallyUnique"]

RenameGraphFiles[]

ChromaticallyUnique === False

l3={#,{0,False}}&/@Select[cochrom[[All,1]],GraphData[#,"ChromaticallyUnique"]=!=False&]

MissingFillin[l3,"ChromaticallyUnique"]

RenameGraphFiles[]

Compute >10 nodes

Compute

groups=SplitBy[Sort[{Expand[GraphData[#,"ChromaticPolynomial"][x]],#}&/@Intersection[GraphData[11;;],GraphData["ChromaticPolynomial","Defined"]]],First];

coc=Pick[groups,Length/@groups,Except[1,_Integer]][[All,All,2]]

CochromaticGraphNames

new=DeleteCases[{First[#],GraphData[#[[1]],"CochromaticGraphNames"],SortBy[Rest[#],First[Flatten[{#}]]&]}&/@Flatten[NestList[RotateRight,#,Length[#]-1]&/@coc,1],{_,x_,x_}]

l={#1,{0,#3}}&@@@new

PropertyReplace[l,"CochromaticGraphNames","14.2"]

RenameGraphFiles[]

ChromaticallyUnique False

l2={#,{0,False}}&/@Select[Flatten[coc,1],GraphData[#,"ChromaticallyUnique"]=!=False&]

MissingFillin[l2,"ChromaticallyUnique"]

RenameGraphFiles[]