Nothing
# functions_meek.R - last revised 28 june 2023, minor rev'n 23 jan 2024
# functions transfer and share; decision and decision_text;
# function select for permutations used in share
# vm a matrix - row = 1st pref, col = who with currently
# case where equal prefs allowed
# -> delegates sharing out of each vote to function ..
# .. share which calculates details for a single vote
transfer=function(k,iter,vote,mult,ns,ie,em,surplus,sel){
# to transfer surpluses at each stage
nv=dim(vote)[[1]]; nc=dim(vote)[[2]]; ic=1:nc
je=ic[ie==1]; ne=length(je)
v3=array(0,dim=c(nc,(nc+1),2^ne))
for(iv in 1:nv){
b=vote[iv,]
# split vote if more than one first pref (needed to audit transfers)
if(length(b[b!=0])==0){v3[(nc+1),(nc+1),1]=v3[(nc+1),(nc+1),1]+1 # (empty vote)
}else{
f=min(b[b!=0])
e1=ic[b==f] # could pick out "all equal" votes here (length(e1)==nc)
nf=length(e1)
for(j in e1){
bj=b; bj[b>0]=b[b>0]+1
bj[[j]]=1
# deal with this (part of a) vote, going through choices in order of pref
bj[ie==-1]=0 # ignore any preferences for excluded candidates
v3[j,,]=v3[j,,]+share(ie,bj,sel)*mult[[iv]]/nf # for share see below
}}
}
if(ne==0){iter=iter+1
vm=v3[,,1]; vc=apply(vm,2,sum)
qa=sum(vc[1:nc])/(ns+1) # revise quota
}else{
perm=sel[[ne]]
v4=apply(v3,c(2,3),sum)
i94=1
while(surplus>em | i94==1){
i94=0
t=1-k; te=t[je]; tr=te[ne:1]
# Calc vc from coefs using current val of t (=1-k)
coef=numeric()
for(i in 1:2^ne){
coef[[i]]=prod(tr^perm[[i]])
}
vc=v4%*%coef
qa=sum(vc[1:nc])/(ns+1) # revise quota
# calculate surplus of already-elected candidates
surplus=sum(vc[je]-qa)
k[je]=k[je]*qa/vc[je]; te=1-k[je]
iter=iter+1
}
vm=matrix(0,nrow=nc,ncol=(nc+1))
for(i in 1:nc){
for(j in 1:(nc+1)){
vm[i,j]=sum(v3[i,j,]*coef)}}
}
list(k=k,vm=vm,vc=vc,qa=qa,inn=je,iter=iter,sur=surplus)
}
share=function(ie,b,sel){
# share - function to share out one vote, b (in ballot format)
# new version 10 Mar 2022 to save as (nc+1) x 2^ne matrix of polynomial coefficients
# ie indicates candidate status = -1 if excl, 1 if elec, 0 if undecided
nc=length(b); ic=1:nc
jj=ic[ie==1]; ne=length(jj)
code=rep(0,nc); code[jj]=2^(0:(ne-1))
sh=matrix(0,nrow=(nc+1),ncol=2^ne) # for shares of vote
c0=1
b[ie<0]=0 # treat excl candidates as though non-existent
if(max(b)>0){
prefs=as.numeric(names(table(b[b!=0]))) # pref values used, in order
mu=0 # no. of undecided in group
ip=0
while(mu==0 & ip<length(prefs)){
ip=ip+1 # look at next set of equal prefs
jp=ic[b==prefs[[ip]]]; m=length(jp) # = me+mu
# separate into elec and undecided; elec trickier - they transfer surpluses
je=ic[b==prefs[[ip]] & ie==1]; me=length(je)
ju=ic[b==prefs[[ip]] & ie==0]; mu=length(ju)
if(me==1){sh[je,c0+c(0,code[[je]])]=c(1,-1)/m}
if(me>1){
z=sel[[me-1]]
for(i in je){
c1=code[je[je!=i]]
for(j in z){
j=as.logical(j)
amt=factorial(sum(j))/prod(m:(m-sum(j)))
coef=c0+sum(c1[j])+c(0,code[[i]])
sh[i,coef]=sh[i,coef]+amt*c(1,-1)
}}
}
if(mu>0){
d=rep(0,2^ne); d[[c0]]=1
if(me==1){d=d-sh[je,]}
if(me>1){d=d-apply(sh[je,],2,sum)}
for(jj in 1:mu){sh[ju[jj],]=d/mu}
}
c0=c0+sum(code[je])
}
sh[(nc+1),c0]={mu==0}
}else{sh[(nc+1),1]=1}
sh
}
decision=function(nc,vc,qa,ie,k,stage,fin,csum,st,surplus,hp){
# to make next decision (elect/exclude)
x=order(-vc[1:nc]); x=x[ie[x]==0]; elec=numeric(); xcl=numeric(); hp0=hp
# will switch to `high precision' if a close call
# 1 is there another clearly elec?
if(vc[x[[1]]]>=qa){
# if exact order of elec important, need to check margin > surplus
# if margin <= surplus, need to reduce em and try again
elec=x[vc[x]>=qa]
surplus=surplus+sum(vc[elec])-qa*length(elec)
}else{
# 2 if at low precision, is there another within surplus of election?
if(hp==1 & vc[x[[1]]]>=(qa-surplus)){hp=2}else{
# 3 if at low precision
x=order(vc[1:nc]); x=x[ie[x]==0]
if(hp==1 & vc[[x[[1]]]]>(vc[[x[[2]]]]-surplus)){hp=2}else{
# 4 exclude lowest
xcl=x[[1]]
k[[xcl]]=0
ic=1:nc
}
}}
# skip output if have gone to high precn (hp!=hp0)
if(hp==hp0){
if(length(c(elec,xcl))>0){
ie[elec]=1; ie[xcl]=-1
stage=stage+1
if(fin==0){
csum=cbind(csum,vc); st=c(st,paste("st",stage,sep=""))
}}}
list(k=k,ie=ie,elec=elec,xcl=xcl,stage=stage,csum=csum,st=st,surplus=surplus,hp=hp)
}
decision_text=function(stage,ne,ns,elec,xcl,name,dnext){
# function to generate output text for a stage
# not expecting to elect and exclude at same stage
# and only expect one exclusion at a time
if(ne==ns){final=" - final result"}else{final=""}
dec2=""
if(stage==1){dec1=paste("first preferences - ",final,sep="")}else{
dec1=paste("stage ",stage,final," - ",dnext,sep="")
}
if(length(elec)>0){
x=plural(name[elec])
dec2=paste(x$out,x$has,"achieved the quota, so",x$is,"elected")
dnext=paste("after transfer of surplus",x$es," of ",x$out,sep="")
}
if(length(elec)==0){
if(ne==0){nomore="no-one"}else{nomore="no-one else"}
dec2=paste(nomore,"has achieved the quota, so exclude",name[xcl])
dnext=paste("after transfer of votes of",name[xcl])
}
list(t=c(dec1,dec2),d=dnext)
}
select=function(nmax){
# for use generating all subsets of a set of size n, for up to n=nmax
# returns a list whose nth element is the binary representations of 0:(2^n-1)
# needed for polynomial expression for transfer values
# need for up to ns-1 for count, and ns for final keep value calculation
# only need to use once (`sel=select(ns)') in preamble
bi=list()
bi[[1]]=list(0,1)
for(n in 1:(nmax-1)){
bn=list()
for(j in 1:2^n){
bn[[j]]=c(0,bi[[n]][[j]])
bn[[2^n+j]]=c(1,bi[[n]][[j]])
}
bi[[n+1]]=bn
}
bi
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.