Joey O'Brien

spRingsteen

Wed, 04 May 2022 00:00:00 +0000

We all love him — if you disagree you just haven’t spent long enough listening — it is of course the Boss, the Jersey Devil, Bruce Springsteen. With a musical career spanning over fifty years, record breaking albums, an award-winning one-man Broadway show, podcast series with ex-Presidents and so much more. However what Bruce (I hope he is okay with me working on first name terms) is most famous for is his live performances. Hard rocking four hour sets, solo acoustic shows, country swing bands, the list goes on and on but throughout his career there has been a huge collection of performances with ever-changing setlists working there way through both his own recording history and also the classics from other artists.

Thankfully, this huge repertoire of performances have been carefully collected by the devoted followers on E Street through the fan site Brucebase. Within this platform is a huge collection of data describing the majority of shows the Boss has ever performed including ever song performed at each gig. This source of data is what makes up the spRingsteen R package which I have created to allow for the data inclined to analyse both quickly and in a reproducible manner. In this post I discuss the data collection alongside its storage in a SQL setting, the process of wrapping the data in an R package and a quick demonstration of some possible data analysis that can be performed with it.

Data collection and database storage

As mentioned before, the goldmine needed for this project is Brucebase - a fan led platform containing a huge collection of data describing the Springsteen career over the past 50 years. Given that this data is readily available via this online platform it can be collected rather quickly via web-scraping. This is the idea of setting up a computer program to literally scrape, or collect, the content from a website and store it in an accessible manner.

The main idea is to find a systematic approach towards accessing the entire corpus of setlists, thankfully the maintainers of the site structure the URL associated with each page such that the date and venue of the concert is the main identifier, for example http://brucebase.wikidot.com/gig:2016-05-27-croke-park-dublin-ireland. As such, if the date and location of each performance is known the setlists can then be readily accessed. Fortunately, there are separate pages (found here) which simply contain these exact values, so the first thing is to collect these values which then feed the setlist collector. Using the R packages rvest and dplyr this can be done rather quickly.

It is important to note however that there is quite a lot of data here, with over 50 years of performances, 25 tours, and over 1,500 songs. As such the storage of the data is important, classical spreadsheets can of course be used however more standard approaches for such data, particularly given that there are multiple tables (setlists, song details, venues and dates) is in a database setting. This is where the DBI and RSQLite packages comes into play where we can perform work with reading/writing a database directly in R.

### we connect to a database like so
db_loc = here('database/springsteen_data.sqlite')
springsteen_db = DBI::dbConnect(RSQLite::SQLite(), db_loc)
### concert_df would be a tibble containing the collected data
### which we now write to the "concerts" table in the database
DBI::dbWriteTable(springsteen_db,
"concerts",
concert_df)
### and finally close the database connection
DBI::dbDisconnect(springsteen_db)

So we can collect all the data we need from Brucebase, parse it in a tidy format and write to a database all within R, what a language! This is exactly what happens in the springsteen_db repository hosted on my Github. There is also some very nice automation hosted within there such that the scripts are run every day to check if the Boss has had any new shows and if so that data also gets added to the database.

Creating a data-centric R package

Now with the data in place and neatly stored within a repository anyone can quickly load it into their programming language of choice, however I thought it would be particularly nice if it was accessible directly in R via its very own package. In order to perform such development work we are extremely fortunate in the R-universe to have packages like usethis which take away a lot of the pain from package creation with a huge array of tools. The main emphasis - as any data scientist/engineer has no doubt been told by their software developer peers (if fortunate enough to work alongside some) - is documentation. Each dataset in my case, and how it originated, has to be described in detail alongside toy examples to demonstrate possible use cases of the data.

Indeed, usethis also offers functionality that allows for the package to be based upon a Github repository for future maintenance and also allows for it to be accessed in its latest form via

remotes::install_github("obrienjoey/spRingsteen")

However for a package to be really picked up I believe it needs to be hosted on CRAN, the official R package platform. Again, usethis offers a range of functionality to prepare the new package for submission, where it goes through extensive validation and testing on a range of environments from the team there. All going well with documentation and the package performing correctly within the different tests on CRAN the work will get accepted and have its very own page like so.

Example analysis

So having collected the data and developed a package we are now left with the fun part - playing with the data! So let’s load in the package directly from CRAN and have a look at some example data analysis we can do straight away. For example let’s check out the top 10 most played songs by Springsteen through out his career:

library(spRingsteen)
spRingsteen::setlists |>
count(song, sort = TRUE) |>
slice(1:10) |>
mutate(song = ifelse(song == 'Born In The U.s.a.', 'Born In The U.S.A.', song),
song = forcats::fct_rev(forcats::fct_inorder(song))) |>
ggplot(aes(x = n, y = song)) +
geom_col(fill = '#2176FF') +
geom_text(aes(label = n),
hjust = 0, nudge_x = .5,
size = 4, fontface = "bold", family = "Fira Sans") +
coord_cartesian(clip = "off") +
scale_x_continuous(expand = c(.01, .01)) +
theme_void() +
theme(
axis.text.y = element_text(size = 14, hjust = 1, family = "Fira Sans"),
plot.margin = margin(15, 30, 15, 15)
)

Conclusions

I hope this summary gave you a nice insight into the spRingsteen package (and hopefully has you inspired for a quick check in on the Boss). Overall it is a dense data engineering project involving setting up an automated scraper that can collect all the data needed, storage in a SQL database, and a nice wrapping in a R package. All of the code can be found on my Github and hopefully it can help in setting up similar pipelines, because remember - you can’t start a fire without a spark.

COVID Northern Ireland

Tue, 22 Feb 2022 00:00:00 +0000

One of the many scientific benefits that have occurred since the start of the Coronavirus 19 pandemic is the emergence of large-scale open access data describing the dynamics of the virus at a range of scales. Governments, health organizations, and many others have produced data at a unparalleled rate to help society understand how the disease has rampaged through society.

This has offered a unique opportunity for data analysts, engineers, scientists, or even simply enthusiasts, to work with real world data that is constantly evolving as the pandemic unfolds. There are great examples of storytelling that have emerged from this occurrence, for example the flatten the curve narrative which was so prevalent in the early stages all the way up to more recent information regarding vaccination uptake globally.

I myself have been fortunate to have been involved in numerous efforts in utilizing these novel datasets, for example early data studies regarding mobility data (provided by Apple and Google) among citizens in Ireland were a particular entertaining aspect for me as virus begun to spread, see for example this invited blog post on Irish mobility) or some visuals which picked up national attention.

More recently I have focused on the affect of the pandemic in Northern Ireland. The work on which will be the main discussion point of this post.

Data Collection

Firstly, like any good data scientist I had to ask the question - where is the data? It turns out that the Department of Health NI produce a fantastic summary of the main metrics describing the disease including, cases, testing, hospitilizations, and deaths arising from Covid-19 on a daily-ish basis (more on this in a moment). Unfortunately, for those of us who want to access data as quickly and cleanly as possible, the data is stored in rather clunky .xlsx spreadsheets with each tab representing a different summary.

Look for the latest spreadsheet on a daily basis.
Extract the needed info from each of the sheets of the .xlsx file individually.
Clean this data in a more usable format.
Store the data in a public repository for others to use.

This is exactly the framework introduced in the covid19northernireland repo hosted on my GitHub. The main point of this code is to first of all collect the latest spreadsheet from the online platform, clean and parse the data into a tidy format, and lastly store the data. Nicely, due to the repetitive nature of this task I could set up a server which would do this for me automatically each night and produce the output observed in the repo. See this post for a detailed discussion on how this entire package works.

Dashboard

Okay, so the data has been collected in a great format which is very easy to work with. Of course there are a huge number of things one could do here (epidemic modelling, spatial statistics,…) but I really wanted to learn about developing dashboards in R so that’s what I’ll write about now (to see the finished product check here).

After some initial research I came across the flexdashboard package which looked to be perfect for what I wanted to do. In essence it is entirely described in a .Rmarkdown document so it is generally okay to work with, plus can look quite fantastic if given a bit of love and care (and help from the plotly package!), for example here’s one page of the finished dashboard.

For some more specifics about how it works, it makes use of a number of the cleaned datasets from the first part of this post to extract information about tests, cases, and deaths at an number of time and spatial scales. For example it was possible to load in the data at an electoral level to see how the number of cases varied by region using the mapview package:

`%>%` <- magrittr::`%>%`
### Pulling most recent data from Github
national_df <- data.table::fread("https://raw.githubusercontent.com/obrienjoey/covid19northernireland/main/data/ni_covid_national.csv")
last_national_data <- national_df %>%
tidyr::drop_na() %>%
dplyr::filter(date == max(date))
local_df <- data.table::fread("https://raw.githubusercontent.com/obrienjoey/covid19northernireland/main/data/ni_covid_local.csv")
shapefile <- sf::st_read(
"shapefiles/OSNI_Open_Data_-_Largescale_Boundaries_-_Local_Government_Districts_(2012).shp", quiet = TRUE)
local_df_summary <- local_df %>%
dplyr::distinct() %>%
dplyr::mutate_if(is.numeric, ~replace(., is.na(.), 0)) %>%
dplyr::group_by(area) %>%
dplyr::summarise(tests_1 = sum(tail(tests,1)),
tests_7 = sum(tail(tests,7)),
tests_30 = sum(tail(tests,30)),
tests_all = sum(tests),
cases_1 = sum(tail(cases,1)),
cases_7 = sum(tail(cases,7)),
cases_30 = sum(tail(cases,30)),
cases_all = sum(cases),
deaths_1 = sum(tail(deaths,1)),
deaths_7 = sum(tail(deaths,7)),
deaths_30 = sum(tail(deaths,30)),
deaths_all = sum(deaths)) %>%
janitor::adorn_totals("row") %>%
dplyr::as_tibble() %>%
dplyr::filter(area != 'Missing Postcode') %>%
tidyr::drop_na() %>%
tidyr::pivot_longer(cols = tests_1:deaths_all,
names_to = 'category') %>%
tidyr::separate(category,
into = c("Category", "Time"),
sep="_(?=[^_]+$)")
map_df <- local_df_summary %>%
dplyr::filter(Time == 1,
Category == 'cases') %>%
dplyr::inner_join(shapefile, .,
by = c('LGDNAME' = 'area'))
mapview::mapview(sf::st_zm(map_df),
zcol = c('value'),
layer.name = 'Cases',
popup = FALSE)

The main problem then was that the underlying of this data updates daily as discussed before. However given the data pipeline is already set up, a similar server can be utilized to automatically update the dashboard after the original collection script has run.

Conclusions

So there we have it, a discussion on developing a pipeline to automatically update and collect data (which I had a lot of fun doing, maybe I should think about a career in data engineering…) and also creating a number of visualizations to create a story regarding the pandemic’s evolution. Wrapping these altogether in a neat dashboard which I particularly like!

Data-Driven Snooker Rankings

Sun, 10 Oct 2021 00:00:00 +0000

The following is a project that came from a hobby project arising from my interest in snooker and how ideas from network science can be used in helping to rank competitors in the sport. This resulted in a peer-reviewed academic article during my PhD studies, a blog post for Oxford University Press, and some interesting commentary in the Sunday Mail!

People love ranking things. Each year we are faced with endless awards ceremonies—just think about the Oscars, Grammys, Ballon d’Or, Time Person of the Year… the list goes on and on.

The problem with these lists is that they are rarely backed up by quantitative data, which arises from most things rarely directly competing to help us determine who exactly the best is. One area however which experiences no shortage of such data is the realm of sport. So here let’s use a combination of data science and network science to try and answer the question in the case of snooker.

This will involve - obtaining the data (the exact details are beyond the scope of this post but may result in some content further up the road…) - performing an exploratory data analysis to get a feel for the underlying structure - developing models to rank competitors in a data-driven manner

It will also be a good chance to show some R code that was used to perform the analysis

1. The Data

The data which was scraped from cuetracker is already available on my Github so let’s load this into R straight away. There’ll be two dataframes, one describing every match played over 50 years of the sport and the other describing the details of the different tournaments in the same time period.

## load the packages
options(tidyverse.quiet = TRUE)
library(tidyverse)
library(scales)
library(cowplot)
library(tidygraph)
library(igraph)
library(ggrepel)
library(Matrix)
theme_set(theme_light())
tourn_df <- read_csv('https://raw.githubusercontent.com/obrienjoey/snooker_rankings/master/Data/final_tourn_df.csv')
match_df <- read_csv('https://raw.githubusercontent.com/obrienjoey/snooker_rankings/master/Data/final_match_df.csv')

2. Exploratory Data Analysis

Okay so now we can dive in and do some analysis on these two dataframes using the tidyverse toolbox. First of all how many matches are in the data?

match_df %>%
select(match_id) %>%
unique() %>%
nrow()

## [1] 47710

And what about the actual players?

match_df %>%
select(match_id, player_1, player_2) %>%
pivot_longer(2:3, values_to = 'player') %>%
select(player) %>%
unique() %>%
nrow()

## [1] 1221

Lastly how many tournaments were played?

tourn_df %>%
nrow()

## [1] 657

Okay, that is a good start let’s consider a more technical problem and check which player’s have won the most matches

# find the result frequencies of each player
player_result_df <- match_df %>%
filter(walkover != TRUE) %>%
select(match_id, season, player_1, player_2, player_1_score, player_2_score) %>%
mutate(winner = if_else(player_1_score > player_2_score,
player_1, player_2),
loser = if_else(player_1_score > player_2_score,
player_2, player_1)
) %>%
select(match_id, winner, loser) %>%
pivot_longer(cols = 2:3, values_to = 'player', names_to = 'result') %>%
group_by(result, player) %>%
tally() %>%
ungroup() %>%
pivot_wider(names_from = 'result', values_from = 'n') %>%
mutate(loser = replace_na(loser, 0),
winner = replace_na(winner,0),
total = loser + winner) %>%
pivot_longer(cols = 2:4, names_to = 'result',
values_to = 'matches')
player_result_df %>%
filter(result == 'winner') %>%
select(-result) %>%
arrange(desc(matches)) %>%
slice(1:5)

## # A tibble: 5 x 2
## player matches
## <chr> <int>
## 1 John Higgins 899
## 2 Ronnie O'Sullivan 843
## 3 Stephen Hendry 818
## 4 Mark Williams 768
## 5 Steve Davis 761

So there we have the top five ranked players based on the number of wins they have had during their career.

Interestingly, there is also a temporal element to this data in that the matches each occur within a given year, let’s look at how the above values vary over time

# number of tournaments by season
tourn_season_plot <- match_df %>%
mutate(season = as.integer(season)) %>%
group_by(season) %>%
summarise(no_tournaments = n_distinct(tourn_id)) %>%
ggplot(aes(x = season, y = no_tournaments)) +
geom_bar(stat='identity', fill = '#008DA8',
color = 'black') +
scale_x_continuous(expand = c(0,0), breaks = seq(1968,2020,4)) +
scale_y_continuous(expand = c(0,0)) +
theme_minimal() +
labs(x = 'Season', y = 'Number of Tournaments') +
theme(axis.line = element_line(),
axis.text=element_text(size=12),
plot.title.position = 'plot',
panel.grid.major.x = element_blank(),
legend.text=element_text(size=12),
legend.position = c(0.85,0.9),
axis.text.x = element_text(angle = 60, hjust = 1),
plot.title = element_text(size = 14, face = 'bold'),
axis.title=element_text(size=14))
# number of players by season
player_season_plot <- match_df %>%
select(season, player_1, player_2) %>%
pivot_longer(cols = 2:3, values_to = 'player') %>%
mutate(season = as.integer(season)) %>%
group_by(season) %>%
summarise(no_players = n_distinct(player)) %>%
ggplot(aes(x = season, y = no_players)) +
geom_bar(stat='identity', fill = '#008DA8',
color = 'black') +
theme_minimal() +
scale_x_continuous(expand = c(0,0), breaks = seq(1968,2020,4)) +
scale_y_continuous(expand = c(0,0)) +
labs(x = 'Season', y = 'Number of Players') +
theme(axis.line = element_line(),
axis.text=element_text(size=12),
plot.title.position = 'plot',
panel.grid.major.x = element_blank(),
legend.text=element_text(size=12),
legend.position = c(0.85,0.9),
axis.text.x = element_text(angle = 60, hjust = 1, size = 10),
plot.title = element_text(size = 14, face = 'bold'),
axis.title=element_text(size=14))
cowplot::plot_grid(tourn_season_plot, player_season_plot)

# plot the probability distribution of results obtained by each player
player_result_df %>%
group_by(result, matches) %>%
summarise(n = n()) %>%
ungroup() %>%
mutate(freq = n / sum(n)) %>%
filter(matches != 0) %>%
ggplot(aes(x = matches, y = freq, col = result)) +
geom_point() +
scale_y_log10(labels=trans_format('log10',math_format(10^.x))) +
scale_x_log10(labels=trans_format('log10',math_format(10^.x))) +
labs(y = 'Probability',
x = 'Number of Matches'
) +
theme_minimal() +
scale_color_manual(name = '',
breaks = c('total', 'winner', 'loser'),
values = c('#008DA8','#C3627D','#4A904D'),
labels = c('Total', 'Won', 'Lost')) +
theme(axis.line = element_line(colour = 'black'),
axis.text=element_text(size=12),
plot.title.position = 'plot',
legend.text=element_text(size=12),
legend.position = c(0.85,0.85),
plot.title = element_text(size = 14, face = 'bold'),
axis.title=element_text(size=14))

result_df <- match_df %>%
filter(walkover != TRUE) %>%
select(match_id, player_1, player_2, player_1_score, player_2_score) %>%
mutate(winner = if_else(player_1_score > player_2_score,
player_1, player_2),
loser = if_else(player_1_score > player_2_score,
player_2, player_1),
) %>%
select(winner, loser)

3. The Model

So now getting to the main aim of this post, let’s borrow some tools from network science to help figuring out an alternative way of ranking snooker players. We’ll use what is known as PageRank, an algorithm originally developed by the founders of Google in ranking webpages that helped their search engine return better results!

The main idea is to represent the sport as a graph, where each of the \(N\) players are a node and the edges of the graph are created by considering the matches played between players. Importantly, the result of the match is important and this is captured by the direction of the edge we draw, so in each match we draw the edge from loser to winner. After consider all matches in the dataset we obtain a \(N \times N\) matrix with entries \(w_{ij}\) describing the number of times player \(i\) has lost to player \(j\).

With this set-up we can proceed to use the PageRank algorithm to rank the players based on the prestige of player \(i\) - \(P_i\), obtained from the following set of equations (feel free to ignore this part if equations aren’t your thing)

\[\begin{equation} P_i = (1-q)\sum_j P_j \frac{w_{ji}}{k_j^{\text{out}}} + \frac{q}{N} + \frac{1-q}{N}\sum_j P_j \delta(k_j^{\text{out}}) \end{equation}\]

Importantly this algorithm considers not only how many times one player defeated another but also how frequently the defeated player themselves defeated others. In this sense each player has some associated prestige describing their quality, and in defeating a player the winner receives some of this associated prestige. This implies that a win against a strong competitor with high prestige is now more worthwhile to a player’s rank than defeating a weaker competitor.

Okay, so no doubt there are plenty of software packages to do this calculation for us but sometimes it is nice to code up the system ourselves so let’s do that now, using the brilliant tidygraph and igraph packages to work with the networks.

page_rank_sim = function(match_result_df){
node_list <- match_result_df %>%
gather() %>%
select(-key) %>%
unique() %>%
rename(label = value) %>%
rowid_to_column("id")
el <- match_result_df %>%
count(winner, loser, name = 'weight') %>%
rename(target = winner,
source = loser) %>%
left_join(., node_list, by = c('source' = 'label')) %>%
rename(from = id) %>%
left_join(., node_list, by = c('target' = 'label')) %>%
rename(to = id) %>%
select(to, from, weight)
snooker_net <- tbl_graph(nodes = node_list,
edges = el,
directed = TRUE)
adj <- as_adj(snooker_net, sparse = TRUE, attr = 'weight')
### PageRank algorithm
N <- node_list %>% nrow() # number of nodes in the network
P0 <- rep(1/N, N) # initial values
q = 0.15 # page rank factor
s_out <- rowSums(adj) # outdegree of the nodes
P_temp <- P0
thres <- 1e-20
error <- 1
iter = 1
while(error > thres & iter < 1e4){
temp <- (1-q)*((P_temp/s_out) %*% adj) + (q/N) + ((1-q)/N)*(P0 * (s_out == 0))
error <- max(P_temp - temp)
P_temp <- temp
iter <- iter + 1
}
prestige <- as.vector(temp)
result <- tibble(player = node_list$label, prestige = prestige,
in_strength = as.vector(colSums(adj))) %>%
arrange(desc(prestige)) %>%
mutate(rank_pre = rank(-prestige, ties.method = "first"),
rank_str = rank(-in_strength, ties.method = "first"))
result
}

4. Results

Using the approach described above, after constructing a network based upon all recorded professional snooker games, it can quickly be determined who is the greatest player of all time. Interestingly, it is not Ronnie O’Sullivan with his natural talent, Steve Davis and his distinguished trophy room, or the winning machine known as Stephen Hendry, but rather the four-time world champion John Higgins! This result may seem surprising to some snooker fans but when the data is considered it is entirely understandable. While both Davis and Hendry have plenty of trophies and wins to their name, the quality of player competing in their era was considerably less than those faced by Higgins and O’Sullivan (who is ranked the second greatest through our approach).

set.seed(1)
# perform the PageRank
all_time_df <- page_rank_sim(result_df)
all_time_df %>%
filter(rank_pre <= 30 | rank_str <= 30) %>%
ggplot(aes(x = rank_str, y = rank_pre, label = player)) +
geom_abline(slope = 1, intercept = 0,
color="red",
linetype="dashed", size=1) +
geom_point() +
theme_minimal() +
geom_text_repel(size = 2.25) +
labs(x = 'Rank by Wins',
y = 'Rank by PageRank') +
theme(axis.line = element_line(colour = 'black'),
axis.text=element_text(size=10),
plot.title.position = 'plot',
plot.title = element_text(size = 14, face = 'bold'),
plot.subtitle = element_text(size = 12),
axis.title=element_text(size=12))

5. Concluding Thoughts

In order to help satisfy the intrinsic human desire to rank entities, this work has proposed a method which utilizes a mathematical framework to determine a ranking of competitors which considers not only the number of times a player has won but also the quality associated with each win.