Code for calculating the probability of winning a set in volleyball based on score and probabilities of winning a point

volleyball_win_probability.R

library(Matrix)
library(dplyr)
library(ggplot2)

# set points to win - 25 for sets 1-4, 15 for set 5 #
ptw<-15
# set point probabilities #
srp<-0.42 # probability of winning a point when serving #
sop<-0.58 # probability of winning a point when receiving serve (sideout) #
# create tibble of game states 
me<-c(0:ptw)
th<-c(0:ptw)
si<-c(0:1)

mmi<-merge(me,th,by=NULL)
mmi<-merge(mmi,si,by=NULL)
colnames(mmi)<-c("me","th","si")
mmi<-as_tibble(mmi)

mmi<-mmi %>%
  mutate(ci=th*(ptw+1)+me+1+si*(ptw+1)*(ptw+1)) %>%
  # calculate end states #
  mutate(mewin=ifelse(me==ptw & th<=ptw-2,1,0),thwin=ifelse(me<=ptw-2 & th==ptw,1,0)) %>%
  # index if won point - halt transitions if game reaches end state #
  # if you reach 25 to 24 or 24 to 25, reset score to 24 to 23 or 23 to 24 #
  mutate(mew=me+1,thw=th,reset=ifelse(mew==ptw & thw==ptw-1,1,0),thw=ifelse(reset==1,ptw-2,thw),mew=ifelse(reset==1,ptw-1,mew)) %>%
  mutate(wi=ifelse(mewin+thwin>0,ci,thw*(ptw+1)+mew+1+1*(ptw+1)*(ptw+1)),wv=ifelse(mewin+thwin>0,1,ifelse(si==0,sop,srp))) %>%
  mutate(wi=ifelse(me==ptw & th==ptw,ci,wi)) %>%
  # index if lost point - halt transitions if game reaches end state  #
  mutate(mel=me,thl=th+1,reset=ifelse(mel==ptw-1 & thl==ptw,1,0),thl=ifelse(reset==1,ptw-1,thl),mel=ifelse(reset==1,ptw-2,mel)) %>%
  mutate(li=ifelse(mewin+thwin>0,ci,thl*(ptw+1)+mel+1+0*(ptw+1)*(ptw+1)),lv=ifelse(mewin+thwin>0,0,ifelse(si==0,1-sop,1-srp))) %>%
  mutate(li=ifelse(me==ptw & th==ptw,ci,li)) 

# create sparse matrix with transition probabilities #
# transition probabilities for winning a point #
sm1<-sparseMatrix(i=mmi$wi,j=mmi$ci,x=mmi$wv,dims=c((ptw+1)*(ptw+1)*2,(ptw+1)*(ptw+1)*2))
# transition probabilities for losing a point #
sm2<-sparseMatrix(i=mmi$li,j=mmi$ci,x=mmi$lv,dims=c((ptw+1)*(ptw+1)*2,(ptw+1)*(ptw+1)*2))
# total transition probabilities #
sm<-sm1+sm2         

# loop through 500 times to play out all possible game states and enough deuce-advantage states #
smi<-sm
for (i in 1:500) {
  smi<-smi %*% sm
}

# aggregate end state probabilities #
mewin<-t(mmi$mewin)
thwin<-t(mmi$thwin)

pr_mewin<-as.vector(mewin %*% smi)
pr_thwin<-as.vector(thwin %*% smi)

# create tibble of end state probabilities based on game state #
prt<-tibble(ci=c(1:((ptw+1)*(ptw+1)*2)),pr_mewin=pr_mewin,pr_thwin=pr_thwin)

# merge in with game state file #
wprb <- mmi %>%
  left_join(prt,by="ci") %>%
  mutate(pr_check=pr_mewin+pr_thwin) %>%
  select(me,th,si,pr_mewin,pr_thwin,pr_check)

# replace games states 24-25,25-24,25-25 with the values for 23-24, 24-23, 24-24 - they're equivalent #
replc<-wprb %>%
  filter((me==ptw-1 & th==ptw-2) | (me==ptw-2 & th==ptw-1) | (me==ptw-1 & th==ptw-1)) %>%
  mutate(me=me+1,th=th+1)

# final win probability file for all game states #
# field descriptions #
# me -> your score
# th -> opponent score
# si -> serve indicator - if 0, your opponent is serving, if 1, you are serving
# pr_mewin -> your probability of winning a set for the given game state #
# pr_thwin -> your opponent's set win probability
# pr_check -> check that the two probabilities sum to 1

wprb <- wprb %>%
  filter(!(me==ptw & th==ptw-1) & !(me==ptw-1 & th==ptw) & !(me==ptw & th==ptw)) %>%
  bind_rows(replc) %>%
  arrange(me,th,si)

# ggplot parameters #
service<-1 # enter 1 if team is serving, 0 if opponent is serving #
svc_title<-ifelse(service==0,"Opponent Serving","When Serving")
prob_subtt<-paste0("point win probability (when serving) = ",format(srp,nsmall=2,digits=3),", point win probability (when opponent serving) = ",format(sop,nsmall=2,digits=3))
# set intercept lines #
if (ptw==15) {intcpt<-c(4.5,9.5,14.5)} else {intcpt<-c(4.5,9.5,14.5,19.5,24.5)}
# create heat map of win probabilities #
ggplot(data=subset(wprb,si==service),aes(x=me,y=th)) +
  geom_tile(aes(fill=pr_mewin)) +
  scale_fill_gradient2(low = "red", mid="white", high = "blue", midpoint=0.5)  +
  geom_text(aes(label = sprintf("%0.2f",pr_mewin)),size=5) +
  theme_minimal(base_size = 15) +
  scale_x_continuous(breaks=c(0:ptw),limits=c(-0.5,ptw+0.5),expand = c(0, 0)) +
  scale_y_continuous(breaks=c(0:ptw),expand = c(0, 0)) +
  labs(title = paste0("Volleyball Set Win Percentages - ",svc_title), subtitle = prob_subtt,caption = "@inpredict",x = "your score", y = "opponent score") +
  theme( # remove the vertical grid lines
    panel.grid.major.x = element_blank() ,
    panel.grid.minor.x = element_blank() ,
    panel.grid.major.y = element_blank() ,
    panel.grid.minor.y = element_blank() 
  ) +
  geom_hline(yintercept=intcpt,size=0.25) +
  geom_vline(xintercept=intcpt,size=0.25) +
  theme(legend.position="none",text=element_text(family="Open Sans")) +
  theme(plot.title = element_text(hjust = 0.5)) +
  theme(plot.subtitle = element_text(hjust = 0.5))