---
title: "exponential Bradley-Terry"
author: "robin hankin"
date: "2025-04-02"
output: html_document

---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(hyper2)
library(stringr)
library("partitions")
library("magrittr")
set.seed(0)
```

Basic idea is to have $n$ competitors with BT strengths $\beta, \beta
x,\ldots \beta x^{n-1}$ with $x\in[0,1]$.  The unit sum constraint
gives $\beta=\frac{1-x}{1-x^n}$ but this usually cancels out.  One of
the competitors is the _focal_ competitor with BT strength $\beta
x^{r-1}$ for some $r$ with $1\leqslant r < n$.  Thus $r=1$ means that
the focal competitor is the strongest among the $n$, $r=2$ means he is
the second, and so on.

# Some simple cases


We consider the smallest non-trivial cases $n=3$ and $n=4$.  For $n=3$
we have Plackett-Luce strengths $\alpha x,\alpha x^2,\alpha x^3$ [the
  extra factor of $x$ allows us to identify the $r$ in ``$\alpha x^r$''
  with the rank of the competitor, the best being rank 1].  Suppose
the focal competitor came first, the likelihood function would be

\begin{equation}
  \mathcal{L}(x,r)=\frac{x^{r-1}}{1+x+x^2}\qquad r=1,2,3
\end{equation}

```{r plot123first}
worker_123first <- function(...){
f <- function(x,r){ x^r/(x + x^2 + x^3) }

x <- seq(from=0.01 , to=1, by=0.01)
plot(c(-3,0), c(-3,0), type='n',
     xlab="log x", ylab="log-likelihood",main="(a)")
points(log(x),log(f(x,1)), type="l", col="black")
points(log(x),log(f(x,2)), type="l", col="red"  )
points(log(x),log(f(x,3)), type="l", col="blue" )

abline(h=0, lty=2)
abline(h = -2)
e <- exp(1)
r2reject <- ((e^2-1)-sqrt(e^4-2*e^2-3))/2
segments(x0=log(r2reject), y0=-2.2,y1=-1.8)

r3reject <- (1+sqrt(1+4*(e^2-1)))/(2*(e^2-1))
segments(x0=log(r3reject), y0=-2.2,y1=-1.8)
legend(x= -3, y= - 0.5, lty=1, col=c("black","red","blue"),
       legend=c("r=1","r=2","r=3"))
}
e <- exp(1)
r2reject <- ((e^2-1)-sqrt(e^4-2*e^2-3))/2
print(r2reject)
r3reject <- (1+sqrt(1+4*(e^2-1)))/(2*(e^2-1))
print(r3reject)

worker_123first()
pdf(file="123first.pdf")
worker_123first()
dev.off()


```

If the focal competitor came second we would have two Plackett-Luce
probabilities to add, corresponding to different order statistics.
$\alpha x^i$ or $\alpha x^j$ coming first where $i,j\neq r$.  For
example, if $r=1$ we would have two finishing orders that are
consistent with the observation: $2\succ 1\succ 3$ and $3\succ 1\succ
2$.  These are disjoint so the likelihood will be proportional to

$$
\frac{x^2}{x+x^2+x^3}\cdot\frac{x}{x+x^3} + 
\frac{x^3}{x+x^2+x^3}\cdot\frac{x}{x+x^2}
$$

After simplification:

\begin{equation}
  \mathcal{L}(x,r)=
  \begin{cases}
    \frac{x  }{x+x^2+x^3}\left(\frac{x^2}{x+x^3}   + \frac{x^3}{x+x^2}\right)\qquad r=1\\
    \frac{x^2}{x+x^2+x^3}\left(\frac{x  }{x^2+x^3} + \frac{x^3}{x+x^2}\right)\qquad r=2\\
    \frac{x^3}{x+x^2+x^3}\left(\frac{x  }{x^2+x^3} + \frac{x^2}{x+x^3}\right)\qquad r=3
\end{cases}
\end{equation}


```{r plot123second}
worker_123second <- function(...){
like <- function(x,r){
  S <- x + x^2 + x^3
  switch(r,
         '1' = x^2/S*x^1/(x^1+x^3) + x^3/S*x^1/(x^1+x^2), # 213+312
         '2' = x^1/S*x^2/(x^2+x^3) + x^3/S*x^2/(x^1+x^2), # 123+321
         '3' = x^1/S*x^3/(x^2+x^3) + x^2/S*x^3/(x^1+x^3)  # 132+231
  )
}

x <- seq(from=0.01, to=1, by=0.01)
plot(c(-3,0),c(-3,0), type='n',
     xlab="log x", ylab="log-likelihood", main="(b)")
points(log(x),log(like(x,1)), type="l", col="black")
points(log(x),log(like(x,2)), type="l", col="red"  )
points(log(x),log(like(x,3)), type="l", col="blue" )

abline(h=0,lty=2)
abline(h=-2)

legend(x = -3, y = -0.5, lty=1, col=c("black","red","blue"),
       legend=c("r=1", "r=2", "r=3"))
}
worker_123second()
pdf(file="123second.pdf")
worker_123second()
dev.off()
```

Now the focal competitor comes last:


```{r plot123third}
worker_123third <- function(...){
like <- function(x,r){
  S <- x + x^2 + x^3
  switch(r,
         '1' = x^3/S*x^2/(x^1+x^2) + x^2/S*x^3/(x^1+x^3), # 213+312
         '2' = x^1/S*x^3/(x^2+x^3) + x^3/S*x^1/(x^1+x^2), # 123+321
         '3' = x^1/S*x^2/(x^2+x^3) + x^2/S*x^1/(x^1+x^3)  # 132+231
  )
}

x <- seq(from=0.01, to=1, by=0.01)
plot(c(-3,0),c(-3,0),type='n',
     xlab="log x", ylab="log-likelihood", main="(c)")
points(log(x),log(like(x,1)), type="l", col="black")
points(log(x),log(like(x,2)), type="l", col="red"  )
points(log(x),log(like(x,3)), type="l", col="blue" )

abline(h=0,lty=2)
abline(h=-2)

legend(x = -3, y = -0.5, lty=1, col=c("black", "red", "blue"),
       legend=c("r=1", "r=2", "r=3"))
}

worker_123third()
pdf(file="123third.pdf")
worker_123third()
dev.off()
```


```{r allthree}
worker_allthree <- function(...){
op <- par(mfrow=c(1,3))
worker_123first()
worker_123second()
worker_123third()
dev.off()
par(op)
}
worker_allthree()
pdf(file="123all.pdf",height=4)
worker_allthree()
dev.off()
```
The $n=4$ case is harder as we potentially have six consistent
orderings for each observation.  As an example, if the focal
competitor comes third we have

\begin{equation}
\newcommand{pl}[4]{
\frac{x^{#1}}{x^{#1} + x^{#2} + x^{#3} + x^{#4}}\cdot
\frac{x^{#2}}{         x^{#2} + x^{#3} + x^{#4}}\cdot
\frac{x^{#3}}{                  x^{#3} + x^{#4}}}

\end{equation}


SDAdsfDSFFDSAfdsafdsff asdf dfs dfs dfs dsff dsfds fds fds sfd s fs sd sdf sdf sdf sdf sdf sdf sdf sdfs dfsdf sdsdfsa asdf saf

\begin{eqnarray}
\mathcal{L}(x;r=1)
\quad &=& \quad\hphantom{+}
            \pl{2}{3}{1}{4}\\
&{}&\quad + \pl{2}{4}{1}{3}\\
&{}&\quad + \pl{3}{2}{1}{4}\\
&{}&\quad + \pl{3}{4}{1}{2}\\
&{}&\quad + \pl{4}{2}{1}{3}\\
&{}&\quad + \pl{4}{3}{1}{2}
\end{eqnarray}

\begin{eqnarray}
\mathcal{L}(x;r=2) 
\quad &=& \quad\hphantom{+}
            \pl{1}{3}{2}{4}\\
&{}&\quad + \pl{1}{4}{2}{3}\\
&{}&\quad + \pl{3}{1}{2}{4}\\
&{}&\quad + \pl{3}{4}{2}{1}\\
&{}&\quad + \pl{4}{1}{2}{3}\\
&{}&\quad + \pl{4}{3}{2}{1}
\end{eqnarray}

and so on.


```{r fourcompetitors}
PL <- function(v){
  stopifnot(length(v) == 4)
  v[1]/(v[1]+v[2]+v[3]+v[4]) *
  v[2]/(     v[2]+v[3]+v[4]) *
  v[3]/(          v[3]+v[4])
}


f1 <- function(v){  # focal competitor came third, r=1
  return(
  PL(v^c(2,3,1,4)) +
  PL(v^c(2,4,1,3)) +
  PL(v^c(3,2,1,4)) +
  PL(v^c(3,4,1,2)) +
  PL(v^c(4,2,1,3)) +
  PL(v^c(4,3,1,2))
  )
}
f2 <- function(v){  # focal competitor came third, r=2
  return(
  PL(v^c(1,3,2,4)) +
  PL(v^c(1,4,2,3)) +
  PL(v^c(3,1,2,4)) +
  PL(v^c(3,4,2,1)) +
  PL(v^c(4,1,2,3)) +
  PL(v^c(4,3,2,1))
  )
}
f3 <- function(v){  # focal competitor came third, r=2
  return(
  PL(v^c(1,2,3,4)) +
  PL(v^c(1,4,3,2)) +
  PL(v^c(2,1,3,4)) +
  PL(v^c(2,4,3,1)) +
  PL(v^c(4,1,3,2)) +
  PL(v^c(4,2,3,1))
  )
}
f4 <- function(v){  # focal competitor came third, r=4
  return(
  PL(v^c(1,2,4,3)) +
  PL(v^c(1,3,4,2)) +
  PL(v^c(2,1,4,3)) +
  PL(v^c(2,3,4,1)) +
  PL(v^c(3,1,4,2)) +
  PL(v^c(3,2,4,1))
  )
}


worker <- function(...){

o <- 1:4

plot(c(-3,0),c(-3,0), type='n',
     xlab="log x", ylab="log-likelihood", main="Focal competitor came third")
x <- seq(from=0.01,to=1,by=0.001)

points(log(x),log(sapply(x,f1)), type="l", col="black")
points(log(x),log(sapply(x,f2)), type="l", col="red")
points(log(x),log(sapply(x,f3)), type="l", col="blue")
points(log(x),log(sapply(x,f4)), type="l", col="green")

abline(h=0,lty=2)
abline(h = -2, lty=1, col="gray")
           
legend("topright",lty=1,col=c("black", "red", "blue", "green"),
       legend=c("r=1", "r=2", "r=3", "r=4"), bg="white")


f1_solve <- function(x){log(sapply(exp(x), f1)) + 2}
f2_solve <- function(x){log(sapply(exp(x), f2)) + 2}
f4_solve <- function(x){log(sapply(exp(x), f4)) + 2}

root1 <- uniroot(f1_solve, c(-3,-0.1))$root
root2 <- uniroot(f2_solve, c(-3,-0.1))$root
root4 <- uniroot(f4_solve, c(-3,-0.1))$root

segments(x0=root1, y0=-2.1, y1=-1.9, col="gray")
segments(x0=root2, y0=-2.1, y1=-1.9, col="gray")
segments(x0=root4, y0=-2.1, y1=-1.9, col="gray")

print(c(root1, root2, root4))
} # worker() def closes



worker()
pdf(file="1234third.pdf")
worker()
dev.off()


```


# Try 8 competitors, focal competitor comes third


```{r calconetoeight, cache=TRUE}
pl <- function(v){
  out <- 1
  n <- length(v)
  for(i in seq_len(n-1)){
    out <- out*v[i]
    out <- out/sum(v[seq(from=i, to=n)])
  }
  return(out)
}

f <- function(x, place, no_of_comp){
    M <- perms(no_of_comp)
    out <- rep(0, no_of_comp)
    for(i in seq_len(ncol(M))){
        out[M[place,i]] %<>% `+`(pl(x^M[,i]))
    }
    return(out)
}

n <- 8
place <- 3
x <- seq(from = 0.1, to=1, by=0.01)
L <- matrix(0, length(x), n)
for(i in seq_along(x)){
    L[i,] <- f(x[i], place, n)
}
```

```{r onetoeight}
worker <- function(...){
    matplot(log(x),log(L), type='l', lty=1,ylim=c(-4,0))
}
pdf(file = "onetoeight.pdf")
worker()
dev.off()
worker()
```

# More stuff






```{r defineBT}
BT <- function(n,x){
    out <- x^(0:(n-1))
    if(x != 1){
        out <- out*(1-x)/(1-x^n)
    } else {
        out <- out/n
    }
    names(out) <- paste0("p",str_pad(1:n,ceiling(log10(n))))
    out
}
BT(4,0.5)
sum(BT(4,0.5))
```

We will consider $n=9$, $x=0.5$, $r=4$ and make repeated observations:


```{r showtabulate}
(jj <- BT(9,0.5))
o <- tabulate(replicate(1e4,which(rrace(jj) == "p4")))
o
plot(o,type='h')
```


    
```{r definegetprob, caasdf=TRUE}
getprob <- function(n, r, x, N=1e4){
    jj <- BT(n, x)
    wanted <- paste0("p", str_pad(r ,ceiling(log10(n))))
    c(r=r, x=x, setNames(tabulate(replicate(N, which(rrace(jj) == wanted)),nbins=n), paste0("p", 1:n)))
}
rbind(
getprob(9,1,0.5,N=100),
getprob(9,2,0.5,N=100),
getprob(9,3,0.5,N=100),
getprob(9,4,0.5,N=100),
getprob(9,5,0.5,N=100),
getprob(9,6,0.5,N=100),
getprob(9,7,0.5,N=100),
getprob(9,8,0.5,N=100),
getprob(9,9,0.5,N=100)
)

rbind(
getprob(9,1,0.2,N=100),
getprob(9,2,0.2,N=100),
getprob(9,3,0.2,N=100),
getprob(9,4,0.2,N=100),
getprob(9,5,0.2,N=100),
getprob(9,6,0.2,N=100),
getprob(9,7,0.2,N=100),
getprob(9,8,0.2,N=100),
getprob(9,9,0.2,N=100)
)
rbind(
getprob(9,1,0.9,N=100),
getprob(9,2,0.9,N=100),
getprob(9,3,0.9,N=100),
getprob(9,4,0.9,N=100),
getprob(9,5,0.9,N=100),
getprob(9,6,0.9,N=100),
getprob(9,7,0.9,N=100),
getprob(9,8,0.9,N=100),
getprob(9,9,0.9,N=100)
)
```

```{r makeII, cache=TRUE}
r_try <- 1:9
x_try <- seq(from = 0.1, to = 1, by = 0.05)
jj <- as.matrix(expand.grid(r_try, x_try))
II <- t(apply(jj, 1, function(v){getprob(9, v[1], v[2], N=1e4)}))
head(II)
```


```{r makesupp, cache=TRUE}
r_true <- 3
x_true <- 0.85
set.seed(0)
o <- getprob(9, r_true, x_true, 100)  # observations
o[1:2]
o[-(1:2)]

support_func <- function(o, v){
    v <- v[-(1:2)]
    v <- v/sum(v)
    dmultinom(o[-(1:2)], prob=v, log=TRUE)
}
support <- rep(0,nrow(II))
for(i in seq_len(nrow(II))){
    support[i] <- support_func(o, II[i,])
}
```
    
```{r}
x_try
length(support)
support <- support-max(support)
support <- pmax(support, -10)
support  <- matrix(support,length(r_try),length(x_try))
contour(r_try, x_try, support, xlab="r", ylab="x", levels = -c(1,(1:5)*2), lwd=c(1,3,1,1,1,1))
abline(v=1:9, lwd=0.3, col='gray')
abline(v = r_true)
abline(v = 1:9, col = 'gray', lty = 3, lwd = 0.3)
filled.contour(r_try, x_try, support, xlab = "r", ylab = "x")
```

```{r contourLO}
x_try
wanted <- 8:18
LO <- function(p){log(p/(1-p))}
contour(r_try, LO(x_try[wanted]), support[,wanted], xlab="r", ylab="Log-odds of x", levels = -c(1,(1:5)*2), lwd=c(1,3,1,1,1,1))
```

```{R showjj}
jj <- cbind(II[,1:2],c(support))
jj[jj[,2] == 1,]
```

#  Analysis from a single observation


We translate $\alpha\in [0,1]$ to a number from 1 to $n$ inclusive
with $\lceil n\alpha\rceil$

Write a likelihood function for 9,12 [that is, came 9th in a class of
12] There are 8 better and 3 worse than the focal student.


```{r ninetwelve}
single_like_fun <- function(n, a,          # n competitors, places a [e.g a=3 -> third]
                            a_try, x_try,  # values to try
                            N=1e2){        # N is number of trials
    p_try <- ceiling(n * a_try)
    jj <- as.matrix(expand.grid(p_try, x_try))
    II <- t(apply(jj,1,function(v){getprob(n, v[1], v[2], N)}))
    matrix(II[, ceiling(a*n) + 2], length(a_try), length(x_try))
}
```


```{r makesupp912, cache=TRUE}
a_try <- seq(from = 0.01, to = 0.99, len = 10)
x_try <- seq(from = 0.2, to = 1, by = 0.1)
allsupp <- list(
    log(single_like_fun(12, a =  8/12, a_try, x_try)),  # pure
    log(single_like_fun(17, a = 12/17, a_try, x_try)),  # pure
    log(single_like_fun(23, a = 18/23, a_try, x_try)),  # pure
    log(single_like_fun(14, a =  5/14, a_try, x_try)),  # applied
    log(single_like_fun(13, a =  3/13, a_try, x_try)),  # applied
    log(single_like_fun(11, a =  2/11, a_try, x_try)),  # applied
    log(single_like_fun(13, a =  3/13, a_try, x_try))   # applied
)
```

```{r showallsupp}
S <- Reduce("+",allsupp)
S <- pmax(S-max(S),-10)
contour(a_try, x_try, S, levels = -1*(1:7))
jj <- which(S == max(S), arr.ind = TRUE)
points(a_try[jj[1]], x_try[jj[2]], pch=16, col = 'red')
```


```{r showbothsupp}
S_pure    <- Reduce("+", allsupp[1:3])
S_applied <- Reduce("+", allsupp[4:7])
S_all     <- Reduce("+", allsupp[1:7])
max(S_all)
max(S_pure)
max(S_applied)
max(S_pure) + max(S_applied)
max(S_pure) + max(S_applied) - max(S_all)
pchisq(max(S_pure) + max(S_applied) - max(S_all),df=2,lower.tail=FALSE)
```


# Parkrun

In the following chunks, each execution of
`single_like_fun(...,N=1000)` takes  about 5 minutes

```{r sethowmany}
howmany <- 1000
```

```{r parkrunlikefunobs1, cache = TRUE}
print(system.time(parkrun01 <- single_like_fun(259, 177/259, N = howmany, a_try, x_try)))
```

```{r}
parkrun01
```

```{r parkrunlikefunobs2, cache = TRUE}
 print(system.time(parkrun02 <- single_like_fun(305, 222/305, N = howmany, a_try, x_try)))
```

```{r}
parkrun02
```

```{r parkrunlikefunobs3, cache = TRUE}
print(system.time(parkrun03 <- single_like_fun(297, 206/297, N = howmany, a_try, x_try)))
```

```{r}
parkrun03
```

```{r parkrunlikefunobs4, cache = TRUE}
print(system.time(parkrun04 <- single_like_fun(241, 142/241, N = howmany, a_try, x_try)))
```

```{r}
parkrun04
```

```{r parkrunlikefunobs5, cache = TRUE}
print(system.time(parkrun05 <- single_like_fun(179, 118/179, N = howmany, a_try, x_try)))
```

```{r}
parkrun05
```
 
```{r parkrunlikefunobs6, cache = TRUE}
print(system.time(parkrun06 <- single_like_fun(338, 224/338, N = howmany, a_try, x_try)))
```

```{r}
parkrun06
```

```{r parkrunlikefunobs7, cache = TRUE}
print(system.time(parkrun07 <- single_like_fun(203, 128/203, N = howmany, a_try, x_try)))
```

```{r}
parkrun07
```


```{r}
c(
sum(parkrun01),
sum(parkrun02),
sum(parkrun03),
sum(parkrun04),
sum(parkrun05),
sum(parkrun06),
sum(parkrun07)
)
```

```{r}
contour(a_try,x_try,parkrun05)
contour(a_try,x_try,parkrun06)
parkrun01*parkrun02*parkrun03*parkrun04*parkrun05*parkrun06*parkrun07
```



## Formula 1


```{r checo}
n <- 20 # 20 drivers
multiple_like_fun <- function(n,           # n competitors
                            a_try, x_try,  # values to try
                            N=1e2){        # N is number of trials
    p_try <- ceiling(n * a_try)
    jj <- as.matrix(expand.grid(p_try, x_try))
    t(apply(jj,1,function(v){getprob(n, v[1], v[2], N)}))
}
```


```{r checo2023}

o <- c(5,5,2,6,6,4,2,3,8,3,4,4,6,6,3,5,2,8,7,9)  # Lewis Hamilton 2023
# o <- c(7,9,9,9,6,6,7,4,3,4,1,3,1,8,5,9,6,4,10,2,12,4) # Lewis Hamilton 2024
# o <- c(6,8,3,5,2,1,2,4,2,2,20,3,2,5,1,3,4,1,4,2,6,6,10) # lando norris 2024
```

```{r trymultx, cache=TRUE}
II <- multiple_like_fun(20, a_try,x_try,1e4)
head(II)
nrow(II)
length(a_try)
length(x_try)
```

```{r calcmultx, cache=TRUE}
like <- list()
dim(II)
o
for(i in seq_along(o)){
    like[[i]] <-  matrix(II[, o[i] + 2], length(a_try), length(x_try))
}
```

```{r showlike, cache=FALSE}
options(digits=5)
like
alllike <- Reduce("*",like)
alllike 
alllike/max(alllike)
S <- log(alllike)
S <- S-max(S)
S <- pmax(S,-15)
contour(S,levels = -(0:6)*2, lwd=c(1,4,1,1,1,1,1))
filled.contour(S)
```


