Michael Malecki recently shared a link to a Business Insider article that discussed the Monty Hall Problem.

The problem starts with three doors, one of which has a car and two of which have a goat. You choose one door at random and then the host reveals one door (not the one you chose) that holds a goat. You can then choose to stick with your door or choose the third, remaining door.

Probability theory states that people who switch win the car two-thirds of the time and those who don’t switch only win one-third of time.

But people often still do not believe they should switch based on the probability argument alone. So let’s run some simulations.

This function randomly assigns goats and cars behind three doors, chooses a door at random, reveals a goat door, then either switches doors or does not.

monty <- function(switch=TRUE)
{
    # randomly assign goats and cars
    doors <- sample(x=c("Car", "Goat", "Goat"), size=3, replace=FALSE)

    # randomly choose a door
    doorChoice <- sample(1:3, size=1)

    # get goat doors
    goatDoors <- which(doors == "Goat")
    # show a door with a goat
    goatDoor <- goatDoors[which(goatDoors != doorChoice)][1]

    if(switch)
        # if we are switching choose the other remaining door
    {
        return(doors[-c(doorChoice, goatDoor)])
    }else
        # otherwise keep the current door
    {
        return(doors[doorChoice])
    }
}

Now we simulate switching 10,000 times and not switching 10,0000 times

withSwitching <- replicate(n = 10000, expr = monty(switch = TRUE), simplify = TRUE)
withoutSwitching <- replicate(n = 10000, expr = monty(switch = FALSE), simplify = TRUE)

head(withSwitching)

## [1] "Goat" "Car"  "Car"  "Goat" "Car"  "Goat"

head(withoutSwitching)

## [1] "Goat" "Car"  "Car"  "Car"  "Car"  "Car"

mean(withSwitching == "Car")

## [1] 0.6678

mean(withoutSwitching == "Car")

## [1] 0.3408

Plotting the results really shows the difference.

require(ggplot2)

## Loading required package: ggplot2

require(scales)

## Loading required package: scales

qplot(withSwitching, geom = "bar", fill = withSwitching) + scale_fill_manual("Prize", 
    values = c(Car = muted("blue"), Goat = "orange")) + xlab("Switch") + ggtitle("Monty Hall with Switching")

qplot(withoutSwitching, geom = "bar", fill = withoutSwitching) + scale_fill_manual("Prize", 
    values = c(Car = muted("blue"), Goat = "orange")) + xlab("Don't Switch") + 
    ggtitle("Monty Hall without Switching")

(How are these colors? I’m trying out some new combinations.)

This clearly shows that switching is the best strategy.

The New York Times has a nice simulator that lets you play with actual doors.

That was my favorite, more after the break.  I’ll continue updating as they catch my eye.

Update:  Found some not from Facebook.

2013

Continuing the annual tradition of Pi Cakes from Chrissie Cook we have gotten another Pi Cake!  This year we let Drew Conway’s wife pick the flavors and she went with vanilla and red velvet (the blue color is to cause some cognitive dissonance).  Looking forward to enjoying this tonight after some pizza.

Previous cakes in the gallery after the break.

Given the warnings for today’s winter storm, or lack of panic, I thought it would be a good time to plot the NYC evacuation maps using R. Of course these are already available online, provided by the city, but why not build them in R as well?

I obtained the shapefiles from NYC Open Data on February 28th, so it’s possible they are the new shapefiles redrawn after Hurricane Sandy, but I am not certain.

First we need the appropriate packages which are mostly included in maptools, rgeos and ggplot2.

require(maptools) 

## Loading required package: maptools 

## Loading required package: foreign 

## Loading required package: sp 

## Loading required package: lattice 

## Checking rgeos availability: TRUE 

require(rgeos) 

## Loading required package: rgeos 

## Loading required package: stringr 

## Loading required package: plyr 

## rgeos: (SVN revision 348) GEOS runtime version: 3.3.5-CAPI-1.7.5 Polygon ## checking: TRUE 

require(ggplot2) 

## Loading required package: ggplot2 

require(plyr) require(grid) 

## Loading required package: grid 

Then we read in the shape files, fortify them to turn them into a data.frame for easy plotting then join that back into the original data to get zone information.

# read the shape file evac <- readShapeSpatial("../data/Evac_Zones_with_Additions_20121026/Evac_Zones_with_Additions_20121026.shp") # necessary for some of our work gpclibPermit() 

## [1] TRUE 

# create ID variable evac@data$id <- rownames(evac@data) # fortify the shape file evac.points <- fortify(evac, region = "id") # join in info from data evac.df <- join(evac.points, evac@data, by = "id") # modified data head(evac.df) 

## long lat order hole piece group id Neighbrhd CAT1NNE Shape_Leng ## 1 1003293 239790 1 FALSE 1 0.1 0 <NA> A 9121 ## 2 1003313 239782 2 FALSE 1 0.1 0 <NA> A 9121 ## 3 1003312 239797 3 FALSE 1 0.1 0 <NA> A 9121 ## 4 1003301 240165 4 FALSE 1 0.1 0 <NA> A 9121 ## 5 1003337 240528 5 FALSE 1 0.1 0 <NA> A 9121 ## 6 1003340 240550 6 FALSE 1 0.1 0 <NA> A 9121 ## Shape_Area ## 1 2019091 ## 2 2019091 ## 3 2019091 ## 4 2019091 ## 5 2019091 ## 6 2019091 

# as opposed to the original data head(evac@data) 

## Neighbrhd CAT1NNE Shape_Leng Shape_Area id ## 0 <NA> A 9121 2019091 0 ## 1 <NA> A 12250 54770 1 ## 2 <NA> A 10013 1041886 2 ## 3 <NA> B 11985 3462377 3 ## 4 <NA> B 5816 1515518 4 ## 5 <NA> B 5286 986675 5 

Now, I’ve begun working on a package to make this step, and later ones easier, but it’s far from being close to ready for production. For those who want to see it (and contribute) it is available at https://github.com/jaredlander/mapping. The idea is to make mapping (including faceting!) doable with one or two lines of code.

Now it is time for the plot.

ggplot(evac.df, aes(x = long, y = lat)) + geom_path(aes(group = group)) + geom_polygon(aes(group = group, fill = CAT1NNE)) + list(theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(), axis.text.x = element_blank(), axis.text.y = element_blank(), axis.ticks = element_blank(), panel.background = element_blank())) + coord_equal() + labs(x = NULL, y = NULL) + theme(plot.margin = unit(c(1, 1, 1, 1), "mm")) + scale_fill_discrete("Zone") 

There are clearly a number of things I would change about this plot including filling in the non-evacuation regions, connecting borders and smaller margins. Perhaps some of this can be accomplished by combining this information with another shapefile of the city, but that is beyond today’s code.

All I did was copy the old functions (geom_dodge, collide, pos_dodge and PositionDodge) and make them vertical by swapping y's with x's, height with width and vice versa. It's hacky and not tested but seems to work as I'll show below.

First the new functions:

require(proto)

## Loading required package: proto

collidev <- function(data, height = NULL, name, strategy, check.height = TRUE) {
    if (!is.null(height)) {
        if (!(all(c("ymin", "ymax") %in% names(data)))) {
            data <- within(data, {
                ymin <- y - height/2
                ymax <- y + height/2
            })
        }
    } else {
        if (!(all(c("ymin", "ymax") %in% names(data)))) {
            data$ymin <- data$y
            data$ymax <- data$y
        }
        heights <- unique(with(data, ymax - ymin))
        heights <- heights[!is.na(heights)]
        if (!zero_range(range(heights))) {
            warning(name, " requires constant height: output may be incorrect", 
                call. = FALSE)
        }
        height <- heights[1]
    }
    data <- data[order(data$ymin), ]
    intervals <- as.numeric(t(unique(data[c("ymin", "ymax")])))
    intervals <- intervals[!is.na(intervals)]
    if (length(unique(intervals)) > 1 & any(diff(scale(intervals)) < -1e-06)) {
        warning(name, " requires non-overlapping y intervals", call. = FALSE)
    }
    if (!is.null(data$xmax)) {
        ddply(data, .(ymin), strategy, height = height)
    } else if (!is.null(data$x)) {
        message("xmax not defined: adjusting position using x instead")
        transform(ddply(transform(data, xmax = x), .(ymin), strategy, height = height), 
            x = xmax)
    } else {
        stop("Neither x nor xmax defined")
    }
}

pos_dodgev <- function(df, height) {
    n <- length(unique(df$group))
    if (n == 1) 
        return(df)
    if (!all(c("ymin", "ymax") %in% names(df))) {
        df$ymin <- df$y
        df$ymax <- df$y
    }
    d_width <- max(df$ymax - df$ymin)
    diff <- height - d_width
    groupidx <- match(df$group, sort(unique(df$group)))
    df$y <- df$y + height * ((groupidx - 0.5)/n - 0.5)
    df$ymin <- df$y - d_width/n/2
    df$ymax <- df$y + d_width/n/2
    df
}

position_dodgev <- function(width = NULL, height = NULL) {
    PositionDodgev$new(width = width, height = height)
}

PositionDodgev <- proto(ggplot2:::Position, {
    objname <- "dodgev"

    adjust <- function(., data) {
        if (empty(data)) 
            return(data.frame())
        check_required_aesthetics("y", names(data), "position_dodgev")

        collidev(data, .$height, .$my_name(), pos_dodgev, check.height = TRUE)
    }

})

Now that they are built we can whip up some example data to show them off. Since this was inspired by a refactoring of my coefplot package I will use a deconstructed sample.

# get tips data
data(tips, package = "reshape2")

# fit some models
mod1 <- lm(tip ~ day + sex, data = tips)
mod2 <- lm(tip ~ day * sex, data = tips)

# build data/frame with coefficients and confidence intervals and combine
# them into one data.frame
require(coefplot)

## Loading required package: coefplot

## Loading required package: ggplot2

df1 <- coefplot(mod1, plot = FALSE, name = "Base", shorten = FALSE)
df2 <- coefplot(model = mod2, plot = FALSE, name = "Interaction", shorten = FALSE)
theDF <- rbind(df1, df2)
theDF

##    LowOuter HighOuter LowInner HighInner     Coef            Name Checkers
## 1    1.9803    3.3065  2.31183    2.9750  2.64340     (Intercept)  Numeric
## 2   -0.4685    0.9325 -0.11822    0.5822  0.23202          daySat      day
## 3   -0.2335    1.1921  0.12291    0.8357  0.47929          daySun      day
## 4   -0.6790    0.7672 -0.31745    0.4056  0.04408         dayThur      day
## 5   -0.2053    0.5524 -0.01589    0.3630  0.17354         sexMale      sex
## 6    1.8592    3.7030  2.32016    3.2421  2.78111     (Intercept)  Numeric
## 7   -1.0391    1.0804 -0.50921    0.5506  0.02067          daySat      day
## 8   -0.5430    1.7152  0.02156    1.1507  0.58611          daySun      day
## 9   -1.2490    0.8380 -0.72725    0.3163 -0.20549         dayThur      day
## 10  -1.3589    1.1827 -0.72349    0.5473 -0.08811         sexMale      sex
## 11  -1.0502    1.7907 -0.34000    1.0804  0.37022  daySat:sexMale  day:sex
## 12  -1.5324    1.4149 -0.79560    0.6781 -0.05877  daySun:sexMale  day:sex
## 13  -0.9594    1.9450 -0.23328    1.2189  0.49282 dayThur:sexMale  day:sex
##          CoefShort       Model
## 1      (Intercept)        Base
## 2           daySat        Base
## 3           daySun        Base
## 4          dayThur        Base
## 5          sexMale        Base
## 6      (Intercept) Interaction
## 7           daySat Interaction
## 8           daySun Interaction
## 9          dayThur Interaction
## 10         sexMale Interaction
## 11  daySat:sexMale Interaction
## 12  daySun:sexMale Interaction
## 13 dayThur:sexMale Interaction

# build the plot
require(ggplot2)
require(plyr)

## Loading required package: plyr

ggplot(theDF, aes(y = Name, x = Coef, color = Model)) + geom_vline(xintercept = 0, 
    linetype = 2, color = "grey") + geom_errorbarh(aes(xmin = LowOuter, xmax = HighOuter), 
    height = 0, lwd = 0, position = position_dodgev(height = 1)) + geom_errorbarh(aes(xmin = LowInner, 
    xmax = HighInner), height = 0, lwd = 1, position = position_dodgev(height = 1)) + 
    geom_point(position = position_dodgev(height = 1), aes(xmax = Coef))

Compare that to the multiplot function in coefplot that was built using geom_dodge and coord_flip.

multiplot(mod1, mod2, shorten = F, names = c("Base", "Interaction"))

With the exception of the ordering and plot labels, these charts are the same. The main benefit here is that avoiding coord_flip still allows the plot to be faceted, which was not possible with coord_flip.

Hopefully Hadley will be able to take these functions and incorporate them into ggplot2.

Continuing with the newly available football data and inspired by a question from Drew Conway I decided to look at play selection based on down by the Giants for the past 10 years.

Visually, we see that until 2011 the Giants preferred to run on first and second down.  Third down is usually a do-or-die down so passes will dominate on third-and-long.  The grey vertical lines mark Super Bowls XLII and XLVI.

Code for the graph after the break.

The packages to be used are:

require(plyr) require(stringr) require(ggplot2) require(reshape2) require(parallel) require(doParallel) 

We will be running this in parallel so let’s register a parallel backend.

cl <- makeCluster(2) registerDoParallel(cl) 

First we read the data for all available years.

theFiles <- file.path("../data", dir("../data/")) # read the csvs in parallel system.time(allGames <- adply(theFiles, .margins = 1, read.csv2, header = TRUE, sep = ",", stringsAsFactors = FALSE, .parallel = TRUE)) # took 10.98 seconds on a dual core 2,66 GHz machine save it so this does # not have to be done again save(allGames, file = "../data/allGames.rdata") write.table(allGames, file = "../data/allGames.csv", row.names = FALSE, sep = ",") # stop the cluster stopCluster(cl) 

We are only interested in the giants on offense so let’s narrow it down to them.

# get just giants games nyg <- allGames[str_detect(string = allGames$gameid, "NYG"), ] # get just when they are on offense nygOff <- nyg[nyg$off == "NYG", ] 

To determine which plays were passes, runs, kickoffs, punts and field goals we need to process the description column a bit. To do this we will make four new columns, one for each type of play with a logical value.

# If the word pass is used, it was a pass nygOff$Pass <- str_detect(string = nygOff$description, pattern = ignore.case(" pass ")) # same for punt nygOff$Punt <- str_detect(string = nygOff$description, pattern = ignore.case(" punts ")) # and field goal nygOff$FieldGoal <- str_detect(string = nygOff$description, pattern = ignore.case(" field goal ")) # and kick nygOff$Kick <- str_detect(string = nygOff$description, pattern = ignore.case(" kicks ")) # This is for a penalty which we assume blows the play dead nygOff$Penalty <- str_detect(string = nygOff$description, pattern = "^PENALTY") # for cases where the inteded play was aborted nygOff$Aborted <- str_detect(string = nygOff$description, pattern = ignore.case("aborted")) # if none of the other cases are true we assume it was a run nygOff$Run <- rowSums(nygOff[, c("Pass", "Punt", "FieldGoal", "Kick", "Penalty", "Aborted")]) == 0 # which(rowSums(nygOff[, c('Pass', 'Punt', 'FieldGoal', 'Kick', 'Penalty', # 'Aborted', 'Run')]) != 1) View(nygOff[which(rowSums(nygOff[, c('Pass', # 'Punt', 'FieldGoal', 'Kick', 'Penalty', 'Aborted', 'Run')]) != 1), ]) 

After all that processing we end up with 4 rows that do not have only one of the indicator columns as TRUE.

The first is the play that ended the horrible 2003 playoff game against the 49ers where the Giants blew a huge half time lead. This play was a muffed field goal attempt where the holder, Matt Allen, attempts to pass the ball downfield where Rich Seubert is the first player to touch it. The referees mistakenly thought he was an ineligible receiver and called a penalty ending the game. The league later admitted that he was indeed eligible and that defensive pass interference should have been called. Since the game cannot end on a defensive penalty the Giants should have had another field goal opportunity from much better field position. Clearly, this is still a sore point for Giants fans. Since this is a muffed field goal we will eliminate it from the data.

The next two are plays where the quarterback (Kerry Collins and Eli Manning) got a fumbled snap and then threw an incomplete pass. We will classify these plays as passes.

The last play is a fumble by St. Louis quarterback Sam Bradford which was recovered by Michael Boley for a Giants touchdown. That will be eliminated as well.

# find out the row numbers for the bad plays badRows <- which(rowSums(nygOff[, c("Pass", "Punt", "FieldGoal", "Kick", "Penalty", "Aborted", "Run")]) != 1) # the middle two are to be classified as passes so we set Aborted to FALSE nygOff[badRows[2:3], "Aborted"] <- FALSE # check which rows have the indicator variables summing to one and only # keep those nygOff <- nygOff[which(rowSums(nygOff[, c("Pass", "Punt", "FieldGoal", "Kick", "Penalty", "Aborted", "Run")]) == 1), ] # check it worked which(rowSums(nygOff[, c("Pass", "Punt", "FieldGoal", "Kick", "Penalty", "Aborted", "Run")]) != 1) 

## named integer(0) 

Now we narrow it down to just run and pass plays and count up each by season and down.

nygPassRun <- nygOff[nygOff$Pass | nygOff$Run, ] playCount <- aggregate(cbind(Pass, Run) ~ season + down, nygPassRun, sum) playCount$Plays <- with(playCount, Pass + Run) # calculate the percent of each type of play playCount$PassPct <- with(playCount, Pass/Plays) playCount$RunPct <- with(playCount, Run/Plays) 

Time to plot the data.

playMelt <- melt(playCount[, c("season", "down", "PassPct", "RunPct")], id.vars = c("season", "down"), value.name = "Percent", variable.name = "Play") playMelt$Play <- as.character(playMelt$Play) playMelt$Play[playMelt$Play == "PassPct"] <- "Pass" playMelt$Play[playMelt$Play == "RunPct"] <- "Run" playMelt$Play <- factor(playMelt$Play, levels = c("Run", "Pass")) ggplot(playMelt, aes(x = season, y = Percent, group = Play, color = Play)) + geom_line() + facet_wrap(~down, ncol = 1, scales = "free_y") + ggtitle("Type of Play by Down") + labs(x = "Season") + geom_vline(xintercept = c(2007, 2011), color = "grey", linetype = 2) 

From this we can see that the Giants, traditionally known as a running team, mostly preferred the run over the pass on both first and second down, until the 2011 season when Eli became a truly dominant quarterback and passed more on those downs.

This does not take into account the time left in the game, the score or the yards to go, but that’s for another day.

About a month ago we had our final Data Science class of the semester.  We took a great class photo that I meant to share then but am just getting to it now.

I also snapped a great shot of Adam Obeng in front of an NYC Data Mafia slide during his class presentation.

With the recent availability of play-by-play NFL data I got to analyzing my favorite team, the New York Giants with some very hasty EDA.

From the above graph you can see that on 1st down Eli preferred to throw to Hakim Nicks and on 2nd and 3rd downs he slightly favored Victor Cruz.

The code for the analysis is after the break.

I’ve only had the data for a few hours so I am just going to look at who Eli passed to on a given down during their Super Bowl XLVI season. Hopefully I’ll get to more analysis later.

opts_chunk$set(cache = TRUE) 

For this I used the following packages:

require(stringr) require(plyr) require(ggplot2) 

Next we load the data and winnow it down to just passing plays by the Giants.

# read in the data for 2011 allGames <- read.csv2("../data/2011_nfl_pbp_data.csv", header = TRUE, sep = ",") # just keep the giants games nyg <- allGames[which(allGames$off == "NYG" | allGames$def == "NYG"), ] # just the offensive plays and don't count kickoffs or punts nygOff <- nyg[nyg$off == "NYG" & !is.na(nyg$down), ] # just passing plays nygPass <- nygOff[str_detect(nygOff$description, "pass"), ] nygPass$description <- as.character(nygPass$description) ## extract out the receiver nygPass$Receiver <- str_extract(nygPass$description, "to [A-Za-z]\\.[A-Za-z]+( |\\.)") nygPass$Receiver <- str_replace_all(string = nygPass$Receiver, pattern = "(^to )|( $)|(\\.$)", replacement = "") 

Now we will look at how many times each receiver was passed to (including incompletes) on a given down.

# how many times each receiver was passed to for each down downRec <- aggregate(offscore ~ down + Receiver, nygPass, length) # make down a factor for easier plotting downRec$down <- factor(downRec$down) # rename the offscore column to Passes downRec <- rename(downRec, c(offscore = "Passes")) ## calculate the total number of passes to a receiver throughout the ## season so we can remove receivers who didn't get passed to often totalPasses <- aggregate(Passes ~ Receiver, downRec, sum) totalPasses <- rename(totalPasses, c(Passes = "Total")) ## join that into the passing data and reduce the number of receivers downRec <- join(downRec, totalPasses, by = "Receiver") downRec <- downRec[which(downRec$Total >= 10), ] head(downRec, 10) 

## down Receiver Passes Total ## 1 1 A.Bradshaw 31 67 ## 2 2 A.Bradshaw 23 67 ## 3 3 A.Bradshaw 13 67 ## 4 1 B.Jacobs 16 29 ## 5 2 B.Jacobs 11 29 ## 6 3 B.Jacobs 2 29 ## 7 1 B.Pascoe 12 21 ## 8 2 B.Pascoe 7 21 ## 9 3 B.Pascoe 2 21 ## 18 1 D.Ware 16 38 

Now that we have the data ready we produce the graph from the top of this page shown here again.

ggplot(downRec, aes(x = reorder(Receiver, Passes), y = Passes)) + geom_bar(aes(group = down, color = down, fill = down), stat = "identity") + theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5)) + facet_wrap(~down) + scale_color_discrete("Down") + scale_fill_discrete("Down") + labs(x = "Receiver") 

We can see that on 1st down Eli preferred to throw to Hakim Nicks over anyone else. On subsequent downs (not much happened on 4th down) he slightly favored Victor Cruz including his 99-yard touchdown reception against the Jets in December.

More advanced analysis will hopefully come soon.

By the way, this is my first post using knitr to build the post and it made life SO much easier.  I highly recommend knitr for any web content involving code or the results of code.

This Monday I’ll be talking at the Amsterdam R meetup, better known as amst-R-dam.  At their request I’ll discuss the differences between the New York and Silicon Valley data scenes.  Time permitting I’ll also go over some topic that I’ll let the audience choose.

While President Obama made big news for his trip to Myanmar I would like to point out I rang the same bell as him (picture above) three years before he did.