options(scipen=999)
library(socviz) # use for the round_df() function
load("NBA_viz.RData")LAB 6 MAKE A MODEL
Partition 60% Train / 40% Test
library(caret)
set.seed(1)
index <- createDataPartition(NBA_viz$GP, p=0.6, list=FALSE)
train <- NBA_viz[index, c("AGE", "W", "MIN", "PTS", "FGM", "TEAM", "GP")]
test <- NBA_viz[-index, c("AGE", "W", "MIN", "PTS", "FGM", "TEAM", "GP")]EDA
Descriptive Statistics
library(psych)
library(tidyverse)
library(flextable)
psych::describe(train[, -ncol(train)], fast = TRUE) vars n mean sd min max range se
AGE 1 319 26.16 4.27 19 39.0 20.0 0.24
W 2 319 25.46 16.08 0 60.0 60.0 0.90
MIN 3 319 1098.37 814.22 1 2848.0 2847.0 45.59
PTS 4 319 19.39 6.42 0 42.8 42.8 0.36
FGM 5 319 7.27 2.48 0 17.1 17.1 0.14
TEAM 6 319 NaN NA Inf -Inf -Inf NABoxplots – All Numeric
library(dplyr)
library(tidyr)
library(ggplot2)
data_long <- train %>%
select(where(is.numeric)) %>%
pivot_longer(cols = everything(), names_to = "Variable", values_to = "Value")
# Creating a horizontal boxplot for each numeric variable
ggplot(data_long, aes(x = Variable, y = Value)) +
geom_boxplot() +
coord_flip() +
facet_wrap(~ Variable, scales = "free", ncol = 3) +
theme_minimal() +
theme(axis.text.x = element_blank()) +
labs(title = "Horizontal Boxplot for Each Numeric Variable")
The code generates a faceted plot with multiple horizontal boxplots, one for each numeric variable in the original dataset. The boxplots are arranged in a grid with three columns, and each panel displays the distribution of values for a specific numeric variable. This visualization allows for a compact and efficient comparison of the ranges, medians, and potential outliers across all numeric features simultaneously, making it easy to identify variables with similar or divergent distributions at a glance.
library(DataExplorer)
plot_boxplot(train, by="TEAM") 
Histograms
plot_histogram(train)
Scatterplots (depvar ~ all x)
plot_scatterplot(test, by="GP")
Correlation Matrix
plot_correlation(train, type="continuous")
MODEL
Linear Regression Model
Estimate the following model:
\(log(GP) = AGE + W + MIN + PTS + FGM\)
Estimate Coefficients and show coefficients table
model <- lm(log(GP) ~ AGE + W + MIN + PTS + FGM, data=train)
model %>% as_flextableEstimate | Standard Error | t value | Pr(>|t|) | ||
|---|---|---|---|---|---|
(Intercept) | 2.253 | 0.231 | 9.737 | 0.0000 | *** |
AGE | 0.002 | 0.008 | 0.226 | 0.8217 |
|
W | 0.030 | 0.003 | 9.025 | 0.0000 | *** |
MIN | 0.000 | 0.000 | 6.361 | 0.0000 | *** |
PTS | 0.009 | 0.019 | 0.483 | 0.6293 |
|
FGM | -0.016 | 0.049 | -0.322 | 0.7476 |
|
Signif. codes: 0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05 | |||||
Residual standard error: 0.59 on 313 degrees of freedom | |||||
Multiple R-squared: 0.6496, Adjusted R-squared: 0.644 | |||||
F-statistic: 116.1 on 313 and 5 DF, p-value: 0.0000 | |||||
The linear regression model analyzes the relationship between the log of a performance metric (GP) and several independent variables (AGE, W, MIN, PTS, FGM). The coefficient estimates indicate the change in log(GP) associated with a one-unit increase in each predictor variable, while the p-values assess the statistical significance of each variable’s contribution. The model’s overall fit is evaluated through the R-squared, adjusted R-squared, F-statistic, and corresponding p-value. This concise output summarizes the predictive power of the independent variables and the quality of the model’s fit, enabling insights into the factors influencing the dependent variable.
Coefficient Magnitude Plot
# note this simple code using coefplot package produces chart like Figure 6.6 in one short line.
library(coefplot)
coefplot(model, soft="magnitude", intercept=FALSE)
Check for predictor independence
Using Variance Inflation Factors (VIF)
library(car)
vif(model) AGE W MIN PTS FGM
1.042462 2.570092 2.875727 13.825569 13.286659 Residual Analysis
Residual Range
quantile(round(residuals(model, type = "deviance"),2)) 0% 25% 50% 75% 100%
-2.470 -0.275 0.130 0.385 1.000 Residual Plots
We are looking for: - Random distribution of residuals vs fitted values - Normally distributed residuals : Normal Q-Q plot with values along line - Homoskedasticity with a Scale-Location line that is horizontal and no residual pattern - Minimal influential obs - that is, those outside the borders of Cook’s distance
plot(model)
Plot Wins (W) by Actual Value
library(broom)
train2 <- augment(model, data=train)
p <- ggplot(train2, mapping = aes(y=W, x=GP))
p + geom_point()
Plot Minutes Played (MIN) by Wins (W) Values
p <- ggplot(train2, mapping = aes(y=MIN, x=W))
p + geom_point()
Performance Evaluation
Use Model to Score test dataset (Display First 10 values - depvar and fitted values only)
pred <- predict(model, newdata = test, interval="predict")
test_w_predict <- cbind(test, pred)
test_w_predict %>%
head(10) %>%
select(TEAM, GP, W, MIN, PTS) %>%
as_flextable(show_coltype = FALSE) TEAM | GP | W | MIN | PTS |
|---|---|---|---|---|
BKN | 5 | 1 | 26 | 33.8 |
SAC | 64 | 19 | 1,375 | 19.6 |
ATL | 21 | 7 | 305 | 16.8 |
IND | 14 | 9 | 64 | 9.7 |
BKN | 43 | 19 | 1,133 | 17.5 |
NYK | 64 | 13 | 1,459 | 22.9 |
ORL | 12 | 9 | 68 | 19.0 |
PHI | 51 | 32 | 529 | 18.2 |
NOP | 17 | 6 | 186 | 14.0 |
MIN | 73 | 31 | 2,543 | 24.9 |
n: 10 | ||||
The table presents a sample of 10 rows from the test dataset, showcasing the actual values of various team statistics alongside the model’s predictions. It displays the team names along with their respective games played (GP), wins (W), total minutes (MIN), and points scored (PTS). This sample highlights the diversity in the test data, with teams exhibiting a wide range of values across these predictor variables. By comparing the actual values to the model’s predictions for each team, one can assess the model’s performance in estimating the response variable based on these inputs, providing insights into its generalization ability and predictive accuracy on new, unseen data.
Plot Actual vs W (test)
plot(test_w_predict$GP, test_w_predict$W, pch=16, cex=1)
Performance Metrics
library(Metrics)
metric_label <- c("MAE","RMSE", "MAPE")
metrics <- c(round(mae(test_w_predict$GP, test_w_predict$W),4),
round(rmse(test_w_predict$GP, test_w_predict$W),4),
round(mape(test_w_predict$GP, test_w_predict$W),4))
pmtable <- data.frame(Metric=metric_label, Value = metrics)
flextable(pmtable)Metric | Value |
|---|---|
MAE | 25.6493 |
RMSE | 29.9453 |
MAPE | 0.5360 |
The evaluation metrics calculated on the test data provide a quantitative assessment of the linear regression model’s predictive performance. The MAE of 25.6 indicates an average absolute deviation of around 25 units between predicted and actual values. The RMSE of 29.9 suggests higher penalties for larger errors, while the MAPE of 53.6% expresses the average prediction error as a percentage of the actual values. Together, these metrics offer insights into the model’s accuracy, enabling the interpretation of its suitability and potential for improvement based on the specific requirements and context of the problem.
Model Fit by Continent
# more in depth plots of performance
p <- ggplot(data = subset(test_w_predict, TEAM %in% c("OKC", "ATL")),
aes(x = GP,
y = W, ymin = lwr, ymax = upr,
color = TEAM,
fill = TEAM,
group = TEAM))
p + geom_point(alpha = 0.5) +
geom_line() + geom_ribbon(alpha = 0.2, color = FALSE) +
labs(title="Games Played vs Wins Between Teams",
subtitle="Teams: OKC and ATL",
caption="NBA_viz{datasetsICR}") +
xlab(NULL) + ylab("WINS") +
theme(legend.position = "bottom")
The code generates a scatter plot comparing the relationship between games played (GP) and wins (W) for two specific teams, OKC and ATL, within the test dataset. The plot displays colored and filled points representing the actual data for each team, with a line connecting the points to show the trend of wins over games played. Surrounding each team’s line is a ribbon indicating the prediction interval, providing a visual representation of the model’s prediction variability. The plot title, subtitle, and caption identify the teams and data source, while the y-axis is labeled “WINS” and the legend is positioned at the bottom for clarity. This visualization effectively communicates the performance trends and prediction ranges for the selected teams, enabling direct comparison and interpretation of their results.
ggplot2 explore (Intro Section)
This is just replication of the first section within Chapter 6 (as FYI)
pip <- lm(GP ~ TEAM + AGE + W + MIN + PTS + FGM, data = train)
summary(pip)
Call:
lm(formula = GP ~ TEAM + AGE + W + MIN + PTS + FGM, data = train)
Residuals:
Min 1Q Median 3Q Max
-18.2035 -4.7845 0.1897 4.2787 18.6476
Coefficients:
Estimate Std. Error t value Pr(>|t|)
(Intercept) 16.717965 3.453923 4.840 0.00000213150 ***
TEAMBKN -8.562186 3.437240 -2.491 0.013309 *
TEAMBOS -13.488640 3.028766 -4.454 0.00001215807 ***
TEAMCHA -0.509291 3.126230 -0.163 0.870706
TEAMCHI 3.029003 3.316983 0.913 0.361922
TEAMCLE 1.803410 3.214655 0.561 0.575242
TEAMDAL 1.728002 3.036668 0.569 0.569775
TEAMDEN -18.631972 3.224649 -5.778 0.00000001985 ***
TEAMDET -5.725599 3.096173 -1.849 0.065461 .
TEAMGSW -17.626381 3.410779 -5.168 0.00000044701 ***
TEAMHOU -16.541999 3.088974 -5.355 0.00000017667 ***
TEAMIND -10.368402 3.105740 -3.338 0.000955 ***
TEAMLAC -9.628011 3.074127 -3.132 0.001918 **
TEAMLAL -8.188728 2.976108 -2.751 0.006314 **
TEAMMEM -6.252039 2.972149 -2.104 0.036298 *
TEAMMIA -8.832584 3.133722 -2.819 0.005163 **
TEAMMIL -20.300840 3.066914 -6.619 0.00000000018 ***
TEAMMIN -3.948528 3.121098 -1.265 0.206869
TEAMNOP -2.441627 3.310865 -0.737 0.461452
TEAMNYK 2.718319 3.180726 0.855 0.393481
TEAMOKC -10.946411 3.089251 -3.543 0.000462 ***
TEAMORL -10.883951 3.450917 -3.154 0.001784 **
TEAMPHI -11.789839 3.147586 -3.746 0.000218 ***
TEAMPHX 7.981574 2.903503 2.749 0.006362 **
TEAMPOR -14.117724 2.938392 -4.805 0.00000251508 ***
TEAMSAC -4.047368 3.454053 -1.172 0.242270
TEAMSAS -9.751231 3.107383 -3.138 0.001879 **
TEAMTOR -19.242237 3.132228 -6.143 0.00000000272 ***
TEAMUTA -12.110552 3.003054 -4.033 0.00007089741 ***
TEAMWAS -2.536406 3.030532 -0.837 0.403324
AGE -0.024086 0.100524 -0.240 0.810814
W 1.199421 0.057130 20.995 < 0.0000000000000002 ***
MIN 0.010493 0.001012 10.373 < 0.0000000000000002 ***
PTS -0.327239 0.245318 -1.334 0.183293
FGM 0.756489 0.621064 1.218 0.224215
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Residual standard error: 7.186 on 284 degrees of freedom
Multiple R-squared: 0.9305, Adjusted R-squared: 0.9222
F-statistic: 111.8 on 34 and 284 DF, p-value: < 0.00000000000000022p <- ggplot(data = train, aes(x = GP, y = log(GP)))
p + geom_point(alpha = 0.2) +
geom_smooth(method = "lm", aes(color = "OLS", fill = "OLS"))
p + geom_point(alpha = 0.1) +
geom_smooth(color = "purple", fill = "purple", method = MASS::rlm)
p + geom_point(alpha = 0.1) +
geom_smooth(color = "lightblue", fill = "lightblue", method = "lm",
formula = y ~ splines::bs(x, 3), se = FALSE)
p + geom_point(alpha = 0.1) +
geom_quantile(color = "purple", size = 1.2, method = "rqss",
lambda = 1, quantiles = c(0.20, 0.5, 0.85))
The code explores the relationship between a performance metric GP and its logarithmic transformation using multiple regression techniques. It fits a linear model to predict GP from various predictors, visualizes the scatter plot of GP vs. log(GP), and overlays lines representing different regression methods. These include ordinary least squares, robust regression to handle outliers, spline regression to capture non-linearity, and quantile regression to examine the conditional distribution across percentiles. By applying these analyses and visualizations, the code provides insights into the nature of the relationship, the impact of outliers, potential non-linear patterns, and the distribution of the response variable at different levels of the predictor.
SUMMARY ASSESSMENT AND EVALUATION OF THE MODEL
Based on the various analyses and visualizations presented, we can draw the following general interpretation:
The code begins by fitting a linear regression model to predict a performance metric (GP) using several predictor variables, including team, age, wins, minutes played, points scored, and field goals made. This model provides insights into the significance and impact of each predictor variable on the response variable.
The predictions from this model are then evaluated on a test dataset, and various error metrics (MAE, RMSE, MAPE) are calculated to assess the model’s predictive accuracy. Lower values of these metrics generally indicate better performance and a closer alignment between predicted and actual values.
To further explore the relationship between the response variable (GP) and the predictor variables, the code generates visualizations comparing specific teams’ performance trends. These plots show the actual data points, regression lines, and prediction intervals, allowing for a visual comparison of teams’ win patterns as a function of games played.
Additionally, the code investigates the relationship between the performance metric GP and its logarithmic transformation, log(GP). Several regression techniques, including ordinary least squares, robust regression, spline regression, and quantile regression, are applied to the training data. These analyses help identify potential non-linear patterns, account for the presence of outliers, and examine the conditional distribution of the response variable at different quantiles of the predictor.
By combining these various statistical models, evaluation metrics, and visualizations, the code provides a comprehensive exploration of the factors influencing the performance metric, the model’s predictive capabilities, and the nature of the relationship between the response and predictor variables. These insights can inform decision-making, identify areas for model improvement, and enhance the understanding of the underlying patterns in the data.