Tools for finding minimal or almost-minimal graph vertex colorations in Mathematica v9?

Question

I'm looking to compute minimum vertex colorations (s.t. no two vertices of the same color share an edge: http://en.wikipedia.org/wiki/Graph_coloring) for graphs in Mathematica v9 with potentially up to a few hundred vertices. I noticed that there are some old functions for this in the Combinatorica package (MinimumVertexColoring and VertexColoring), however these seem to no longer work with Mathematica v9 graph data structures. Unfortunately, I couldn't find anything newer in the function directory.

How does one find a graph coloring in Mathematica v9, or at least the chromatic number of the graph? Is there anything that will guarantee a minimal coloring conditioned on a result being returned?

Sage has the following functionalities: http://www.sagemath.org/doc/reference/graphs/sage/graphs/graph_coloring.html, but I can't seem to find anything in Mathematica v9 for this.

Update - Let's take belisarius' suggestion to use ToCombinatoricaGraph (and Szabolcs code from Generating a graph where vertices correspond to points in an integer lattice and edges connect points less than a threshold distance apart, which doesn't clash with Combinatorica package definitions):

Needs["Combinatorica`"]
Needs["GraphUtilities`"]

pts = Tuples[Range[10], 2];
threshold = 2;

distances = With[{tr = N@Transpose[pts]}, Function[point, Sqrt[Total[(point - tr)^2]]] /@ pts];
G = SimpleGraph[AdjacencyGraph@UnitStep[threshold - distances], VertexCoordinates -> pts]

MinimumVertexColoring[ToCombinatoricaGraph[G]]

The output (for threshold = 2) is:

{1, 2, 3, 4, 5, 1, 2, 3, 4, 5, 3, 4, 5, 1, 2, 3, 4, 5, 1, 2, 5, 1, 2, 3, 4, 5, 1, 2, 3, 4, 2, 3, 4, 5, 1, 2, 3, 4, 5, 1, 4, 5, 1, 2, 3, 4, 5, 1, 2, 3, 1, 2, 3, 4, 5, 1, 2, 3, 4, 5, 3, 4, 5, 1, 2, 3, 4, 5, 1, 2, 5, 1, 2, 3, 4, 5, 1, 2, 3, 4, 2, 3, 4, 5, 1, 2, 3, 4, 5, 1, 4, 5, 1, 2, 3, 4, 5, 1, 2, 3}

So this seems to work. I suppose the obvious questions would be:

Is it known what algorithm MinimumVertexColoring is actually using? The help directory says that it returns a minimum vertex coloring, but is it actually guaranteed to be minimal? In other words, what algorithm is being employed? (Partial answer: the algorithm is based on [Mehrotra, A. and Trick, M. A. "A Column Generation Approach for Graph Coloring." INFORMS J. on Computing 8, 344-354, 1996.] http://mathworld.wolfram.com/ChromaticNumber.html. I need to read the paper to determine if there are any caveats to obtaining an exact minimum coloring.

Also, can we place markers on the vertices in the Mathematica v9 graph structure indicating their color? It's not clear to me if ToCombinatoricaGraph is preserving vertex orderings when reporting a coloring?

Answer 1

This is a great question, and surely a function that should be implemented in Mathematica already. Let me outline both an exact algorithm and a heuristic.

Exact algorithm

We can proceed in two phases:

• Compute the chromatic number $\chi(G)$ of the graph $G$.
• Iterate over all possible $\chi(G)$-colorings, and choose the first valid one.

From this answer, we know how to compute the chromatic number:

ChromaticNumber[g_] := MinValue[{z, z > 0 && ChromaticPolynomial[g, z] > 0}, z, Integers];

Everything else is then quite straightforward:

ValidColoringQ[g_, c_] := 
AllTrue[Table[Intersection[{c[[i]]}, c[[AdjacencyList[g, i]]]] == {}, {i, 1, VertexCount[g]}], TrueQ];

g = RandomGraph[{6, 9}, VertexLabels -> "Name"]
chrom = ChromaticNumber[g];
colorings = Tuples[Table[i, {i, 1, chrom}], VertexCount[g]];
sol = SelectFirst[colorings, ValidColoringQ[g, #] &];

To visualize the result, let us use this nice answer to get a good-looking palette:

discreteColors[n_] := 
With[{partL = Ceiling[Sqrt[n]]}, 
DeleteCases[
Flatten[Transpose[
 Partition[
  Table[Lighter[Darker[Hue[c], .1], .25], {c, 0, 1 - 1/n, 1/n}], 
  partL, partL, 1, 0]]], 0]];

palette = discreteColors[chrom];
Do[PropertyValue[{g, v[[1]]}, VertexStyle] = v[[2]],
 {v, Table[{i, palette[[sol[[i]]]]}, {i, 1, VertexCount[g]}]}]

g

And there we have it. It should be noted that the code crucially assumes the vertex set is defined on the continuous integer set $\{1, \ldots, n\}$. (If this is not the case, we can use GraphIndex to make it hold).

Unfortunately, this approach will only be feasible for quite tiny graphs.

Heuristic approach

We can easily implement the RLF (recursive largest first) heuristic in Mathematica. The idea is simple: we proceed by picking a maximal independent set at a time, i.e., we do one color class per iteration.

g = RandomGraph[{6, 9}];

h = g;
cols = {};
While[!EmptyGraphQ[h],
 maxd = RandomChoice[VertexList[h]];
 indset = Flatten[FindIndependentVertexSet[{h, maxd}]];
 AppendTo[cols, indset];
 h = VertexDelete[h, indset];
]

AppendTo[cols, VertexList[h]];

(* Holds a list of lists, where the 1st list contains vertices of color 1 etc. *)
cols 

I believe the original RLF heuristic chooses a vertex of maximum degree from which a maximal independent set is expanded from; the above code does this from a randomly chosen vertex.

Again, to visualize, we can do say:

chrom = Length[cols];
palette = discreteColors[chrom];
For[i = 1, i <= Length[cols], ++i,
 Do[PropertyValue[{g, v}, VertexStyle] = palette[[i]], {v, cols[[i]]}]
 ]

g

Answer 2

IGraph/M now includes functions for computing vertex colourings efficiently.

To check if a graph g is k-vertex-colourable use,

IGKVertexColoring[g, k]

If the answer is yes, {coloring} will be returned. If it is no, {} will be returned.

To compute a minimum colouring, use IGMinimumVertexColroing. To just find the chromatic number, use IGChromaticNumber.

There are analogous IGKEdgeColoring and IGMinimumEdgeColoring functions.

If you want a fast but not necessarily minimal colouring, use IGVertexColoring and IGEdgeColoring.

We can also visualize the colourings easily.

g = GraphData["DodecahedralGraph"];

Graph[g, GraphStyle -> "BasicBlack", VertexSize -> Large] // 
 IGVertexMap[ColorData[106], VertexStyle -> IGMinimumVertexColoring]

Graph[g, GraphStyle -> "BasicBlack", EdgeStyle -> Thickness[0.02]] // 
 IGEdgeMap[ColorData[106], EdgeStyle -> IGMinimumEdgeColoring]

Note that IGraph/M requires Mathematica 10.0 or later.