# Schelling’s Neighborhood Model

April 30, 2011
By

(This article was first published on mickeymousemodels, and kindly contributed to R-bloggers)

The New York Times has created a beautiful visualization of the Census Bureau's 2005-2009 American Community Survey data. The distribution of racial and ethnic groups in New York City is particularly fascinating:

Chinatown appears in red toward the south-eastern end of Manhattan; Harlem, above Central Park, is solidly blue; nearby, Spanish Harlem is mostly yellow; and the Upper East Side is solidly green. (Read the map key if none of this is making sense.) In general, many neighborhoods are segregated, in the sense of being inhabited predominantly by one ethnic group. How does this happen?

When I saw the New York Times' map I thought immediately of Schelling's neighborhood model, which provides a simple and yet somewhat unexpected explanation for spatial segregation. Here's how it works: everyone would prefer to live in a neighborhood where a fraction >= f of their neighbors are of the same race; and if anyone is unhappy, they move. The striking result is that, even with a fairly tolerant f -- say, 30% -- people's movements will end up creating extremely segregated neighborhoods. That's the surprising bit: despite being perfectly happy when up to (say) 70% of their neighbors are of a different race, the people in Schelling's model end up living in neighborhoods that are almost entirely same-race. Let's see if I can get this into a little R simulation:

# Number of peoplen <- 10000# The people will live in a square with area side^2side <- ceiling(sqrt(n))df <- data.frame(x=((0:(n-1)) %% side),                 y=floor((0:(n-1)) / side), row.names=0:(n-1))# Most lots will have a race; some will be empty, ie uninhabitedraces <- c("forestgreen", "dodgerblue", "darkred")# Assign races iid uniformly; leave roughly 10% of lots emptydf$race <- sample(c(races, "empty"), n, replace=TRUE, prob=c(rep(0.90 / length(races), length(races)), 0.10))PlotNeighborhood <- function() { with(subset(df, race != "empty"), plot(x, y, col=race, pch=20, axes=FALSE, xlab="", ylab="", xlim=c(0, side), ylim=c(0, side), main="A Schelling-esque Neighborhood"))}dev.new(height=8, width=8)par(mar=rep(1, 4), oma=rep(1, 4))PlotNeighborhood()savePlot("neighborhood_before_movement.png")# Neighbors are counted within a Chebyshev distance <= depthdepth <- 3CountNeighbors <- function(i) { # Count people of each race in person i's immediate neighborhood curr.x <- i %% side curr.y <- floor(i / side) neighbors <- subset(df, x %in% (curr.x - depth):(curr.x + depth) & y %in% (curr.y - depth):(curr.y + depth) & !(curr.x == x & curr.y == y)) return(sapply(races, function(x) { sum(neighbors$race == x) }))}# Apply CountNeighbors to the entire data frame; append results to dfdf <- cbind(df, t(sapply(0:(n - 1), CountNeighbors)))df$num.neighbors <- rowSums(df[ , races])# Minimum fraction of own-race neighborsfraction <- 0.30GetPeopleWhoWantToMove <- function(curr.race) { subset.who.want.to.move <- subset(df, race == curr.race & get(curr.race) / num.neighbors < fraction) return(rownames(subset.who.want.to.move))}AdjustNeighborCounts <- function(row, race.of.mover, delta) { curr.x <- as.integer(row) %% side curr.y <- floor(as.integer(row) / side) df[df$x %in% (curr.x - depth):(curr.x + depth) &     df$y %in% (curr.y - depth):(curr.y + depth) & !(curr.x == df$x & curr.y == df$y), c(race.of.mover, "num.neighbors")] <<- df[df$x %in% (curr.x - depth):(curr.x + depth) &          df$y %in% (curr.y - depth):(curr.y + depth) & !(curr.x == df$x & curr.y == df$y), c(race.of.mover, "num.neighbors")] + delta}MoveOnePerson <- function() { # Returns 1 if a person was successfully moved, and 0 otherwise people.who.want.to.move <- c(lapply(races, GetPeopleWhoWantToMove), recursive=TRUE) if (!length(people.who.want.to.move) >= 1) return(0) # Of people who want to move, pick one uniformly at random person.who.will.move <- sample(people.who.want.to.move, size=1) race.of.mover <- df$race[rownames(df) == person.who.will.move]  possible.new.homes <- rownames(    subset(df, race == "empty" &               get(race.of.mover) / num.neighbors >= fraction))  if (!length(possible.new.homes) >= 1) return(0)  # Of acceptable new homes, choose one uniformly at random  new.home <- sample(possible.new.homes, size=1)  df[rownames(df) == new.home, ]$race <<- race.of.mover df[rownames(df) == person.who.will.move, ]$race <<- "empty"  AdjustNeighborCounts(person.who.will.move, race.of.mover, -1)  AdjustNeighborCounts(new.home, race.of.mover, +1)  return(1)}RunSimulation <- function(max.movements = 5000, plots.in.loop=TRUE) {  par(mar=rep(1, 4), oma=rep(1, 4))  for(i in 1:max.movements) {    if (!MoveOnePerson()) break    if (plots.in.loop & (i %% 50) == 0) PlotNeighborhood()  }}library(animation)saveVideo(RunSimulation(),          video.name="schelling_neighborhood_model.mp4",          interval=0.20, outdir=getwd())dev.new(height=8, width=8)par(mar=rep(1, 4), oma=rep(1, 4))PlotNeighborhood()savePlot("neighborhood_after_movement.png")

Here's the initial neighborhood, before anyone moves around:

As you can see, people are scattered around randomly, and there are no large same-race areas. But this cannot last long: it is very likely that someone will want to move; by moving, they must increase the homogeneity of their new neighborhood; and in doing so, they may cause someone to become unhappy and move out. The process is self-perpetuating. Here is the same neighborhood, post-movement:

And just for fun, here's the animation:

The purpose of this model is to demonstrate how a slight preference for own-race neighbors can lead to extremely segregated neighborhoods. In Schelling's words, "a moderate urge to avoid small-minority status may cause a nearly integrated pattern to unravel, and highly segregated neighborhoods to form." The group's aggregate behavior is not actually desired by any individual; and, therefore, observing a segregated neighborhood does not allow us to conclude that its inhabitants desire segregation.