San Francisco ballot data analyzer

Adam G. Weyhaupt
Southern Illinois University Edwardsville
June 1, 2011

We are doing some dangerous things here with single letter symbols.  The symbols “a” through “z” need to have no value, so we clear everything.  It is not safe to use single variable symbols in any code in this notebook.

Clear[Evaluate[Context[]<>"*"]]

Data input and setup

votes = ReadList["/Users/adamweyhaupt/Dropbox/papers/classroom_capsule/D10/BallotImage-D10.txt"];

Length[votes]

listVotes = IntegerDigits[votes];

Length[listVotes]

Pull out only the candidate ranks for each ballot.

numPrefList = Table[{listVotes[[i]][[36;;37]] , listVotes[[i+1]][[36;;37]] , listVotes[[i+2]][[36;;37]] }, {i, 1, Length[listVotes], 3}];

Next command takes the candidate code and turns it into a,b,c, etc.  You can do this automatically or manually with the code that is commented out.  If you want to collapse several candidates into one, this is the place to do it.

(* alphaPrefList = numPrefList/.Thread[Rule[Union[Flatten[numPrefList,1]], Take[Prepend[Map[Symbol,CharacterRange["a","z"]],""], Length[Union[Flatten[numPrefList,1]]]]]]; *)

alphaPrefList = numPrefList/.{{4,6}->y, {4,7}->c, {4,8}->b, {4,9}->y, {5,0}->y, {5,1}->g, {5,2}->h, {5,3}->y, {5,4}->y, {5,5}->y, {5,6}->z, {5,7}->m, {5,8}->y, {5,9}->o, {6,0}->z, {6,1}->y, {6,2}->r, {6,3}->f, {6,4}->t, {6,5}->u, {6,6}->z,{2,6}->a, {0,0}->""};

Number of ballots.

Length[numPrefList]

Functions to manipulate data and compute social choice

(* Comments appear inside paren/asterisk pairs *)

(* Functions to clean the data. *)

(* creates a list of those alternatives which appear on ballots *)
alternatives = DeleteCases[Union[Flatten[alphaPrefList]], ""];

(* an internal function used to ensure that all alternatives are represented in tallies *) 
standardizeList[list_, alts_] := Module[{output = list,i}, 
For[i=1, i ≤ Length[alts], i++, 
If[!MemberQ[output,{alts[[i]], _}], PrependTo[output,{alts[[i]], 0}]]];
Sort[DeleteCases[output, {"",_}]]];

(* removes duplicates from a list of preference lists *)
noDups[list_] := Map[Fold[If[MemberQ[#1,#2],Append[#1, ""],Append[#1,#2]]&,{},#]&, list];
(* removes blanks from a list of preference lists *)
noBlanks[list_] := DeleteCases[Delete[list, Position[list, ""]], {}];
(* removes blanks and duplicates from a list of preference lists *)
noBlanksnoDups[list_] := DeleteCases[Map[DeleteDuplicates[#]&, noBlanks[list]], {}];

(* Functions to compute social choices. *)

(* computes the Borda tallies *)
borda[list_] := Sort[Map[{#[[1]]/6, #[[2]]}&, 3 standardizeList[Tally[Map[#[[1]]&,Map[PadRight[#,3,""]&,list]]], DeleteCases[Union[Flatten[list]], ""]] + 2 standardizeList[Tally[Map[#[[2]]&,Map[PadRight[#,3,""]&,list]]], DeleteCases[Union[Flatten[list]], ""]]+ 1*standardizeList[Tally[Map[#[[3]]&,Map[PadRight[#,3,""]&,list]]], DeleteCases[Union[Flatten[list]], ""]]], #1[[2]]>#2[[2]]&];

(* computes plurality tallies *)
plurality[list_] := Sort[standardizeList[Tally[Map[First,list]],  DeleteCases[Union[Flatten[list]], ""]], #1[[2]]>#2[[2]]&];

(* internal function to remove an alternatives from all ballots *)
remove[list_, elt_] := Map[(Delete[#, Position[#, elt]])&, list];

(* computes the instant run-off winner *)
instantRunOff[list_] := Module[{win = plurality[list], len},
len = Length[win];
If[len == 1, win[[1]][[1]], 
instantRunOff[noBlanks[remove[list, win[[-1]][[1]]]]]
]];

(* given a list of preference lists and two alternatives a and b, determines which is the winner of a head to head competition *) 
vs[list_, a_, b_] := Module[{
count = {0,0},
winner
},

Map[(count+=Which[Length[Position[#, a,1,1]] == 0 && Length[Position[#, b,1,1]] == 0, {0,0},
Length[Position[#, a,1,1]] == 1 && Length[Position[#, b,1,1]] == 0, {1,0},
Length[Position[#, a,1,1]] == 0 && Length[Position[#, b,1,1]] == 1, {0,1},
Length[Position[#, a,1,1]] == 1 && Length[Position[#, b,1,1]] == 1 && Flatten[Position[#, a,1,1]][[1]] < Flatten[Position[#, b,1,1]][[1]], {1,0},
Length[Position[#, a,1,1]] == 1 && Length[Position[#, b,1,1]] == 1 && Flatten[Position[#, a,1,1]][[1]] > Flatten[Position[#, b,1,1]][[1]], {0,1}])&,list];
winner = Which[count[[1]] < count[[2]], b, count[[1]]> count[[2]], a];
winner
]

(* determines the condorcet winner, or outputs the phrase "no winner" if none exists *)
condorcet[list_] := Module[{
winner,
condmatrix,
alts = DeleteCases[Union[Flatten[list]], ""],
condwinner = "no winner",
i =1,
j
},
condmatrix = Table[If[i == j, 1, 2], {i, 1, Length[alts]}, {j, 1, Length[alts]}];
While[i ≤ Length[alts],  
If[Times@@condmatrix[[i]] > 1,
j = Flatten[Position[condmatrix[[i]],2]][[1]];
If[SymbolName[vs[list, alts[[j]], alts[[i]]]] ==  SymbolName[alts[[i]]],
condmatrix[[i]][[j]] = 1;
condmatrix[[j]][[i]] = 0;,
condmatrix[[i]][[j]] = 0;
condmatrix[[j]][[i]] = 1;]
];
If[Times@@condmatrix[[i]] == 1, condwinner= i; i = Length[alts] + 1,If[Times@@condmatrix[[i]] == 0,  i ++ ]];
];
If[condwinner == "no winner", condwinner, alts[[condwinner]]]
]

Examples

borda[alphaPrefList]

borda[noDups[alphaPrefList]]

borda[noBlanks[alphaPrefList]]

borda[noBlanksnoDups[alphaPrefList]]

plurality[alphaPrefList]

plurality[noDups[alphaPrefList]]

plurality[noBlanks[alphaPrefList]]

plurality[noBlanksnoDups[alphaPrefList]]

condorcet[noBlanksnoDups[alphaPrefList]]

instantRunOff[alphaPrefList]

Export["Apreflist_nodups.csv", noDups[alphaPrefList]]