Creating QC+ Part 4 - Metric Validation

Lastly, in this notebook I show the performance of my new QC+ metric. Again following Baseball Prospectus, in “Prospectus Feature: OPS and wOBA, Briefly Revisited” Jonathan Judge lays out the way the crew at BP goes about validating metrics. He breaks it down into three contribution measures:

• Descriptive Performance: the correlation between the metric and same-year team runs/PA;
• Reliability Performance: the correlation between the metric and itself in the following year; and
• Predictive Performance: the correlation between the metric and the following year’s runs/PA.

In another article, “The Performance Case for DRC+,” Judge says the order of importance for those three is: reliability, predictiveness, and descriptiveness.

In order to compute the reliability performance I found each batter with more than 250 batted balls in back to back seasons (’15 & ’16, ’16 & ’17, ’17 & ’18, and ’18 & ’19). I then calculated each batter’s average QC+ in each season and found the correlation between the two. I ended up with four correlations (’15 with ’16, ’16 with ’17, ’17 with ’18, and ’18 with ’19) and found the mean of those four correlations. The result was an estimated reliability performance of 0.695. Comparatively, I found the reliability correlation of wOBAcon to be 0.628. So, it’s doing a better job than a measured metric. Not bad.

Next, for predictive and descriptive peformance I had to first calculate each team’s runs/PA for the 2015-2020 seasons. I then found each team’s average QC+ for the 2015-2019 seasons. For predictiveness, I found the correlation with year1’s QC+ and year2’s runs/PA (i.e., QC+ in 2015 with runs/PA in 2016). I had some far ranging values, from .239 all the way up to .651, so that was pretty interesting. Overall, the average correlation was .439.

For descriptiveness, I calculated the corelation with each team’s average QC+ and runs/PA for each season. It stuck out to me that the correlation started low at .593 in 2015, but, for the most part, kept increasing until 2019 where the correlation was .827. In total, the average correlation was .703.

• Average reliability performance for QC+: 0.6950
• Average predictive peformance for QC+: 0.4368
• Average descriptive peformance for QC+: 0.7032

Overall, I’m pretty happy with the performance of this metric. While it doesn’t compare to metrics such as DRC+ or Connor Kurcon’s TrueHit, that wasn’t the goal of this project. Making a metric from stratch was incredibly fun and a great learning experience. As I keep learning, I hope to make the metric stronger. If you made it this far, thanks for following along.

I’d like to thank Andrew Perpetua, Harry Pavlidis, and Jonathan Judge for guidance at various stages of this project.

Reliability Performance

group.2015 <- batted_ball_results_2015 %>%
  group_by(player_name) %>%
  summarise(BBE_2015 = n(),
            avg_qcp_2015 = mean(qcp),
            woba_con_2015 = mean(woba_value / woba_denom, na.rm=T)) %>%
  filter(BBE_2015 > 250)

group.2016 <- batted_ball_results_2016 %>%
  group_by(player_name) %>%
  summarise(BBE_2016 = n(),
            avg_qcp_2016 = mean(qcp),
            woba_con_2016 = mean(woba_value / woba_denom, na.rm=T)) %>%
  filter(BBE_2016 > 250)

group.2017 <- batted_ball_results_2017 %>%
  group_by(player_name) %>%
  summarise(BBE_2017 = n(),
            avg_qcp_2017 = mean(qcp),
            woba_con_2017 = mean(woba_value / woba_denom, na.rm=T)) %>%
  filter(BBE_2017 > 250)

group.2018 <- batted_ball_results_2018 %>%
  group_by(player_name) %>%
  summarise(BBE_2018 = n(),
            avg_qcp_2018 = mean(qcp),
            woba_con_2018 = mean(woba_value / woba_denom, na.rm=T)) %>%
  filter(BBE_2018 > 250)

group.2019 <- batted_ball_results_2019 %>%
  group_by(player_name) %>%
  summarise(BBE_2019 = n(),
            avg_qcp_2019 = mean(qcp),
            woba_con_2019 = mean(woba_value / woba_denom, na.rm=T)) %>%
  filter(BBE_2019 > 250)

# 2015-2016
joined_15_16 <- left_join(group.2015, group.2016, by = "player_name") %>%
  filter(player_name %in% group.2015$player_name & player_name %in% group.2016$player_name)

cor(joined_15_16$avg_qcp_2015, joined_15_16$avg_qcp_2016) # n > 250 = 0.7783435 ##########################################
summary(lm(avg_qcp_2016 ~ avg_qcp_2015, data = joined_15_16)) # n > 250 =  0.6058
#cor this season qcp with next wobacon
cor(joined_15_16$avg_qcp_2015, joined_15_16$woba_con_2016) # n > 250 =  0.7238685
summary(lm(woba_con_2016 ~ avg_qcp_2015, data = joined_15_16)) # n > 250, R^2 = 0.524

# 2016-2017
joined_16_17 <- left_join(group.2016, group.2017, by = "player_name") %>%
  filter(player_name %in% group.2016$player_name & player_name %in% group.2017$player_name)

cor(joined_16_17$avg_qcp_2016, joined_16_17$avg_qcp_2017) # n > 250 = 0.5735659 ##########################################
summary(lm(avg_qcp_2017 ~ avg_qcp_2016, data = joined_16_17)) # n > 250 =  0.329
#cor this season qcp with next wobacon
cor(joined_16_17$avg_qcp_2016, joined_16_17$woba_con_2017) # n > 250 =  0.455185
summary(lm(woba_con_2017 ~ avg_qcp_2016, data = joined_16_17)) # n > 250, R^2 = 0.2072

# 2017-2018
joined_17_18 <- left_join(group.2017, group.2018, by = "player_name") %>%
  filter(player_name %in% group.2017$player_name & player_name %in% group.2018$player_name)

cor(joined_17_18$avg_qcp_2017, joined_17_18$avg_qcp_2018) # n > 250 = 0.7253101 ##########################################
summary(lm(avg_qcp_2018 ~ avg_qcp_2017, data = joined_17_18)) # n > 250 =  0.5261
#cor this season qcp with next wobacon
cor(joined_17_18$avg_qcp_2017, joined_17_18$woba_con_2018) # n > 250 =  0.6887269
summary(lm(woba_con_2018 ~ avg_qcp_2017, data = joined_17_18)) # n > 250, R^2 = 0.4743

# 2018-2019
joined_18_19 <- left_join(group.2018, group.2019, by = "player_name") %>%
  filter(player_name %in% group.2018$player_name & player_name %in% group.2019$player_name)

cor(joined_18_19$avg_qcp_2018, joined_18_19$avg_qcp_2019) # n > 250 = 0.7026071 ##########################################
summary(lm(avg_qcp_2019 ~ avg_qcp_2018, data = joined_18_19)) # n > 250 =  0.4937
#cor this season qcp with next wobacon
cor(joined_18_19$avg_qcp_2018, joined_18_19$woba_con_2019) # n > 250 =  0.6328501
summary(lm(woba_con_2019 ~ avg_qcp_2018, data = joined_18_19)) # n > 250, R^2 = 0.4005

avg_rel_perf <- mean(c(cor(joined_15_16$avg_qcp_2015, joined_15_16$avg_qcp_2016), cor(joined_16_17$avg_qcp_2016, joined_16_17$avg_qcp_2017), 
                       cor(joined_17_18$avg_qcp_2017, joined_17_18$avg_qcp_2018), cor(joined_18_19$avg_qcp_2018, joined_18_19$avg_qcp_2019)))
avg_rel_perf #0.6949567


avg_rel_wobacon <- mean(c(cor(joined_15_16$woba_con_2015, joined_15_16$woba_con_2016), cor(joined_16_17$woba_con_2016, joined_16_17$woba_con_2017), 
                       cor(joined_17_18$woba_con_2017, joined_17_18$woba_con_2018), cor(joined_18_19$woba_con_2018, joined_18_19$woba_con_2019)))
avg_rel_wobacon # 0.6284415

Calculating runs/PA for each team 2015-2020.

teams_scoring_2 <- read_csv("teams_scoring_2.csv")

qcp_2015 <- batted_ball_results_2015 %>%
  group_by(batter_team) %>%
  summarise(bbe_2015 = n(),
            qcp_2015 = mean(qcp))

qcp_2016 <- batted_ball_results_2016 %>%
  group_by(batter_team) %>%
  summarise(bbe_2016 = n(),
            qcp_2016 = mean(qcp))

qcp_2017 <- batted_ball_results_2017 %>%
  group_by(batter_team) %>%
  summarise(bbe_2017 = n(),
            qcp_2017 = mean(qcp))

qcp_2018 <- batted_ball_results_2018 %>%
  group_by(batter_team) %>%
  summarise(bbe_2018 = n(),
            qcp_2018 = mean(qcp))

qcp_2019 <- batted_ball_results_2019 %>%
  group_by(batter_team) %>%
  summarise(bbe_2019 = n(),
            qcp_2019 = mean(qcp))

qcp_all <- left_join(qcp_2015, qcp_2016, by = "batter_team") %>%
  left_join(., qcp_2017, by = "batter_team") %>%
  left_join(., qcp_2018, by = "batter_team") %>%
  left_join(., qcp_2019, by = "batter_team")

qcp_and_scoring <- left_join(x = qcp_all, y = teams_scoring_2, by = c("batter_team" = "Team"))

qcp_and_scoring %<>%
  mutate(total_pa = G * PA,
         total_r = G * R,
         runs_per_pa = total_r / total_pa)

Predictive Performance

### 2015 qcp to 2016 runs/pa
pred_15_16 <- qcp_and_scoring %>%
  filter(Year == 2016) %$%
  cor(runs_per_pa, qcp_2015) # 0.6096966

### 2016 qcp to 2017 runs/pa
pred_16_17 <- qcp_and_scoring %>%
  filter(Year == 2017) %$%
  cor(runs_per_pa, qcp_2016) #0.3272711

### 2017 qcp to 2018 runs/pa
pred_17_18 <- qcp_and_scoring %>%
  filter(Year == 2018) %$%
  cor(runs_per_pa, qcp_2017) #  0.2390079

### 2018 qcp to 2019 runs/pa
pred_18_19 <- qcp_and_scoring %>%
  filter(Year == 2019) %$%
  cor(runs_per_pa, qcp_2018) #  0.6513941

### 2019 qcp to 2020 runs/pa
pred_19_20 <- qcp_and_scoring %>%
  filter(Year == 2020) %$%
  cor(runs_per_pa, qcp_2019) #  0.3568525

avg_pred_perf <- mean(c(pred_15_16, pred_16_17, pred_17_18, pred_18_19, pred_19_20))
avg_pred_perf #0.4368444

Descriptive Performance

### 2015
des_2015 <- qcp_and_scoring %>%
  filter(Year == 2015) %$%
  cor(runs_per_pa, qcp_2015) # 0.5933172

### 2016
des_2016 <- qcp_and_scoring %>%
  filter(Year == 2016) %$%
  cor(runs_per_pa, qcp_2016) #0.6646133

### 2017
des_2017 <- qcp_and_scoring %>%
  filter(Year == 2017) %$%
  cor(runs_per_pa, qcp_2017) #  0.659218

### 2018
des_2018 <- qcp_and_scoring %>%
  filter(Year == 2018) %$%
  cor(runs_per_pa, qcp_2018) #  0.7716518

### 2019
des_2019 <- qcp_and_scoring %>%
  filter(Year == 2019) %$%
  cor(runs_per_pa, qcp_2019) # 0.8270482

avg_des_perf <- mean(c(des_2015, des_2016, des_2017, des_2018, des_2019))
avg_des_perf #0.7031697