Speed bumps

Where it was wondered about the way that the 2011 earthquake’s effect on road conditions might influence people street racing cars.

Taking the Road Policing driver offence data


and the date of the Canterbury Earthquake of 22nd February 2011, let’s see if “Did the munted roads alter speeding behaviour” in a couple of quick exploratory graphs

download.file("http://www.police.govt.nz/sites/default/files/publications/road-policing-driver-offence-data-2-jan-2009-sept-2015.xlsx", destfile="policeroad.xlsx")

I am pulling out the speed by excess table (police officers rather than speed cameras), as that is the evidence for how fast people are speeding (if only for December and January) by region

rdsp <- read.xlsx("policeroad.xlsx", sheet="Speed by Excess Dec-Jan", colNames = FALSE, rows=5:41, cols=1:134)
rdsp[,3:134] <- sapply( rdsp[,3:134], as.numeric )
names(rdsp)[1:2] <- c("region", "area")
yr <- "DecX2009_12_01"
steps <- c("under11", "11to15", "16to20", "21to25", "26to30", "31to35", "36to40", "41to45", "46to50", "over50", "total")
names(rdsp)[3:13] <- paste(yr, steps, sep="X")
yr <- "JanX2010_01_01"
names(rdsp)[14:24] <- paste(yr, steps, sep="X")
yr <- "DecX2010_12_01"
names(rdsp)[25:35] <- paste(yr, steps, sep="X")
yr <- "JanX2011_01_01"
names(rdsp)[36:46] <- paste(yr, steps, sep="X")
yr <- "DecX2011_12_01"
names(rdsp)[47:57] <- paste(yr, steps, sep="X")
yr <- "JanX2012_01_01"
names(rdsp)[58:68] <- paste(yr, steps, sep="X")
yr <- "DecX2012_12_01"
names(rdsp)[69:79] <- paste(yr, steps, sep="X")
yr <- "JanX2013_01_01"
names(rdsp)[80:90] <- paste(yr, steps, sep="X")
yr <- "DecX2013_12_01"
names(rdsp)[91:101] <- paste(yr, steps, sep="X")
yr <- "JanX2014_01_01"
names(rdsp)[102:112] <- paste(yr, steps, sep="X")
yr <- "DecX2014_12_01"
names(rdsp)[113:123] <- paste(yr, steps, sep="X")
yr <- "JanX2015_01_01"
names(rdsp)[124:134] <- paste(yr, steps, sep="X")

Calculate the proportion for each region caught travelling more than 30 km/hr over the limit.

rdsp$DecX2009_12_01Xpercent_above30 <- rowSums(rdsp[,8:12])/rdsp[,13]
rdsp$JanX2010_01_01Xpercent_above30 <- rowSums(rdsp[,19:23])/rdsp[,24]
rdsp$DecX2010_12_01Xpercent_above30 <- rowSums(rdsp[,30:34])/rdsp[,35]
rdsp$JanX2011_01_01Xpercent_above30 <- rowSums(rdsp[,41:45])/rdsp[,46]
rdsp$DecX2011_12_01Xpercent_above30 <- rowSums(rdsp[,52:56])/rdsp[,57]
rdsp$JanX2012_01_01Xpercent_above30 <- rowSums(rdsp[,63:67])/rdsp[,68]
rdsp$DecX2012_12_01Xpercent_above30 <- rowSums(rdsp[,74:78])/rdsp[,79]
rdsp$JanX2013_01_01Xpercent_above30 <- rowSums(rdsp[,85:89])/rdsp[,90]
rdsp$DecX2013_12_01Xpercent_above30 <- rowSums(rdsp[,96:100])/rdsp[,101]
rdsp$JanX2014_01_01Xpercent_above30 <- rowSums(rdsp[,107:111])/rdsp[,112]
rdsp$DecX2014_12_01Xpercent_above30 <- rowSums(rdsp[,118:122])/rdsp[,123]
rdsp$JanX2015_01_01Xpercent_above30 <- rowSums(rdsp[,129:133])/rdsp[,134]

Rearrange the data

rdspL <- gather(rdsp, category, value, DecX2009_12_01Xunder11:JanX2015_01_01Xpercent_above30)
rdspL$category <- as.character(rdspL$category)
rdspL$category <- sub("DecX","",rdspL$category)
rdspL$category <- sub("JanX","",rdspL$category)
rdspL <- separate(rdspL, category, c("speeddate","division"), sep="X")
rdspL$speeddate <- as.Date(gsub("_","-",rdspL$speeddate))

Making a plot of the propotion of over 30 km/h speeders to all speeders

#all individual areas in faded grey
perc <- rdspL[grep("percent", rdspL$division),]
perc <- perc[order(perc$speeddate),]
plot(perc$speeddate, perc$value, pch=19, col="#AAAAAA33", cex=0.3, frame.plot=FALSE, ylab="Proportion of speeders > 30km/h over limit", xlab="month", main="Proportion of speeders exceeding 30km/h")
for (anArea in unique(perc$area)){
  rowcriteria <- perc$area == anArea
  lines(perc$speeddate[rowcriteria], perc$value[rowcriteria], pch=19, col="#AAAAAA33", cex=0.3)
#the median propotion for each time dotted and black
media <- aggregate(value ~ speeddate, data = perc, median)
points(media$speeddate, media$value, pch=19, col="black", cex=0.3)
lines(media$speeddate, media$value, col="black", cex=0.3)
#Christchurch in green
perc <- perc[perc$area == "Canterbury Metro",]
points(perc$speeddate, perc$value, pch=19, col="#008800", cex=0.3)
lines(perc$speeddate, perc$value, col="#008800", cex=0.3)
legend("topright", legend = c("areas", "median", "Christchurch"), inset=.05, col=c("#AAAAAA33","#000000","#008800"), lty=1, bty="n")


Given the variablity between regions and times, the Chirstchurch data is highly normal.

Making a plot of the propotion speeders that come from each region

tots <- rdspL[grep("total", rdspL$division),]

timetotal <- aggregate(value ~ speeddate, data=tots, sum)
names(timetotal)[2] <- "total"
tots <- merge(tots, timetotal)
tots$perc <- tots$value/ tots$total
#all individual areas in faded grey
tots <- tots[order(tots$speeddate),]
plot(tots$speeddate, tots$perc, pch=19, col="#AAAAAA33", cex=0.3, frame.plot=FALSE, ylab="Proportion of speeders from area", xlab="month", main="Proportion of speeders in area in relation to country", ylim=c(0,0.13))
for (anArea in unique(tots$area)){
  rowcriteria <- tots$area == anArea
  lines(tots$speeddate[rowcriteria], tots$perc[rowcriteria], pch=19, col="#AAAAAA33", cex=0.3)
#the median propotion for each time dotted and black
media <- aggregate(perc ~ speeddate, data = tots, median)
points(media$speeddate, media$perc, pch=19, col="black", cex=0.3)
lines(media$speeddate, media$perc, col="black", cex=0.3)
#Christchurch in green
tots <- tots[tots$area == "Canterbury Metro",]
points(tots$speeddate, tots$perc, pch=19, col="#008800", cex=0.3)
lines(tots$speeddate, tots$perc, col="#008800", cex=0.3)
legend("top", legend = c("areas", "median", "Christchurch"), horiz=TRUE, col=c("#AAAAAA33","#000000","#008800"), lty=1, bty="n")


I’m not going to say “shame on you Christchurch” without going to multiple censuses and getting the number of cars per household and working out the number of cars in each area, so we could then in turn work out the number of speeding incidents per vehical (which I am not going to do for this exercise).

The key, for this perspective, is that there was no dramatic reduction in the proportion of Christchuch to other places between January 2011 and December 2011, suggesting no particular effect on speeding.


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 )

Google+ photo

You are commenting using your Google+ 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 )


Connecting to %s