Regression and Other Stories: Last letters of names

Last letters of names - Distributions of last letters of names of American babies. See Chapter 2 in Regression and Other Stories.

---

Load packages

library("rprojroot")
root<-has_file(".ROS-Examples-root")$make_fix_file()

Load data

allnames <- read.csv(root("Names/data","allnames_clean.csv"))
girl <- as.vector(allnames$sex)=="F"
names <- as.vector(allnames$name)

Plot data

namelength <- nchar(names)
lastletter <- substr(names, namelength, namelength)
firstletter <- substr(names, 1, 1)

discrete.histogram <- function (x, prob, prob2=NULL,
    xlab="x", ylab="Probability", xaxs.label=NULL, yaxs.label=NULL, bar.width=NULL, ...){
  if (length(x) != length(prob)) stop()
  x.values <- sort (unique(x))
  n.x.values <- length (x.values)
  gaps <- x.values[2:n.x.values] - x.values[1:(n.x.values-1)]
  if (is.null(bar.width)) bar.width <- min(gaps)*.2
  par(mar=c(3,3,2,2), mgp=c(1.7,.3,0), tck=0)
  plot(range(x)+c(-1,1)*bar.width, c(0,max(prob)),
    xlab=xlab, ylab=ylab, xaxs="i", xaxt="n",  yaxs="i",
    yaxt=ifelse(is.null(yaxs.label),"s","n"), bty="l", type="n", ...)
  if (is.null(xaxs.label)){
    axis(1, x.values)
  }
  else {
    n <- length(xaxs.label[[1]])
    even <- (1:n)[(1:n)%%2==0]
    odd <- (1:n)[(1:n)%%2==1]
    axis(1, xaxs.label[[1]][even], xaxs.label[[2]][even], cex.axis=.9)
    axis(1, xaxs.label[[1]][odd], xaxs.label[[2]][odd], cex.axis=.9)
  }
  if (!is.null(yaxs.label)){
    axis(2, yaxs.label[[1]], yaxs.label[[2]], tck=-.02)
  }
  for (i in 1:length(x)){
    polygon(x[i] + c(-1,-1,1,1)*bar.width/2, c(0,prob[i],prob[i],0),
      border="gray10", col="gray10")
    if (!is.null(prob2))
      polygon(x[i] + c(-1,-1,1,1)*bar.width/10, c(0,prob2[i],prob2[i],0),
        border="red", col="black")
  }
}

for (year in c(1900,1950,2010)){
  thisyear <- allnames[,paste("X",year,sep="")]
  lastletter.by.sex <- array(NA, c(26,2))
  firstletter.by.sex <- array(NA, c(26,2))
  for (i in 1:26){
    lastletter.by.sex[i,1] <- sum(thisyear[lastletter==letters[i] & girl])
    lastletter.by.sex[i,2] <- sum(thisyear[lastletter==letters[i] & !girl])
    firstletter.by.sex[i,1] <- sum(thisyear[firstletter==LETTERS[i] & girl])
    firstletter.by.sex[i,2] <- sum(thisyear[firstletter==LETTERS[i] & !girl])
  }
  if (savefigs) pdf(root("Names/figs", paste("boys", year, ".pdf", sep="")),
                   height=3, width=4.5)
  discrete.histogram(1:26, 100*(lastletter.by.sex[,2])/sum(lastletter.by.sex[,2]), xaxs.label=list(1:26,letters), yaxs.label=list(seq(0,30,10),seq(0,30,10)), xlab="", ylab="Percentage of boys born", main=paste("Last letter of boys' names in", year), cex.axis=.9, cex.main=.9, bar.width=.8)
  for (y in c(10,20,30)) abline (y,0,col="gray",lwd=.5)
  if (savefigs) dev.off()
  if (savefigs) pdf(root("Names/figs", paste("girls", year, ".pdf", sep="")),
                   height=3, width=4.5)
  discrete.histogram(1:26, 100*(lastletter.by.sex[,1])/sum(lastletter.by.sex[,1]), xaxs.label=list(1:26,letters), yaxs.label=list(seq(0,30,10),seq(0,30,10)), xlab="", ylab="Percentage of girls born", main=paste("Last letter of girls' names in", year), cex.main=.9)
  if (savefigs) dev.off()
}

yrs <- 1880:2010
n.yrs <- length(yrs)
lastletterfreqs <- array(NA, c(n.yrs,26,2))
firstletterfreqs <- array(NA, c(n.yrs,26,2))
dimnames(lastletterfreqs) <- list(yrs, letters, c("girls","boys"))
dimnames(firstletterfreqs) <- list(yrs, letters, c("girls","boys"))
for (i in 1:n.yrs){
  thisyear <- allnames[,paste("X",yrs[i],sep="")]
  for (j in 1:26){
    lastletterfreqs[i,j,1] <- sum(thisyear[lastletter==letters[j] & girl])
    lastletterfreqs[i,j,2] <- sum(thisyear[lastletter==letters[j] & !girl])
    firstletterfreqs[i,j,1] <- sum(thisyear[firstletter==LETTERS[j] & girl])
    firstletterfreqs[i,j,2] <- sum(thisyear[firstletter==LETTERS[j] & !girl])
  }
  for (k in 1:2){
    lastletterfreqs[i,,k] <- lastletterfreqs[i,,k]/sum(lastletterfreqs[i,,k])
    firstletterfreqs[i,,k] <- firstletterfreqs[i,,k]/sum(firstletterfreqs[i,,k])
  }
}

par(mar=c(2,2,1,1), mgp=c(1.7,.3,0), tck=-.01, oma=c(0,0,2,0), mfrow=c(2,3))
popular <- rev(order(lastletterfreqs[1,,2]))[1:6]
for (k in 1:length(popular)){
  plot(range(yrs), c(0,50), type="n", xlab="", ylab="", bty="l", xaxt="n", yaxt="n", yaxs="i", xaxs="i")
  axis(1, seq(1900,2000,50))
  axis(2, seq(0,40,20), paste(seq(0,40,20), "%", sep=""))
  mtext(paste(". . .", LETTERS[popular[k]]), side=3, line=-1, cex=.8)
  for (j in 1:26){
    maxfreq <- max(lastletterfreqs[,j,2])
    best <- (1:n.yrs)[lastletterfreqs[,j,2]==maxfreq]
    lines(yrs, 100*lastletterfreqs[,j,2], col=if (j==popular[k]) "black" else "darkgray", lwd=if (j==popular[k]) 1 else .5)
  }
}
mtext("Last letters of boys' names", side=3, outer=TRUE, line=.5)

par(mar=c(2,3,2,1), mgp=c(1.7,.3,0), tck=-.01)
popular <- c(14,25,4)
width <- rep(.5,26)
type <- rep(1,26)
width[popular] <- c(2,3,3)
type[popular] <- c(1,3,2)
plot(range(yrs), c(0,41), type="n", xlab="", ylab="Percentage of all boys' names that year", bty="l", xaxt="n", yaxt="n", yaxs="i", xaxs="i")
  axis(1, seq(1900,2000,50))
  axis(2, seq(0,40,20), paste(seq(0,40,20), "%", sep=""))
  for (j in 1:26){
    maxfreq <- max(lastletterfreqs[,j,2])
    best <- (1:n.yrs)[lastletterfreqs[,j,2]==maxfreq]
    lines(yrs, 100*lastletterfreqs[,j,2], col="black", lwd=width[j], lty=type[j])
  }
text(2000, 35, "N")
text(1935, 20, "D")
text(1975, 15, "Y")
mtext("Last letters of boys' names", side=3, line=.5)

par(mar=c(2,3,2,1), mgp=c(1.7,.3,0), tck=-.01)
popular <- c(14,25,4)
plot(range(yrs), c(0,41), type="n", xlab="", ylab="Percentage", bty="l", xaxt="n", yaxt="n", yaxs="i", xaxs="i")
  axis(1, seq(1900,2000,50))
  axis(2, seq(0,40,20), paste(seq(0,40,20), "%", sep=""))
  for (j in 1:26){
    maxfreq <- max(firstletterfreqs[,j,2])
    best <- (1:n.yrs)[firstletterfreqs[,j,2]==maxfreq]
    if (j %in% popular){
      lines(yrs, 100*firstletterfreqs[,j,2], col="black", lwd=2)
    }
    else{
      lines(yrs, 100*firstletterfreqs[,j,2], col="black", lwd=.5)
    }
  }
mtext("First letters of boys' names", side=3, line=.5)

Stuff for NYT column

dim(lastletterfreqs[,,2])

[1] 131  26

round(lastletterfreqs[yrs>2005,,2], 2)  # 35% end in n

        a    b    c    d    e f g    h    i j    k    l    m    n    o p q    r
2006 0.02 0.02 0.01 0.03 0.07 0 0 0.05 0.02 0 0.02 0.08 0.02 0.35 0.05 0 0 0.09
2007 0.02 0.02 0.01 0.02 0.07 0 0 0.05 0.02 0 0.02 0.08 0.02 0.36 0.05 0 0 0.09
2008 0.02 0.02 0.01 0.02 0.07 0 0 0.05 0.02 0 0.02 0.07 0.02 0.36 0.05 0 0 0.09
2009 0.02 0.02 0.01 0.02 0.07 0 0 0.05 0.02 0 0.02 0.07 0.02 0.36 0.04 0 0 0.09
2010 0.01 0.02 0.01 0.02 0.07 0 0 0.05 0.02 0 0.02 0.07 0.02 0.36 0.04 0 0 0.09
        s    t u v    w    x    y z
2006 0.07 0.02 0 0 0.02 0.01 0.06 0
2007 0.07 0.02 0 0 0.02 0.01 0.06 0
2008 0.07 0.02 0 0 0.02 0.01 0.06 0
2009 0.07 0.02 0 0 0.02 0.01 0.06 0
2010 0.07 0.02 0 0 0.02 0.01 0.06 0

round(lastletterfreqs[yrs>2005,,1], 2)  # 38% of all girls end in a

        a b c d    e f g    h    i j k    l m    n o p q    r    s    t u v w x
2006 0.40 0 0 0 0.17 0 0 0.07 0.03 0 0 0.03 0 0.13 0 0 0 0.02 0.01 0.01 0 0 0 0
2007 0.39 0 0 0 0.17 0 0 0.07 0.03 0 0 0.03 0 0.14 0 0 0 0.02 0.01 0.01 0 0 0 0
2008 0.38 0 0 0 0.18 0 0 0.07 0.03 0 0 0.03 0 0.14 0 0 0 0.02 0.01 0.01 0 0 0 0
2009 0.38 0 0 0 0.18 0 0 0.08 0.03 0 0 0.03 0 0.14 0 0 0 0.02 0.01 0.01 0 0 0 0
2010 0.38 0 0 0 0.18 0 0 0.08 0.03 0 0 0.03 0 0.14 0 0 0 0.02 0.01 0.01 0 0 0 0
        y z
2006 0.12 0
2007 0.12 0
2008 0.12 0
2009 0.12 0
2010 0.12 0

1950

round(lastletterfreqs[yrs==1950,,2], 2)  # 14% end in n (tied with d, s, and y as most popular)

   a    b    c    d    e    f    g    h    i    j    k    l    m    n    o    p 
0.00 0.00 0.00 0.15 0.09 0.00 0.00 0.04 0.00 0.00 0.03 0.10 0.04 0.14 0.01 0.01 
   q    r    s    t    u    v    w    x    y    z 
0.00 0.03 0.14 0.07 0.00 0.00 0.00 0.00 0.14 0.00 

round(lastletterfreqs[yrs==1950,,1], 2)  # 34% of all girls end in a

   a    b    c    d    e    f    g    h    i    j    k    l    m    n    o    p 
0.34 0.00 0.00 0.00 0.22 0.00 0.00 0.05 0.01 0.00 0.00 0.04 0.00 0.15 0.00 0.00 
   q    r    s    t    u    v    w    x    y    z 
0.00 0.00 0.02 0.02 0.00 0.00 0.00 0.00 0.14 0.00 

1900

round(lastletterfreqs[yrs==1900,,2], 2)  # 14% end in n (tied with d, s, and y as most popular)

   a    b    c    d    e    f    g    h    i    j    k    l    m    n    o    p 
0.01 0.00 0.00 0.10 0.15 0.00 0.00 0.04 0.00 0.00 0.04 0.06 0.07 0.14 0.01 0.00 
   q    r    s    t    u    v    w    x    y    z 
0.00 0.07 0.13 0.07 0.00 0.00 0.01 0.00 0.08 0.00 

round(lastletterfreqs[yrs==1900,,1], 2)  # 34% of all girls end in a

   a    b    c    d    e    f    g    h    i    j    k    l    m    n    o    p 
0.30 0.00 0.00 0.01 0.36 0.00 0.00 0.05 0.00 0.00 0.00 0.05 0.00 0.06 0.00 0.00 
   q    r    s    t    u    v    w    x    y    z 
0.00 0.01 0.03 0.02 0.00 0.00 0.00 0.00 0.10 0.00 

Most popular names in any given year

boy.names <- names[!girl]
girl.names <- names[girl]
for (year in c(1900,1950,2010)){
  thisyear <- allnames[,paste("X",year,sep="")]
  boy.totals <- thisyear[!girl]
  boy.proportions <- boy.totals/sum(boy.totals)
  index <- rev(order(boy.proportions))
  popular.names <- boy.names[index]
  popularity <- boy.proportions[index]
  print(year)
  print(popular.names[1:30])
  round(popularity[1:30],3)
  print(c(sum(popularity[1:10]), sum(popularity[1:20]), sum(popularity[1:30]), sum(popularity[1:50]), sum(popularity[1:100])))
}

[1] 1900
 [1] "John"     "William"  "James"    "George"   "Charles"  "Robert"  
 [7] "Joseph"   "Frank"    "Edward"   "Henry"    "Thomas"   "Walter"  
[13] "Harry"    "Willie"   "Arthur"   "Albert"   "Fred"     "Clarence"
[19] "Paul"     "Harold"   "Roy"      "Joe"      "Raymond"  "Richard" 
[25] "Charlie"  "Louis"    "Jack"     "Earl"     "Carl"     "Ernest"  
[1] 0.3433763 0.4666782 0.5401941 0.6310008 0.7491101
[1] 1950
 [1] "James"   "Robert"  "John"    "Michael" "David"   "William" "Richard"
 [8] "Thomas"  "Charles" "Gary"    "Larry"   "Ronald"  "Joseph"  "Donald" 
[15] "Kenneth" "Steven"  "Dennis"  "Paul"    "Stephen" "George"  "Daniel" 
[22] "Edward"  "Mark"    "Jerry"   "Gregory" "Bruce"   "Roger"   "Douglas"
[29] "Frank"   "Terry"  
[1] 0.3384098 0.4769608 0.5572918 0.6489598 0.7768003
[1] 2010
 [1] "Jacob"       "Ethan"       "Michael"     "Jayden"      "William"    
 [6] "Alexander"   "Noah"        "Daniel"      "Aiden"       "Anthony"    
[11] "Joshua"      "Mason"       "Christopher" "Andrew"      "David"      
[16] "Matthew"     "Logan"       "Elijah"      "James"       "Joseph"     
[21] "Gabriel"     "Benjamin"    "Ryan"        "Samuel"      "Jackson"    
[26] "John"        "Nathan"      "Jonathan"    "Christian"   "Liam"       
[1] 0.08965114 0.16407578 0.22514563 0.32102364 0.46921162

n_percentage <- 100*lastletterfreqs[,14,2]
topten_percentage <- array(NA, c(length(yrs), 2))
for (i in 1:length(yrs)){
  thisyear <- allnames[,paste("X",yrs[i],sep="")]
  boy.totals <- thisyear[!girl]
  boy.proportions <- boy.totals/sum(boy.totals)
  index <- rev(order(boy.proportions))
  popular.names <- boy.names[index]
  popularity <- boy.proportions[index]
  topten_percentage[i,2] <- 100*sum(popularity[1:10])
  girl.totals <- thisyear[girl]
  girl.proportions <- girl.totals/sum(girl.totals)
  index <- rev(order(girl.proportions))
  popular.names <- girl.names[index]
  popularity <- girl.proportions[index]
  topten_percentage[i,1] <- 100*sum(popularity[1:10])
}

par(mar=c(4,2,1,0), mgp=c(1.3,.2,0), tck=-.02)
plot(yrs, n_percentage, type="l", xaxt="n", yaxt="n", xaxs="i", yaxs="i", ylim=c(0,45), bty="l", xlab="Year", ylab="", cex.lab=.8)
axis(1, c(1900,1950,2000), cex.axis=.8)
axis(2, c(0,20,40), c("0%","20%","40%"), cex.axis=.8)
mtext("Percentage of new boys' names each year ending in 'n'", cex=.8)
mtext("Source:  Social Security Administration, courtesy of Laura Wattenberg", 1, 2.5, cex=.5, adj=0)

par(mar=c(4,2,1,0), mgp=c(1.3,.2,0), tck=-.02)
plot(yrs, topten_percentage[,2], type="l", xaxt="n", yaxt="n", xaxs="i", yaxs="i", ylim=c(0,45), bty="l", xlab="Year", ylab="", cex.lab=.8)
lines(yrs, topten_percentage[,1])
axis(1, c(1900,1950,2000), cex.axis=.8)
axis(2, c(0,20,40), c("0%","20%","40%"), cex.axis=.8)
text(1902, 35, "Boys", cex=.75, adj=0)
text(1911, 20, "Girls", cex=.75, adj=0)
mtext("Total popularity of top ten names each year, by sex", cex=.8)
mtext("Source:  Social Security Administration, courtesy of Laura Wattenberg", 1, 2.5, cex=.5, adj=0)