R Notebook on Women’s Curling 2018 Olympics

An analysis of Women’s Curling at the 2018 Winter Olympics in South Korea. The technique to predict future matches is based on the Baseball Pythagorean Theorem. The exponents for the Pythagorean Expetctaion were tested against games played to date on February 21, 2018 from 1.9 to 4.1 (by 0.1). Empirically 3.4 had the lowest mean-squared-error of that set

library('rvest')
participants <- "Women" # Set for output reasons
#Specifying the url for desired website to be scrapped
url <- 'http://results.worldcurling.org/Championship/DisplayResults?tournamentId=561&associationId=0&teamNumber=0&drawNumber=0'
exponent <- 3.4 # The exponent to use for the Pythagorean Expectation, determined empirically 

The website www.worldcurling.org is accessed for game data

#Reading the HTML code from the website
webpage <- read_html(url)
#Using CSS selectors to scrape the rankings section
rank_data_html <- html_nodes(webpage,'.game-table')
num_games = length(rank_data_html)

The dowloaded webpage is scraped for the appropriate data

games <- matrix(nrow = num_games, ncol = 4)
# Scrape the data from the webpage
for (i in seq_len(num_games)) {
  this_result <- rank_data_html[i]
  teams <- html_text(html_nodes(this_result,".game-team"))
  scores <- html_text(html_nodes(this_result,".game-total"))
  games[i,c(1,2)] <- trimws(gsub('\r\n', '', teams))
  games[i,c(3,4)] <- strtoi(trimws(gsub('\r\n', '', scores)))
}
rm(i, scores, teams, this_result)

At this point, data for all Women’s Curling games at the Olympics has been retrieved and stored in a matrix named games. We will split this matrix into a matrix of only the games that have already completed and the games scheduled to be held (as of February 22, 2018)

completeGames <- games[!is.na(games)[,3],]
# Get a list of the teams that are playing
teams <- unique(games[,1])
if (!is.na(pmatch("To Be", teams))) teams = teams[-length(teams)]

# Take a subset of the games that are scheduled to come
scheduledGames <- matrix(nrow=nrow(games[is.na(games)[,3],]), ncol = 6)
scheduledGames[,1] <- games[is.na(games)[,3],1]
scheduledGames[,4] <- games[is.na(games)[,3],2]
scheduledGames <- scheduledGames[!grepl("To Be", scheduledGames[,1]),]
# Get a list of the teams that are scheduled to play
upcomingTeams <- unique(c(scheduledGames[,1],scheduledGames[,4]))

Based on each team’s record, determine the percentage of games they have won.

standings = matrix(nrow=length(teams), ncol = 5)
count <- 1L
for(team in teams) {
  wins <- sum(strtoi(completeGames[grepl(team, completeGames[,1]),3]) > strtoi(completeGames[grepl(team, completeGames[,1]),4])) +
    sum(strtoi(completeGames[grepl(team, completeGames[,2]),4]) > strtoi(completeGames[grepl(team, completeGames[,2]),3]))
  losses <- sum(strtoi(completeGames[grepl(team, completeGames[,1]),3]) < strtoi(completeGames[grepl(team, completeGames[,1]),4])) +
    sum(strtoi(completeGames[grepl(team, completeGames[,2]),4]) < strtoi(completeGames[grepl(team, completeGames[,2]),3]))
  standings[count,1] <- team
  standings[count,2] <- wins
  standings[count,3] <- losses
#  standings[count,4] <- wins / (wins + losses)
  standings[count,4] <- paste0(formatC(100 * (wins / (wins + losses)), format = "f", digits = 2), "%")
  count <- count + 1L
  print(paste(team, wins, losses, sep = ","))
}

[1] "Japan,5,4"
[1] "Olympic Athlete From Russia,2,7"
[1] "Denmark,1,8"
[1] "Switzerland,4,5"
[1] "Canada,4,5"
[1] "China,4,5"
[1] "Great Britain,6,3"
[1] "United States of America,4,5"
[1] "Korea,8,1"
[1] "Sweden,7,2"

# Clean up
rm(count, wins, losses, team)

No we can compute the Pythagorean Expectation for each team.

count <- 0L
for (team in teams) {
    count <- count + 1L
    scored <- sum(strtoi(completeGames[grepl(team, completeGames[,1]),3])) +
        sum(strtoi(completeGames[grepl(team, completeGames[,2]),4]))
    allowed <- sum(strtoi(completeGames[grepl(team, completeGames[,1]),4])) +
        sum(strtoi(completeGames[grepl(team, completeGames[,2]),3]))
    pythagorean <- (scored^exponent) / ((scored^exponent) + (allowed^exponent))
    pythagorean <- paste0(formatC(100 * pythagorean, format = "f", digits = 2), "%")
    standings[count,5] <- pythagorean
    print(paste(team, pythagorean, sep=" = "))
}

[1] "Japan = 55.94%"
[1] "Olympic Athlete From Russia = 14.41%"
[1] "Denmark = 22.45%"
[1] "Switzerland = 57.34%"
[1] "Canada = 61.84%"
[1] "China = 39.02%"
[1] "Great Britain = 57.22%"
[1] "United States of America = 37.60%"
[1] "Korea = 85.97%"
[1] "Sweden = 72.67%"

standings <- as.data.frame(standings)
names(standings) <- c("Team", "Wins", "Losses", "Standing", "Pythagorean")
print(standings)

rm(count, pythagorean, allowed, scored, team)

Finally, prepare and list the upcoming games with each team’s standings and Pythagorean Expectation.

for (team in upcomingTeams) {
    scheduledGames[grep(team, scheduledGames[,1]),2] <- as.character(standings[grep(team, standings[,1]),4])
    scheduledGames[grep(team, scheduledGames[,1]),3] <- as.character(standings[grep(team, standings[,1]),5])
    scheduledGames[grep(team, scheduledGames[,4]),5] <- as.character(standings[grep(team, standings[,1]),4])
    scheduledGames[grep(team, scheduledGames[,4]),6] <- as.character(standings[grep(team, standings[,1]),5])
}
rm(team)
scheduledGames <- as.data.frame(scheduledGames)
names(scheduledGames) <- c("Team1", "Standings1", "Pythagorean1", "Team2", "Standings2", "Pythagorean2")
print(scheduledGames)

Interpreting this table, Sweden has been playing at a 72.67% level while winning 77.78% of their games. The other team, Great Britain has been playing at a 57.22% level. It is thought that these percentages are a better indication of their records than their actual record because the Pythagorean Expectation takes the score into account. A team that wins by several points is playing better than a team that barely wins by one point.