Lab 6

NBA Dataset

Author

Gustavo Maida

DATA

options(scipen=999)

library(socviz) # use for the round_df() function

load("NBA_viz.RData")
#load("Catholic_viz.RData")
#load("NBA_viz.RData")
#load("Murders96_viz.RData")

Partition 60% Train / 40% Test

library(caret)
set.seed(1)
index <- createDataPartition(NBA_viz$PTS, p=0.6, list=FALSE)
train <- NBA_viz[index,]
test  <- NBA_viz[-index,]

Training set number of observations: 320
Test dataset number of observations: 210

EDA

Descriptive Statistics

library(psych)
library(tidyverse)
psych::describe(train, fast=TRUE)
        vars   n    mean     sd min    max  range    se
PLAYER     1 320     NaN     NA Inf   -Inf   -Inf    NA
FORWARD    2 320     NaN     NA Inf   -Inf   -Inf    NA
CENTER     3 320     NaN     NA Inf   -Inf   -Inf    NA
GUARD      4 320     NaN     NA Inf   -Inf   -Inf    NA
ROOKIE     5 320     NaN     NA Inf   -Inf   -Inf    NA
TEAM       6 320     NaN     NA Inf   -Inf   -Inf    NA
AGE        7 320   26.33   4.36  19   42.0   23.0  0.24
GP         8 320   50.27  26.45   1   82.0   81.0  1.48
W          9 320   24.58  16.06   0   60.0   60.0  0.90
MIN       10 320 1154.53 842.56   1 3028.0 3027.0 47.10
PTS       11 320   19.70   6.98   0   42.8   42.8  0.39
FGM       12 320    7.36   2.70   0   17.1   17.1  0.15
FGA       13 320   16.63   4.88   0   39.5   39.5  0.27
FTM       14 320    2.94   1.84   0   10.2   10.2  0.10
FTA       15 320    4.01   2.38   0   12.3   12.3  0.13
REB       16 320    8.97   4.73   0   35.7   35.7  0.26
AST       17 320    4.30   2.78   0   17.1   17.1  0.16
TOV       18 320    2.47   1.47   0   12.8   12.8  0.08

Boxplots – All Numeric

data_long <- train %>%
  select(where(is.numeric)) %>%
  pivot_longer(cols = everything(), names_to = "Variable", values_to = "Value")

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")

library(DataExplorer)
plot_boxplot(train, by="ROOKIE")

Histograms

plot_histogram(train)

Scatterplots (depvar ~ all x)

plot_scatterplot(test, by="PTS")

Correlation Matrix

plot_correlation(train, type="continuous")

MODEL

Linear Regression Model

Estimate the following model:
\(log(MIN) = PTS + AGE + W + AST + FGM + FGA + FTM + FTA + GP + REB + TOV\)

Estimate Coefficients and show coefficients table

library(DataExplorer)
library(caret)
library(psych)
library(tidyverse)
library(flextable)
model <- lm(log(MIN) ~ PTS + AGE + W + AST + FGM + FGA + FTM + FTA + GP + REB + TOV, data=train)
model %>% as_flextable

Estimate

Standard Error

t value

Pr(>|t|)

(Intercept)

3.094

0.287

10.765

0.0000

***

PTS

0.074

0.033

2.269

0.0240

*

AGE

0.008

0.009

0.951

0.3425

W

-0.013

0.005

-2.825

0.0050

**

AST

0.030

0.016

1.879

0.0611

.

FGM

-0.146

0.077

-1.896

0.0590

.

FGA

-0.023

0.012

-1.923

0.0554

.

FTM

0.071

0.081

0.874

0.3830

FTA

-0.014

0.056

-0.251

0.8019

GP

0.058

0.003

20.793

0.0000

***

REB

0.019

0.010

1.909

0.0572

.

TOV

0.020

0.030

0.650

0.5161

Signif. codes: 0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05

Residual standard error: 0.6637 on 308 degrees of freedom

Multiple R-squared: 0.8358, Adjusted R-squared: 0.83

F-statistic: 142.5 on 308 and 11 DF, p-value: 0.0000

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)
      PTS       AGE         W       AST       FGM       FGA       FTM       FTA 
37.863623  1.080567  3.818601  1.424933 31.304595  2.548494 16.339764 12.802202 
       GP       REB       TOV 
 3.916739  1.551519  1.437942

Residual Analysis

Residual Range

quantile(round(residuals(model, type = "deviance"),2))
    0%    25%    50%    75%   100% 
-3.400 -0.305  0.010  0.400  1.520

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 Fitted Value by Actual Value

library(broom)
train2 <- augment(model, data=train)  # this appends predicted to original dataset to build plots on your own

p <- ggplot(train2, mapping = aes(y=.fitted, x=MIN))
p  + geom_point()

Plot Residuals by Fitted Values

p <- ggplot(train2, mapping = aes(y=.resid, x=.fitted))
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")  #score test dataset wtih model
test_w_predict <- cbind(test, pred)  # append score to original test dataset

test_w_predict %>%
  head(10) %>%
    select(PLAYER, MIN, fit, lwr,upr) %>% 
  as_flextable(show_coltype = FALSE)

PLAYER

MIN

fit

lwr

upr

Al Horford

1,973

7.2

5.9

8.5

Alex Abrines

588

5.1

3.7

6.4

Alex Poythress

305

4.9

3.6

6.3

Alfonzo McKinnie

1,003

7.1

5.8

8.4

Allen Crabbe

1,133

5.9

4.6

7.3

Amile Jefferson

68

4.6

3.3

6.0

Andre Iguodala

1,578

7.1

5.8

8.5

Andre Ingram

15

3.3

1.9

4.7

Andrew Bogut

134

4.3

3.0

5.7

Anfernee Simons

141

4.6

3.3

6.0

n: 10

Plot Actual vs Fitted (test)

plot(test_w_predict$MIN, test_w_predict$fit, pch=16, cex=1)

Performance Metrics

library(Metrics)
metric_label <- c("MAE","RMSE", "MAPE")
metrics <- c(round(mae(test_w_predict$MIN, test_w_predict$fit),4),
                         round(rmse(test_w_predict$MIN, test_w_predict$fit),4),
                         round(mape(test_w_predict$MIN, test_w_predict$fit),4))
pmtable <- data.frame(Metric=metric_label, Value = metrics)
flextable(pmtable)

Metric

Value

MAE

1,065.2628

RMSE

1,349.7436

MAPE

0.9766

Model Fit by Team

p <- ggplot(data = subset(test_w_predict, TEAM %in% c("BOS", "LAL")),
            aes(x = MIN,
                y = fit, 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="Actual vs Fitted with Upper and Lower CI",
              subtitle="Boston Celtics and Los Angeles Lakers",
              caption="NBA{datasetsICR}") +
       xlab(NULL) + ylab("fitted") +
       theme(legend.position = "bottom")

ggplot2 explore (Intro Section)

pip <- lm(log(MIN) ~ W, data=train)
summary(pip)

Call:
lm(formula = log(MIN) ~ W, data = train)

Residuals:
    Min      1Q  Median      3Q     Max 
-4.5934 -0.5025  0.1177  0.6760  2.1247 

Coefficients:
            Estimate Std. Error t value            Pr(>|t|)    
(Intercept) 4.593426   0.111776   41.09 <0.0000000000000002 ***
W           0.073730   0.003809   19.36 <0.0000000000000002 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 1.092 on 318 degrees of freedom
Multiple R-squared:  0.5409,    Adjusted R-squared:  0.5395 
F-statistic: 374.7 on 1 and 318 DF,  p-value: < 0.00000000000000022
# knitr does not like autoplot
#autoplot(lm(log(Wage.n) ~ Potential, data=train), data=train, colour = 'Nationality_Continent')


library(ggplot2)
p <- ggplot(data=train, mapping=aes(y=log(MIN), x=W))

p +  geom_point(alpha = 0.2) + 
       geom_smooth(method = "lm", aes(color = "OLS", fill = "OLS"))

p + geom_point(alpha=0.1) +
    geom_smooth(color = "tomato", fill="tomato", method = MASS::rlm) +
    geom_smooth(color = "steelblue", fill="steelblue", method = "lm")

p + geom_point(alpha=0.1) +
    geom_smooth(color = "tomato", method = "lm", linewidth = 1.2, 
                formula = y ~ splines::bs(x, 3), se = FALSE)

p + geom_point(alpha=0.1) +
    geom_quantile(color = "tomato", size = 1.2, method = "rqss",
                  lambda = 1, quantiles = c(0.20, 0.5, 0.85))

SUMMARY ASSESSMENT AND EVALUATION OF THE MODEL

The Linear Regression Model of minutes played improves model fit. Points, games played and rebounds are most significant positive predictors. Model has decent performance on test data with R-squared over 0.83.
Residuals appear randomly distributed and normal. No obvious patterns or heteroskedasticity. Provides evidence of a reasonable model fit.
Overall this linear model explains a large proportion of variability in minutes played. The model has limitations in terms of causal inference but provides a reasonable predictive model for expected playing time based on performance metrics.

END