Mathematica in Education and Research

"Social Simulations" Column
by
Louis J. D'Andria

Transmitting Culture
Part II

Introduction

In our previous column [Gaylord and D'Andria, 1998] we presented a mobile version of the Axelrod model of social learning through the binary transmission of cultural values [Axelrod, 1997]. In this column, we will look at a simpler variant of that model and then an even simpler version of the model in which social status determines the direction of meme transmission.

The Closer We Agree, the Closer Our Agreement Becomes

In this model of cultural transmission, the number of meme values that are shared between two facing individuals is ignored and instead, a meme value is randomly chosen and changed based on how similar the chosen meme value is for the two individuals.

The System

Our model [Gaylord and D'Andria, 1998] uses an n by n square lattice with wraparound boundary conditions. There is a population density p of individuals occupying lattice sites and the remaining sites are empty. Each person is characterized by the direction he is facing and a meme list with s elements. The system evolves over a given number of time steps or until all of the people have identical meme lists.

Populating Society

We first need to specify the values of the lattice sites.

The code for creating this system is given by [Gaylord and D'Andria, 1998]:

RND := Random[Integer, {1, 4}]
society = Table[Floor[p + Random[]], {n}, {n}] /. 
            1 :> {RND, Table[Random[Integer, {1, m}], {s}]}

Executing a Time Step

The time step will be executed in three consecutive partial-steps, the first two involving the cultural exchange between individuals facing one another on adjacent sites and the last one involving the movement of individuals.

Deciding and Exchanging

Any individual who is facing another individual on an adjacent site (e.g., a south (east, north, west) facing individual who is face-to-face with a north (west, south, east) facing individual on the adjacent site) interacts culturally with that individual. The cultural exchange that occurs between facing individuals is a two-way interaction between the two individuals, allowing both to be changed by the interaction. A comparison is made between the values of corresponding memes of the two individuals. If all of the values of the corresponding memes are the same for each individual, nothing happens. If any of the values of the corresponding memes of the two individuals differ, then cultural transmission or social learning occurs by randomly choosing one of the memes whose value differs for the two individuals and changing that value for both individuals. This process will be carried out in two stages, the first being to decide what meme to change and what the new meme value will be, and the second being to carry out the change.

The lattice sites are first updated using the following set of rules.

decide[{3, y_}, _, _, {1, y_}, _] := {3, y}
decide[{2, y_}, _, {4, y_}, _, _] := {2, y}
decide[{2, y_}, _, {4, z_}, _, _] := 
  Module[{r = Random[Integer, {1, s}]},
          {2, y, Random[Integer, {y[[r]], z[[r]]}], r} /;
           Random[Integer,{1, m}] > Abs[y[[r]] - z[[r]]]]
           decide[{3, y_}, _, _, {1, z_}, _] := 
  Module[{r = Random[Integer, {1, s}]},
          {3, y, Random[Integer, {y[[r]], z[[r]]}], r} /;
           Random[Integer,{1, m}] > Abs[y[[r]] - z[[r]]]]
decide[a_, _, _, _, _] := a

The first two decide rules apply to a south (east) facing individual having a north (west) facing individual on the adjacent southern (eastern) site, when the meme lists of both are identical. In this case the decision is to make no change in any of the meme values.

The third and fourth decide rules apply to a south (east) facing individual having a north (west) facing individual on the adjacent southern (eastern) site, when the meme lists of the two are not identical. Since, as in a fair coin toss where it does not matter who flips the coin and who makes the call of heads or tails, it is irrelevant which of the two interacting individuals determines the cultural exchange for both individuals. We let each south (east) facing individual who is face-to-face with another individual on an adjacent site randomly select a meme in his meme list to change and, with a probability equal to the closeness of the meme's value for the two individuals, determine what the new meme value will be by randomly choosing a new value between the meme values for the two individuals.

The fifth decide rule applies to all other sites (either empty or occupied by an individual) and leaves them unchanged.

The decide rules are applied to the lattice sites using

vonNeumann[decide, #]&

where

vonNeumann[func_, lat_] := 
  MapThread[func, Map[RotateRight[lat, #]&,
          {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1}}], 2]

Having decided what cultural exchange to make, we next carry out the exchange by having each individual who is face-to-face with another individual on an adjacent site make the change in one of his meme values that was determined by the south (east) facing neighbor. This is done by updating the lattice sites using the rules:

exchange[{3, y_, c_, d_}, _, _, _, _] := 
                               {3, ReplacePart[y, c, d]}
exchange[{2, y_, c_, d_}, _, _, _, _] := 
                               {2, ReplacePart[y, c, d]}
exchange[{1, z_}, {3, y_, c_, d_}, _, _, _] :=
                               {1, ReplacePart[z, c, d]}
exchange[{4, z_}, _, _, _, {2, y_, c_, d_}] := 
                               {4, ReplacePart[z, c, d]}
exchange[a_, _, _, _, _] := a

In the preceding exchange rules, the individuals with four-element lists are the ones who have made the decision on what meme to change and what the new meme value should be. The first and second exchange rules use these values, which are given by the third and fourth list elements, to make the change in these persons. The third and fourth exchange rules use these same values to make the changes in the meme lists of the people facing the decision makers. The fifth rule applies to people who do not exchange values and to empty sites.

The exchange rules are applied to the lattice sites using the anonymous function

vonNeumann[exchange, vonNeumann[decide, #]]&

Moving

The 28 rules for the movement of individuals are given by the set of walk rules derived in a previous column [Gaylord and D'Andria, 1998]

walk[{1,a___},0,_,_,_,{4,___},_,_,_,_,_,_,_] := {RND,a}
walk[{1,a___},0,_,_,_,_,_,_,{2,___},_,_,_,_] := {RND,a}
walk[{1,a___},0,_,_,_,_,_,_,_,{3,___},_,_,_] := {RND,a}
walk[{1,a___},0,_,_,_,_,_,_,_,_,_,_,_] := 0
walk[{2,a___},_,0,_,_,{3,___},_,_,_,_,_,_,_] := {RND,a}
walk[{2,a___},_,0,_,_,_,{1,___},_,_,_,_,_,_] := {RND,a}
walk[{2,a___},_,0,_,_,_,_,_,_,_,{4,___},_,_] := {RND,a}
walk[{2,a___},_,0,_,_,_,_,_,_,_,_,_,_] := 0
walk[{3,a___},_,_,0,_,_,{4,___},_,_,_,_,_,_] := {RND,a}
walk[{3,a___},_,_,0,_,_,_,{2,___},_,_,_,_,_] := {RND,a}
walk[{3,a___},_,_,0,_,_,_,_,_,_,_,{1,___},_] := {RND,a}
walk[{3,a___},_,_,0,_,_,_,_,_,_,_,_,_] := 0
walk[{4,a___},_,_,_,0,_,_,{1,___},_,_,_,_,_] := {RND,a}
walk[{4,a___},_,_,_,0,_,_,_,{3,___},_,_,_,_] := {RND,a}
walk[{4,a___},_,_,_,0,_,_,_,_,_,_,_,{2,___}] := {RND,a}
walk[{4,a___},_,_,_,0,_,_,_,_,_,_,_,_] := 0
walk[{_,a___},_,_,_,_,_,_,_,_,_,_,_,_] := {RND,a}
walk[0,{3,___},{4,___},_,_,_,_,_,_,_,_,_,_] := 0
walk[0,{3,___},_,{1,___},_,_,_,_,_,_,_,_,_] := 0
walk[0,{3,___},_,_,{2,___},_,_,_,_,_,_,_,_] := 0
walk[0,_,{4,___},{1,___},_,_,_,_,_,_,_,_,_] := 0
walk[0,_,{4,___},_,{2,___},_,_,_,_,_,_,_,_] := 0
walk[0,_,_,{1,___},{2,___},_,_,_,_,_,_,_,_] := 0
walk[0,{3,a___},_,_,_,_,_,_,_,_,_,_,_] := {RND,a}
walk[0,_,{4,a___},_,_,_,_,_,_,_,_,_,_] := {RND,a}
walk[0,_,_,{1,a___},_,_,_,_,_,_,_,_,_] := {RND,a}
walk[0,_,_,_,{2,a___},_,_,_,_,_,_,_,_] := {RND,a}
walk[0,_,_,_,_,_,_,_,_,_,_,_,_] := 0

The walk rules are applied to the lattice sites using the anonymous function

GN[walk, vonNeumann[exchange, vonNeumann[decide, #]]]&

where

GN[func_, lat_] :=
  MapThread[func, Map[RotateRight[lat, #]&,
            {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1},
             {1, -1}, {-1, -1}, {-1, 1}, {1, 1}, {2, 0},
             {0, -2}, {-2, 0}, {0, 2}}], 2]

Evolving the System

The system evolves over t time steps, starting with the initial lattice configuration, society, using the following nesting operation.

NestList[GN[walk, vonNeumann[exchange,
                     vonNeumann[decide, #]]]&, society, t]

The Program

cultureSpreadingCloseness[n_, p_, s_, m_, t_] :=
Module[{society, RND, decide, exchange,
                                    walk, vonNeumann, GN},
  RND:= Random[Integer, {1, 4}];
  society = Table[Floor[p + Random[]], {n}, {n}] /. 
           1 :> {RND, Table[Random[Integer, {1, m}], {s}]};
  
  decide[{3, y_}, _, _, {1, y_}, _] := {3, y};
  decide[{2, y_}, _, {4, y_}, _, _] := {2, y};
  decide[{2, y_}, _, {4, z_}, _, _] := 
    Module[{r = Random[Integer, {1, s}]},
          {2, y, Random[Integer, {y[[r]], z[[r]]}], r} /;
          Random[Integer,{1, m}] > Abs[y[[r]] - z[[r]]]];
  decide[{3, y_}, _, _, {1, z_}, _] := 
    Module[{r = Random[Integer, {1, s}]},
          {3, y, Random[Integer, {y[[r]], z[[r]]}], r} /;
          Random[Integer,{1, m}] > Abs[y[[r]] - z[[r]]]];
  decide[a_, _, _, _, _] := a;

  exchange[{3, y_, c_, d_}, _, _, _, _] :=
                               {3, ReplacePart[y, c, d]};
  exchange[{2, y_, c_, d_}, _, _, _, _] :=
                               {2, ReplacePart[y, c, d]};
  exchange[{1, z_}, {3, y_, c_, d_}, _, _, _] :=
                               {1, ReplacePart[z, c, d]};
  exchange[{4, z_}, _, _, _, {2, y_, c_, d_}] :=
                               {4, ReplacePart[z, c, d]};
  exchange[a_, _, _, _, _] := a;
  
  walk[{1,a___},0,_,_,_,{4,___},_,_,_,_,_,_,_] := {RND,a};
  walk[{1,a___},0,_,_,_,_,_,_,{2,___},_,_,_,_] := {RND,a};
  walk[{1,a___},0,_,_,_,_,_,_,_,{3,___},_,_,_] := {RND,a};
  walk[{1,a___},0,_,_,_,_,_,_,_,_,_,_,_] := 0;
  walk[{2,a___},_,0,_,_,{3,___},_,_,_,_,_,_,_] := {RND,a};
  walk[{2,a___},_,0,_,_,_,{1,___},_,_,_,_,_,_] := {RND,a};
  walk[{2,a___},_,0,_,_,_,_,_,_,_,{4,___},_,_] := {RND,a};
  walk[{2,a___},_,0,_,_,_,_,_,_,_,_,_,_] := 0;
  walk[{3,a___},_,_,0,_,_,{4,___},_,_,_,_,_,_] := {RND,a};
  walk[{3,a___},_,_,0,_,_,_,{2,___},_,_,_,_,_] := {RND,a};
  walk[{3,a___},_,_,0,_,_,_,_,_,_,_,{1,___},_] := {RND,a};
  walk[{3,a___},_,_,0,_,_,_,_,_,_,_,_,_] := 0;
  walk[{4,a___},_,_,_,0,_,_,{1,___},_,_,_,_,_] := {RND,a};
  walk[{4,a___},_,_,_,0,_,_,_,{3,___},_,_,_,_] := {RND,a};
  walk[{4,a___},_,_,_,0,_,_,_,_,_,_,_,{2,___}] := {RND,a};
  walk[{4,a___},_,_,_,0,_,_,_,_,_,_,_,_] := 0;
  walk[{_,a___},_,_,_,_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,{3,___},{4,___},_,_,_,_,_,_,_,_,_,_] := 0;
  walk[0,{3,___},_,{1,___},_,_,_,_,_,_,_,_,_] := 0;
  walk[0,{3,___},_,_,{2,___},_,_,_,_,_,_,_,_] := 0;
  walk[0,_,{4,___},{1,___},_,_,_,_,_,_,_,_,_] := 0;
  walk[0,_,{4,___},_,{2,___},_,_,_,_,_,_,_,_] := 0;
  walk[0,_,_,{1,___},{2,___},_,_,_,_,_,_,_,_] := 0;
  walk[0,{3,a___},_,_,_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,{4,a___},_,_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,_,{1,a___},_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,_,_,{2,a___},_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,_,_,_,_,_,_,_,_,_,_,_] := 0;
 
  vonNeumann[func_, lat_] := 
    MapThread[func, Map[RotateRight[lat, #]&,
          {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1}}], 2];
  GN[func_, lat_] :=
    MapThread[func, Map[RotateRight[lat, #]&,
            {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1},
             {1, -1}, {-1, -1}, {-1, 1}, {1, 1}, {2, 0},
             {0, -2}, {-2, 0}, {0, 2}}], 2];
  
  NestList[GN[walk, vonNeumann[exchange,
                    vonNeumann[decide, #]]]&, society, t]]

Running the Simulation

We run the cultureSpreadingCloseness program on a 25 by 25 lattice having a 70% population of individuals with two memes, each of which can have two possible values, over 500 time steps.

SeedRandom[5];
results = cultureSpreadingCloseness[25, 0.7, 2, 2, 500];

We can look look at a percentile bar chart of the number of individuals with common meme lists.

<<Graphics`;
countCultures[lat_] := Map[Count[lat, {_, #}, 2]&,
                       {{1, 1}, {1, 2}, {2, 1}, {2, 2}}];
counts[res_] := Map[countCultures,
                               res[[Range[1, 500, 25]]]];
Apply[PercentileBarChart, Transpose[counts[results]]];

Comparing the figures obtained from the cultureSpreadingCloseness model to the figures obtained from the cultureSpreadingShared model [Gaylord and D'Andria, 1998], we see that the two models give similar results, indicating that there is no tendency for the population to adopt a common set of shared values. One way that convergence towards a shared value set might be achieved is to have a bias in the cultural exchange process, so that only one of the individuals changes one of his meme's values.

Social Status and Role Models

When two people of unequal social status interact culturally, it is more likely that the individual with the lower status will adopt a meme value of the individual with a higher social status while the meme value of the higher social status person will remain unchanged. This is most evident amongst young people who often adopt the attitudes of a so-called role model (hence, the famous advertising phrase "be like Mike"). We can model this effect using a simpler version of the previous model because of the one-way nature of the cultural interaction. The necessary code changes follow.

Creating People with Varying Social Status

The value of a site that is occupied by an individual is a triplet of the form {direction, status, memelist}. The first component is a randomly chosen integer between 1 and 4, indicating that the individual is facing north, east, south, or west, respectively. The second component is a random real number between 0 and 1, representing the social status of the person. The third component is a meme list of s elements, each of which has an integer value between 1 and m.

Note: Although we use randomly chosen fixed social status values for each individual in this simple model, it is straightforward to use one or more changeable attributes of an individual, such as wealth, to determine social status. We can then change an individual's status over time as that attribute value changes endogeneously. It is also possible to consider a model in which nonchangeable attributes, such as race or gender, play a role in determining status. Finally, we can combine these two by considering some combination of changeable and unchangeable attributes to determine social status. For example, a changeable attribute that is important in determining the social status of people who are in a dominant position in a society, such as WASPS, may become less important in determining the social status of people who are not in the that position, such as blacks and women.

The code for creating an n by n lattice with a population density p of individuals with varying social status is given by:

RND := Random[Integer, {1, 4}]
society = Table[Floor[p + Random[]], {n}, {n}] /. 1 :> 
     {RND, Random[], Table[Random[Integer, {1, m}], {s}]}

Deciding and Exchanging

No decide rules are needed in this model because the decision to change the value of a (randomly chosen) meme can be incorporated into the exchange rules by simply carrying out the exchange only if the person has a lower status than the individual he is facing. The exchange rules are given by:

exchange[{1, a_, u_}, {3, b_, v_}, _, _, _] := 
  {1, a, ReplacePart[u, v[[#]], #]&[
                       Random[Integer, {1, s}]]} /; a < b
exchange[{2, a_, u_}, _, {4, b_, v_}, _, _] :=
  {2, a, ReplacePart[u, v[[#]], #]&[
                       Random[Integer, {1, s}]]} /; a < b
exchange[{3, a_, u_}, _, _, {1, b_, v_}, _] :=
  {3, a, ReplacePart[u, v[[#]], #]&[
                       Random[Integer, {1, s}]]} /; a < b
exchange[{4, a_, u_}, _, _, _, {2, b_, v_}] :=
  {4, a, ReplacePart[u, v[[#]], #]&[
                       Random[Integer, {1, s}]]} /; a < b

All other individuals and empty sites remain unchanged.

exchange[z_, _, _, _, _] := z

The Program

charlesBarkley[n_, p_, s_, m_, t_] :=
Module[{society, RND, exchange, walk, vonNeumann, GN},

  RND := Random[Integer, {1, 4}];
  society = Table[Floor[p + Random[]], {n}, {n}] /. 1 :> 
     {RND, Random[], Table[Random[Integer, {1, m}], {s}]};
  
  exchange[{1, a_, u_}, {3, b_, v_}, _, _, _] := 
    {1, a, ReplacePart[u, v[[#]], #]&[
                      Random[Integer, {1, s}]]} /; a < b;
  exchange[{2, a_, u_}, _, {4, b_, v_}, _, _] :=
    {2, a, ReplacePart[u, v[[#]], #]&[
                      Random[Integer, {1, s}]]} /; a < b;
  exchange[{3, a_, u_}, _, _, {1, b_, v_}, _] :=
    {3, a, ReplacePart[u, v[[#]], #]&[
                      Random[Integer, {1, s}]]} /; a < b;
  exchange[{4, a_, u_}, _, _, _, {2, b_, v_}] :=
    {4, a, ReplacePart[u, v[[#]], #]&[
                      Random[Integer, {1, s}]]} /; a < b;
  exchange[z_, _, _, _, _] := z;
  
  walk[{1,a___},0,_,_,_,{4,___},_,_,_,_,_,_,_] := {RND,a};
  walk[{1,a___},0,_,_,_,_,_,_,{2,___},_,_,_,_] := {RND,a};
  walk[{1,a___},0,_,_,_,_,_,_,_,{3,___},_,_,_] := {RND,a};
  walk[{1,a___},0,_,_,_,_,_,_,_,_,_,_,_] := 0;
  walk[{2,a___},_,0,_,_,{3,___},_,_,_,_,_,_,_] := {RND,a};
  walk[{2,a___},_,0,_,_,_,{1,___},_,_,_,_,_,_] := {RND,a};
  walk[{2,a___},_,0,_,_,_,_,_,_,_,{4,___},_,_] := {RND,a};
  walk[{2,a___},_,0,_,_,_,_,_,_,_,_,_,_] := 0;
  walk[{3,a___},_,_,0,_,_,{4,___},_,_,_,_,_,_] := {RND,a};
  walk[{3,a___},_,_,0,_,_,_,{2,___},_,_,_,_,_] := {RND,a};
  walk[{3,a___},_,_,0,_,_,_,_,_,_,_,{1,___},_] := {RND,a};
  walk[{3,a___},_,_,0,_,_,_,_,_,_,_,_,_] := 0;
  walk[{4,a___},_,_,_,0,_,_,{1,___},_,_,_,_,_] := {RND,a};
  walk[{4,a___},_,_,_,0,_,_,_,{3,___},_,_,_,_] := {RND,a};
  walk[{4,a___},_,_,_,0,_,_,_,_,_,_,_,{2,___}] := {RND,a};
  walk[{4,a___},_,_,_,0,_,_,_,_,_,_,_,_] := 0;
  walk[{_,a___},_,_,_,_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,{3,___},{4,___},_,_,_,_,_,_,_,_,_,_] := 0;
  walk[0,{3,___},_,{1,___},_,_,_,_,_,_,_,_,_] := 0;
  walk[0,{3,___},_,_,{2,___},_,_,_,_,_,_,_,_] := 0;
  walk[0,_,{4,___},{1,___},_,_,_,_,_,_,_,_,_] := 0;
  walk[0,_,{4,___},_,{2,___},_,_,_,_,_,_,_,_] := 0;
  walk[0,_,_,{1,___},{2,___},_,_,_,_,_,_,_,_] := 0;
  walk[0,{3,a___},_,_,_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,{4,a___},_,_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,_,{1,a___},_,_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,_,_,{2,a___},_,_,_,_,_,_,_,_] := {RND,a};
  walk[0,_,_,_,_,_,_,_,_,_,_,_,_] := 0;
     
  vonNeumann[func_, lat_] := 
    MapThread[func, Map[RotateRight[lat, #]&,
          {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1}}], 2];

  GN[func_, lat_] :=
    MapThread[func, Map[RotateRight[lat, #]&,
            {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1},
             {1, -1}, {-1, -1}, {-1, 1}, {1, 1}, {2, 0},
             {0, -2}, {-2, 0}, {0, 2}}], 2];
  
  NestList[GN[walk, vonNeumann[exchange, #]]&, society, t]]

Running the Simulation

We run the charlesBarkley program on a 25 by 25 lattice having a 70% population of individuals with two memes, each of which can have two possible values, over 500 time steps, and look at the resulting graphics of the initial and final states of the system.

SeedRandom[7]
results = charlesBarkley[25, 0.7, 2, 2, 500];

We can look at a percentile bar chart of the number of individuals with common meme lists.

<<Graphics`;
countCultures[lat_] := Map[Count[lat, {_, _, #}, 2]&,
                       {{1, 1}, {1, 2}, {2, 1}, {2, 2}}];
counts[res_] := Map[countCultures,
                               res[[Range[1, 500, 25]]]];
Apply[PercentileBarChart, Transpose[counts[results]]];

Comparing this figure to the corresponding figures for the cultureSpreadingShared and cultureSpreadingCloseness programs, we see that the percentage of individuals with the same set of meme values changes over time to a much greater extent in the charlesBarkley program.

Thus, the presence of individuals who can serve as role models for others seems to dramatically increase the convergence of the society towards a common meme list and shared values. This is known as a social norm.

Clustering of Like-Minded Individuals

To answer these questions, it would be useful to be able to identify clusters of individuals with shared values, where a cluster is a set of contiguous lattice sites that are populated by individuals whose meme lists are identical. We can easily determine the number and location of these clusters as follows.

We first assign to each individual (each occupied site) on the lattice, a unique number that represents the individual's cluster number. This number is appended to the individual's attribute list using

k = 0;
latCluster = lattice /. {a_, memes_List} :> {a, memes, ++k}

We now apply the following transformation to the lattice: each individual's cluster number is changed to equal the maximum cluster number among those of his five nearest neighbors (including himself) who have the same meme list as he has. This can be done with the following rewrite rules.

renumber[0, __] := 0
renumber[{a_, memes_List, c_}, res__] := 
       {a, memes, Max[c, Cases[{res}, {_, memes, d_} :> d]]}

The renumber rules are applied to the lattice using

vonNeumann[renumber, latCluster]

where

vonNeumann[func_, lat_] := 
  MapThread[func, Map[RotateRight[lat, #]&,
          {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1}}], 2]

If we perform this relabeling of cluster numbers repeatedly until the lattice configuration no longer changes, each individual in a cluster of individuals with the same meme list will then have the same cluster number as the highest numbered individual in that cluster. This can be done by employing the built-in function FixedPoint.

FixedPoint[vonNeumann[renumber, #]&, latCluster]

Note: The clusters are not numbered consecutively (1, 2, 3, …) by this procedure, although it is very simple to create a set of transformation rules to produce consecutive cluster numbers if that is desirable.

Combining these code fragments, we can create the folowing cluster identification function.

clusterNumbering[lattice_] :=
Module[{k, latCluster, renumber, vonNeumann},
  k = 0;
  latCluster = lattice /. {a_, memes_List} :> {a, memes, ++k};
  
  renumber[0, __] := 0;
  renumber[{a_, memes_List, c_}, res__] :=
      {a, memes, Max[c, Cases[{res}, {_, memes, d_} :> d]]};

  vonNeumann[func_, lat_] := 
    MapThread[func, Map[RotateRight[lat, #]&,
          {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0, 1}}], 2];
  
  FixedPoint[vonNeumann[renumber, #]&, latCluster]]

References

Axelrod, Robert. 1997. The Complexity of Cooperation: Agent-Based Models of Competition and Cooperation. Princeton, NJ: Princeton University Press.
Gaylord, Richard J. and Louis J. D'Andria. 1998. SIMULATING SOCIETY: A Mathematica Toolkit for Modeling Socioeconomic Behavior. New York: TELOS/Springer-Verlag. 
Gaylord, Richard J. and Louis J. D'Andria. 1998. Modeling a Society of Mobile Heterogeneous Individuals, Mathematica in Education and Research, 7(3), xx - yy. 
Gaylord, Richard J. and Louis J. D'Andria. 1998. Transmitting Culture Part I, Mathematica in Education and Research, 7(4), xx - yy.