Graph Coloring

Graph Functions

Generating Erdős-Rényi random graphs

An Erdős-Rényi random graph has n vertices, and each edge is included independently with probability p. The following module generates such a graph and returns it as a neighbors list.

erGraph[n_,p_]:=Module[
{ (* initialze empty neighbors lists *)
neighbors=Table[{},n]},

(* include each possible edge with probability p *)
Do[
If[RandomReal[]<=p,AppendTo[neighbors[[i]],j];AppendTo[neighbors[[j]],i]],
{i,1,n},{j,i+1,n}
];

(* return the neighbors lists *) 
neighbors
]

Here is a sample:

sampleGraph=erGraph[8,0.5]

Drawing a graph

The following module takes a neighbors list and returns a drawing of the graph it defines:

drawGraph[neighbors_]:=Module[
{edgeList},

edgeList=Flatten[Table[a\[UndirectedEdge]b,{a,1,Length[neighbors]},{b,neighbors[[a]]}]];
edgeList=DeleteDuplicates[Sort/@edgeList];
Graph[Range[Length[neighbors]],edgeList,VertexLabels->Placed[Automatic,Center],VertexSize->0.3]
]

For example:

drawGraph[sampleGraph]

Drawing a graph with vertex colors

The following module takes a neighbors list and a list of vertex colors, and returns a drawing of the graph it defines:

drawColorGraph[neighbors_,vertexColors_]:=Module[
{colorList},

edgeList=Flatten[Table[a\[UndirectedEdge]b,{a,1,Length[neighbors]},{b,neighbors[[a]]}]];
edgeList=DeleteDuplicates[Sort/@edgeList];

colorList=vertexColors/.{1->Red,2->Blue,3->Green,4->Orange,5->Purple,6->Yellow,7->Pink,8->Gray,9->Brown,10->Cyan,11->White,12->Magenta};
vColorList=Table[Style[i,colorList[[i]]],{i,Length[neighbors]}];

Graph[vColorList,edgeList,VertexLabels->Placed[Automatic,Center],VertexSize->0.5]
]

For example:

vertexColors={1,4,3,2,3,2,1,1};
drawColorGraph[sampleGraph,vertexColors]

Sample Graphs

graph1 is an Erdős-Rényi random graph with n=8 and p=0.5:

graph1={{2,3,4,5,6},{1,3,5,8},{1,2,5,7},{1,5},{1,2,3,4,7},{1,8},{3,5},{2,6}};
drawGraph[graph1]

vertexColors={1,2,3,2,4,2,2,3};
drawColorGraph[graph1,vertexColors]

graph2 is an Erdős-Rényi random graph with n=15 and p=0.6:

graph2={{4,5,6,7,9,10,11,12,13,14},{3,6,8,12,13,14},{2,4,6,9,12,13,14,15},{1,3,6,8,11,12,13,15},{1,7,8,9,10,12},{1,2,3,4,7,9,10,13},{1,5,6,10,11,14,15},{2,4,5,9,11,12,13,14,15},{1,3,5,6,8,10,12,14,15},{1,5,6,7,9,14},{1,4,7,8,12,14},{1,2,3,4,5,8,9,11,13,14,15},{1,2,3,4,6,8,12,14,15},{1,2,3,7,8,9,10,11,12,13},{3,4,7,8,9,12,13}};
drawGraph[graph2]

graph3 is an Erdős-Rényi random graph with n=20 and p=0.4:

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

graph4 is an Erdős-Rényi random graph with n=40 and p=0.4:

graph4={{2,8,10,12,13,15,16,17,22,24,25,26,29,30,31,34,36,38},{1,7,8,9,10,11,12,15,16,17,20,23,24,31,33,35,36,37},{4,5,6,8,12,13,14,15,19,22,23,24,27,29,35,37,38},{3,5,6,7,14,16,17,18,19,20,22,26,27,28,29,30,38,39,40},{3,4,6,14,17,19,21,22,26,32,34,38,39},{3,4,5,7,10,11,14,16,22,23,28,30,33,34,35,36,37,38},{2,4,6,8,9,14,15,17,20,24,25,26,29,30,31,34,35,40},{1,2,3,7,11,13,16,19,26,31,37},{2,7,10,16,17,19,23,24,29,32,36,37},{1,2,6,9,11,15,17,22,23,29,33,37,38,40},{2,6,8,10,12,16,21,22,24,29,36,37,39,40},{1,2,3,11,14,15,16,18,19,20,23,26,27,29,31,32,33,39},{1,3,8,16,17,23,25,26,29,30,34,36,38},{3,4,5,6,7,12,23,25,29,30,31,32,33,39},{1,2,3,7,10,12,18,23,24,25,26,31,35},{1,2,4,6,8,9,11,12,13,17,18,22,23,24,25,26,28,29,33,35,38,40},{1,2,4,5,7,9,10,13,16,19,24,30,33,35,36,37},{4,12,15,16,19,22,26,28,33,35},{3,4,5,8,9,12,17,18,20,21,22,26,27,29,32,37,39},{2,4,7,12,19,21,23,24,25,26,27,28,33,34,36},{5,11,19,20,22,24,28,29,30,31,34,38},{1,3,4,5,6,10,11,16,18,19,21,23,24,26,27,32,36,38},{2,3,6,9,10,12,13,14,15,16,20,22,24,25,31,32,35,36,37,39},{1,2,3,7,9,11,15,16,17,20,21,22,23,26,28,29,32,33,39},{1,7,13,14,15,16,20,23,26,28,31,34,35,36,38,39,40},{1,4,5,7,8,12,13,15,16,18,19,20,22,24,25,27,31,34,38,39,40},{3,4,12,19,20,22,26,28,29,33,34,36},{4,6,16,18,20,21,24,25,27,29,30,32,33,36},{1,3,4,7,9,10,11,12,13,14,16,19,21,24,27,28,34,35},{1,4,6,7,13,14,17,21,28,31,33,35,36,40},{1,2,7,8,12,14,15,21,23,25,26,30,34,35,36,37},{5,9,12,14,19,22,23,24,28,33,34},{2,6,10,12,14,16,17,18,20,24,27,28,30,32,37,39},{1,5,6,7,13,20,21,25,26,27,29,31,32,35,39},{2,3,6,7,15,16,17,18,23,25,29,30,31,34,36,38,39},{1,2,6,9,11,13,17,20,22,23,25,27,28,30,31,35,39},{2,3,6,8,9,10,11,17,19,23,31,33},{1,3,4,5,6,10,13,16,21,22,25,26,35,39,40},{4,5,11,12,14,19,23,24,25,26,33,34,35,36,38,40},{4,7,10,11,16,25,26,30,38,39}};
drawGraph[graph4]

Minimal Coloring by Simulated Annealing

Our objective function is the number of pairs of adjacent vertices with same color. A proper coloring occurs when this objective function is maximized at value zero.

objFn[neighbors_,vertexColors_]:=Module[
{total=0},

(* loop over all (ordered) pairs of vertex indexes *)
Do[
(* if vertexes are the same color, increment the total *)
If[vertexColors[[i]]==vertexColors[[j]],total+=1]
,{i,1,Length[neighbors]},{j,neighbors[[i]]}];

(* return value *) 
-total/2
]

Test the objective function:

objFn[sampleGraph,vertexColors]

Simulated Annealing code

The following module uses simulated annealing to color the vertices with a specified number of colors, attempting to maximize the objective function.

graphColoringMCMC[neighbors_,numColors_,βstart_,βinc_,maxIter_]:=Module[
{n=Length[neighbors], (* number of vertices in the graph *)
currState, (* an list of colors, one for each vertex *)
β=βstart, (* value of β we can update *)
v,newColor,propState, (* variables for generating a new state *)
currF,propF,Δf ,fVals=Table[0,maxIter],(* values of the objective function *),
ρ (* acceptance ratio *)
},

(* generate a random coloring *) 
currState=RandomInteger[{1,numColors},n];

(* main loop *)
Do[
(* select a random vertex *)
v=RandomInteger[{1,n}];

(* choose a different color for the selected vertex *) 
newColor=RandomInteger[{1,numColors}];
While[newColor==currState[[v]],newColor=RandomInteger[{1,numColors}]];

(* proposed state: assign the new color to the selected vertex *) 
propState=currState;
propState[[v]]=newColor;

(* compute change in the objective function *) 
currF=objFn[neighbors,currState];
propF=objFn[neighbors,propState];
Δf=propF-currF;

(* select the next β in the annealing schedule *)
β*=βinc;

(* compute the acceptance ratio *) 
ρ=Exp[β*Δf];

(* decide whether to accept the proposed transition *) 
If[RandomReal[]<ρ,
currState=propState;
];

(* if currF is zero, then quit *)
fVals[[i]]=objFn[neighbors,currState];
If[fVals[[i]]==0,Print["Success! steps = ",i];fVals=fVals[[1;;i]];Break[] ]
,{i,1,maxIter}];
Print["final β: ",β];

(* return values *) 
{fVals,β,currState}
]

Try it out:

{fVals,finalβ,finalState}=graphColoringMCMC[graph1,4,1,1.001,1000]

drawColorGraph[graph1,finalState]

{fVals,finalβ,finalState}=graphColoringMCMC[graph4,8,1,1.00001,10000];

drawColorGraph[graph4,finalState]

Timing[graphColoringMCMC[graph4,8,1,1.00001,10000]][[1]]

Binomial[40,9]

More efficient simulated annealing

The previous simulated annealing code was rather slow. Complete the following module to achieve faster graph coloring by simulated annealing.

graphColoringMCMCfast[neighbors_,numColors_,βstart_,βinc_,maxIter_]:=Module[
{n=Length[neighbors], (* number of vertices in the graph *)
state, (* an list of colors, one for each vertex *)
β=βstart, (* value of β we can update *)
v,newColor,propState, (* variables for generating a new state *)
currF,Δf ,fVals=Table[0,maxIter],(* values of the objective function *),
ρ (* transition probability *)
},

(* generate a random coloring *) 
state=RandomInteger[{1,numColors},n];
currF=objFn[neighbors,state];

(* main loop *)
Do[
(* select a random vertex *)
v=RandomInteger[{1,n}];

(* choose a different color for the selected vertex *) 
newColor=RandomInteger[{1,numColors}];
While[newColor==state[[v]],newColor=RandomInteger[{1,numColors}]];

(* proposed state: assign the new color to the selected vertex *) 
propState=state;
propState[[v]]=newColor;

(* compute change in the objective function *) 
Δf=0;
Do[ (* i is an index of a vertex adjacent to v *)
If[state[[i]]==state[[v]],Δf+=1];
If[propState[[i]]==propState[[v]],Δf-=1]
,{i,neighbors[[v]]}];

(* select the next β in the annealing schedule *)
β*=βinc;

(* compute the acceptance ratio *) 
ρ=Exp[β*Δf];

(* decide whether to accept the proposed transition *) 
If[RandomReal[]<ρ,
state=propState;
currF +=Δf
];

(* if currF is zero, then quit *)
fVals[[i]]=currF;
If[currF==0,Print["Success! steps = ",i];fVals=fVals[[1;;i]];Break[] ]
,{i,2,maxIter}];
Print["final β: ",β];

(* return values *) 
{fVals,β,state}
]

Try it out:

Timing[graphColoringMCMCfast[graph4,8,1,1.00001,10000]][[1]]

{fVals,finalβ,finalState}=graphColoringMCMCfast[graph4,6,0.5,1.00001,1000000];

drawColorGraph[graph4,finalState]

How  many subsets of 7 vertices in a graph of 40 vertices?

Binomial[40,7]

Length[#]&/@graph4//Max

Degree of graph4 is 22.

graph4