Shortly after the Giants fantastic defeat of the Patriots in Super Bowl XLVI (I was a little disappointed that Eli, Coughlin and the Vince Lombardi Trophy all got off the parade route early and the views of City Hall were obstructed by construction trailers, but Steve Weatherford was awesome as always) a friend asked me to settle a debate amongst some people in a Super Bowl pool.

He writes:

We have 10 participants in a superbowl pool.  The pool is a “pick the player who scores first” type pool.  In a hat, there are 10 Giants players.  Each participant picks 1 player out of the hat (in no particular order) until the hat is emptied.  Then 10 Patriots players go in the hat and each participant picks again.

In the end, each of the 10 participants has 1 Giants player and 1 Patriots player.  No one has any duplicate players as 10 different players from each team were selected.  Pool looks as follows:

Winners = First Player to score wins half the pot.  First player to score in 2nd half wins the remaining half of the pot.

The question is, what are the odds that someone wins Both the 1st and 2nd half.  Remember, the picks were random.

Before anyone asks about the safety, one of the slots was for Special Teams/Defense.

There are two probabilistic ways of thinking about this.  Both hinge on the fact that whoever scores first in each half is both independent and not mutually exclusive.

First, let’s look at the two halves individually.  In a given half any of 20 players can score first (10 from the Giants and 10 from the Patriots) and an individual participant can win with two of those.  So a participant has a 2/20 = 1/10 chance of winning a half.  Thus that participant has a (1/10) * (1/10) = 1/100 chance of winning both halves.  Since there are 10 participants there is an overall probability of 10 * (1/100) = 1/10 of any single participant winning both halves.

The other way is to think a little more combinatorically.  There are 20 * 20 = 400 different combinations of players scoring first in each half.  A participant has two players which are each valid for each half giving them four of the possible combinations leading to a 4 / 400 = 1/100 probability that a single participant will win both halves.  Again, there are 10 participants giving an overall 10% chance of any one participant winning both halves.

Since both methods agreed I am pretty confidant in the results, but just in case I ran some simulations in R which you can find after the break.

For the simulation I built a function that randomly assigned a player from the Giants and a player from the Patriots to each participant, then randomly chose–from those 20 players–someone to score first and someone to score second, allowing the two to be the same.  If the two scorers belonged to the same participant the function returned 1, otherwise 0.  The code is below.

runGame <- function(participants, pick1, pick2)
{
    # build data.frame assigning a random selection from each team to each player
    choices <- data.frame(Participants=participants, Pick1=sample(x=pick1, size=length(pick1), replace=FALSE), Pick2=sample(x=pick2, size=length(pick2), replace=FALSE))
    # randomly pick a player to score first
    firstScore <- sample(c(pick1, pick2), 1)
    # randomly pick a player to score second
    secondScore <- sample(c(pick1, pick2), 1)
    # see if the players who scored were both "owned" by the same participant
    if(max(which(choices$Pick1 == firstScore), which(choices$Pick2 == firstScore)) == max(which(choices$Pick1 == secondScore), which(choices$Pick2 == secondScore)))
    {
        return(1)
    }else
    {
        return(0)
    }
}

A second function run the simulation however many times are desired.

runSim <- function(participants, pick1, pick2, n=10000)
{
    # number of simulations
    # hold the results
    results <- rep(NA, n)

    for(i in 1:n)
    {
        results[i] <- runGame(participants=participants, pick1=pick1, pick2=pick2)
    }
    # find percentage
    return(results)
}

Running this simulation 10,000 times, I found that the average rate for the same participant to win both parts of the pool was .1041 with a standard error of .003.

So, the simulations confirm the probability theory that about 10% of the time the same participant will both sections of the pool, pissing off all of his friends.

With the Super Bowl only hours away now is your last chance to buy your boxes.  Assuming the last digits are not assigned randomly you can maximize your chances with a little analysis.  While I’ve seen plenty of sites giving the raw numbers, I thought a little visualization was in order.

In the graph above (made using ggplot2 in R, of course) the bigger squares represent greater frequency.  The axes are labelled “Home” and “Away” for orientation, but in the Super Bowl that probably doesn’t matter too much, especially considering that Indianapolis is (Peyton) Manning territory so the locals will most likely be rooting for the Giants.  Further, I believe Super Bowl XLII, featuring the same two teams, had a disproportionate number of Giants fans.  Bias disclaimer:  GO BIG BLUE!!!

Below is the same graph broken down by year to see how the distribution has changed over the past 20 years.

All the data was scraped from Pro Football Reference.  All of my code and other graphs that didn’t make the cut are at my github site.

As always, send any questions my way.

My sink was clogged, not with anything specific, but just years worth of gunk.  So after scraping out what I could with my hands and a wire hanger–and wanting to avoid caustic chemicals like Drano–I searched the Internet to see if Listerene or Coca-Cola might do the trick.  But extensive searching led me to baking soda and vinegar.

It’s very simple:  Stuff a half cup of baking soda into the train then pour a half cup of vinegar down it, return the sink stopper and wait 15 minutes.  Then pour down another half cup of vinegar, close the stopper and wait another 15 minutes.  After that pour a gallon (a tea kettle’s worth) of boiling water down the drain and you’re done!  Not only will it unclog your drain, it leaves all the chrome shining like new!

For those of us who never got to make a model volcano in science class it was really awesome watching the baking soda and vinegar react

Over dinner in New York’s Little India he explained how the largest cell phone company in Haiti provided him with anonymized cell tower records.  As many people are aware, cell phones–even those without GPS–report their locations back to cell towers at regular intervals.  By tracking the daily position of the phones before and after the earthquake they were able to determine that 20% of Port-Au-Prince’s population had left the capitol within 19 days of the disaster.

They used plenty of solid math in the analysis and amazingly did it all without resorting to spatial statistics.  They have some nice map-based visualizations but I’ve been meaning to get the data from Dr. Garfield so I can attempt something similar to the amazing work done by the NYC Data Mafia on the WikiLeaks Afghanistan data.  Though I don’t promise anything nearly as good.

It is also worth noting that they did this at a fraction of the cost and time of an extensive UN survey.  That survey only had about 2,500 respondents whereas the cell phone project incorporated around 1.9 million people without them spending valuable time with an interviewer.

While playing Words with Friends my randomly chosen opponent played “radiale” as her first word.  Since that used up all of her tiles, she received a bonus on top of all the points the word itself got, resulting in a one-move score of 53 points!  Rather than being impressed I was upset at the large deficit I would have to overcome.

To combat this I did what comes naturally:  Write an R script to find the perfect word!

Needing to combine my seven letters with one of her letters there were two routes I could take.  The first would be for each combination of my seven letters and one of hers, find all 40,320 (8!) permutations then hit dictionary.com to see if it is a real word for a total of 282,240 (8!*7) http calls.  That seemed a bit excessive and impractical so I moved on to the next idea.

So, first thing I did was pull a list of common eight-letter words. Then for each combination of my letters and one of hers (only 7 iterations) I checked if those letters (in any order) matched the letters in any of the possible words.  Once a match was found there was a check for the counts of the letters and if that passed then the word was recorded as a true match.

The algorithm took about 17 seconds to run and found me one possible word for my letters combined with one of hers:  ”headrace”, for 63 points!  Perhaps I should have been able to figure that out on my own, but where would be the fun in that.  Find the code after the break.

require(RCurl)
require(XML)
require(plyr)

myLetters <- "ercaehd"
theirLetters <- "radiale"

wordSite <- getURL("http://www.poslarchive.com/math/scrabble/lists/common-8.html")  # get page with words

# parse out the page
wordsParsed <- htmlTreeParse(wordSite, handlers=list("pre"=function(x, ...){ x }, "p"=function(x, ...){ NULL },
                                                    "head"=function(x, ...){ NULL }), asTree=TRUE)

# get just the list of words
words <- as.character(wordsParsed$children$html[["body"]][["pre"]][["text"]])
words <-gsub("\n", " ", words)  # sub out carriage return characters for spaces

## Turn the block of words into a nice list, each element of which is a vector of characters
words <- strsplit(words, split=" ")[[6]]    # split the long string into a vector seperating by spaces
words <- as.list(words)     # change from vector to list
words <- lapply(words, strsplit, split="")  # split each element of the list into a vector of it's characters

findAllWords <- function(baseLetters, theirWord, listOfWords)
{
    extraLetters <- strsplit(theirWord, split="")[[1]]   # split their word into letters, probably should have removed redundant letters first for a slight efficiency gain

    wordSuccess <- vector("list", length(extraLetters))

    for(a in 1:length(extraLetters))
    {
        seedLetters <- paste(baseLetters, extraLetters[a], sep="")
        #seedLetters <- strsplit(seedLetters, split="")[[1]]

        wordSuccess[[a]] <- checkForWord(words=listOfWords, letters=seedLetters)
    }

    return(wordSuccess)
}

checkForWord <- function(words, letters)
{
    holder <- vector("list", length(words)) # to hold results
    letters <- strsplit(letters, split="")[[1]]  # split up letters
    letterFrame <- data.frame(Letters=letters, stringsAsFactors=FALSE)  # to facilitate counting
    letterCount <- ddply(letterFrame, .(Letters), nrow)   # counts for each letter
    rm(letterFrame); gc()
    names(letterCount)[2] <- "LetterCount"

    ## loop through every word in the list and see if our letters are found in there
    for(i in 1:length(words))
    {
        if(all(letters %in% words[[i]][[1]]))   # if all the letters are found in the word
        {
            # check counts
            wordFrame <- data.frame(Letters=words[[i]][[1]], stringsAsFactors=FALSE)    # put letters from word into DF
            wordCount <- ddply(wordFrame, .(Letters), nrow) # get counts
            rm(wordFrame); gc()
            names(wordCount)[2] <- "WordLetterCount"

            joinedLetters <- join(letterCount, wordCount, by="Letters") # join the tables for a comparison

            holder[[i]] <- all(with(joinedLetters, LetterCount == WordLetterCount)) # holder gets the result of the comparison
        }else
        {
            holder[[i]] <- FALSE
        }
    }

    holder <- laply(holder, function(x) x) # convert to vector

    if(sum(holder) == 0)
    {
        return(sum(holder))
    }else
    {
        return(which(holder == TRUE))
    }
}

system.time(result <- findAllWords(baseLetters=myLetters, theirWord=theirLetters, listOfWords=words))

If you think you can help send a letter to:

FBI Laboratory
Cryptanalysis and Racketeering Records Unit
2501 Investigation Parkway
Quantico, VA 22135
Attn: Ricky McCormick Case

There’s no reward but you’d be helping your country.

Pi Day Celebrants

As mentioned earlier, yesterday was Pi Day so a bunch of statisticians and other such nerds celebrated at the new(ish) Artichoke Basille near the High Line.  We had three pies:  the signature Artichoke, the Margherita and the Anchovy, which was delicious but only some of us ate.  And of course we had our custom cake from Chrissie Cook.

The photos were taken by John.

Pi Cake 2011

NYC Data Mafia

Today is also Albert Einstein’s birthday so there are plenty of reasons to have fun.

The cake below was my first ever Pi Cake in what is sure to become an annual tradition.

Update:  Drew Conway does far more justice to our fair, irrational, transcendental number.

Update 2:  Engadget posted this awesome video of “What Pi Sounds Like.“

Fig. 1: This graph shows received and sent text messages by month. Notice the spike in July 2010.

A few weeks ago my iPhone for some reason erased ALL of my previous text messages (SMS and MMS) and it was as if I was starting with a new phone. After doing some digging I discovered that each time you sync your iPhone a copy of its text message database is saved on your computer which can be accessed without jailbreaking.    

My original intent was to take the old database and union it with the new database for all the texting I had done since then, thus restoring all of my text messages. But once I got into the SQLite database I realized that I had a ton of information on my hands that was begging to be analyzed. It also didn’t hurt that I was in a lovely but small Vermont town for the week without much else to do at night.    

My first finding, as seen above, is that my text messaging spiked after my girlfriend and I broke up around July of last year. Notice that for both years there is a dip in December. That’s because in 2009 I was in Burma during December and for 2010 the data stopped on December 6th when the last backup was made. A simple t-test confirmed that my texting did indeed increase after the breakup.    

Fig. 2: This graph shows my text messaging pattern over time for both men and women. Notice the crossover around August 2010.

More interestingly, is that before my girlfriend and I broke up last year I texted more men than women, but shortly after we broke up that flipped. I don’t think that needs much of an explanation. The above graph and further analysis excludes her and family members because they would bias the gender effect. Being a good statistician I ran a poisson regression to see if there really was a significant change. The coefficient plot below (which is on the logarithmic scale) shows that my texting with males increased after the breakup (or Epoch) by 74% (calculated by summing the coefficients for “Epoch”, “Male” and “Male:Epoch” and then exponentiating) while my texting with females increased 127%.    

Fig. 3: Here the "Male" coefficient seems statistically insignificant but its direction makes sense so it is left in the model. The "Intercept" is interpreted as the texting rate with females before the breakup, "Epoch" is the increase with females after the breakup, "Intercept" plus "Male" is the rate with males before the breakup. "Epoch" combined with "Male:Epoch" is the change in rate for texts with males after the breakup.

Further analysis and a how-to after the break.    

Next I saw that my text messages–both incoming and outgoing–surge, unsurprisingly, toward the end of the week. I ran a regression using the day of the week as an unordered factor and saw that texts do trend up toward the end of the week, particularly Sunday which I can’t explain. Then again, it’s probably counting late night Saturday, after midnight, when I’m texting people while enjoying New York’s nightlife.    

Fig 4: This graph shows a clear upward trend toward the end of the week with a bump on Thursday as well.

Fig. 5: This coefficient plot shows that Sunday clearly stands out far and above the other days in terms of text messages sent and receive. Day 1 is Monday and Day 7 is Sunday. Putting the days in their natural order isn't built into my coefficient plot yet.

Update:  As suspected, the uptick on Sunday is really due to late night Saturday texts as seen in the graph below.  I didn’t run ay test on it, the graph was good enough for me.  

Figure 6: Now the lines represent calls in the AM or PM. PM Calls steadily increases toward the end of the week and AM calls jump dramatically on Saturday and Sunday. This is due to late night texting on Friday and Saturday when I am out well past midnight.

And now for code and instructions  

First, you have to locate the two necessary databases in your backup folder. These are in different places depending on your OS, so please see these instructions. The two databases you want are 3d0d7e5fb2ce288813306e4d4636395e047a3d28 (the messages) and 31bb7ba8914766d4ba40d6dfb6113c8b614be442 (your contacts). Save those databases to a new folder (you don’t want to mess with originals, just in case) and rename them “sms.db” and “AddressBook sqlitedb” respectively. I don’t know if you need to rename them, but I did and it worked. A complete list of databases is available here.    

Next you must download and install the appropriate driver for SQLite from this site. Then you need to use that driver to make connections to both databases under the “File DSN” section of ODBC Data Source Administrator. Sorry, I don’t know where to do this on Mac or Linux.    

Click “Add” and select SQLite3 ODBC Driver.    

Click “Next” then give a name for the connection such as “sms.db.dsn” in the appropriate folder.    

Click “Next” then “Finish” which brings you to following screen where you should click “Browse” then select the “sms.db” database. Do the same for the “AddressBook sqlitedb” database calling the connection “AddressBook sqlitedb.dsn”.    

As usual, all of my analysis was done in R and the graphs were made with ggplot.    

First up, load in the necessary libraries.    

## Load needed libraries
library(RODBC) # to read the database
library(ggplot2) # to make the nice charts and facilitate table joins
library(lmtest) # to test how well the models fit the data
source("http://www.jaredlander.com/code/plotCoef.r") # grab the coefficient plot function
source("http://www.jaredlander.com/code/overdispersion.r") # grab the overdispersion test function

Now we connect to the databases.    

# Connect to messages DB
DB <- odbcDriverConnect()
# Connect to the Contacts DB
DB2 <- odbcDriverConnect()

Each of those commands pulls up a dialog like the one below. First choose “sms.db.dsn” and then for the second dialog choose “AddressBook sqlitedb.dsn.” The order is important.    

This next bunch of code cleans up the data. Sorry for the text wrapping.    

Days <- data.frame(DayNum=1:7, DayOfWeek=c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"))
Days$DayOfWeek <- as.character(Days$DayOfWeek) # change to character
messages <- sqlQuery(DB,paste("SELECT * FROM message")) # grab messages data
messages$Type <- ifelse(messages$flags == 2, 'Received', ifelse(messages$flags == 3, 'Sent', ifelse(messages$flags == 33, 'Message send failure', ifelse(messages$flags == 129, 'Deleted', ifelse(messages$flags == 35, 'Other', 'Other'))))) ## Denote message type
messages$Date <- as.Date(floor(messages$date/60/60/24), origin="1970-01-01") ## Set dates
messages$DayOfWeek <- weekdays(messages$Date) ## Find out what day of the week that day fell on
messages$Year <- substr(messages$Date, 1, 4) # get the Year
messages <- within(messages, Month <- droplevels(factor(strftime(Date, format = "%B"),levels = month.name))) # Clean up the data
messages <- messages[messages$Type %in% c("Sent", "Received"), ] # only keep data on messages successfully sent or received
messages <- join(x=messages, y=Days, by="DayOfWeek") # join the days of week information to the messages table
members <- sqlQuery(DB,paste("SELECT * FROM group_member")) # This table is used as a link from the messages table to the contacts table
members$TextLink <- members$address # Creates the key field to the contacts table
members$Number <- members$address # Get the cleanest version of phone number available
personNumbers <- sqlQuery(DB2,paste("SELECT * FROM ABMultiValue")) # The table that joins between the members table and the contacts table
personNumbers$TextLink <- personNumbers$value # Creates the key field to the members table
personNumbers$ContactLink <- personNumbers$record_id # Creates the key field to the contacts table    

addresses <- sqlQuery(DB2, paste("SELECT * FROM ABPerson")) # The Contacts table
addresses$ContactLink <- addresses$ROWID # Creates the key field to the personNumbers table
addresses$AddressRow <- addresses$ROWID # For indexing reasons
addresses$Name <- paste(addresses$First, addresses$Last, sep=" ") # Make a combined name

I have gone through and labelled my contacts male or female. If you don’t want to go through that work, you can skip the gender analysis or scrape a site like Baby Name Guesser. It’s fairly simple, you put the name of interest in the URL then use readLines() to get what the site guesses.    

gender <- read.csv("C:\\Users\\Jared\\Documents\\iPhone SMS Backup\\Gender.csv", sep=",", header=T, stringsAsFactors=F)

Now join all those tables together.    

## Join all of our tables
master <- join(x=messages, y=members, by="group_id")
master <- join(x=master, y=personNumbers, by="TextLink")
master <- join(x=master, y=addresses, by="ContactLink")
master <- join(x=master, y=gender, by="Name")

Build the data for plotting texts by month and year in Figure 1.    

 # Count per month, year, type
textMonth <- aggregate(ROWID ~ Year + Month + Type, data=master, length)
# Plot by month, year, type
qplot(Month, ROWID, data=textMonth, group=Type, colour=Type, geom="line", ylab="# Texts", main="Texts by Month") + facet_grid(Year ~ .) + opts(axis.text.x=theme_text(angle=45, hjust=1)) # Figure 1

The following t-test (and aggregation) tests to see if texting increased after a certain date.    

textByDay <- aggregate(ROWID ~ Date + DayOfWeek + DayNum + Year + Month, data=master, length)
textByDay$Epoch <- ifelse(textByDay$Date >= "YYYY-MM-DD", 1, 0)
t.test(ROWID ~ Epoch, data=textByDay[textByDay$Month != "December", ], alternastive="less")

Now to make the data ready to check the gender crossover, plotting it (Figure 2), and testing it (Figure 3).    

# Count per month, year, gender
textGenderMonth <- aggregate(ROWID ~ Year + Month + Gender, data=master[!master$Number %in% c("(xxx) xxx-xxxx", "(xxx) xxx-xxxx", "(xxx) xxx-xxxx", "(xxx) xxx-xxxx"), ], length)
textGenderMonth$Gender <- ifelse(textGenderMonth$Gender == "f", "Female", "Male")
# Plot by day, year, type
# Shows crossover point for texting girls vs guys
qplot(Month, ROWID, data=textGenderMonth, group=Gender, colour=Gender, geom="line", ylab="# Texts") + facet_grid(Year ~ .) + opts(axis.text.x=theme_text(angle=45, hjust=1)) # Figure 2
textByDayGender <- aggregate(ROWID ~ Date + DayOfWeek + DayNum + Year + Month + Gender, data=master[!master$Number %in% c("(xxx) xxx-xxxx", "(xxx) xxx-xxxx", "(xxx) xxx-xxxx", "(xxx) xxx-xxxx"), ], length)
textByDayGender$Epoch <- ifelse(textByDayGender$Date >= "YYYY-MM-DD", 1, 0)
textByDayGender$Gender <- ifelse(textByDayGender$Gender == "f", "Female", "Male")
textByDayGender$Gender <- factor(textByDayGender$Gender)
femaleLM <- lm(ROWID ~ Gender*Epoch, data = textByDayGender[textByDayGender$Month != "December", ])
femaleGLM <- glm(ROWID ~ Gender*Epoch, data = textByDayGender[textByDayGender$Month != "December", ], family="quasipoisson")
overdispersionTest(femaleGLM)
bptest(femaleGLM)
resettest(femaleGLM)
plotCoef(femaleGLM, Main="Coefficient Plot for Poisson Regression", YLab="Variable", XLab="Coefficient") # Figure 3

And now we check for the trend in texts over the course of a week (Figures 4 and 5).    

textDayNoYear <- aggregate(ROWID ~ DayOfWeek + DayNum + Type, data=master, length)
qplot(reorder(DayOfWeek, DayNum), ROWID, data=textDayNoYear, group=Type, colour=Type, geom="line", xlab="Day of Week", ylab="# Texts") + opts(axis.text.x=theme_text(angle=45, hjust=1)) # Figure 4
textByDay <- aggregate(ROWID ~ Date + DayOfWeek + DayNum + Year + Month, data=master, length)
textByDay$Epoch <- ifelse(textByDay$Date >= "YYYY-MM-DD", 1, 0)
dayOfWeekLM <- lm(ROWID ~ factor(DayNum) - 1, data=textByDay)
plotCoef(dayOfWeekLM, Main="Average Texts by Day", YLab="Day", XLab="Texts") #Figure 5

And that’s the basic idea. I left out a lot of the nitty gritty of model checking and all the troubleshooting. I hope everyone enjoyed it and please feel free to message (or @jaredlander on Twitter) me with any questions.    

]]> http://www.jaredlander.com/2011/02/texting-patterns/feed/ 0 http://www.jaredlander.com/2011/01/supreme-court-justice-rules-for-ny-pizza/ http://www.jaredlander.com/2011/01/supreme-court-justice-rules-for-ny-pizza/#comments Tue, 04 Jan 2011 23:26:55 +0000 Jared http://www.jaredlander.com/?p=546 Daily Intel caught wind of a California Lawyer interview with US Supreme Court Justice Antonin Scalia where he proclaims New York pizza “is infinitely better than Washington pizza, and infinitely better than Chicago pizza.”  I may be biased to New York pizza as well, but that is a debate I’ll save for another day.

It gets really interesting when he says, “You know these deep-dish pizzas—it’s not pizza. It’s very good, but … call it tomato pie or something.”  While an argument can certainly me made that deep-dish pizza is almost a casserole, I think the folks down in Trenton (where Scalia was born) have already claimed the name tomato pie, referring to a round pie with the sauce on top.

Hopefully Slice will chime in on this.