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"))

To cite the hyper2 package in publications, please use @hankin2017_rmd; this Rmd file takes about 45 minutes to process without cache. 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 nonexistant, or if the players have the same strength.

We can use the bespoke function 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 21, 2024, 11:38 a.m.