In RobinHankin/hyper2: The Hyperdirichlet Distribution, Mark 2

set.seed(0)
knitr::opts_chunk$set(echo = TRUE)
library("hyper2")
library("magrittr")
options("digits" = 5)

knitr::include_graphics(system.file("help/figures/hyper2.png", package = "hyper2"))

(takes about forty five minutes to run without cache)

To cite the hyper2 package in publications, please use @hankin2017_rmd. Here we define dataset kka which is the observed scorelines between players Karpov, Kasparov, and Anand. It is used to calculate likelihood functions: karpov_kasparov_anand, kka_3whites and kka_3draws. This Rmd file supercedes files inst/karpov_kasparov_anand.R and inst/kka_3draws.R and inst/kka_array.R. Some more detail is given in man/kka.Rd.

kka <- c(
## Kasparov vs Karpov
karpov_plays_white_beats_kasparov = 18,  # 12 on p1, 6 on p2
kasparov_plays_white_beats_karpov = 30, # 13 on p1, 17 on p2
kasparov_plays_white_losesto_karpov = 07,
karpov_plays_white_losesto_kasparov = 09,
karpov_plays_white_draws_kasparov = 11+13+14+17+14+03,
kasparov_plays_white_draws_karpov = 14+12+11+08+11+01,

## Kasparov vs Anand
kasparov_plays_white_beats_anand = 15,
anand_plays_white_beats_kasparov = 06,
anand_plays_white_losesto_kasparov = 11,
kasparov_plays_white_losesto_anand = 02,
kasparov_plays_white_draws_anand = 26,
anand_plays_white_draws_kasparov = 20,

## Karpov vs Anand
karpov_plays_white_beats_anand = 07,
anand_plays_white_beats_karpov = 18,
anand_plays_white_losesto_karpov = 05,
karpov_plays_white_losesto_anand = 13,
karpov_plays_white_draws_anand = 29,
anand_plays_white_draws_karpov = 20
)
kka

Quite a lot of information here, but for example we might ask what the scoreline is for Karpov playing white against Kasparov:

(a1 <- c(
kka["karpov_plays_white_beats_kasparov"],
kka["karpov_plays_white_draws_kasparov"],
kka["karpov_plays_white_losesto_kasparov"]
))

If we were to ask instead what happens if Karpov plays black against Kasparov this would be:

(a2 <- c(
kka["kasparov_plays_white_beats_karpov"],
kka["kasparov_plays_white_draws_karpov"],
kka["kasparov_plays_white_losesto_karpov"]
))

To investigate the effect of playing white we might do this:

M <- rbind(a1,rev(a2))
dimnames(M) <- list(karpov_plays=c("White","Black"),result=c("karpov wins","karpov draws","karpov loses"))
M
fisher.test(M)

but we need a likelihood function. Here I define likelihood function karpov_kasparov_anand but to save typing we work with temporary object H and rename it at the end:

results <- as.list(kka)
attach(results)
H <- hyper2()


## Kasparov vs Karpov
karpov_vs_kasparov <- c("Karpov","Kasparov","white","draw")  # all "players", real and imaginary

H <- H + trial(c("Karpov"  ,"white"), karpov_vs_kasparov, karpov_plays_white_beats_kasparov)
H <- H + trial(c("Kasparov","white"), karpov_vs_kasparov, kasparov_plays_white_beats_karpov)
H <- H + trial(  "Karpov"           , karpov_vs_kasparov, kasparov_plays_white_losesto_karpov)
H <- H + trial(  "Kasparov"         , karpov_vs_kasparov, karpov_plays_white_losesto_kasparov)
H <- H + trial(  "draw"             , karpov_vs_kasparov, karpov_plays_white_draws_kasparov)
H <- H + trial(  "draw"             , karpov_vs_kasparov, kasparov_plays_white_draws_karpov)

## Kasparov vs Anand
kasparov_vs_anand <- c("Kasparov","Anand","white","draw")
H <- H + trial(c("Kasparov","white"), kasparov_vs_anand, kasparov_plays_white_beats_anand)
H <- H + trial(c("Anand"   ,"white"), kasparov_vs_anand, anand_plays_white_beats_kasparov)
H <- H + trial(c("Kasparov"        ), kasparov_vs_anand, anand_plays_white_losesto_kasparov)
H <- H + trial(c("Anand"           ), kasparov_vs_anand, kasparov_plays_white_losesto_anand)
H <- H + trial(  "draw"             , kasparov_vs_anand, kasparov_plays_white_draws_anand)
H <- H + trial(  "draw"             , kasparov_vs_anand, anand_plays_white_draws_kasparov)

## Karpov vs Anand
karpov_vs_anand <- c("Karpov","Anand","white","draw")
H <- H + trial(c("Karpov","white"), karpov_vs_anand, karpov_plays_white_beats_anand)
H <- H + trial(c("Anand" ,"white"), karpov_vs_anand, anand_plays_white_beats_karpov)
H <- H + trial(  "Karpov"         , karpov_vs_anand, anand_plays_white_losesto_karpov)
H <- H + trial(  "Anand"          , karpov_vs_anand, karpov_plays_white_losesto_anand)
H <- H + trial(  "draw"           , karpov_vs_anand, karpov_plays_white_draws_anand)
H <- H + trial(  "draw"           , karpov_vs_anand, anand_plays_white_draws_karpov)

detach(results)

karpov_kasparov_anand <- H
karpov_kasparov_anand
(karpov_kasparov_anand_maxp <- maxp(karpov_kasparov_anand))

Test the hypothesis that all three players have the same strength; first do the free optimization:

samep.test(karpov_kasparov_anand,c("Karpov","Kasparov","Anand"))

and we reject that null. Now test the hypothesis that playing white confers no advantage:

specificp.test(karpov_kasparov_anand,"white",0)

We now allow each player to have a personalised draw monster. The resulting likelihood function is called kka_3draws but the idiom below uses H to save typing.

library("hyper2")
H <- hyper2()

results <- as.list(kka)
attach(results)

karpov_vs_kasparov <- c("Karpov","Kasparov","Karpov_draw","Kasparov_draw","white")
draw1 <- c("Karpov_draw","Kasparov_draw")

H <- H + trial(c("Karpov"  ,"white"), karpov_vs_kasparov, karpov_plays_white_beats_kasparov)
H <- H + trial(c("Kasparov","white"), karpov_vs_kasparov, kasparov_plays_white_beats_karpov)
H <- H + trial(c("Karpov"  )        , karpov_vs_kasparov, kasparov_plays_white_losesto_karpov)
H <- H + trial(c("Kasparov")        , karpov_vs_kasparov, karpov_plays_white_losesto_kasparov)
H <- H + trial(draw1                , karpov_vs_kasparov, karpov_plays_white_draws_kasparov)
H <- H + trial(draw1                , karpov_vs_kasparov, kasparov_plays_white_draws_karpov)

## Kasparov vs Anand
kasparov_vs_anand <- c("Kasparov","Anand","Kasparov_draw","Anand_draw","white")
draw2 <- c("Kasparov_draw","Anand_draw")
H <- H + trial(c("Kasparov","white"), kasparov_vs_anand, kasparov_plays_white_beats_anand)
H <- H + trial(c("Anand"   ,"white"), kasparov_vs_anand, anand_plays_white_beats_kasparov)
H <- H + trial(c("Kasparov"  )      , kasparov_vs_anand, anand_plays_white_losesto_kasparov)
H <- H + trial(c("Anand")           , kasparov_vs_anand, kasparov_plays_white_losesto_anand)
H <- H + trial(draw2                , kasparov_vs_anand, kasparov_plays_white_draws_anand)
H <- H + trial(draw2                , kasparov_vs_anand, anand_plays_white_draws_kasparov)


## Karpov vs Anand
karpov_vs_anand <- c("Karpov","Anand","Karpov_draw","Anand_draw","white")
draw3 <- c("Karpov_draw","Anand_draw")

H <- H + trial(c("Karpov","white"), karpov_vs_anand, karpov_plays_white_beats_anand)
H <- H + trial(c("Anand" ,"white"), karpov_vs_anand, anand_plays_white_beats_karpov)
H <- H + trial(c("Karpov"        ), karpov_vs_anand, anand_plays_white_losesto_karpov)
H <- H + trial(c("Anand"         ), karpov_vs_anand, karpov_plays_white_losesto_anand)
H <- H + trial(draw3              , karpov_vs_anand, karpov_plays_white_draws_anand) 
H <- H + trial(draw3              , karpov_vs_anand, anand_plays_white_draws_karpov) 

detach(results)

kka_3draws <- H
kka_3draws 

and one natural test is that the three draw monsters are of equal strength:

(kka_3draws_maxp <- maxp(kka_3draws))
pie(kka_3draws_maxp)
samep.test(kka_3draws,c("Karpov_draw","Kasparov_draw","Anand_draw"))

Now allow each player to have distinct white strength. We create kka_3whites, again using temporary variable H to save typing:

H <- hyper2()

results <- as.list(kka)
attach(results)

D <- "draw"

## First: Karpov vs Kasparov
karpov_plays_white_vs_kasparov <- c("Karpov","Kasparov","Karpov_white","draw"  )  # "players" 
kasparov_plays_white_vs_karpov <- c("Karpov","Kasparov","Kasparov_white","draw")
H <- H + trial(c("Karpov"  ,"Karpov_white"  ), karpov_plays_white_vs_kasparov, karpov_plays_white_beats_kasparov  ) # Karpov wins playing white
H <- H + trial(c("Kasparov","Kasparov_white"), kasparov_plays_white_vs_karpov, kasparov_plays_white_beats_karpov  ) # Kasparov wins playing white
H <- H + trial(c("Kasparov")                 , karpov_plays_white_vs_kasparov, karpov_plays_white_losesto_kasparov) # Kasparov wins playing black
H <- H + trial(c("Karpov"  )                 , kasparov_plays_white_vs_karpov, kasparov_plays_white_losesto_karpov) # Karpov wins playing black
H <- H + trial(D                             , karpov_plays_white_vs_kasparov, karpov_plays_white_draws_kasparov  ) # Karpov white, draws
H <- H + trial(D                             , kasparov_plays_white_vs_karpov, kasparov_plays_white_draws_karpov  ) # Kasparov white, draws

## Second: Karpov vs Anand
karpov_plays_white_vs_anand <- c("Karpov","Anand","Karpov_white","draw"  )
anand_plays_white_vs_karpov <- c("Karpov","Anand","Anand_white","draw")
H <- H + trial(c("Karpov","Karpov_white"), karpov_plays_white_vs_anand, karpov_plays_white_beats_anand  ) # Karpov wins playing white
H <- H + trial(c("Anand" ,"Anand_white" ), anand_plays_white_vs_karpov, anand_plays_white_beats_karpov  ) # Anand wins playing white
H <- H + trial(c("Anand"                ), karpov_plays_white_vs_anand, karpov_plays_white_losesto_anand) # Anand wins playing black
H <- H + trial(c("Karpov"               ), anand_plays_white_vs_karpov, anand_plays_white_losesto_karpov) # Karpov wins playing black
H <- H + trial(D                         , karpov_plays_white_vs_anand, karpov_plays_white_draws_anand  ) # Karpov white, draws
H <- H + trial(D                         , anand_plays_white_vs_karpov, anand_plays_white_draws_karpov  ) # Anand white, draws

## Third: Kasparov vs Anand
anand_plays_white_vs_kasparov <- c("Anand","Kasparov","Anand_white","draw"   )
kasparov_plays_white_vs_anand <- c("Anand","Kasparov","Kasparov_white","draw")
H <- H + trial(c("Kasparov","Kasparov_white"), kasparov_plays_white_vs_anand, kasparov_plays_white_beats_anand  ) # Kasparov wins playing white
H <- H + trial(c("Anand"   ,"Anand_white"   ), anand_plays_white_vs_kasparov, anand_plays_white_beats_kasparov  ) # Anand wins playing white
H <- H + trial(c("Anand"                    ), kasparov_plays_white_vs_anand, kasparov_plays_white_losesto_anand) # Anand wins playing black
H <- H + trial(c("Kasparov"                 ), anand_plays_white_vs_kasparov, anand_plays_white_losesto_kasparov) # Kasparov wins playing black
H <- H + trial(D                             , kasparov_plays_white_vs_anand, kasparov_plays_white_draws_anand  ) # Kasparov white, draws
H <- H + trial(D                             , anand_plays_white_vs_kasparov, anand_plays_white_draws_kasparov  ) # Anand white, draws

detach(results)

kka_3whites <- H
kka_3whites

Natural test for equality of the three white monsters's strengths:

(kka_3whites_maxp <- maxp(kka_3whites))
pie(kka_3whites_maxp)
samep.test(kka_3whites,c("Karpov_white","Kasparov_white","Anand_white"))

(fail to reject the null).

We now create a 3x3x3 array of results for the dataset.

library("hyper2")
library("abind")
attach(as.list(kka))

players <- c("Anand","Karpov","Kasparov")

plays_white_wins <- matrix(NA,3,3)
dimnames(plays_white_wins) <- list(plays_white_wins=players,plays_black_loses=players)
plays_white_wins["Anand"   ,"Karpov"  ] <- anand_plays_white_beats_karpov
plays_white_wins["Anand"   ,"Kasparov"] <- anand_plays_white_beats_kasparov
plays_white_wins["Karpov"  ,"Anand"   ] <- karpov_plays_white_beats_anand
plays_white_wins["Karpov"  ,"Kasparov"] <- karpov_plays_white_beats_kasparov
plays_white_wins["Kasparov","Anand"   ] <- kasparov_plays_white_beats_anand
plays_white_wins["Kasparov","Karpov"  ] <- kasparov_plays_white_beats_karpov

plays_white_draws  <- matrix(NA,3,3)
dimnames(plays_white_draws) <- list(plays_white_draws=players,plays_black_draws=players)
plays_white_draws["Anand"   ,"Karpov"  ] <- anand_plays_white_draws_karpov
plays_white_draws["Anand"   ,"Kasparov"] <- anand_plays_white_draws_kasparov
plays_white_draws["Karpov"  ,"Anand"   ] <- karpov_plays_white_draws_anand
plays_white_draws["Karpov"  ,"Kasparov"] <- karpov_plays_white_draws_kasparov
plays_white_draws["Kasparov","Anand"   ] <- kasparov_plays_white_draws_anand
plays_white_draws["Kasparov","Karpov"  ] <- kasparov_plays_white_draws_karpov


plays_white_loses <- matrix(NA,3,3)
dimnames(plays_white_loses) <- list(plays_white_loses=players,plays_black_wins=players)
plays_white_loses["Karpov"   ,"Anand"   ] <- karpov_plays_white_losesto_anand
plays_white_loses["Kasparov" ,"Anand"   ] <- kasparov_plays_white_losesto_anand
plays_white_loses["Anand"    ,"Karpov"  ] <- anand_plays_white_losesto_karpov
plays_white_loses["Kasparov" ,"Karpov"  ] <- kasparov_plays_white_losesto_karpov
plays_white_loses["Anand"    ,"Kasparov"] <- anand_plays_white_losesto_kasparov
plays_white_loses["Karpov"   ,"Kasparov"] <- karpov_plays_white_losesto_kasparov
detach(as.list(kka))

    plays_white_wins
    plays_white_draws
    plays_white_loses

kka_array <- abind(
    plays_white_wins,
    plays_white_draws,
    plays_white_loses,
    along=3)
dimnames(kka_array)[[3]] <- c("plays_white_wins", "plays_white_draws", "plays_white_loses")
kka_array

Some ideas for hyper3 analysis.

First we ignore the draws and create a matrix with real parts representing white wins (home wins in the context of football) and imaginary parts representing black (away) wins. A pairwise likelihood function would be

$$ \left(\frac{\lambda p_1}{\lambda p_1+p_2}\right)^a \left(\frac{ p_2}{\lambda p_1+p_2}\right)^b \left(\frac{ p_1}{p_1+\lambda p_2}\right)^c \left(\frac{\lambda p_1}{p_1+\lambda p_2}\right)^d $$

for the observation of $+a$ $\text{=}0$ $-b$ for $p_1$ playing white and $+c$ $\text{=}0$ $-d$ for $p_2$ playing white. We then translate this into a hyper3 likelihood function as follows

(M <- kka_array[,,1] + 1i*kka_array[,,3])
home_away3(M,lambda=1.1)

Above we use $\lambda=1.1$, as a specific numeric value is required by the idiom.

l <- function(lambda){
  H <- home_away3(M,lambda=lambda)
  loglik(maxp(H),H)
}
lam <- seq(from=1.2,to=3.5,len=10)
like <- sapply(lam,l)

and plot it:

plot(lam,like-max(like),type="b",pch=16)
abline(h=c(0,-2),lty=2)

Above we see a credible interval for $\lambda$ being about $(1.4,2.9)$. Of course, this is crude and it would be better to have more transparent package idiom. But I'm working on this.

We can now introduce draws but first a change of notation. Considering repeated trials between entities $1,2,\ldots, r$ with Bradley-Terry strengths $p_1,\ldots, p_r$ and counts $n_1,\ldots, n_r$ a suitable likelihood function would be

$$ \left(\frac{p_1}{\sum p_i}\right)^{n_1}\cdot \left(\frac{p_2}{\sum p_i}\right)^{n_2}\ldots \left(\frac{p_r}{\sum p_i}\right)^{n_r} $$

but we may represent this in the following compact form:

$$ \left(\frac{p_1,p_2,\ldots, p_r}{\sum p_i}\right)^{\left(n_1,\ldots n_r\right)} $$

Or, noting that the sum of the numerators is equal to the common denominator, even more compactly as $\left(p_1,p_2,\ldots, p_r\right)^{\left(n_1,\ldots n_r\right)}$.

The previous likelihood function can be represented thus:

$$ \left(\frac{\lambda p_1, p_2}{\lambda p_1+p_2}\right)^{(a,b)} \left(\frac{p_1, \lambda p_2}{p_1+\lambda p_2}\right)^{(c,d)} $$

Draws would change this by introducing a weighted Draw monster $D$:

$$ \left(\frac{\lambda p_1, D(p_1+p_2),p_2}{\lambda p_1+D(p_1+p_2)+p_2}\right)^{(a,b,c)} \left(\frac{p_1, D(p_1+p_2),\lambda p_2}{p_1+D(p_1+p_2)+\lambda p_2}\right)^{(d,e,f)} $$

or possibly an individual Draw monster:

$$ \left(\frac{\lambda p_1, D_1p_1+D_2p_2,p_2}{\lambda p_1+D_1p_1+D_2p_2+p_2}\right)^{(a,b,c)} \left(\frac{p_1, D_1p_1+D_2p_2),\lambda p_2}{p_1+D_1p_1+D_2p_2+\lambda p_2}\right)^{(d,e,f)} $$

Package idiom for this would require the following form:

$$ \left(\frac{\lambda p_1, D_1p_1+D_2p_2,p_2}{(\lambda+D_1)p_1+(1+D_2)p_2}\right)^{(a,b,c)} \left(\frac{p_1, D_1p_1+D_2p_2,\lambda p_2}{(1+D_1)p_1+(\lambda+D_2)p_2}\right)^{(d,e,f)} $$

Note that in neither of these models do we have the probability of a draw for $p_1$ playing white being the same as for $p_2$ playing white. In the first case the two probabilities are

$$ \frac{D(p_1+p_2)}{(\lambda +D)p_1 + (1+D)p_2},\qquad \frac{D(p_1+p_2)}{(1+D)p_1 + (\lambda+D)p_2} $$

and in the second they are

$$ \frac{D_1p_1+D_2p_2}{(\lambda +D_1)p_1 + (1+D_2)p_2},\qquad \frac{D_1p_1+D_2p_2}{(1 +D_1)p_1 + (\lambda+D_2)p_2} $$

With strictly positive $D,D_1,D_2$ these are equal if and only if $(\lambda-1)(p_1-p_2)=0$, that is, if the white advantage is nonexistent, or if the players have the same strength.

We can use the bespoke function hyper2::white_draw3() to make a likelihood function:

white_draw3(kka_array, 1.1, 2.3)

Then make a wrapper:

f <- function(v){
    lambda <- v[1]
    D      <- v[2]
    H <- white_draw3(kka_array, lambda,D)
    max(maxp(H,n=1,justlikes=TRUE))
}   
f(c(1.5,2.3))

n <- 10
lambda <- seq(from=1.4,to=2.9,len=n)
D <- seq(from=1.6,to=3.4,len=n) 
M <- as.matrix(expand.grid(lambda=lambda,D=D))
l <- matrix(apply(M,1,f),n,n)

l <- l-max(l)
contour(lambda,D,l,nlevels=30,xlab="lambda",ylab="D")
abline(v=lambda,col='gray',lwd=0.2)
abline(h=D,col='gray',lwd=0.2)
lambda
D

Optimize:

(o <- optim(par=c(2.1,2.4),fn=f,control=list(fnscale = -1)))

jj <- round(o$par,2)
(chess3 <-  white_draw3(kka_array, lambda=jj[1],D=jj[2]))
(chess3_maxp <-  maxp(chess3))

Package dataset

Following lines create kka.rda, residing in the data/ directory of the package.

save(kka,karpov_kasparov_anand,kka_3draws,kka_3whites,kka_array,chess3,chess3_maxp,file="kka.rda")

RobinHankin/hyper2 documentation built on April 13, 2025, 9:33 a.m.