Graph Coloring based on neighboring vertices? Cellular Automata

Question

I would like to apply a majority rule cellular automata to graphs. Specifically, I would like to take a graph as input, and then define two functions, InitialColoring[graph] and MajorityRule[graph]. Suppose the set of colors is some given finite list.

InitialColoring[graph] uses some rule (such as randomly assigning colors to each vertex). MajorityRule[graph] this "updates" the coloring for a given graph by getting the neighbors of each vertex, checking which color has the majority, and then coloring the majority color. For simplicity, let's assume the set of colors only has two colors, and if there is a tie, the vertex keeps its current color.

My thoughts: Make a loop ranging over vertices, get neighbors, get colors, count colors, apply. I am very new to Mathematica so I am not sure how to implement this. Any suggestions on this approach or a better method to accomplish the same goal?

Also note: I want to apply cellular automata to graphs (specifically CayleyGraphs), not just the integer lattice so the built-in CellularAutomata function doesn't seem to help much.

EDIT: EXAMPLE:

Suppose we have the graph shown in the upper left corner in the figure below.

We want to apply the rule that a vertex's color is determined by the color of the majority of its neighbors (if there is a tie, it keeps its color). Below shows an example of the progression of this automata. This outlines what I want: 1) enter a graph with an initial coloring 2) apply a rule (shown through progression of arrows) that outputs a new graph (or perhaps two functions, one that outputs the graph data, and one that outputs the color data... then these are combined in some way... I'm not sure which would be easier/more efficient to implement).

I am lost as to how to implement this, although the algorithm is pretty easy. In fact, focusing to the case where we only have two colors and the majority rule would suffice.

EDIT 2: Further Details Updating should be synchronous, i.e., when we go from one time to the next, it should look like we updated every vertex all at once. Otherwise, we could get unwanted colorings due to intermediate updates in sequential updating. For example, in the example above, if we colored the top vertex first, and then proceeded, the rightmost vertex would stay blue the next generation instead of changing to red.

Also, when checking for the vertex's color, the vertex itself should only be considered in the event of a tie, i.e., it is not considered one of its neighbors unless there is a loop (we don't assume graphs are implicitly reflexive).

Answer 1

More is better, other variation:

upDateColor[g_] :=
 Block[{color, vlist, c},
  color = Association[PropertyValue[g, VertexStyle]];
  vlist = VertexList[g];
  SetProperty[g, 
   VertexStyle -> 
    Table[v -> 
      If[Length[c = Commonest[color /@ AdjacencyList[g, v]]] == 1, 
       First[c], color[v]], {v, vlist}]]
  ]

example:

g = PetersenGraph[5, 
   2, {VertexSize -> Large, ImageSize -> 200, 
    VertexLabels -> Placed["Name", Center], 
    VertexStyle -> 
     Thread[Range[10] -> RandomChoice[{Red, Blue, Green}, {10}]]}];

Row@Most[FixedPointList[upDateColor, g]]

in case of repeating sequence, you could define a function like below to detect sequence pattern (this one only detect result one above):

iFixedPointList[func_, g_, n___] :=
 Block[{i},
  i = g;
  FixedPointList[func, g, n, 
   SameTest -> (SameQ[i, #2] || (i = #1; SameQ[#1, #2]) &)]
  ]

SeedRandom[1]; g = 
 PetersenGraph[5, 
  2, {VertexSize -> Large, ImageSize -> 200, 
   VertexLabels -> Placed["Name", Center], 
   VertexStyle -> 
    Thread[Range[10] -> RandomChoice[{Red, Blue}, {10}]]}];

iFixedPointList[upDateColor, g] // Length

4

FixedPointList[upDateColor, g, 6] // Length

7

Answer 2

Update: The original post below computes the commonest color in the NeighborhoodGraph of a vertex v including the vertex v itself. To exclude a vertex in counting the colors in its neighborhood, we can use the following helper function:

ClearAll[newClrF];
newClrF = Module[{nc=#, oc=First@#, c1= Commonest[Rest@#][[1]], c2= Quiet@Commonest[Rest@#, 2]}, 
            If[And[Length@c2 > 1, Equal @@ (Count[Rest@nc, #] & /@ c2)], oc, c1]] &;

and modify reColorF1 and reColorF2:

ClearAll[reColorF1B, reColorF2B];
reColorF1B = Module[{g = #1, vl = VertexList[#1], cl, ncl},
    ncl = (neighborColorsF[g, #1] &) /@ vl; cl = newClrF /@ ncl;                      
    MapThread[(PropertyValue[{g, #}, VertexStyle] = #2) &, {vl, cl}]; g] &;

reColorF2B = Module[{g = #1, vl = VertexList[#1], cl, ncl},
    ncl = (neighborColorsF[g, #1] &) /@ vl; cl = newClrF /@ ncl;                              
    SetProperty[g, VertexStyle -> Thread[vl -> cl]]] &;

Using the same examples as in the previous post:

Grid[Most@FixedPointList[reColorF1B, #, 5] & /@ {g1, g2}]

Another example:

g3 = SetProperty[g, {VertexStyle -> 
     Thread[Range[10] -> {Red, Blue, Green, Orange, Red, Green, Orange, Red, Red, Orange}], 
        VertexSize -> Large, ImageSize -> 100}];
Grid[Most@FixedPointList[#, g3, 9] & /@ {reColorF1, reColorF1B}]

---

Previous post: In the following, color counts in the neighborhood of a vertex v include the color of vertex v.

ClearAll[neighborsF, neighborColorsF, commonestColorF, reColorF1, reColorF2];
neighborsF = Function[{g, v}, VertexList[NeighborhoodGraph[g, v]]];
neighborColorsF = Function[{g, v}, PropertyValue[{g, #}, VertexStyle] & /@ neighborsF[g, v]];
commonestColorF = Function[{g, vl}, (Commonest[neighborColorsF[g, #]][[1]]) & /@ vl];

Using the above helper functions, define

reColorF1 =  Module[{g = #, vl = VertexList @ #, cl = commonestColorF[#, VertexList @ #]}, 
             MapThread[(PropertyValue[{g, #}, VertexStyle] = #2) &, {vl, cl}]; g] &;

Alternatively, you can use SetProperty to change the vertex colors:

reColorF2 =  Module[{g = #, vl = VertexList @ #, cl = commonestColorF[#, VertexList @ #]}, 
             SetProperty[g, VertexStyle -> Thread[vl -> cl]]] &;

Examples:

g = PetersenGraph[5, 2];
g1 = SetProperty[g, { VertexSize -> Large, ImageSize -> 200, 
       VertexLabels -> Placed["Name", Center],
       VertexStyle -> Thread[Range[10] -> RandomChoice[{Red, Blue, Green}, {10}]]}];
g2 = SetProperty[g, { VertexSize -> Large, ImageSize -> 200, 
       VertexLabels -> Placed["Name", Center],
       VertexStyle -> Thread[Range[10] -> RandomChoice[{Red, Blue, Green}, {10}]]}];

Grid[Most@FixedPointList[reColorF1, #, 5] & /@ {g1, g2}]

Grid[Most@FixedPointList[reColorF2, #, 5] & /@ {g1, g2}]
(* same picture *)

Note: Breaking ties in favor of current color:

OP's requirement

"if there is a tie, the vertex keeps its current color"

is satisfied, i.e., both functions above break ties in favor of the current own color, because

1. VertexList[NeighborhoodGraph[g, x]] lists x as the first vertex, and
2. Commonest[list] breaks the ties based on the order the elements appear in list.

Answer 3

First, let's whip up a random graph:

n = RandomInteger[{10, 15}];
m = RandomInteger[{Floor[n^2/20], n (n - 1)/2}];
G = RandomGraph[{n, m}];
For[i = 1, i <= n, i++,
  chi[0, i] = {Red, Blue}[[RandomInteger[] + 1]]
  ];
Graph[G, VertexStyle -> Table[i -> chi[0, i], {i, 1, n}]]

The coloring at step k will be denoted chi[k,i], where i indicates a vertex. I am going to start now assuming that some graph object G is given, but that it is not necessarily of the above form, so the vertex i might not be an integer:

VX = VertexList[G];
n = Length[VX];
EX = EdgeList[G];
m = Length[EX];

Obviously if you generate G as above, some of that is unnecessary.

Since the underlying graph is static, it's easiest to just hash out the neighborhoods of each vertex quickly:

For[i = 1, i <= n, i++,
 NBHD[i] = Select[EX, #[[1]] == i || #[[2]] == i &];
 NBHD[i] = Complement[Union @@ (List @@ # & /@ NBHD[i]), {i}];
 ]

From there, we can define kmax steps of this process as:

kmax = 10;
For[k = 1, k <= kmax, k++,
  For[i = 1, i <= n, i++,
    COL = Commonest[chi[k - 1, #] & /@ NBHD[VX[[i]]]];
    chi[k, i] =
     Which[
      Length[COL] == 1, COL[[1]],
      MemberQ[COL, chi[k - 1, i]], chi[k - 1, i],
      True, COL[[RandomInteger[{1, Length[COL]}]]]
      ];
    ];
  ];

I've made the choice that if there is a tie among neighbors, if that tie includes the current color, the vertex says the same color. If some vertex has a tie among neighbors that does not include its current color, it changes randomly to one of those most popular colors. (That's what's happening in the Which conditional.)

You can display the results with:

Manipulate[
 Graph[G, VertexStyle -> Table[i -> chi[k, i], {i, 1, n}]],
 {k, 0, kmax, 1}]

I'm sure there are other/different/better ways to do parts of this, but I think this gets you going the way you want. I hope it is also flexible enough if your G has a non-integer vertex set or some other issue. And so long as you define chi[0,i] for all i using some valid color, you get what you need out. This should be fairly flexible in such regards.

You can reproduce the "usual" automata using GridGraph like this:

G = GridGraph[{10, 10}];
For[i = 1, i <= n, i++,
  chi[0, i] = {Red, Blue}[[Mod[i, 2] + 1]]
  ];

I've used this particular coloring (not random) to get some interesting behavior out of the automaton.

Update

To achieve the tie-breaking rule where ties result in no color change, just swap out:

     If[
      Length[COL] == 1, COL[[1]], chi[k - 1, i]
      ];

for the Which conditional above. Note that this will produce possibly counter-intuitive behavior, like a green node with 10 red neighbors and 10 blue neighbors remaining green without any green neighbors.