Rubix³: A Data Blog

NCAA Basketball: Clustering Conferences

Sun, 18 Nov 2018 00:00:00 +0000

With the recent start of the college basketball season, I thought it would be fun to explore how style of play varies between conferences and reveal how the game has changed over time. Using yearly data for each school found on kenpom.com, a site for advanced college basketball stats, I examined the state of college hoops.

Data Pre-Processing

Load Packages

library(tidyverse)
library(rvest)
library(stringi)
library(kableExtra)
library(ggthemr)
library(factoextra)
library(cluster)
library(NbClust)
library(plotly)

Scrape and Clean Data

#define column names
variables <- c("Team", "Conference", "Record", "AdjEM", "AdjO", "AdjD", "AdjT", "Luck", "SOS.AdjEM", "OppO", "OppD", "NC.SOS.AdjEM")

#scrape kenpom data
seasons <- lapply(paste0('https://kenpom.com/index.php?y=', 2002:2018),
                function(url){
                    url %>% 
                    read_html() %>% 
                    html_nodes("table") %>%
                    html_table() %>%
                    as.data.frame() %>%
                    select(-c(Var.1, Var.7, Var.9, Var.11, Var.13,
                                  Strength.of.Schedule.1, 
                                  Strength.of.Schedule.3, 
                                  Strength.of.Schedule.5, NCSOS.1)) %>%
                    `colnames<-`(variables) %>%
                    filter(!is.na(as.numeric(OppO))) %>%
                    mutate(year = stri_sub(url, from = -4, length = 4))
                })

#combine yearly data
ncaa <- do.call(rbind, seasons) %>% 
  separate(Record, into = c("Wins", "Losses")) #extract wins/losses 

ncaa[,3:13] <- lapply(ncaa[,3:13], as.numeric) #convert to numeric values
ncaa$Team <- gsub('[0-9]+', "", ncaa$Team) %>% #remove ncaa/nit tourney rank
  trimws("r") #remove trailing spaces
ncaa$Conference <- recode(ncaa$Conference, P10 = "P12") #combine pac10 with pac12

In total, we’ll examine 17 years of data including 5,804 individual team seasons. Each season will be classified according to the year it ends, not the year it starts. For example, the 2017-18 college basketball season will be labeled simply as “2018”. A quick look at how the data is organized is shown below.

glimpse(ncaa)

## Observations: 5,804
## Variables: 14
## $ Team         <chr> "Duke", "Cincinnati", "Maryland", "Kansas", "Oklaho…
## $ Conference   <chr> "ACC", "CUSA", "ACC", "B12", "B12", "B10", "SEC", "…
## $ Wins         <dbl> 31, 31, 32, 33, 31, 25, 22, 26, 26, 22, 26, 22, 24,…
## $ Losses       <dbl> 4, 4, 4, 4, 5, 12, 9, 9, 9, 10, 7, 10, 10, 6, 10, 6…
## $ AdjEM        <dbl> 34.19, 30.19, 29.25, 28.99, 26.04, 24.80, 24.72, 23…
## $ AdjO         <dbl> 121.0, 118.1, 119.2, 118.7, 114.9, 114.0, 115.1, 11…
## $ AdjD         <dbl> 86.8, 87.9, 89.9, 89.7, 88.9, 89.2, 90.4, 92.5, 96.…
## $ AdjT         <dbl> 74.5, 67.4, 73.7, 77.3, 66.5, 65.6, 69.6, 68.5, 71.…
## $ Luck         <dbl> -0.027, 0.002, 0.025, 0.022, 0.043, -0.049, -0.073,…
## $ SOS.AdjEM    <dbl> 9.87, 6.58, 9.88, 10.66, 8.77, 14.11, 9.11, 10.60, …
## $ OppO         <dbl> 109.1, 106.3, 109.1, 110.3, 109.0, 110.8, 108.1, 10…
## $ OppD         <dbl> 99.2, 99.7, 99.3, 99.6, 100.2, 96.7, 99.0, 99.1, 99…
## $ NC.SOS.AdjEM <dbl> 6.66, 3.48, 1.62, 8.32, -0.45, 13.53, -0.56, 6.78, …
## $ year         <chr> "2002", "2002", "2002", "2002", "2002", "2002", "20…

Pace of Play

Overall Tempo

To begin, let’s look at how tempo has varied over time. Kenpom defines tempo as a team’s total possessions per 40 minutes (the length of a game minus overtime) adjusted for opponent. So, in general, the greater the tempo, the faster pace a team plays at. The plot below maps how tempo has evolved over time with the red dot representing each year’s mean.

It looks like most teams slowly but surely began slowing down overall pace; tempo was trending downwards right until the 2016 season. So, what happened in 2016? The NCAA reduced the shot clock from 35 seconds to 30 and looks to have made an immediate impact on the way teams play. The average team possessions jumped from 64.4 in 2015 to 68.2 in 2016, the highest since 2002. That’s an increase of about 8 more total possessions per game! Next, let’s break it down on the conference level.

Conference Tempo

The plot below shows how each of the major conferences transitioned in terms of pace during the five years prior to using a 30 second shot clock and the three years since.

before <- ncaa %>%
  filter(Conference %in% c("B10", "B12", "P12", "SEC", "ACC", "BE")) %>%
  filter(year < 2016 & year > 2010) %>%
  group_by(Conference) %>%
  summarise("30 Seconds" = mean(AdjT))

after <- ncaa %>%
  filter(Conference %in% c("B10", "B12", "P12", "SEC", "ACC", "BE")) %>%
  filter(year > 2015) %>%
  group_by(Conference) %>%
  summarise("35 Seconds" = mean(AdjT))

tempo <- full_join(before, after, by = "Conference") %>% 
  gather("Shot Clock", Tempo, 2:3)

tempo$Conference <- recode(tempo$Conference, B10 = "Big 10", B12 = "Big 12", P12 = "Pac-12", BE = "Big East")

The Big East is no longer a slower paced, defensive-minded conference like the Big 10; they lead all conferences in terms of average tempo using a 30 second shot clock.

Conference Clustering

High-Major vs. Mid-Major

Each school competes in one of 32 different conferences which are determined primarily by geography and school size. Not all conferences are created equally, however. At the top of the food chain, “Power Six” conferences (ACC, Big 10, Big 12, Big East, Pac-12, SEC) recruit the top talent year in, year out and are the most competitive each year. The rest of the conferences could be considered “mid-major”, but some like to make the distinction to separate into one more category: “high-major.” They are typically a step above the rest of the mid-majors but aren’t as strong top-to-bottom as the Power Six. Let’s use k-means clustering to determine which conferences deserve the high-major distinction.

K-means

First things first, let’s determine what data to use. Conference realignment kind of throws a wrench into things, so to get a better idea of the current landscape we’ll focus our efforts only on the past five seasons. We’ll use each conference’s median team offensive and defensive efficiency metric defined as the points scored or allowed per 100 possessions (adjusted for opponent) and tempo (described above) to paint a picture of each conference’s overall skill and style of play. Combining those features let’s determine the optimal number of clusters using silhouette coefficients.

set.seed(8675309)

kmeans.data <- ncaa %>%
  filter(year > 2013) %>%
  group_by(Conference) %>%
  select(AdjO, AdjD, AdjT) %>%
  summarise_all(median) %>%
  column_to_rownames("Conference") %>%
  scale()

The optimal number of centers to use for k-means model is 2. The silhouette score measures the separation of each point between clusters. In short, the higher score, the better the clustering result. The silhouette plot with 2 clusters is shown below.

ncaa.km <- kmeans(kmeans.data, 2, nstart = 33)

The results of our k-means cluster can be visualized on a PCA biplot showing 96.7% (65.6 + 31.1) of the variability in the data.

Congratulations to members of the American, Atlantic 10, Mountain West, Missouri Valley, and West Coast Conferences. You have officially been promoted to High-Major status! Now of those High-Majors, let’s see which schools could make the jump to a Power Six conference based on recent performance.

#define conference type
ncaa <- ncaa %>%
  mutate(type = case_when(Conference %in% c("ACC", "B10", "B12", "P12", "SEC", "BE") ~ "Power 6",
                          Conference %in% c("A10", "Amer", "MWC", "MVC", "WCC") ~ "High-Major",
                          TRUE ~ "Mid-Major"))

The Best of the Rest

Kenpom ranks each team by its efficiency margin which is a team’s offensive minus defensive efficiency. Since 2014, the average efficiency margin for Power Six schools’ is 13.80. During that same time, High-Majors with an overall efficiency margin of that or better are listed below.

Team	AdjEM
Gonzaga	24.764
Wichita St.	23.054
Cincinnati	19.846
SMU	18.098
Saint Mary’s	15.658
San Diego St.	14.752
VCU	13.898

These schools will most likely be given a hard look from Power Six conferences looking to expand. Gonzaga, Wichita St., and VCU have all made the Final Four this decade as well.

Baseball Ejections and Replay Review

Wed, 03 Oct 2018 00:00:00 +0000

The 2014 MLB season marked the first time a team could utilize instant replay to challenge an umpire’s ruling. Although technically introduced in 2008, previously only home run boundary calls could be reviewed at an umpire’s discretion. Now with less time spent arguing safe/out calls and more time consulting replay officials in New York, there seems to be less opportunity for players and managers to argue and get ejected. But let’s consult the data first. I looked at ten years of ejection data (2008-2017) coming from UEFL Portal to see if I could reveal any interesting patterns. The steps of my analysis are outlined below.

Data Pre-Processing

Load Packages

library(tidyverse)
library(readxl)
library(lubridate)
library(jcolors)
library(scales)
library(treemap)
library(d3treeR)
library(kableExtra)
library(ggtern)

Import Data

#load ejections data
load(file = "data/ejections.rda")

Clean Data

The data is stored in a list containing ten data frames, each containing one year’s worth of ejections. As the years progressed, some column names evolved into simpler variable titles such as “Ejected Reason” becoming just “Reason”. I’ll adjust the differing variable names to match the others before combining all ten data frames into one.

map(ejections, names) #review column names for each yearly dataset

#create function to replace '08-'12 column names
fix_columns <- function(df){
  new_names <- c("W/L Pre-" = "W/L at time?" , 
                 "W/L Final" ="W/L at final?",
                 "Ej Pos" = "Pos__1")
  df %>%
    rename(!!new_names)
}

ejections[6:10] <- map(ejections[6:10], fix_columns)

#create anonymous functions to fix remaining differences
ejections[5:10] <- map(ejections[5:10], function(.x) .x %>% rename("Name" = "Ejected Name") %>% rename("Reason" = "Eject Reason"))
ejections[9:10] <- map(ejections[9:10], function(.x) .x %>% rename("Team" = "Ej Team"))

#create function to select columns for each dataset in list
select_columns<- function(df){
  df %>%
  filter(`W/L Final` != "NA") %>%
    select("Date", "Team", "Ej Pos", "Name", "H", "AB", "W/L Pre-", "W/L Final", "RS", "RA", "AB", "Inn", "Reason", "Play Result")
}

ejections <- map(ejections, select_columns)

#combine all years
ejections <- bind_rows(ejections)

From 2008-2017 there were a total of 1930 ejections. A quick snapshot of the data is shown below.

glimpse(ejections)

## Observations: 1,930
## Variables: 13
## $ Date          <dttm> 2017-04-05, 2017-04-06, 2017-04-09, 2017-04-10, 2…
## $ Team          <chr> "MIA", "LAD", "TB", "PHI", "COL", "SEA", "TEX", "T…
## $ `Ej Pos`      <chr> "Manager", "CF", "CF", "Manager", "Manager", "Mana…
## $ Name          <chr> "Don Mattingly", "Joc Pederson", "Kevin Kiermaier"…
## $ H             <dbl> NA, 0, 3, NA, NA, NA, NA, NA, NA, NA, NA, 1, NA, 0…
## $ AB            <dbl> NA, 3, 4, NA, NA, NA, NA, NA, NA, NA, NA, 2, NA, 3…
## $ `W/L Pre-`    <chr> "L", "W", "W", "Tie", "L", "L", "L", "L", "L", "L"…
## $ `W/L Final`   <chr> "L", "W", "W", "L", "L", "W", "L", "W", "L", "L", …
## $ RS            <dbl> 2, 0, 2, 1, 2, 3, 1, 2, 0, 0, 2, 2, 0, 2, 2, 6, 0,…
## $ RA            <dbl> 0, 0, 0, 2, 4, 1, 5, 0, 2, 0, 2, 2, 2, 2, 2, 2, 1,…
## $ Inn           <dbl> 7, 7, 7, 8, 5, 6, 3, 9, 8, 8, 5, 5, 8, 7, 7, 3, 7,…
## $ Reason        <chr> "Unsportsmanlike-NEC", "Balls/Strikes", "Balls/Str…
## $ `Play Result` <chr> "HBP", "K", "K", "Ball", "No Balk", "Fair", "Foul"…

After a few more housekeeping data manipulations, I think our data is ready to be explored!

#convert from DateTime to Date
ejections$Date <- ymd(ejections$Date)

#Create Year variable
ejections$Year <- year(ejections$Date)

#adjust differing team name abbreviations
ejections$Team <-
  fct_recode(ejections$Team, MIA = "FLA", ARI = "AZ", MIA = "FL", WAS = "WSH")

#Check swing ejections were not differentiated from ball/strikes until 2014
ejections$Reason <- fct_recode(ejections$Reason, `Balls/Strikes` = "Check Swing")

#recode levels
ejections$`W/L Pre-` <- recode(ejections$`W/L Pre-`, L = -1, Tie = 0, TIe = 0, W = 1) 
ejections$`W/L Final` <- recode(ejections$`W/L Final`, L = -1, W = 1)

Ejections By Year & Cause

First let’s take a look at how ejections have changed since replay was introduced in 2014.

From 2008 to 2017, an MLB season averaged 193 ejections per season. In 2014, the first year of expanded replay, the number of ejections increased by 21, eclipsing 200. The following year saw yet another jump, before dropping below the 10-year average in ’16 and ’17. While the replay system doesn’t appear to be deterring ejections, I wouldn’t say it’s encouraging them either. What could be changing; however, is the reason for players/coaches getting ejected. Let’s look at how the cause of arguments could be evolving.

ejections$Reason <- fct_other(ejections$Reason, keep = c("Balls/Strikes", "Fighting", "Replay Review", "Safe/Out", "Throwing At"))

data <- ejections %>%
  group_by(Year, Reason) %>%
  select(Year, Reason) %>%
  add_tally() %>%
  distinct() %>%
  group_by(Year) %>%
  mutate(percent = n/sum(n)) %>%
  group_by(Year, Reason) %>%
  summarise(percent = sum(percent)) %>%
  ungroup() %>%
  add_row(Year = 2008:2013, Reason = "Replay Review", percent = 0) %>%
  add_row(Year = 2016:2017, Reason = "Safe/Out", percent = 0)

Arguing safe/out sharply declined after having the ability to challenge calls before going extinct in 2016. A new type of ejection emerged as a result though. Issues with the replay ruling or why a challenge was or was not granted seemed to fill the gap. The “other” category refers to play regarding interference, balks, or any other less common ruling. Perhaps what is most noteworthy, is that from 2013 to 2017 the percentage of yearly ejections via arguing balls/strikes (which also includes check swings) is up 17%. The trust in an umpire’s ability to manage the strike zone seems to be at least shrinking some. If that number doesn’t decrease anytime soon, I wouldn’t be surprised to see the automated strike zone make its debut sooner rather than later.

Ejections By Division

The following chart outlines the total amount of ejections by division. Try clicking on each square to explore which teams contribute the most to their respective divisions total and hover over each to see their count.

divisions <- ejections %>%
  mutate(division = case_when(Team %in% c("STL", "CHC", "MIL", "CIN", "PIT") ~ "NL Central",
                              Team %in% c("LAD", "SF", "SD", "COL", "ARI") ~ "NL West",
                              Team %in% c("MIA", "PHI", "WAS", "NYM", "ATL") ~ "NL East",
                              Team %in% c("NYY", "BOS", "TB", "TOR", "BAL") ~ "AL East",
                              Team %in% c("LAA", "HOU", "OAK", "TEX", "SEA") ~ "AL West",
                              Team %in% c("CWS", "DET", "KC", "CLE", "MIN") ~ "AL Central")) %>%
  group_by(Team, division) %>%
  count()

The most penalized division is the AL East with 388 ejections over 10 years. On average a team will receive 6.43 ejections per season. The top five teams with the most ejections since ’08 are listed below.

Team	division	n
BOS	AL East	95
TOR	AL East	94
DET	AL Central	90
LAD	NL West	89
ATL	NL East	82

Managerial Ejections

It’s often said during a broadcast that after a manager is ejected, they’ll pay attention to how the players respond. The team will either take the lead (positive outcome), lose the lead (negative outcome), or remain ahead/behind (neutral outcome). The graph below plots all outcomes against each other among managers with 6 or more ejections over the past 10 years.

ejections$Name <- recode(ejections$Name, "A.J. Hinch" = "AJ Hinch", "Fredi Gonzales" = "Fredi Gonzalez")

manager_ej <- ejections %>%
  filter(`Ej Pos` == "Manager") %>%
  mutate(result = case_when(.$`W/L Final` > .$`W/L Pre-` ~ "Positive",
                            .$`W/L Final` < .$`W/L Pre-` ~ "Negative",
                            .$`W/L Final` == .$`W/L Pre-` ~ "Neutral")) %>%
  group_by(Name, result) %>%
  count() %>%
  spread(result, n, fill =0) %>%
  mutate(total = sum(Positive, Negative, Neutral)) %>%
  filter(total > 6) %>%
  mutate(diff = abs(Positive - Negative)/total)

After a team’s manager has been ejected, the current result of the game rarely changes, meaning the team in the lead tends to hang on for the victory. Some managers like Joe Girardi, Bobby Cox, or Bruce Bochy have seen their teams rally to a win in their absence more often than seeing a lead slip away or losing a tied game while others like Jim Riggleman haven’t been so lucky.

Avocado Market Research

Thu, 13 Sep 2018 00:00:00 +0000

The following report intends to analyze avocado prices and sales volume from 2015 to early 2018 across the US. In addition to a thorough exploratory analysis, I’ll also try to calculate the price elasticity of demand for each individual market. The dataset comes from the Hass Avocado Board.

Data Pre-Processing

Load Data

#load avocado data
load("data/avocados.Rda")

Load Packages

library(tidyverse)
library(scales)
library(plotly)
library(wesanderson)

Clean Data

The dataset contains weekly average prices and total amount sold for both organic and conventional avocados for 45 different markets (New York, Boise, St. Louis, etc.) that make up 8 larger regions (California, Great Lakes, Midsouth, Northeast, Plains, South Central, Southeast, and West). I’ll create three different datasets: one containing the 45 markets, one for the 8 larger regions, and one for entire US. Also, three price lookup codes (PLU’s) are listed, but for Hass avocados only, so I’ll create another variable to hold the rest of avocados (e.g. green-skinned) sold per week.

#replace spaces with underscores in column names
names(avocados) <- gsub(" ", "_", names(avocados))

#rename PLU codes and tidy up data
avocados <- avocados %>%
  rename(small_hass = "4046", large_hass = "4225", xl_hass = "4770") %>%
  mutate(other = Total_Volume - small_hass - large_hass - xl_hass) %>%
  gather(bag_size, bag_total, c(Small_Bags, Large_Bags, XLarge_Bags)) %>%
  gather(avocado_type, avocado_volume, c(small_hass, large_hass, xl_hass,
                                         other)) 

#subset data by region
avocados_region <- avocados %>%
  filter(region %in% c("California", "West", "SouthCentral", "GreatLakes",
                       "Midsouth", "Southeast", "Northeast", "Plains")) 

#subset data by market (city)
avocados_market <- avocados %>%
  filter(!(region %in% c("California", "West", "SouthCentral", "GreatLakes",
                       "Midsouth", "Southeast", "Northeast", "Plains",
                       "TotalUS")))

#dataset for entire US
avocados_total <- avocados %>%
  filter(region == "TotalUS")

Let’s make sure we don’t have any missing values

paste(sum(is.na(avocados_market)),
sum(is.na(avocados_region)),
sum(is.na(avocados_total)))

## [1] "0 0 0"

Bravocado! Also, let’s see if there are any hidden markets that make up a region.

cat(paste("Market Volume:",
sum(avocados_market$avocado_volume),"\n"),
paste("Region Volume:",
sum(avocados_region$avocado_volume), "\n"),
paste("Total Volume:",
sum(avocados_total$avocado_volume)))

## Market Volume: 11381766688.74 
##  Region Volume: 17594220546.06 
##  Total Volume: 17594220545.4

So it looks like some avocados (6,212,453,857 to be exact) were sold over the past few years in markets not found in the dataset. But the eight regions do in fact contain the entirety of US avocado sales (minus rounding error).

Exploratory Data Analysis

Distribution

Alright now that we understand the data, I think it’s time for some exploratory data analysis! First, let’s look at how the prices of organic and conventional avocados are distributed.

Not surprisingly, organic avocados are generally priced higher than conventional ones. The dashed vertical line in the middle represents the average weekly price for all avocados, $1.37. Next, let’s look at how prices have varied over time.

Avocado Prices

A couple of things stick out to me. Avocados reached a 3-year high in late summer 2017. Also the apocalyptic organic price drop around July 2015. My guess is that there was some missing data for US total organic avocado prices in July 2015 that got imputed as $1.00. Let’s check the price movement for each region to see if any sharp declines in July 2015 exist.

Nothing out of the ordinary here. Organic prices never dropped below conventional prices in each region. I will just leave the US dataset as is and focus the rest of my analysis on the region dataset. Now, let’s see how avocado prices vary across regions.

The Northeast region sells avocados at the highest average price. Now, let’s determine which size of avocados each region buys.

Avocado Volume

The South Central, California, and West regions make up the three largest avocado regions by volume. The Northeast region sells the most Large Hass avocados (both proportionally to total regional sales and overall) which probably contributes to them having the highest average price. With that said, let’s look at how each market consumes avocados.

The LA market appears to be ripe for avocados; it doubles the second largest market (New York) in terms of volume. Avocados seem to be most popular in western or warm weathered markets. Even smaller markets like Denver and Portland rank near the top among the larger US cities suggesting avocado consumption has a geographical element to it.

Elasticity

Finally let’s look at the price elasticity of avocados. We can try to determine which markets avocados are the most price elastic. First, let’s plot total volume against average price for all avocados.

Conventional avocados appear to show a linear relationship. It’s hard to make up the shape for the organic avocados so let’s try plotting each type in its own graph. It’s also worth noting that organic avocados are sold in much lower volumes than conventional avocados.

It looks like the organic avocado price vs. sales relationship is more uniform, hinting that it has a less elastic demand than conventional avocados. The linear model seems to do an adequate job of describing the data so, for simplicity, let’s just fit a linear price-response function for all markets and compare their overall elasticities.

elas <- lapply(unique(avocados_market$region), function(b){
            df <- avocados_market %>%
              filter(region == b)
            m <- lm(Total_Volume ~ AveragePrice, data = df)
            x <- m$coefficients[["AveragePrice"]]
            y <- mean(df$AveragePrice)
            z <- mean(df$Total_Volume)
            x*y/z
        })

elas <- do.call(rbind, elas) %>%
  data.frame() %>%
  mutate(market = unique(avocados_market$region)) %>%
  mutate(elasticity = round(., 2)) %>%
  select(-c(.))

The overall demand for avocados is elastic in all markets. Western markets (especially the Pacific Northwest) are typically less responsive to changes in price than eastern markets. A 10% price increase would cause an 18% drop in demand in Seattle but a 37% drop in New York. The Pittsburgh market could very well be immune to the avocado craze as a 10% price increase would decrease demand by 58%, 20% more than the next closest market, fellow Pennsylvanian city, Philadelphia.

The NFL, NBA, & MLB's Center of Gravity

Thu, 06 Sep 2018 00:00:00 +0000

Drawing inspiration from FiveThirtyEight’s article locating the Stanley Cup’s center of gravity, or the average geographic point of all Stanley Cup winners, I wondered where other leagues (MLB, NBA, NFL) championship trophies’ geographical center could lie. Using Cartesian coordinates for each champion’s city, I mapped the location for each league. The corresponding code and plots are shown below.

Load Packages

library(rvest) 
library(tidyverse)
library(ggmap) 
library(DT)
library(leaflet)

Scrape and Clean Data

#scrape NFL table
nfl <- read_html("http://www.espn.com/nfl/superbowl/history/winners") %>%
  html_node("table") %>%
  html_table()

#remove top two header rows
nfl <- nfl[-c(1:2),]

#remove losing teams
nfl <- nfl %>%
  separate(X4, into = "Winner", sep = ",")

#remove winning team score
nfl$Winner <- gsub('[[:digit:]]+', '', nfl[,"Winner"])

#create vector of team names in column
teams <- c("Jets", "Giants", "Steelers", "Saints", "Packers", "Ravens", "Seahawks", "Patriots", "Broncos", "Eagles")

#remove team names from column and replace ambiguous city names
nfl$Winner <- gsub(paste0(teams,collapse = "|"),"", nfl$Winner) %>%
  trimws("right") %>%
  recode("New York" = "New York, NY", "New England" = "Boston", "Washington" = "Washington, D.C.")

#optain latitude and longitude
nfl_locations <- geocode(nfl$Winner)
nfl <- bind_cols(nfl, nfl_locations)

#scrape NBA data
nba <- read_html("https://simple.wikipedia.org/wiki/List_of_NBA_champions") %>%
  html_node("table") %>%
  html_table()

#clean data
nba <- nba[,1:2] %>%
  rename(winner = `Winning team`) %>%
  separate(winner, into = "Winner", sep = " ")

#replace ambiguous city names
nba$Winner <- recode(nba$Winner,"St." = "St. Louis", "New" = "New York, NY", "Los" = "Los Angeles",   "Golden" = "Oakland", "San" = "San Antonio", "Washington" = "Washington, D.C.")

#optain latitude and longitude
nba_locations <- geocode(nba$Winner)
nba <- bind_cols(nba, nba_locations)

#scrape MLB data
mlb <- read_html("http://www.espn.com/mlb/worldseries/history/winners") %>%
  html_node("table") %>%
  html_table()

#remove, sort, and seperate rows
mlb <- mlb[-c(1:2),] %>%
  separate(X2, into = "Winner", sep = " ") %>%
  arrange(-row_number())

#replace ambiguous city names
mlb$Winner <- recode(mlb$Winner, "St." = "St. Louis", "New" = "New York, NY", "Brooklyn" = "New York, NY", "Los" = "Los Angeles", "Kansas" = "Kansas City", "Florida" = "Miami", "Washington" = "Washington, D.C.", "Arizona" = "Phoenix", "San" = "San Francisco")

#optain latitude and longitude
mlb_locations <- geocode(mlb$Winner)
mlb <- bind_cols(mlb, mlb_locations)

Calculate Center of Gravity

#create function to find average point
find_center <- function(df){
  
df2 <- df %>%
  mutate(rad_lon = df[,"lon"]*pi/180, rad_lat = df[,"lat"]*pi/180) %>% 
  mutate(X = cos(rad_lat) * cos(rad_lon)) %>%
  mutate(Y = cos(rad_lat) * sin(rad_lon)) %>%
  mutate(Z = sin(rad_lat)) %>%
  summarise(X = mean(X), Y = mean(Y), Z = mean(Z)) %>% #find mean
  mutate(Lon = atan2(Y,X), Hyp = sqrt(X*X+Y*Y), Lat = atan2(Z, Hyp)) %>%  
  select(Lon, Lat) %>%
  mutate(Lon = Lon*180/pi, Lat = Lat*180/pi)

return(df2)
}

#locate center of gravity for each league
nfl_center <- find_center(nfl)
nba_center <- find_center(nba)
mlb_center <- find_center(mlb)

#find center of gravity after each year
for (i in 1:nrow(nfl)) {
                    nfl$lon_center[i] <- find_center(nfl[1:i,])[[1]]
                    nfl$lat_center[i] <- find_center(nfl[1:i,])[[2]]
}


for (i in 1:nrow(nba)) {
                    nba$lon_center[i] <- find_center(nba[1:i,])[[1]]
                    nba$lat_center[i] <- find_center(nba[1:i,])[[2]]
  }

for (i in 1:nrow(mlb)) {
                    mlb$lon_center[i] <- find_center(mlb[1:i,])[[1]]
                    mlb$lat_center[i] <- find_center(mlb[1:i,])[[2]]
}

The NBA and MLB seem to be trending westward while the NFL looks to be boomeranging back east of the Mississippi. With the Yankees’ 27 championships (not to mention the NY Giants 5 titles plus the Mets 2 in addition to the Brooklyn Dodgers’ lone Series win) it’s no surprise that the MLB’s center of gravity is the furthest east. The Boston Celtic’s ’60s dynasty seems to have left its mark on the Larry O’Brien trophy, carrying the midpoint to upstate New York before ultimately trickling down through Illinois. Use the map below to toggle between leagues and a see which cities have won the most hardware.

Total Titles by City

nfl_total <- nfl %>%
  group_by(Winner) %>%
  select(Winner, lon, lat) %>%
  add_tally()

mlb_total <- mlb %>%
  group_by(Winner) %>%
  select(Winner, lon, lat) %>%
  add_tally()

nba_total <- nba %>%
  group_by(Winner) %>%
  select(Winner, lon, lat) %>%
  add_tally()

References

D. Kahle and H. Wickham. ggmap: Spatial Visualization with ggplot2. The R Journal, 5(1), 144-161. URL http://journal.r-project.org/archive/2013-1/kahle-wickham.pdf

Spotify AnalYEsis

Thu, 30 Aug 2018 00:00:00 +0000

As the Internet of Things (IoT) landscape continues to grow, practically everyone and everything, it seems, is compiling data or at least generating statistics for any variable imaginable. And music is no exception. The music streaming service, Spotify, stores an array of features for each song in its library. They record characteristics such as acousticness, danceability, energy and more. With these variables in mind, I conducted some exploratory analysis along with a couple clustering methods on Kanye West’s Spotify discography. The following report utilizes Spotify’s Web API through Charlie Thompson’s spotifyr package which you can check out here.

Exploratory Data Analysis

Load Packages

The following code and plots make use of these packages:

library(spotifyr)
library(tidyverse)
library(knitr)
library(kableExtra)
library(ggridges)
library(plotly)
library(scales)
library(ggfortify)
library(ggdendro)
library(dendextend)

Import Data

First let’s import the audio features for Kanye West and take a quick look at the data.

kanye <- get_artist_audio_features(artist = "kanye west")

After viewing the data, I noticed a few tracks (rows) are duplicated since some albums contain edited, clean, and/or live versions. Those rows will be removed in addition to some irrelevant columns. Also let’s be sure we don’t have any missing values.

kanye2 <- kanye %>%
  filter(!(album_name %in% c("808s & Heartbreak (Softpak)", "Late Orchestration", 
                             "The College Dropout (Edited)", 
                             "Graduation (Alternative Business Partners)"))) %>%
    select(-c(artist_uri, album_uri, album_type, is_collaboration, track_uri,
            track_preview_url, album_release_year, artist_name, album_img, 
            album_release_date, track_open_spotify_url, track_number,
            disc_number, key, mode, key_mode, album_popularity, time_signature))

sum(is.na(kanye2))

## [1] 0

The dataset we will be working with now has 125 rows and 13 columns with no missing observations!

###Danceability Spotify defines danceability as

“How suitable a track is for dancing based on a combination of musical elements including tempo, rhythm stability, beat strength, and overall regularity. A value of 0.0 is least danceable and 1.0 is most danceable.”

Before determining which album Spotify deems the most danceable, let’s take a look at how danceability is distributed on each album.

The dashed vertical line in the middle represents the midpoint on the danceability scale. Also, the smaller tick marks at the bottom of each shape represent one song on an album. Each album appears to be more danceable than not, but let’s weight each song by its duration to get a better picture of each album in its entirety. The following graph outlines the results.

kanye_dance <- kanye2 %>%
  mutate(total_dance = danceability*duration_ms) %>%
  group_by(album_name) %>%
  summarise(avg_danceability = sum(total_dance)/length(album_name)/10000)

Overall, My Beautiful Dark Twisted Fantasy and 808s & Heartbreak represent Kanye’s most danceable albums. The following table lists his top 10 most danceable songs.

kanye_dance_songs <- kanye2 %>%
  arrange(desc(danceability)) %>%
  select(album_name, track_name, danceability)

kable(head(kanye_dance_songs, 10)) %>%
    kable_styling(full_width = F)

album_name	track_name	danceability
ye	All Mine	0.925
Late Registration	Gone	0.851
KIDS SEE GHOSTS	Kids See Ghosts	0.841
The Life Of Pablo	Feedback	0.837
The Life Of Pablo	30 Hours	0.822
808s & Heartbreak	Paranoid	0.812
808s & Heartbreak	Heartless	0.789
Yeezus	Black Skinhead	0.775
The Life Of Pablo	Facts (Charlie Heat Version)	0.769
KIDS SEE GHOSTS	4th Dimension	0.765

Valence

Spotify defines Valence as

“A measure from 0.0 to 1.0 describing the musical positiveness conveyed by a track. Tracks with high valence sound more positive (e.g. happy, cheerful, euphoric), while tracks with low valence sound more negative (e.g. sad, depressed, angry)”"

Again, let’s look at the overall distribution for each album, but for valence this time.

Perhaps a bit more polarizing than the danceability metric, most albums seem to have their fair share of both positive and negative sounding songs. Now weighting valence by song duration, let’s discover Kanye’s happiest (and saddest) album.

kanye_val <- kanye2 %>%
  mutate(total_valence = valence*duration_ms) %>%
  group_by(album_name) %>%
  summarise(avg_valence = sum(total_valence/length(album_name)/10000))

With a valence score of 14.68, the happiest Kanye release came way back in 2004 with his debut hit The College Dropout. Interestingly, the four albums with the lowest valence score also make up his most recent work. The tracks with the lowest valence scores are shown below.

kanye_valence_songs <- kanye2 %>%
  select(album_name, track_name, valence) %>%
  arrange(valence)

kable(head(kanye_valence_songs,10)) %>%
    kable_styling(full_width = F)

album_name	track_name	valence
The Life Of Pablo	Frank’s Track	0.0000
Yeezus	Hold My Liquor	0.0399
ye	Violent Crimes	0.0400
The Life Of Pablo	Waves	0.0565
808s & Heartbreak	Welcome To Heartbreak	0.0734
Graduation	Can’t Tell Me Nothing	0.0963
My Beautiful Dark Twisted Fantasy	Monster	0.0964
Graduation	I Wonder	0.1060
My Beautiful Dark Twisted Fantasy	Runaway	0.1090
The Life Of Pablo	Wolves	0.1180

Other Variables

Interested in exploring the rest of the variables? Choose which characteristics to plot and select which albums to compare using the interactive graph below!

Clustering

Hierarchical Clustering

Now on to some clustering methods. Let’s determine which albums sound the most alike using hierarchical clustering. A tree with a height of 4 and complete linkage is shown below.

kanye3 <- kanye2 %>%
  select(-c(track_name, track_popularity)) %>%
  group_by(album_name) %>%
  summarise(dance = sum(danceability*duration_ms)/length(album_name),
            energy = sum(energy*duration_ms)/length(album_name),
            loudness = sum(loudness*duration_ms)/length(album_name),
            speechiness = sum(speechiness*duration_ms)/length(album_name),
            acousticness = sum(acousticness*duration_ms)/length(album_name),
            instrumentalness = sum(instrumentalness*duration_ms)/length(album_name),
            liveness = sum(liveness*duration_ms)/length(album_name),
            valence = sum(valence*duration_ms)/length(album_name),
            tempo = sum(tempo*duration_ms)/length(album_name)) %>%
  remove_rownames() %>%
  column_to_rownames("album_name")

kanye.hc <- hclust(dist(scale(kanye3)), method = "complete")
kanye.tree <- dendro_data(kanye.hc, type = "rectangle")
kanye.hc.4 <- cutree(kanye.hc, k = 4)

Kanye’s first three releases belong to one cluster while his last four belong to another. The middle releases, 808s & Heartbreak and Twisted Fantasy, are not only his most danceable records but his most unique sounding as well; they each populate their own cluster.

Principle Component Analysis

Now let’s use those variables and see if we can discover if his more popular songs score similarly for each variable. Using a PCA to reduce dimensionality and account for correlation we can try to reveal any patterns.

kanye_pca <- prcomp(kanye2[,3:11], center = T, scale = T)
summary(kanye_pca)

## Importance of components:
##                           PC1    PC2    PC3    PC4    PC5     PC6     PC7
## Standard deviation     1.5958 1.2793 1.0779 0.9988 0.9512 0.84785 0.69853
## Proportion of Variance 0.2829 0.1819 0.1291 0.1108 0.1005 0.07987 0.05422
## Cumulative Proportion  0.2829 0.4648 0.5939 0.7047 0.8053 0.88513 0.93934
##                            PC8     PC9
## Standard deviation     0.62701 0.39085
## Proportion of Variance 0.04368 0.01697
## Cumulative Proportion  0.98303 1.00000

Using two principle components we can describe a little over 46% of the variability in the data (shown in the plot below). To explain at least 90% of the variability, we need to use 7 principle components. The following graph shows the top two principle components with the top quartile of his most popular songs mapped to one color and the rest to another.

The most popular songs don’t appear to belong to any specific area or cluster on the graph, but it does look like Energy and Loudness are correlated. Try graphing them using the interactive plot above!

About

Mon, 01 Jan 0001 00:00:00 +0000

Purpose

The purpose of creating this website was to generate a space to not only share my independent analytical work but to also serve as a portfolio of sorts. Each post will center around dissecting a dataset and revealing any underlying information. I’ll try to keep it fresh and analyze a variety of topics, but ultimately, I’ll explore whatever I find most interesting (so expect a few sports-related posts). My goal is to publish at least a couple of times a month so feel free to contact me about anything! (suggestions, what you liked, didn’t like, etc.)

A Proud Contributer to R-Bloggers and R Weekly

Contact

Mon, 01 Jan 0001 00:00:00 +0000

Have a question or suggestion? Fill out the form below!

Thank You

Mon, 01 Jan 0001 00:00:00 +0000

#I will get back to you soon!