In RobinHankin/hyper2: The Hyperdirichlet Distribution, Mark 2

knitr::opts_chunk$set(echo = TRUE)
library("hyper2")
library("magrittr")
options("digits" = 5)
abbreviated <- TRUE  # change to FALSE for full names

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

To cite the hyper2 package in publications, please use @hankin2017_rmd; takes about 20 minutes to process without cache. The file eurodance2008.txt, used below, is copied from "Eurovision Dance Contest 2008", Wikipedia, accessed March 31, 2021. First we specify the matrix as appearing in the Wikipedia page:

eurodance_table <- as.matrix(read.table("eurodance2008.txt"))
eurodance_table
o <- eurodance_table # saves typing

Each row corresponds to a contestant and each column to a judge. The points system used was:

points_voters <- c(12,10,8,7,6,5,4,3,2,1)
points_jury   <- 4*points_voters
ov <- o[,-(1:2)] # ='o' but just the voters: exclude total and jury
pref <- ov*0  # retains NA
for(i in seq_along(points_voters)){pref[ov == points_voters[i]] <- i}
pref

Now we treat each column as an order statistic:

eurodance <- hyper2()
for(i in seq_len(ncol(pref))){
    x <- pref[,i]
    eurodance %<>% `+`(ordervec2supp(x[!is.na(x)]))
}  # i loop closes
eurodance_maxp <- maxp(eurodance)
eurodance_maxp
pie(eurodance_maxp)

Note the dominance of Poland. We verify consistency:

consistency(eurodance)

Now we consider the jury's vote:

(jj <- o[,2])
jj <- sort(jj,decreasing=TRUE)
jj[jj>0] <- seq_len(sum(jj>0))
jury <- jj
jury

Now the question is whether the partial rank conferred by the jury is consistent with that of the voters. The permutation test technique used in cook.Rmd is not appropriate here as there are $14!/4!\simeq 3.6\times 10^9$ permutations to consider; we will use a randomised sampling method. Below, we use a resampling technique: 4000 randomised jury observations are created, and the likelihood [under the Plackett-Luce likelihood function for the order statistics of the nationals' voters] is calculated. The $p$-value is then the probability of observing the actual observation or an observation more unlikely under this likelihood function; it is operationally identical to a simulated Fisher's exact test.

n <- 4000
LL <- rep(0,n)
for(i in seq_len(n)){
    jjstar <- sample(jury)
    names(jjstar) <- names(jury)
    LL[i] <- loglik(indep(eurodance_maxp),ordervec2supp(jjstar),log=FALSE)
}

plot(sort(LL),log="y")
p <- loglik(indep(eurodance_maxp),ordervec2supp(jury),log=FALSE)
abline(h=p)

sum(LL[LL<p])/sum(LL)

The $p$-value of about 2.4\% shows that there is strong evidence to suggest that the expert jury's ordering differs from that of the national popular vote.

Package dataset {-}

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

save(eurodance_table,eurodance_maxp,eurodance,file="eurodance.rda")

R References {-}

RobinHankin/hyper2 documentation built on May 6, 2024, 4:25 p.m.