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

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?

-
Check ToCombinatoricaGraph[] ... a tunnel between two universes – Dr. belisarius Nov 8 '13 at 14:48
@belisarius See my update! – user10456 Nov 8 '13 at 15:00
The coloring algorithms are documented here amazon.com/…, section 7-4. Sorry I don't know any free source – Dr. belisarius Nov 8 '13 at 15:24

This is a great question, and surely a function that should be implemented in Mathematica already. To solve the problem, let us 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..n$. (If this is not the case, we can use GraphIndex to make it hold). Also, the search space is of size $k^n$, where $k$ is the chromatic number. Moreover, computing the chromatic number of a graph is NP-hard, so we most likely can't have an algorithm that would always be fast.

Given the size of the search space, memory consumption is likely to become a problem for larger graphs (especially if the chromatic number is large as well). In such a case, I would randomly generate $k$-colorings; this process is guaranteed to terminate with probability approaching 1 as one of the colorings will be valid.

-