Final project
Chin-yu
2023-12-04
library(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.2 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ ggplot2 3.4.3 ✔ tibble 3.2.1
## ✔ lubridate 1.9.2 ✔ tidyr 1.3.0
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorslibrary(ggplot2)
library(dbplyr)##
## Attaching package: 'dbplyr'
##
## The following objects are masked from 'package:dplyr':
##
## ident, sqllibrary(ggthemes)
library(ggrepel)
week3_dataset <- read.csv("baseball.csv",header = TRUE)Slide 3
Graph left
I used the group by function to group every years average batting AVG and then graph it.
avg_by_year <- week3_dataset %>%
group_by(Year)%>%
summarise(avg=mean(BA))
ggplot(avg_by_year)+
geom_line(mapping=aes(x=Year,y=avg))+
theme_minimal()
Graph right
I used the group by function to group every years number of team and then graph it.
total_teams_year <- week3_dataset %>%
group_by(Year)%>%
summarise(teams=n())
ggplot(total_teams_year)+
geom_line(mapping=aes(x=Year,y=teams))+
theme_minimal()
Slide 4
This slide is about finding out outlines in the win percentage column.
label = c("Bad", "Below AVG", "AVG", "Above AVG", "Good")
winning_percentage <- week3_dataset %>%
mutate(win_percentage = W/G)%>%
mutate(Grade = cut_number(win_percentage, n=length(label),
labels = label))%>%
select(Team, League, Year, W, win_percentage, Grade, OBP)
percentiles <- c(quantile(winning_percentage$win_percentage, 0.01),
quantile(winning_percentage$win_percentage, 0.99))
winning_percentage %>%
ggplot()+
geom_jitter(mapping = aes(x = win_percentage, y = ""),
width = 0, height = 0.3)+
geom_vline(mapping = aes(xintercept = percentiles["1%"],
color = "2% percentile"))+
geom_vline(mapping = aes(xintercept = percentiles["99%"],
color = "98% percentiles"))+
geom_text_repel(data = filter(winning_percentage, win_percentage< 0.3),
mapping = aes(x = win_percentage, y = "", label = Team),
color = "darkred")+
geom_text_repel(data = filter(winning_percentage, win_percentage> 0.7),
mapping = aes(x = win_percentage, y = "", label = Team),
color = "darkred")+
theme_hc()
Slide 5
This is slide compares the regression model between RS & BA and RS & OBP. Base on the R-square we can see that OBP is more effective to RS. This is the staple of money ball theory. The theory is about pursuing higher OBP then BA. This theory started being used by MLB team in the 2000 and was most popular at mid 2000, so we can see in the graph that in slide 1 that team’s BA has dropped significantly because teams realized that OBP is more relevant to RS compares to BA.
Graph left
model1 <- lm(RS ~ BA, data = week3_dataset)
summary(model1)##
## Call:
## lm(formula = RS ~ BA, data = week3_dataset)
##
## Residuals:
## Min 1Q Median 3Q Max
## -158.429 -36.057 -1.064 35.018 179.518
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -805.51 29.51 -27.30 <2e-16 ***
## BA 5864.84 113.68 51.59 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 51.48 on 1230 degrees of freedom
## Multiple R-squared: 0.6839, Adjusted R-squared: 0.6837
## F-statistic: 2662 on 1 and 1230 DF, p-value: < 2.2e-16week3_dataset %>%
ggplot(mapping = aes(x = BA, y = RS))+
geom_point()+
geom_smooth(se = FALSE)+
theme_minimal()## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'
Graph right
model1 <- lm(RS ~ OBP, data = week3_dataset)
summary(model1)##
## Call:
## lm(formula = RS ~ OBP, data = week3_dataset)
##
## Residuals:
## Min 1Q Median 3Q Max
## -122.129 -27.110 1.284 26.441 135.265
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1076.6 24.7 -43.59 <2e-16 ***
## OBP 5490.4 75.6 72.62 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 39.82 on 1230 degrees of freedom
## Multiple R-squared: 0.8109, Adjusted R-squared: 0.8107
## F-statistic: 5274 on 1 and 1230 DF, p-value: < 2.2e-16week3_dataset %>%
ggplot(mapping = aes(x = OBP, y = RS))+
geom_point()+
geom_smooth(se = FALSE)+
theme_minimal()## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'
Slide 6
In this slide I used logistic regression model to find out what is the W needed to have a 50% chance of advancing to the playoffs. This is really interesting since the result is around 92 games, but when I calculate the average win of a team advancing to the playoffs is 95.
model2 <- lm(RS ~ OBP + SLG, data = week3_dataset)
summary(model2)##
## Call:
## lm(formula = RS ~ OBP + SLG, data = week3_dataset)
##
## Residuals:
## Min 1Q Median 3Q Max
## -78.365 -16.821 -1.208 16.477 92.684
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -811.66 16.75 -48.47 <2e-16 ***
## OBP 2830.70 77.94 36.32 <2e-16 ***
## SLG 1517.58 35.17 43.15 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 25.12 on 1229 degrees of freedom
## Multiple R-squared: 0.9248, Adjusted R-squared: 0.9247
## F-statistic: 7557 on 2 and 1229 DF, p-value: < 2.2e-16sigmoid <- \(x) 1 / (1 + exp(-(-34.206 + 0.372 * x)))
week3_dataset %>%
ggplot(mapping = aes(x = W, y = Playoffs)) +
geom_jitter(width = 0, height = 0.1, size = 2) +
geom_function(fun = sigmoid, color = 'blue', linewidth = 1)+
labs(title = "Modeling a Binary Response with Playsoff teams and Wins") +
scale_y_continuous(breaks = c(0, 1)) +
theme_minimal()
Wins based on logistic model
w = 34.206/0.372
w## [1] 91.95161Wins based on average
avg_w <- week3_dataset %>%
group_by(Playoffs) %>%
summarise(Wins = mean(W))
avg_w## # A tibble: 2 × 2
## Playoffs Wins
## <int> <dbl>
## 1 0 77.4
## 2 1 95.1