Mathematica in Education and Research

"Social Simulations" Column
by
Richard J. Gaylord and Louis J. D'Andria

Transmitting Culture
Part I

Introduction

How do people come to have shared values based on ideas, beliefs, likes and dislikes, or attitudes? One possible mechanism for the spreading of values through a population is through a sort of contagious process, occurring as individuals come into contact with one another and interact. This interaction results in a form of imitative behavior sometimes referred to as cultural transmission or social learning. In this and the next column, we will look at several models of the change of values in a mobile society. In later columns, we will use some of the ideas employed in these cultural transmission models to examine various other socioeconomic behaviors.

The More Alike We Are, the More Alike We Become

Axelrod [Axelrod, 1997] has proposed a model for the transmission of culture. Using a square lattice, each lattice site is occupied by an agent (known as a homogeneous village) and the lattice has absorbing boundaries so villages on the interior of the lattice have four nearest neighbors (to the north, east, south, and west), villages on the edge of the lattice have three nearest neighbors, and corner villages have two nearest neighbors. A village is characterized by having five attributes (called features), each of which has an integer value (called a trait) ranging from 1 to 10. The system evolves over a number of time steps.

At each time step, one village (called the active village) is randomly chosen. This active village randomly selects a village on a nearest neighbor site. The active village interacts with the selected village as follows: a comparison is made between the traits of corresponding features of the two villages. If the traits of each corresponding feature are the same (e.g., {5, 9, 1, 3, 2} and {5, 9, 1, 3, 2}), nothing happens. If any of the traits of the features of the active village differ from the trait of the corresponding feature of the selected village, then a cultural interaction occurs with a probability equal to the fraction of features that share the same trait, that is, to their degree of cultural similarity. For example, if the traits of the active village's features are {3, 2, 1, 7, 5} and the traits of the selected village's features are {4, 8, 1, 2, 5}, then there is 40% probability that the villages will interact culturally because the traits of the third and fifth features of the two villages are identical. If a cultural interaction does occur, it is carried out by randomly choosing one of the features of the active village which has a different trait from the trait of the corresponding feature of the selected village and changing the active village's feature trait to that of the trait of the selected village's corresponding feature. Thus, if the active village having features {3, 2, 1, 7, 5} does interact with the selected village having features {4, 8, 1, 2, 5}, the interaction will be carried out by randomly choosing the first, second, or fourth feature of the active village and changing its trait to the trait of the corresponding feature of the selected village, so that if, for example, the second feature is chosen, the active village ends up with feature traits of {3, 8, 1, 7, 5}. This process continues until the system becomes invariant.

The Axelrod model is quite elegant in its simplicity (a fundamental rule of scientific model building is to follow the dictums of both the military, "keep it simple, stupid" (the KISS principle), and Albert Einstein, "a [model] should be as simple as possible, but no simpler"). We can make two modifications to the model that will extend its usefulness, while maintaining its essential simplicity.

Axelrod states that "since there is no movement in the model, the sites themselves can be thought of as homogenous villages." If some of the lattice sites were empty and other sites were occupied by individuals, the model could be applied to a mobile society using the walk rules developed in the previous column.

The pair-wise interaction between villages in the Axelrod model is one-way or unilateral in that a randomly chosen active village changes the trait of its features as a result of its interaction with a selected nearest neighbor village, and the selected village is left unchanged.

In our variant of the Axelrod model, individuals roam around a lattice, carrying with them cultural attributes, and altering these attributes as they engage in bilateral interactions with individuals they encounter along the way.

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 agents have identical meme lists.

Note: The term meme was coined by Richard Dawkins to represent the basic unit of cultural transmission, analogous to the gene which is the basic unit of genetic transmission.

Populating Society

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

The code for creating this system is given by:

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

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 follows the Axelrod model, except that it 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 with a probability equal to the percentage of memes that share the same value. If cultural transmission does occur, it is carried out by randomly choosing one of the memes whose value differs for the two individuals and changing that value for both individuals.

For example, if the south-facing individual's meme list is {3, 2, 1, 7, 5} and its north-facing neighbor's meme list is {4, 8, 1, 2, 5}, there is a 60% probability that the meme list will remain unchanged and a 40% probability that the value of the first, second, or fourth meme of each individual will be changed to an integer value somewhere between the values of that meme for the two individuals (thus, if the second meme were randomly chosen, the individuals' meme lists would become {3, x, 1, 7, 5} and {4, x, 1, 2, 5}, where x is a randomly chosen integer between 2 and 8.

We first let individuals facing one another on adjacent sites decide which meme to change and what the meme's value should be. The actual change will take place on the next partial-step. 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 the south (east) facing individual decide for both himself and his north (west) facing neighbor.

The lattice sites are updated using the following rules.

decide[{3, y_}, _, _, {1, y_}, _] := {3, y}
decide[{2, y_}, _, {4, y_}, _, _] := {2, y}
decide[{3, y_}, _, _, {1, z_}, _] := Module[
  {diffs = Flatten[Position[Abs[y - z], _?Positive]]},
  {3, y, Random[Integer, {y[[#]], z[[#]]}], #}&[
         diffs[[Random[Integer, {1, Length[diffs]}]]]] /;
                  Random[Integer, {1,s}] > Length[diffs]]
decide[{2, y_}, _, {4, z_}, _, _] := Module[
  {diffs = Flatten[Position[Abs[y - z], _?Positive]]},
  {2, y, Random[Integer, {y[[#]], z[[#]]}], #}&[
         diffs[[Random[Integer, {1, Length[diffs]}]]]] /;
                  Random[Integer, {1,s}] > Length[diffs]]
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 there is no change in meme list 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.

The calculation involved in the execution of these two rules can be illustrated using the two meme lists, {3, 2, 1, 7, 5} and {4, 8, 1, 2, 5}. The following calculations occur.

The third and fourth decide rules are applied with a probability equal to the number of memes that share the same value. To do this, the condition Random[Integer, {1, s}] > Length[diffs] is used. For our example, we would have Random[Integer, {1, 5}] > 3 so that for facing individuals with nonidentical meme lists, these rules would be applied 40% of the time. The rest of the time, the individuals would follow the fifth decide rule.

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]

Exchanging Meme Values

Having decided the nature of the cultural exchange, we can carry out the exchange, 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 two exchange rules use these values, which are given by the third and fourth list elements, to make the change in these persons. The next two 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 our 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

cultureSpreadingShared[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[{3, y_}, _, _, {1, z_}, _] := Module[
    {diffs = Flatten[Position[Abs[y - z], _?Positive]]},
    {3, y, Random[Integer, {y[[#]], z[[#]]}], #}&[
         diffs[[Random[Integer, {1, Length[diffs]}]]]] /;
                 Random[Integer, {1,s}] > Length[diffs]];
  decide[{2, y_}, _, {4, z_}, _, _] := Module[
    {diffs = Flatten[Position[Abs[y - z], _?Positive]]},
    {2, y, Random[Integer, {y[[#]], z[[#]]}], #}&[
         diffs[[Random[Integer, {1, Length[diffs]}]]]] /;
                 Random[Integer, {1,s}] > Length[diffs]];
  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 cultureSpreadingShared program on a 25 by 25 lattice having a 70% population density of individuals, each of whom can have two possible values for each of its two memes, over 500 time steps.

SeedRandom[3];
results = cultureSpreadingShared[25, 0.7, 2, 2, 500];

The displayCulture function graphically depicts a lattice configuration, using different colors to represent different meme configurations and drawing empty sites in gray.

displayCulture[lat_] := 
  Show[Graphics[RasterArray[lat /.
      {0 -> RGBColor[0.5, 0.5, 0.5],
      {_Integer, {n_, m_}} :> RGBColor[n - 1, m - 1, 0]}]],
    AspectRatio -> Automatic];

Applying the displayCulture program to the lattice configurations generated by the program run at various times,

Show[GraphicsArray[
  {{displayCulture[results[[1]]],
    displayCulture[results[[167]]]},
   {displayCulture[results[[333]]],
    displayCulture[results[[500]]]}}]];

Another way to visualize the changes in the cultural composition of the society over time is to draw the area between two adjacent individuals in white if their meme lists are identical, and in darker shades as the differences in meme list values increase. We can illustrate this using the simulation run that produced the preceding raster array graphic and showing the initial and final lattice configurations.

similarities[0, __] := {1, 1, 1, 1};
similarities[x_, r__] :=  Map[Count[#, 0]&,
       Map[Last[x] - Last[#]&, {r} /. 0 :> x]] / 2.;

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

makeBlock[{a_, b_, c_, d_}, {x_, y_}] := {
  GrayLevel[a],
  Polygon[{{x, y}, {x, y + 1}, {x + .5, y + .5}}],
  GrayLevel[b],
  Polygon[{{x,  y + 1}, {x + 1, y + 1}, {x + .5, y + .5}}],
  GrayLevel[c],
  Polygon[{{x + 1, y}, {x + 1, y + 1}, {x + .5, y + .5}}],
  GrayLevel[d],
  Polygon[{{x,  y}, {x + 1, y}, {x + .5, y + .5}}]};

Show[GraphicsArray[{
  Graphics[MapIndexed[makeBlock,
        vonNeumann[similarities, results[[1]]], {2}]],
  Graphics[MapIndexed[makeBlock,
        vonNeumann[similarities, results[[-1]]], {2}]]}],
  AspectRatio -> Automatic];

Yet another way to see the convergence of shared values in a community over time is to look at the number of individuals that share meme lists. This can be done for a society of individuals having a meme list of 2 memes, each of which can have a value of 1 or 2, using the following code to generate a percentile bar chart of the number of individuals having a particular meme list, in this case {1, 1}, {1, 2}, {2, 1}, or {2, 2}.

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

Discussion

There appears to be no convergence of meme values in this model. One reason for this might be the mobility of the individuals in the population. Were movement to be either surpressed (which could be easily done by increasing the density of the population) or eliminated (which could be done by removing the walk rules which result in an agent moving while retaining the walk rules which result in an agent turning in place), the repeated interactions between individuals might be expected to result in a coming together in terms of shared values. In the next column, we will see that an alternative way of obtaining a common set of value in a population is by having role models who are emulated in the society.

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.