How-to estimate someones age based on their twitter username using R?

When analyzing social media data (such as tweets) it is often the case that you want to understand the demographics of the people that you are studying e.g. age, sex, nationality or where they live. Unfortunately this data is not given so the analyst needs to infer this from what is normally available e.g.  username, user profile picture, tweets content and geotags.

This blog post looks at the challenge predicting someones age based on their user name. There are of course alternative approaches such as predicting age based on facial recognition of profile picture but this type of machine learning is beyond the scope of this blog-post.

The approach I take in this post is inspired by Nate Silver’s post on fivethirtyeight.com which is as follows:

  1. Pattern match the username against a database of known first names thus outputting the first name of best fit
  2. Given a first name, estimate the probability that they were born in each year between 1920 – present day.

Unlike Nate Silver’s post I will be sharing R code so that you can build you own solution and I’ll also be dealing with the case where you’ve only got rank data e.g. a list of top 100 names rather than a full census that includes the frequency of names.

Pattern Matching against username

To perform the pattern matching exercise you’ll need a database of first names – one reasonable source of names is the Social Security Administration popular names list. This amazingly gives you every first name registered in the USA between 1880 – 2014 that has been used >= 5 times, along with gender and the number of times it was used in a particular year.

To find the name of best fit one can use grep for pattern matching – here’s a code snippet below to illustrate the process:

dataset <- data.frame( firstname =  c('bob','terry','jimmy', 'steve'))
username <- tolower ( 'amazingTerry2015' )

matches <- function ( username , dataset )
{
	matches <- vector (  mode = "logical" , length( dataset$firstname ) )
	for ( i in 1:length(dataset$firstname))
	{
		matches[i] <- grepl( dataset$firstname[i] , username )
	}
	return ( matches )
}

In situations where you have multiple matches on a first name a useful heuristic is to select the longest name that matches. This takes care of situations where one name is a derivative of another e.g. Jack and Jacky. Clearly this process is not fool proof  you might get a username like “Zoe Davidson” and accidentally match onto David as a first name. To avoid these cases you may wish to take into account ordering of the match but for my purposes I ignore them and treat them as random noise.

Given a first name estimate the probability that they were born in each decade between 1920 – present day.

To estimate the probability of a first name for a given decade (or year) you’ll need to know what proportion of people with the selected first name are still alive from each year. This means you’ll want to know:

  • [A] what proportion of people with name x were born in a particular year?
  • [B] of those people born with name x how many a still alive today?

To answer question [A] one can simply look-up the value within the Social Security Administration popular names list or a similar alternative for the country you’re interested in. When performing a look up in these tables you’ll get a name, a year and a number of births e.g Emma, 1985, 940.

To answer question [B] one can simply look-up the probability of person born in 1985 still being alive today using a life table. You can get life tables for many countries from http://www.mortality.org. For example, in 1985 a female born in the USA has a probability of 0.9789 to be still alive today.

One can then simply put the answers of question [A] and [B] together giving you the number of Emma’s from 1985 whom are still alive today – which is ~920 (940 * 0.9789). If we then calculate this for each year from 1920 to present day then we can trivially calculate the probability of Emma being born between 1920 -> present day by normalizing the values by the total number of Emma’s still alive.

What can you do if you only have rank data?

The above approach won’t work when you are provided with rank data (a league table of popular names). This is the case for the United Kingdom which only provides the top 100 baby names by decade for historical purposes. In these situations you’re going to have to map ranks to number of children born per year with a specific name. My approach for performing this mapping is as follows:

  • [A] Get number of people born in year of interest [Table of Birth statistics]
  • [B] Get number of people still alive that are born in year of interest [Life table]
  • [C] Estimate what proportion of people are assigned names of rank 1, 2, 3, 4, 5, … and so on.

To answer question [A] a table of birth statistics can be downloaded from mortality.org. To answer [B] you can use the life table from mortality.org that we used previously. To answer [C] one can either assume a Zipfian distribution or fit your distribution to some empirical data e.g. 2013 UK Boys Names which includes frequency values. I opted for the second approach as research suggests that there is no simple intuitive distribution that names fit but may be approximated using a combination beta and exponential distributions.

Using the above described approach I obtained the following age distribution estimates for UK ranked data:

Estimate of Age Distribution of Jack
Estimate of Age Distribution of Jack
Age Distribution Estimation of Emma
Age Distribution Estimation of Emma
Age Distribution Estimation of Andrew
Age Distribution Estimation of Andrew

Example code

setwd ( "/Users/davidgreenwood/Dropbox/Play Projects/EstimateAge" )
ukbirths <- read.csv("UKYearBirths.csv")
malerank2013 <- read.csv("BoysNames2013.csv" , stringsAsFactors = FALSE )
femalerank2013 <- read.csv("GirlsNames2013.csv" , stringsAsFactors = FALSE )

#Male info
malenameshist <- read.csv("MaleNamesHistoric.csv" , stringsAsFactors = FALSE )
malelifetbl <- read.csv("malelifetable.csv")
#Female info
femalenameshist <- read.csv("FemaleNamesHistoric.csv" , stringsAsFactors = FALSE )
femalelifetbl <- read.csv("femalelifetable.csv")

normalized = function ( x )
{
  normalized = x / sum(x)
}

malerank2013$Pr <- normalized ( malerank2013$Count )
femalerank2013$Pr <- normalized ( femalerank2013$Count )

#GetRankForName
getRankForName <- function ( firstName , yr, gender )
{
    if ( gender == "M")
    {
        i = floor ((yr - 1900) / 10 ) + 2
        r <- malenameshist$RANK [ malenameshist[,i] == firstName ]
        if ( length(r) == 0 ) r<- -1
        return ( r )
    }
    
    if ( gender == "F")
    {
      i = floor ((yr - 1900) / 10 ) + 2
      r <- femalenameshist$RANK [ femalenameshist[,i] == firstName ]
      if ( length(r) == 0 ) r<- -1
      return ( r )
    }
    
    
    return (-1)
}

#GetPrForRank
getPrForRank <- function ( rank , gender )
{
  if ( gender == "M")
  {
    return ( malerank2013[ rank+1 , 4 ] )
  }
  
  if ( gender == "F")
  {
    return ( femalerank2013[ rank+1 , 4 ] )
  }
  
  return (-1)
}

#GetPrStillAlive
getPrStillAlive <- function ( yr , today , gender )
{
  if ( gender == "M")
  {
  age <- today  - yr
  lx = subset ( malelifetbl , Year==yr & Age == age , select= lx )[,1]
  return ( lx / 100000 )
  }
  
  if ( gender == "F")
  {
    age <- today  - yr
    lx = subset ( femalelifetbl , Year==yr & Age == age , select= lx )[,1]
    return ( lx / 100000 )
  }
  
  return (-1)
}

#GetNbPplBorn
getNbPplBorn <- function ( yr )
{
  return ( subset ( ukbirths , Year==yr , select = Birth)[,1] )
}

#Example look up
# For an example year NoPplWithNameFromYearStillAlive = NoPplBorn * Pr(StillAlive) * Pr(NameRank) 
NoPplWithNameFromYearStillAlive <- function ( yr , today , gender , firstname )
{
 
  rank <- getRankForName( firstname , yr, gender )
  value <- 0
  if ( rank >= 0 )
  {
    value <- getNbPplBorn( yr ) *
    getPrStillAlive( yr , today , gender ) *
    getPrForRank( rank , gender ) 
  }
  return (value)
}

EstimateAgeDist <- function ( firstname , gender )
{
  firstname <- toupper(firstname)
  v <- vector(mode="numeric",length=8)
  yrs <- c( 1924 , 1934 , 1944 , 1954 , 1964 , 1974 , 1984 , 1994 )
  v[1] <- NoPplWithNameFromYearStillAlive (1924 , 2015 , gender , firstname )
  v[2] <- NoPplWithNameFromYearStillAlive (1934 , 2015 , gender , firstname )
  v[3] <- NoPplWithNameFromYearStillAlive (1944 , 2015 , gender , firstname )
  v[4] <- NoPplWithNameFromYearStillAlive (1954 , 2015 , gender , firstname )
  v[5] <- NoPplWithNameFromYearStillAlive (1964 , 2015 , gender , firstname )
  v[6] <- NoPplWithNameFromYearStillAlive (1974 , 2015 , gender , firstname )
  v[7] <- NoPplWithNameFromYearStillAlive (1984 , 2015 , gender , firstname )
  v[8] <- NoPplWithNameFromYearStillAlive (1994 , 2015 , gender , firstname )
  v = v / sum(v)
  plot ( yrs , v , xlab="Year of Birth" , ylab="Probability of Birth" , main=paste0("Age Distribution for " , firstname ))
  lines ( yrs , v , type="l" , col="blue")
  return ( v )
}

EstimateAge <- function ( firstname , gender )
{ 
  v <- EstimateAgeDist ( firstname , gender )
  yrs <- c( 1924 , 1934 , 1944 , 1954 , 1964 , 1974 , 1984 , 1994 )
  v = sum(v * yrs)
  return (2015-v)
}

EstimateAgeDist ( "jack" , "M")
EstimateAgeDist ( "emma" , "F")
EstimateAgeDist( "andrew" , "M")
Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s