dsdcElectionExample/PollingExampleSource.R at master · robbymeals/dsdcElectionExample · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
##### Called In Driver
#library(ggplot2)
#library(reshape2)
#library(lubridate)
#library(stringr)
#library(xtable)
#library(plyr)
#library(scales)
#library(ggmap)
##library(gridExtra)

## General Bayesian Binom Prop Inference Functions
#source('InferenceFunctions.R')
## Functions specific to Polling Data Example
#source('PollingExampleFunctions.R')

##### 2008 Election ####
## 2008 Parameters
#elecDay <- '2008-11-04'
#cutOff <- '2008-08-01'
##cutOff <- NA
#elecPassed = T
#elecType <- 'President'
#candidates <- list('d'='Obama','r'='McCain')
#d_m = 0.5
#r_m = 0.5
#init_n = 2
#### Called In Driver

## read in datasets
elecYear <- year(as.Date(elecDay))
dataDir <- paste('./Datasets/',elecType,'_',elecYear,'/', sep='')
dSets <- list.files(dataDir)
states <- sub('.txt','',dSets)
raw_dfs <- list()
for (state in states){
	raw_dfs[[state]] <- read.table(paste(dataDir,state,'.txt',sep=''),sep='\t', stringsAsFactors=F,header=T)
}

## Proprocess data frames
poll_dfs <- list()
for(state in names(raw_dfs)){
	poll_dfs[[state]] <- ppDf_polling(raw_dfs[[state]], candidates, elecDay, elecPassed, cutOff=cutOff)
}

## default is same priors for each state
## if you want to specify priors for each state, just write to df
priors_d = matrix(nrow=length(states),ncol=2)
priors_r = matrix(nrow=length(states),ncol=2)
rownames(priors_d) <- states
rownames(priors_r) <- states
colnames(priors_d) <- c('m','n')
colnames(priors_r) <- c('m','n')
for (state in states){
	priors_d[state,] <- c(d_m,init_n)
	priors_r[state,] <- c(d_m,init_n)
}

########################################################################
################### Simple Dual Binomial/Beta Models ###################
########################################################################

## Initial Beta Prior parameters
d_prior <- qplot(data=Prior(d_m,init_n),x=x,y=y,geom='line')
r_prior <- qplot(data=Prior(r_m,init_n),x=x,y=y,geom='line')

## Run updating models
d_models = list()
r_models = list()
for(state in names(poll_dfs)){
	d_models[[state]] <- runUpdatingModels('Y_d',poll_dfs[[state]],init_m=priors_d[state,'m'], init_n=priors_d[state,'n'])
	r_models[[state]] <- runUpdatingModels('Y_r',poll_dfs[[state]],init_m=priors_r[state,'m'], init_n=priors_r[state,'n'])
}

## Compare Predictions to real outcomes
preds = list()
for(state in names(poll_dfs)){
	preds[[state]] <- c(
				r_models[[state]][["models_df"]][nrow(r_models[[state]][["models_df"]]),'mean_posterior'],
				d_models[[state]][["models_df"]][nrow(d_models[[state]][["models_df"]]),'mean_posterior'])
}

## Get Real Clear Politics Predictions
rcpPreds <- ldply(raw_dfs, function(x) return(x[with(x,Poll=='RCP Average'),5:6]))
colnames(rcpPreds) <- sub(paste(candidates[['d']],'..D.',sep=''),'D',colnames(rcpPreds))
colnames(rcpPreds) <- sub(paste(candidates[['r']],'..R.',sep=''),'R',colnames(rcpPreds))
rownames(rcpPreds) <- rcpPreds[,1]
rcpPreds <- rcpPreds[,c('D','R')]
colnames(rcpPreds) <- c(candidates[['d']],candidates[['r']])
rcpPreds[,'Outcome'] <- rcpPreds[,candidates[['d']]] - rcpPreds[,candidates[['r']]]
rcpPreds$Winner <- apply(rcpPreds[,c(candidates[['d']],candidates[['r']])],1,function(x) return(names(which.max(x))))

## Get my predictions
myPreds <- ldply(preds)
myPreds <- myPreds[,2:3]
myPreds <- data.frame(myPreds)
rownames(myPreds) <- names(preds)
colnames(myPreds) <- c(candidates[['r']],candidates[['d']])
myPreds <- round((myPreds*100),1)
myPreds <- myPreds[,c(candidates[['d']],candidates[['r']])]
myPreds[,'Outcome'] <- myPreds[,candidates[['d']]] - myPreds[,candidates[['r']]]
myPreds$Winner <- apply(myPreds[,c(candidates[['d']],candidates[['r']])],1,function(x) return(names(which.max(x))))

## if Election is passed
if(elecPassed == T){
	## get actual outcomes
	outcomes <- ldply(raw_dfs, function(x) return(x[with(x,Poll=='Final Results'),5:6]))
	colnames(outcomes) <- sub(paste(candidates[['d']],'..D.',sep=''),'D',colnames(outcomes))
	colnames(outcomes) <- sub(paste(candidates[['r']],'..R.',sep=''),'R',colnames(outcomes))
	rownames(outcomes) <- outcomes[,1]
	outcomes <- outcomes[,c('D','R')]
	colnames(outcomes) <- c(candidates[['d']],candidates[['r']])
	outcomes[,'Outcome'] <- outcomes[,candidates[['d']]] - outcomes[,candidates[['r']]]
	outcomes$Winner <- apply(outcomes[,c(candidates[['d']],candidates[['r']])],1,function(x) return(names(which.max(x))))

	## Compare forecasts to outcomes
	abs(rcpPreds[,'Outcome'] - outcomes[,'Outcome']) -> rcpPreds[,'fcstError']
	abs(myPreds[,'Outcome'] - outcomes[,'Outcome']) -> myPreds[,'fcstError']
	rcpCorr <- sum(rcpPreds$Winner == outcomes$Winner)
	myCorr <- sum(myPreds$Winner == outcomes$Winner)

	## abuse of rmse
	closeStates <- rownames(subset(outcomes, abs(Outcome) < 2))
	myPreds_rmse <- sqrt(mean(myPreds[,'fcstError']^2))
	rcpPreds_rmse <- sqrt(mean(rcpPreds[,'fcstError']^2))
	myPreds_rmse_close <- sqrt(mean(myPreds[closeStates,'fcstError']^2))
	rcpPreds_rmse_close <- sqrt(mean(rcpPreds[closeStates,'fcstError']^2))
	rmse <- rbind('My Predictions'=c(myPreds_rmse, myPreds_rmse_close, myCorr),
		'RealClearPolitics Predictions'=c(rcpPreds_rmse, rcpPreds_rmse_close, rcpCorr))
	colnames(rmse) <- c('RMSE','RMSE, Diff < 2%','Number Correctly Predicted')
}