6
$\begingroup$

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.

Sample Automata 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).

$\endgroup$
  • $\begingroup$ Would you please try to add a concrete example of what you describe? $\endgroup$ – Mr.Wizard Jan 20 '15 at 21:21
  • $\begingroup$ There is closely related demonstration: Four-Color Outer Median Cellular Automata on Graphs $\endgroup$ – ybeltukov Jan 20 '15 at 23:14
  • 1
    $\begingroup$ Shouldn't the update stop at step 3? $\endgroup$ – kglr Jan 22 '15 at 0:00
2
$\begingroup$

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]]

enter image description here

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

$\endgroup$
  • $\begingroup$ Could you provide more information on how to use this...? $\endgroup$ – user2154420 Feb 3 '15 at 13:10
  • $\begingroup$ @user2154420 just same as others. $\endgroup$ – halmir Feb 3 '15 at 14:03
  • $\begingroup$ Is this guaranteed to halt? I ran it, changing {Red, Blue, Green} to {Red, Blue}, and there hasn't been any output... still calculating away. $\endgroup$ – user2154420 Feb 3 '15 at 14:09
  • $\begingroup$ @user2154420 I didn't think of that... but you're correct I don't have any theoretical background that guarantee the convergence (seems not). Just add 3rd argument to FixedPointList to prevent infinite computations... $\endgroup$ – halmir Feb 3 '15 at 14:24
  • 1
    $\begingroup$ @user2154420 you could get those information by checking documentation : Slot (#) and Function (&) $\endgroup$ – halmir Feb 5 '15 at 3:02
6
$\begingroup$

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}]

enter image description here

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}]

enter image description here


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}]

enter image description here

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.
$\endgroup$
  • $\begingroup$ Very nice, +1, but is this "if there is a tie, the vertex keeps its current color" satisfied? Don't you just choose 1st color in the list of ties? $\endgroup$ – Vitaliy Kaurov Jan 21 '15 at 1:50
  • $\begingroup$ @Vitaly, you are right, thank you. Will update with a fix for the tie-breaking problem. $\endgroup$ – kglr Jan 21 '15 at 2:00
  • $\begingroup$ @Vitaly, come to think of it, we don't need a fix. The function recolorF breaks ties in favor of the current own color because (1) VertexList[NeighborhoodGraph[g1, v]] lists v as the first vertex and (2) Commonest[list] breaks the ties based on the order the elements appear in list. $\endgroup$ – kglr Jan 21 '15 at 2:21
  • 1
    $\begingroup$ for g1, lower left red should turn green? $\endgroup$ – halmir Jan 21 '15 at 14:55
  • 1
    $\begingroup$ @user2154420, updating is "synchronous" in both versions. $\endgroup$ – kglr Jan 22 '15 at 0:02
5
$\begingroup$

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}]]

Mathematica graphics

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}]

Mathematica graphics

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.

$\endgroup$
  • $\begingroup$ I think there is an error somewhere. Initial graph: i.imgur.com/M7e8D4k.jpg After one iteration: i.imgur.com/3vfNnBj.jpg I'll add an edit to my question for further clarification, but when applying the rule, the new graph should look like what would happen if we updated every vertex at the same time (synchronous updating) instead of one, then another (sequential updating), since vertex colors could change based in intermediate updates. I'll add further clarification to the majority rule. We should only consider a vertex itself when updating in the event of a tie. $\endgroup$ – user2154420 Jan 21 '15 at 12:32
  • $\begingroup$ "We should only consider a vertex itself when updating in the event of a tie." I don't understand. That is already addressed in my code and in my commentary. I also cannot reproduce this error you are introducing. $\endgroup$ – Kellen Myers Jan 21 '15 at 22:37
  • $\begingroup$ And thanks Sjoerd for the images, although my mind is having a bit of a paradoxical moment when a static image is used as the output of a random algorithm XD $\endgroup$ – Kellen Myers Jan 21 '15 at 22:38
  • $\begingroup$ No. It doesn't. chi[k,x] gives the coloring of vertex x at step k and this depends only on various values of chi[k-1,_]. It also does not include any vertex in its own list of neighbors. That's what Complement does. $\endgroup$ – Kellen Myers Jan 30 '15 at 22:35
  • $\begingroup$ I just want to say, it is very disappointing to have the questioner continue to insist this code is "insynchronous" [sic] and includes a vertex in its own neighbors. It has neither problem (and has not been modified), and I think others would appreciate it if the time one spends writing answers for you would be reciprocated by taking the time to read those answers more carefully. $\endgroup$ – Kellen Myers Feb 3 '15 at 2:26

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.