Presidential Prediction Markets

We have put up a series of pages using stable analysis of prediction markets.  The Iowa and Intrade markets use real money.  The Wall Street Journal and Rasmussen markets allow people to trade like they are using money, but do not require any payment.  The Iowa market has limited accounts ($500) and special permission from the SEC to operate.  Intrade is based in Ireland.  Links to these pages are given below.

	Iowa Electronic Market Data
	Wall Street Journal Data
	Intrade Data
	Rasmussen Markets Data

When we have analyzed these prices, we have made the assumption that they should behave fundamentally like other financial markets and that differences of log prices should have a heavy tailed distribution.  This seems to be true but there are some differences in the shapes of the logarithmic returns that are difficult to explain.  We show these using the intrade data for the most recent 180 days.

obama=Import["http://data.intrade.com/graphing/jsp/downloadClosingPrice.jsp?contractId=409933","CSV"];
mccain=Import["http://data.intrade.com/graphing/jsp/downloadClosingPrice.jsp?contractId=376101","CSV"];
lrd1= Differences[Log[obama[[-180;;,5]]]];
lrr1= Differences[Log[mccain[[-180;;,5]]]];
Needs["StableM`"];
pd1=Quiet[SFit[lrd1]];
pr1=Quiet[SFit[lrr1]];
TableForm[{pd1,pr1},TableHeadings-> {{"Obama Closing", "McCain Closing"},{"α","β","γ","δ"}},TableSpacing-> {1,5}]

The two price series at the end of the campaign show similar values for the stable shape parameter, α.  To show this graphically stable fits of the density are shown to the two data histograms.

Needs["Histograms`"];
h1=Histogram[lrd1,HistogramScale->1];
d1=Plot[SPDF[x,pd1],{x,Min[lrd1],Max[lrd1]}, PlotStyle->{Thickness[0.008],Darker[Red]},PlotRange->All];
w1=Show[h1,d1,PlotLabel-> "Obama Histogram"];
h2=Histogram[lrr1,HistogramScale->1];
d2=Plot[SPDF[x,pr1],{x,Min[lrr1],Max[lrr1]}, PlotStyle->{Thickness[0.008],Darker[Red]},PlotRange->All];
w2=Show[h2,d2,PlotLabel-> "McCain Histogram"];
GraphicsRow[{w1,w2}]

The histograms show the Obama data to be more concentrated in the center as would be expected by the lower α in the fit.  Are these data truly stable?  The fits below show the tail behavior, using a special log distribution plot.

EmpiricCDFList[data_] := Block[{prob,sel,del},
					
					prob= Table[(i-0.5)/Length[data],{i,Length[data]}];
					Transpose[Join[{Sort[data]},{prob}]]];
Clear[DisplayLogStableFit];
scdf[x_?NumericQ,parm_,type_:1,opts___]:=SCDF[x,parm,type,opts];
DisplayLogStableFit[data_,parm_,type_Integer:1]:=Module[{clist,lt,rt,trt,lp1,lp2,lp3,lp4,lp5,nmn,nstd},
clist=EmpiricCDFList[data];
	lt = Select[clist,#[[1]]<0&];
	rt= Select[clist,#[[1]]>0&];
	trt=Transpose[rt];
lp1=ListLogLogPlot[Abs[lt],PlotStyle->Blue,PlotRange->All];
lp2=ListLogLogPlot[Transpose[{trt[[1]],1- trt[[2]]}],PlotStyle->Red,PlotRange->All];
lp3= LogLogPlot[scdf[-x,parm,type],{x,0.0001,-4 Min[data]},PlotStyle->Blue,PlotRange->All,PerformanceGoal->"Speed"];
lp4= LogLogPlot[1-scdf[x,parm,type],{x,0.0001,-4 Min[data]},PlotStyle->Red,PlotRange->All,PerformanceGoal->"Speed"];
nmn=Mean[data];
nstd=StandardDeviation[data];
lp5= LogLogPlot[1-scdf[x,{2,0,nstd /Sqrt[2],nmn},1],{x,0.0001,4 nstd},PlotStyle->Green,PlotRange->All];
Show[lp1,lp2,lp3,lp4,lp5,PlotLabel->"Log Log Left Tail Blue, Right Red\n    (Normal Green)",AspectRatio->Automatic,PlotRange->All]];wd=Quiet[DisplayLogStableFit[lrd1,pd1]];
wr=Quiet[DisplayLogStableFit[lrr1,pr1]];
GraphicsRow[{wd,wr},PlotLabel-> "Obama                                           McCain"]

The Obama data does not look like it belongs to a stable distribution.  The McCain data appears more likely stable and the fit has an α closer to that seen in real financial markets.  We have no idea why Obama buyers should behave differently than McCain buyers, but this seems consistent right now across all the markets we are following.  In all the markets, volume has been increasing as we approach the election and we may see the shape of the data change.

We are experimenting with another approach to analyze the data.  In the series below we take the log[ratio] of the Obama/McCain prices and look at the differences.  Using a ratio of prices overcomes one problem in the futures prices--they have an upper limit, 100.  The ratio is more like an actual price with a range, (0, ∞).  The series of the logarithm of the ratio is shown below.   A result of zero, Log[1] implies a tie, a positive result implies an Obama win; a negative result implies a McCain win.  

The plot of this data set shows Obama firmly in the lead until recently with the ratio crashing.

lratio=Log[obama[[-180;;,5]]/mccain[[-180;;,5]]];DateListPlot[Transpose[{Take[obama[[All,1]],-180],lratio}],Joined->True,PlotRange->All,PlotLabel->"Log[Obama/McCain]"]

We look at the stable fit to the differences of the Log[Obama/McCain] and find the stable fit to be appropriate.

dflr=Differences[lratio];
hh1=Histogram[dflr,HistogramScale->1];
prat=Quiet[SFit[dflr]];
dd1=Plot[SPDF[x,prat],{x,Min[dflr],Max[dflr]},PlotStyle->{Thickness[0.008],Darker[Red]},PlotRange->All];
CellPrint[TextCell[TableForm[Transpose[{{α,β ,γ ,δ },prat}]],"Text"]]
Show[hh1,dd1,PlotLabel-> "Log Ratio Differences"]

({{α, 1.3917345974124455`}, {β, 0.11603715318645072`}, {γ, 0.02872396013598668`}, {δ, 0.008085812548698874`}})

The fit of the log ratio differences looks more clearly stable on the tails.

Quiet[DisplayLogStableFit[dflr,prat]]

We now project this data set to election day.  The probability of a scaled outcome less than zero is a McCain win and the probability of a scaled outcome greater than zero is an Obama win.  We take the last ratio and see how much change is needed to bring the result to zero.

ScaleS1[n_,s1params_List] := {s1params[[1]],s1params[[2]],n^(1/s1params[[1]])s1params[[3]],n s1params[[4]]};
n=DateDifference[Last[mccain][[1]],{2008,11,4}];
repwin=SCDF[-Last[lratio],ScaleS1[n,prat]];
CellPrint[TextCell["Data scaled by "<>ToString[n]<>" days.  Last data point on "<>DateString[Last[mccain][[1]],"DateShort"]<>".","Text"]];
CellPrint[TextCell["Probability of McCain win "<>ToString[repwin],"Text"]];
CellPrint[TextCell["Probability of Obama win "<>ToString[1-repwin],"Text"]];

Data scaled by 1 days.  Last data point on Mon 3 Nov 2008.

Probability of McCain win 0.000561848

Probability of Obama win 0.999438

The calculation below, removes the trend (expectation of log return) in the data by setting the location parameter, δ, to zero.

repwin=SCDF[-Last[lratio],ScaleS1[n,{prat[[1]],prat[[2]],prat[[3]],0}]];
CellPrint[TextCell["Data scaled by "<>ToString[n]<>" days.  Last data point on "<>DateString[Last[mccain][[1]],"DateShort"]<>".","Text"]];
CellPrint[TextCell["Probability of McCain win "<>ToString[repwin],"Text"]];
CellPrint[TextCell["Probability of Obama win "<>ToString[1-repwin],"Text"]];

Data scaled by 1 days.  Last data point on Mon 3 Nov 2008.

Probability of McCain win 0.000565053

Probability of Obama win 0.999435

txcolor=RGBColor[181/255,18/255,27/255];
t1 = Graphics[Text[Hyperlink[Framed[Style["Financial Home", {txcolor, Bold, Larger}]], "../map/Overview.html"], {-5, 0}]];
t2 = Graphics[Text[Hyperlink[Framed[Style["2004 Data", {txcolor, Bold, Larger}]], "../e00/Election04.html"], {0,1}]];
t3 = Graphics[Text[Hyperlink[Framed[Style["Download Notebook", {txcolor, Bold, Larger}]], "../e05/PresidentialPrediction.nb"], {5, 0}]];
t4 = Graphics[Text[Hyperlink[Framed[Style["InTrade Market", {txcolor, Bold, Larger}]], "../e03/InTradeElection08.html"], {0, 0}]];
t5 = Graphics[Text[Hyperlink[Framed[Style["IEM Market", {txcolor, Bold, Larger}]], "../e01/Election08.html"], {0, -1}]];
Show[ t1, t2, t3, t4,t5, ImageSize -> 500]
CellPrint[TextCell["\n\n© Copyright " <> ToString[DateList[][[1]]] <> " mathestate    " <> DateString[DateList[], "DateShort"], "Text"]]

© Copyright 2008 mathestate    Mon 3 Nov 2008