NBA_HCA.txt

> summary(glm.fit1)
Generalized linear mixed model fit by maximum likelihood (Laplace Approximation) ['glmerMod']
 Family: binomial  ( logit )
Formula: as.factor(FGM) ~ LOCATION + poly(distance.cent, 2) + shot.clock.early +  
    shot.clock.late + def.type + Dribble.type + heightdiff.cent +      age.cent + (1 | PLAYER_NAME)
   Data: df.all[train.set, ]
Control: glmerControl(optCtrl = list(maxfun = 20000))

      AIC       BIC    logLik  deviance  df.resid 
 453737.8  453877.6 -226855.9  453711.8    345042 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-2.5657 -0.8545 -0.6369  1.0233  2.7349 

Random effects:
 Groups      Name        Variance Std.Dev.
 PLAYER_NAME (Intercept) 0.02692  0.1641  
Number of obs: 345055, groups:  PLAYER_NAME, 513

Fixed effects:
                          Estimate Std. Error z value Pr(>|z|)    
(Intercept)              1.370e-01  1.175e-02    11.7  < 2e-16 ***
LOCATIONH                3.712e-02  7.079e-03     5.2 1.56e-07 ***
poly(distance.cent, 2)1 -3.819e+02  8.472e-01  -450.8  < 2e-16 ***
poly(distance.cent, 2)2  7.664e+01  7.901e-01    97.0  < 2e-16 ***
shot.clock.earlyTRUE    -1.055e-01  1.573e-02    -6.7 1.96e-11 ***
shot.clock.lateTRUE     -2.746e-01  1.405e-02   -19.5  < 2e-16 ***
def.typeTight           -3.913e-01  9.342e-03   -41.9  < 2e-16 ***
def.typeVery Tight      -8.030e-01  1.126e-02   -71.3  < 2e-16 ***
def.typeWide Open        1.857e-01  1.080e-02    17.2  < 2e-16 ***
Dribble.typeOff dribble -2.178e-01  8.189e-03   -26.6  < 2e-16 ***
heightdiff.cent          1.124e-01  4.305e-03    26.1  < 2e-16 ***
age.cent                 1.001e-02  2.017e-03     5.0 6.92e-07 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Correlation of Fixed Effects:
               (Intr) LOCATI p(.,2)1 p(.,2)2 sht.clck.rTRUE sht.clck.lTRUE df.tyT df.tVT df.tWO Drb.Od hghtd.
LOCATIONH      -0.300                                                                                        
ply(ds.,2)1    -0.061  0.000                                                                                 
ply(ds.,2)2    -0.012  0.000 -0.109                                                                          
sht.clck.rTRUE -0.108  0.004  0.052  -0.049                                                                  
sht.clck.lTRUE -0.084  0.002 -0.027  -0.004   0.061                                                          
def.typTght    -0.381 -0.002  0.127  -0.023  -0.077         -0.011                                           
df.typVryTg    -0.323 -0.008  0.160  -0.064  -0.114          0.012          0.515                            
df.typWdOpn    -0.406 -0.004 -0.036  -0.006   0.014          0.020          0.416  0.346                     
Drbbl.typOd    -0.271  0.008  0.036   0.097   0.160         -0.029         -0.175 -0.174  0.140              
hghtdff.cnt    -0.062 -0.001 -0.053   0.022   0.001         -0.006         -0.043 -0.002  0.037  0.109       
age.cent        0.004  0.001 -0.007   0.004   0.013         -0.003          0.001  0.010  0.003  0.016  0.002
fit warnings:
Some predictor variables are on very different scales: consider rescaling
convergence code: 0
Model failed to converge with max|grad| = 0.00158144 (tol = 0.001, component 1)

> 
> ## Model wo location
> glm.fit2 <- glmer(as.factor(FGM) ~  poly(distance.cent, 2) + shot.clock.early +
+                     shot.clock.late + def.type + Dribble.type + heightdiff.cent + age.cent +
+                     (1|PLAYER_NAME), 
+                   data = df.all[train.set,], family = "binomial", 
+                   control=glmerControl(optCtrl=list(maxfun=2e4)))
Warning messages:
1: Some predictor variables are on very different scales: consider rescaling 
2: In checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv,  :
  unable to evaluate scaled gradient
3: In checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv,  :
  Model failed to converge: degenerate  Hessian with 1 negative eigenvalues
> summary(glm.fit2)
Generalized linear mixed model fit by maximum likelihood (Laplace Approximation) ['glmerMod']
 Family: binomial  ( logit )
Formula: as.factor(FGM) ~ poly(distance.cent, 2) + shot.clock.early +  
    shot.clock.late + def.type + Dribble.type + heightdiff.cent +      age.cent + (1 | PLAYER_NAME)
   Data: df.all[train.set, ]
Control: glmerControl(optCtrl = list(maxfun = 20000))

      AIC       BIC    logLik  deviance  df.resid 
 453763.3  453892.3 -226869.7  453739.3    345043 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-2.5430 -0.8545 -0.6370  1.0238  2.7097 

Random effects:
 Groups      Name        Variance Std.Dev.
 PLAYER_NAME (Intercept) 0.02694  0.1641  
Number of obs: 345055, groups:  PLAYER_NAME, 513

Fixed effects:
                          Estimate Std. Error z value Pr(>|z|)    
(Intercept)              1.556e-01  1.149e-02   13.54  < 2e-16 ***
poly(distance.cent, 2)1 -3.820e+02  3.121e+00 -122.38  < 2e-16 ***
poly(distance.cent, 2)2  7.664e+01  2.307e+00   33.23  < 2e-16 ***
shot.clock.earlyTRUE    -1.059e-01  1.605e-02   -6.60 4.23e-11 ***
shot.clock.lateTRUE     -2.747e-01  1.410e-02  -19.48  < 2e-16 ***
def.typeTight           -3.913e-01  1.022e-02  -38.29  < 2e-16 ***
def.typeVery Tight      -8.026e-01  1.289e-02  -62.25  < 2e-16 ***
def.typeWide Open        1.859e-01  1.091e-02   17.04  < 2e-16 ***
Dribble.typeOff dribble -2.182e-01  8.538e-03  -25.56  < 2e-16 ***
heightdiff.cent          1.124e-01  4.295e-03   26.18  < 2e-16 ***
age.cent                 1.001e-02  2.018e-03    4.96 7.08e-07 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Correlation of Fixed Effects:
               (Intr) p(.,2)1 p(.,2)2 sht.clck.rTRUE sht.clck.lTRUE df.tyT df.tVT df.tWO Drb.Od hghtd.
ply(ds.,2)1    -0.258                                                                                 
ply(ds.,2)2    -0.054  0.021                                                                          
sht.clck.rTRUE -0.139  0.172  -0.124                                                                  
sht.clck.lTRUE -0.062 -0.091  -0.019   0.047                                                          
def.typTght    -0.453  0.423  -0.014   0.000         -0.046                                           
df.typVryTg    -0.397  0.498  -0.111  -0.007         -0.030          0.606                            
df.typWdOpn    -0.373 -0.144  -0.042  -0.005          0.033          0.320  0.236                     
Drbbl.typOd    -0.323  0.158   0.274   0.148         -0.045         -0.093 -0.096  0.103              
hghtdff.cnt    -0.007 -0.158   0.046  -0.034          0.006         -0.107 -0.088  0.052  0.107       
age.cent        0.009 -0.032   0.008   0.007          0.000         -0.011 -0.005  0.007  0.010  0.012
fit warnings:
Some predictor variables are on very different scales: consider rescaling
convergence code: 0


> 
> 
> anova(glm.fit1, glm.fit2)
Data: df.all[train.set, ]
Models:
glm.fit2: as.factor(FGM) ~ poly(distance.cent, 2) + shot.clock.early + 
glm.fit2:     shot.clock.late + def.type + Dribble.type + heightdiff.cent + 
glm.fit2:     age.cent + (1 | PLAYER_NAME)
glm.fit1: as.factor(FGM) ~ LOCATION + poly(distance.cent, 2) + shot.clock.early + 
glm.fit1:     shot.clock.late + def.type + Dribble.type + heightdiff.cent + 
glm.fit1:     age.cent + (1 | PLAYER_NAME)
         Df    AIC    BIC  logLik deviance  Chisq Chi Df Pr(>Chisq)    
glm.fit2 12 453763 453892 -226870   453739                             
glm.fit1 13 453738 453878 -226856   453712 27.513      1  1.561e-07 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

> 
> predictions1 <- predict(glm.fit1, df.all, type = 'response', allow.new.levels = TRUE)
> predictions2 <- predict(glm.fit2, df.all, type = 'response', allow.new.levels = TRUE)
> outcome <- df.all$FGM
> 
> LogLoss<-function(actual, predicted)
+ {
+   result<- -1/length(actual)*(sum((actual*log(predicted)+(1-actual)*log(1-predicted))))
+   return(result)
+ }
> LogLoss(outcome[test.set], predictions1[test.set])
[1] 0.6552662
> LogLoss(outcome[test.set], predictions2[test.set])
[1] 0.6553695
> ## Small log loss improvement in full model (predictions1)
> 
> 
> predictions <- predict(glm.fit1, df.all, type = 'response', allow.new.levels = TRUE)
> preds <- prediction(predictions[test.set], df.all$FGM[test.set])
> performance(preds, "auc")
An object of class "performance"
Slot "x.name":
[1] "None"

Slot "y.name":
[1] "Area under the ROC curve"

Slot "alpha.name":
[1] "none"

Slot "x.values":
list()

Slot "y.values":
[[1]]
[1] 0.6380581


Slot "alpha.values":
list()

> 
> predictions <- predict(glm.fit2, df.all, type = 'response', allow.new.levels = TRUE)
> preds <- prediction(predictions[test.set], df.all$FGM[test.set])
> performance(preds, "auc")
An object of class "performance"
Slot "x.name":
[1] "None"

Slot "y.name":
[1] "Area under the ROC curve"

Slot "alpha.name":
[1] "none"

Slot "x.values":
list()

Slot "y.values":
[[1]]
[1] 0.6378453


Slot "alpha.values":
list()



> 
> ##glmnet: using elastic net with alpha 0.5
> library(glmnet)
> 
> #Without location
> sparseX <- sparse.model.matrix(~  + (1 + distance.cent) * 
+                 (1 + shot.clock.early + shot.clock.late + def.type + Dribble.type + 
+                  heightdiff.cent + age.cent + PLAYER_NAME), df.all)
Warning messages:
1: In sparse.model.matrix(~+(1 + distance.cent) * (1 + shot.clock.early +  :
  variable 'def.type' converted to a factor
2: In sparse.model.matrix(~+(1 + distance.cent) * (1 + shot.clock.early +  :
  variable 'Dribble.type' converted to a factor
3: In sparse.model.matrix(~+(1 + distance.cent) * (1 + shot.clock.early +  :
  variable 'PLAYER_NAME' converted to a factor
> 
> m1 <- cv.glmnet(sparseX[train.set,],
+                 df.all$FGM[train.set],
+                 alpha = 0.5,
+                 family = 'binomial')
> 
> df.all$sparse.hat <- predict(m1, newx = sparseX, type = 'response')[,1]
> preds <- prediction(df.all$sparse.hat[test.set], df.all$FGM[test.set])
> perf <- performance(preds, 'tpr', 'fpr')
> plot(perf)
> performance(preds, 'auc')
An object of class "performance"
Slot "x.name":
[1] "None"

Slot "y.name":
[1] "Area under the ROC curve"

Slot "alpha.name":
[1] "none"

Slot "x.values":
list()

Slot "y.values":
[[1]]
[1] 0.6395949


Slot "alpha.values":
list()

> 
> 
> #With location
> sparseX <- sparse.model.matrix(~  + (1 + distance.cent) * 
+                                  (1 + shot.clock.early + shot.clock.late + def.type + Dribble.type + 
+                                     heightdiff.cent + age.cent + LOCATION + PLAYER_NAME), df.all)
Warning messages:
1: In sparse.model.matrix(~+(1 + distance.cent) * (1 + shot.clock.early +  :
  variable 'def.type' converted to a factor
2: In sparse.model.matrix(~+(1 + distance.cent) * (1 + shot.clock.early +  :
  variable 'Dribble.type' converted to a factor
3: In sparse.model.matrix(~+(1 + distance.cent) * (1 + shot.clock.early +  :
  variable 'LOCATION' converted to a factor
4: In sparse.model.matrix(~+(1 + distance.cent) * (1 + shot.clock.early +  :
  variable 'PLAYER_NAME' converted to a factor
> 
> m1 <- cv.glmnet(sparseX[train.set,],
+                 df.all$FGM[train.set],
+                 alpha = 0.5,
+                 family = 'binomial')
> 
> df.all$sparse.hat <- predict(m1, newx = sparseX, type = 'response')[,1]
> preds <- prediction(df.all$sparse.hat[test.set], df.all$FGM[test.set])
> perf <- performance(preds, 'tpr', 'fpr')
> plot(perf)
> performance(preds, 'auc')
An object of class "performance"
Slot "x.name":
[1] "None"

Slot "y.name":
[1] "Area under the ROC curve"

Slot "alpha.name":
[1] "none"

Slot "x.values":
list()

Slot "y.values":
[[1]]
[1] 0.6396193


Slot "alpha.values":
list()

> 
> 
> ## Practical significance
> set.seed(100)
> unique.games <- unique(df.all$MATCHUP)
> games <- sample(unique.games, 100)
> sample.games <- filter(df.all, MATCHUP %in% games)
> 
> ##Imagine all 20 teams were away teams
> sample.games$LOCATION <- "A"
> sample.games$p.hatA <- predict(glm.fit1, sample.games, type = 'response', allow.new.levels = TRUE)
> 
> ##Imagine all 20 teams were home teams
> sample.games$LOCATION <- "H"
> sample.games$p.hatH <- predict(glm.fit1, sample.games, type = 'response', allow.new.levels = TRUE)
> 
> #Points scored (predicted)
> sample.games <- sample.games %>%
+   mutate(pts.hatA = p.hatA *PTS_TYPE, pts.hatH = p.hatH*PTS_TYPE)
> 
> ##Total points per game
> sample <- sample.games %>%
+   group_by(MATCHUP) %>%
+   summarise(total.hatA = sum(pts.hatA), total.hatH = sum(pts.hatH), diff.pts = total.hatH - total.hatA)
> 
> 
> histogram(sample$diff.pts)
> quantile(sample$diff.pts, c(0.025, 0.975))
     2.5%     97.5% 
0.8487916 1.8435585