The TradeSports data

In[153]:=

key = {"State", "Winner", "Bid Price", "Prev. Bid Price&quo ... Price Change", "EVs", "EV-weighted change", "24-hour Volume"} ;

The table itself is in this node

Analysis

The two big assumptions here are that the outcomes for the various "states" (we think of D.C. as a state) are independent Bernoulli trials, and that the TradeSports quotes are reasonable proxies for the means of these trials.  Neither is a particularly believable assumption, but it's the best I can do.  Also, no attempt is made to account for non-winner-takes-all outcomes in ME, NE, or CO, nor for the vagaries of faithless electors.

Total EVs up for grabs

In[316]:=

evs = Total[table[[All, 6]]]

Out[316]=

538

Dynamic program for the PDF over EVs

In[317]:=

dp[0] := PadRight[{1}, evs + 1] dp[n_] := With[{ev = table[[n, 6]], prob = Rationalize[table[[ ... ]], 0]/100, prev = dp[n - 1]}, prob * PadLeft[prev, evs + 1, 0, -ev] + (1 - prob) * prev]

The PDF and CDF

In[319]:=

dist = dp[51] ;

In[320]:=

cumdist = Table[Total[Take[dist, i]], {i, Length[dist]}] ;

The mean Bush-advantage

In[321]:=

(mean = Total[dist * Range[-evs/2, evs/2]])//N

Out[321]=

5.9247

Other parameters of the distribution.  Probability of Bush loss/tie/win is 41.7%, 1.5%, 56.8%

In[322]:=

{Length[dist], Total[dist], Total[Take[dist, evs/2]], dist[[evs/2 + 1]], Total[Drop[dist, evs/2 + 1]], Total[dist * Range[-evs/2, evs/2]]}//N

Out[322]=

RowBox[{{, RowBox[{539., ,, 1., ,, 0.417066, ,, 0.0150389, ,, 0.567895, ,, 5.9247}], }}]

In[66]:=

<<Graphics`Colors`

Log plot of the PDF

In[323]:=

ListPlot[Log[dist]]

Graphics :: gptn : Coordinate -∞ in {2, -∞} is not a floating-point number. More…

Graphics :: gptn : Coordinate -∞ in {3, -∞} is not a floating-point number. More…

Graphics :: gptn : Coordinate -∞ in {537, -∞} is not a floating-point number. More…

General :: stop : Further output of Graphics :: gptn will be suppressed during this calculation. More…

[Graphics:HTMLFiles/election2004_20.gif]

Out[323]=

⁃Graphics⁃

The binomial distribution with the same mean, for comparison

In[117]:=

<<Statistics`DiscreteDistributions`

In[324]:=

binapx = BinomialDistribution[evs, (mean + evs/2)/evs]

Out[324]=

BinomialDistribution[538, 2749247/5380000]

In[325]:=

ListPlot[Log[Table[PDF[binapx, i], {i, 0, evs}]]]

[Graphics:HTMLFiles/election2004_26.gif]

Out[325]=

⁃Graphics⁃

Plot of the PDF, with the binomial distribution for comparison

In[326]:=

pts = Table[{Which[i<0, Blue, i0, Green, i>0, Red], Point[{i, dist[[i + evs/2 + 1]]}]}, {i, -evs/2, evs/2}] ;

In[327]:=

binom = Line[Table[{i, PDF[binapx, i + evs/2]}, {i, -evs/2, evs/2}]] ;

In[328]:=

Show[Graphics[{pts, binom}], AxesTrue, PlotRangeAll] ;

[Graphics:HTMLFiles/election2004_31.gif]

Plot of the CDF

In[329]:=

cumpts = Table[{Which[i<0, Blue, i0, Green, i>0, Red], Line[{{i, cumdist[[i + evs/2 + 1]] - dist[[i + evs/2 + 1]]}, {i, cumdist[[i + evs/2 + 1]]}}]}, {i, -evs/2, evs/2}] ;

In[330]:=

cumbinom = Line[Table[{i, CDF[binapx, i + evs/2]}, {i, -evs/2, evs/2}]] ;

In[331]:=

Show[Graphics[{cumpts, cumbinom}], AxesTrue, PlotRangeAll] ;

[Graphics:HTMLFiles/election2004_35.gif]

Quintiles

In[332]:=

RowBox[{RowBox[{Table, [, RowBox[{RowBox[{Count, [, RowBox[{cumdist, ,, RowBox[{x_, /;, RowBox[{x, <, RowBox[{i, *, 0.2}]}]}]}], ]}], ,, {i, 4}}], ]}], -, evs/2}]

Out[332]=

{-18, -2, 12, 29}

Hmm... the CDF is shockingly linear between 20% and 80%.  Is there a simple explanation for that?

The following revised dynamic program computes a PDF for a given subset of the states.

In[333]:=

RowBox[{pdp[{}], :=, RowBox[{PadRight, [, RowBox[{RowBox[{{, 1., }}], ,, evs + 1, ,, 0.}], ]}] ... 1, ,, 0., ,, -ev}], ]}]}], +, RowBox[{RowBox[{(, RowBox[{1., -, prob}], )}], *, prev}]}]}], ]}]}]

The PDF of the lose/tie/win variable for a given subset of the states with a given bias

In[335]:=

ltw[l_, bias_] := With[{pdf = pdp[l]},  {Total[Take[pdf, bias]], pdf[[bias + 1]], Total[Drop[pdf, bias + 1]]}]

The entropy of a PDF, in bits

In[336]:=

ent[l_] := Total[l * Log[.5, l]]

(* ent[l_] := Module[{x}, Total[Map[Limit[x * Log[1/2, x], x#] &, l]]] *)

The entropy of the lose/tie/win variable for a given subset of the states with a given bias

In[337]:=

ltwent[l_, bias_] := ent[ltw[l, bias]]

In[338]:=

states = Length[table]

Out[338]=

51

The entropy of the election

In[339]:=

ltwent[Range[states], evs/2]

Out[339]=

1.08083

The conditional entropy over the states l given the result for state n

In[340]:=

RowBox[{condent[n_, l_, bias_], :=, RowBox[{With, [, RowBox[{RowBox[{{, RowBox[{l2 = Complemen ... ent[l2, bias2], +, RowBox[{RowBox[{(, RowBox[{1., -, prob}], )}], *, ltwent[l2, bias]}]}]}], ]}]}]

The conditional entropies for the various states, as percentages of the total entropy

In[341]:=

cents = With[{tmp = ltwent[Range[states], evs/2]}, Table[(tmp - condent[i, Range[states], evs/2])/tmp, {i, states}]]

Out[341]=

RowBox[{{, RowBox[{0.00113566, ,, 0.0000797879, ,, 0.00508159, ,, 0.00238467, ,, 0.0213238, ,, ... 98, ,, 0.000119589, ,, 0.00850346, ,, 0.00403897, ,, 0.001484, ,, 0.0136118, ,, 0.000125142}], }}]

The states sorted by the conditional entropies

In[342]:=

Reverse @ Transpose[{table[[All, 1]], cents}][[Ordering[cents]]]

Out[342]=

RowBox[{{, RowBox[{RowBox[{{, RowBox[{FLORIDA, ,, 0.126925}], }}], ,, RowBox[{{, RowBox[{OHIO, ... {, RowBox[{ALASKA, ,, 0.0000797879}], }}], ,, RowBox[{{, RowBox[{DC, ,, 0.0000355594}], }}]}], }}]

The upper levels of the decision tree of the lose/tie/win variable

In[343]:=

dtree[0, l_, bias_] := ltw[l, bias] dtree[n_, l_, bias_] := With[{cents = Map[condent[#, l, bi ... s], dtree[n - 1, Complement[l, {l[[order[[1]]]]}], bias - table[[l[[order[[1]]]], 6]]]}]]

In[345]:=

dt = dtree[4, Range[states], evs/2]

Out[345]=

RowBox[{{, RowBox[{1.08083, ,, RowBox[{{, RowBox[{0.417066, ,, 0.0150389, ,, 0.567895}], }}], ... ], ,, RowBox[{{, RowBox[{0.00960385, ,, 0.00157518, ,, 0.988821}], }}]}], }}]}], }}]}], }}]}], }}]

Created by Mathematica  (November 1, 2004)