Regresion lineal multiple

Integrantes

• Carlo Vega
• Jhampier Tapia
• Jair Guillerno
• Victor Valera
• Arturo Sanabria

Descripcion del caso

La valoración de los futbolistas estuvo determinada por varios factores, como las características del jugador y los datos de rendimiento. Debido a que estar equipado con jugadores talentosos era esencial para el desempeño exitoso de un equipo, los clubes profesionales en las principales ligas de fútbol intentaron mantener un equipo competitivo comprando y vendiendo jugadores. Antes de una transacción, la gerencia y los expertos trabajaron colectivamente para explorar variables tanto cualitativas como cuantitativas para calcular un precio justo a pagar (o recibir de) otro equipo a cambio de un jugador en particular, la cantidad de fondos intercambiados entre los clubes a menudo era arbitrario, y no necesariamente representaba el verdadero valor de mercado de un jugador (es decir, el valor de reventa del jugador), que a menudo resultaba en recargos o rebajas después de que el jugador se adaptaba al nuevo entorno.

• Objetivo: Se quiere construir un modelo para predecir el valor de transferencia del jugador en base a las variables recolectadas disponibles.

Lectura de datos

data <- 
  readxl::read_excel(path = "W16653-XLS-ENG task.xlsx", 
                     sheet = 'Student_Data', 
                     .name_repair = 'universal')

## New names:
## * `#` -> .
## * `Player Name` -> Player.Name
## * `GBP (M)` -> GBP..M.
## * `Y-5` -> Y.5
## * `Y-4` -> Y.4
## * ...

BD <- 
  data %>% 
  select(-c(1:5, 7:11)) %>% 
  dplyr::mutate_if(is.character, as.factor) %>% 
  dplyr::mutate(Pos = ifelse(Pos == 'MID', 1, 2),
                Foot = dplyr::case_when(Foot == 'B' ~  1, 
                                        Foot == 'L' ~  2, 
                                        Foot == 'R' ~  3)
                )

Descripcion de datos

Estructura:

# Estructura de los datos
skimr::skim(BD)

Data summary

Name	BD
Number of rows	77
Number of columns	11
_______________________
Column type frequency:
numeric	11
________________________
Group variables	None

Variable type: numeric

skim_variable	n_missing	complete_rate	mean	sd	p0	p25	p50	p75	p100	hist
GBP..M.	0	1	34.18	16.21	4.25	24.70	30.00	35.50	86.00	▁▇▁▁▁
WA	0	1	0.77	0.15	0.26	0.73	0.80	0.87	0.94	▁▁▁▆▇
Goals	0	1	45.25	27.47	4.00	25.00	38.00	61.00	111.00	▇▇▃▃▂
App	0	1	136.17	29.07	47.00	127.00	143.00	156.00	189.00	▁▂▅▇▃
G.A	0	1	0.33	0.18	0.04	0.19	0.27	0.46	0.71	▃▇▃▃▂
Age	0	1	24.73	2.72	19.00	23.00	25.00	27.00	31.00	▃▃▇▆▁
Height	0	1	179.94	6.39	167.00	175.00	180.00	184.00	195.00	▃▇▇▆▂
Pos	0	1	1.61	0.49	1.00	1.00	2.00	2.00	2.00	▅▁▁▁▇
Foot	0	1	2.35	0.81	1.00	2.00	3.00	3.00	3.00	▃▁▃▁▇
CR	0	1	1.18	0.39	1.00	1.00	1.00	1.00	2.00	▇▁▁▁▂
NR	0	1	1.32	0.64	1.00	1.00	1.00	1.00	3.00	▇▁▂▁▁

# Correlaciones entre las variables
psych::mixedCor(data = BD, c = 1:7, d = c(8, 10), p = c(9, 11))

## Call: psych::mixedCor(data = BD, c = 1:7, p = c(9, 11), d = c(8, 10))
##         GBP.. WA    Goals App   G.A   Age   Heght Pos   Foot  CR    NR   
## GBP..M.  1.00                                                            
## WA       0.00  1.00                                                      
## Goals    0.22  0.37  1.00                                                
## App      0.01  0.89  0.41  1.00                                          
## G.A      0.23  0.11  0.94  0.11  1.00                                    
## Age     -0.17  0.46  0.41  0.50  0.27  1.00                              
## Height   0.10  0.02  0.24  0.01  0.26  0.19  1.00                        
## Pos      0.20 -0.08  0.69 -0.10  0.79  0.02  0.21  1.00                  
## Foot    -0.13 -0.15 -0.21 -0.23 -0.16 -0.17 -0.01 -0.18  1.00            
## CR      -0.23  0.30  0.16  0.15  0.15  0.01 -0.02  0.19 -0.13  1.00      
## NR       0.08  0.24  0.22  0.05  0.24  0.14  0.15  0.32 -0.24  0.36  1.00

Conclusion:

• Las variables WA, App y NR presentan correlaciones muy cercanas a cero con la variable objetivo, por lo que seran eliminadas del analisis.

Filtro de variables que no estan correlacionadas con el target.

BD1 <- 
  BD %>% 
  dplyr::select(-c('WA', 'App', 'NR'))

head(BD1)

Graficos:

BD1 %>% 
  dplyr::select(1:5) %>% 
  tidyr::gather(key = 'var', value = 'valor') %>% 
  dplyr::mutate(var = as.factor(var)) %>% 
  ggplot2::ggplot() + 
  ggplot2::aes(y = valor, fill = var) + 
  ggplot2::geom_boxplot() + 
  ggplot2::theme(text = ggplot2::element_text(family = 'serif'), 
                 legend.position = 'none') + 
  ggplot2::theme_minimal() + 
  ggplot2::facet_wrap(var ~ ., scales = 'free')

El grafico de cajas nos muestra que:

• El ratio de goles es la variable que presenta mayor dispersion.
• Las edades tienen una mediana de 25 años.
• El precio de transferencia del jugador en libras, presenta valores extremos en ambos lados (fuera del rango intercuartilico), esto podria afectar al modelo que posteriormente se construira teniendo a esta variable como objetivo de prediccion.

Regresion lineal multiple

Estimacion del modelo y seleccion de las mejores variables.

lm.model <- lm(formula = GBP..M. ~ ., data = BD1)
summary(lm.model)

## 
## Call:
## lm(formula = GBP..M. ~ ., data = BD1)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -29.550 -10.594  -2.446   6.710  48.445 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)   
## (Intercept)  52.5327    52.6728   0.997  0.32208   
## Goals         0.3144     0.2159   1.456  0.14996   
## G.A         -16.4548    33.7909  -0.487  0.62783   
## Age          -2.1982     0.7811  -2.814  0.00637 **
## Height        0.2394     0.2885   0.830  0.40955   
## Pos          -0.5714     4.7278  -0.121  0.90416   
## Foot         -2.1698     2.2335  -0.971  0.33471   
## CR           -8.3582     4.5708  -1.829  0.07178 . 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 15.31 on 69 degrees of freedom
## Multiple R-squared:  0.1904, Adjusted R-squared:  0.1083 
## F-statistic: 2.318 on 7 and 69 DF,  p-value: 0.03488

# Aplicando stepwise
step(lm.model, direction = "both")

## Start:  AIC=427.76
## GBP..M. ~ Goals + G.A + Age + Height + Pos + Foot + CR
## 
##          Df Sum of Sq   RSS    AIC
## - Pos     1      3.42 16180 425.77
## - G.A     1     55.59 16232 426.02
## - Height  1    161.41 16338 426.52
## - Foot    1    221.26 16398 426.80
## <none>                16177 427.76
## - Goals   1    496.92 16674 428.09
## - CR      1    783.92 16961 429.40
## - Age     1   1856.77 18033 434.13
## 
## Step:  AIC=425.77
## GBP..M. ~ Goals + G.A + Age + Height + Foot + CR
## 
##          Df Sum of Sq   RSS    AIC
## - G.A     1     73.64 16254 424.12
## - Height  1    160.17 16340 424.53
## - Foot    1    218.55 16399 424.81
## <none>                16180 425.77
## - Goals   1    508.69 16689 426.16
## - CR      1    789.85 16970 427.44
## + Pos     1      3.42 16177 427.76
## - Age     1   1873.01 18053 432.21
## 
## Step:  AIC=424.12
## GBP..M. ~ Goals + Age + Height + Foot + CR
## 
##          Df Sum of Sq   RSS    AIC
## - Height  1    132.76 16386 422.75
## - Foot    1    234.64 16488 423.23
## <none>                16254 424.12
## + G.A     1     73.64 16180 425.77
## - CR      1    789.35 17043 425.78
## + Pos     1     21.47 16232 426.02
## - Goals   1   1848.18 18102 430.42
## - Age     1   1872.81 18127 430.52
## 
## Step:  AIC=422.75
## GBP..M. ~ Goals + Age + Foot + CR
## 
##          Df Sum of Sq   RSS    AIC
## - Foot    1    221.08 16608 421.78
## <none>                16386 422.75
## + Height  1    132.76 16254 424.12
## - CR      1    810.95 17197 424.47
## + G.A     1     46.22 16340 424.53
## + Pos     1     13.87 16372 424.69
## - Age     1   1786.02 18172 428.72
## - Goals   1   2105.23 18492 430.06
## 
## Step:  AIC=421.78
## GBP..M. ~ Goals + Age + CR
## 
##          Df Sum of Sq   RSS    AIC
## <none>                16608 421.78
## + Foot    1    221.08 16386 422.75
## + Height  1    119.20 16488 423.23
## - CR      1    760.09 17368 423.23
## + G.A     1     59.94 16548 423.50
## + Pos     1      9.72 16598 423.74
## - Age     1   1699.76 18307 427.29
## - Goals   1   2320.26 18928 429.85

## 
## Call:
## lm(formula = GBP..M. ~ Goals + Age + CR, data = BD1)
## 
## Coefficients:
## (Intercept)        Goals          Age           CR  
##     80.9602       0.2221      -1.9062      -8.2010

Conclusion:

• En base a la regresion anterior, nos quedamos con las variables Goals, Age y CR (Edad y Ranking del club), esto considerando significancia al 10%.
• Procederemos con la regresion lineal multiple con Goals, Age y CR.

Estimacion del modelo optimo

lm1.model <- lm(formula = GBP..M. ~ Goals + Age + CR, data = BD)
summary(lm1.model)

## 
## Call:
## lm(formula = GBP..M. ~ Goals + Age + CR, data = BD)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -29.841 -10.135  -2.462   6.129  50.107 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 80.96019   17.22794   4.699  1.2e-05 ***
## Goals        0.22206    0.06953   3.194  0.00207 ** 
## Age         -1.90617    0.69736  -2.733  0.00786 ** 
## CR          -8.20102    4.48669  -1.828  0.07166 .  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 15.08 on 73 degrees of freedom
## Multiple R-squared:  0.1689, Adjusted R-squared:  0.1347 
## F-statistic: 4.943 on 3 and 73 DF,  p-value: 0.003517

Conclusion:

• El modelo, considerando un 10% de significancia, explica el 13.47% de la variabilidad del precio de transferencia del jugador el libras.
• Para la variable ‘Ranking del club’ (CR), se esta considerando 10% de significancia puesto que se considera una variable relevante para explicar el precio de transferencia del jugador.
• El modelo es significantivo al nivel del 1% de significancia, esto ya que el p valor asociado al F estadistico global es aproximadamente 0.3%.

Intervarlos de confianza para los beta estimados.

confint(lm1.model) %>% round(., 3)

##               2.5 %  97.5 %
## (Intercept)  46.625 115.295
## Goals         0.083   0.361
## Age          -3.296  -0.516
## CR          -17.143   0.741

Conclusion:

• Para el valor del parametro estimado asociado a la variable ‘Goals’, el verdadero valor del parametro se encuentra entre 0.083 y 0.361, esto con una confianza del 95%.
• Para el valor del parametro estimado asociado a la variable ‘Age’, el verdadero valor del parametro se encuentra entre -3.296 y -0.516, esto con una confianza del 95%.
• Para el valor del parametro estimado asociado a la variable ‘CR’, el verdadero valor del parametro se encuentra entre -17.143 y 0.741, esto con una confianza del 95%.

Evaluacion de los supuestos del modelo de regresion:

Prueba de normalidad: Residuales

residuales <- lm1.model$residuals

par(mfrow = c(1, 2))
# Izquierda
hist(residuales)
# Derecha
car::qqPlot(residuales)

## [1] 52 77

# Prueba de normalidad
nortest::ad.test(lm1.model$residuals)

## 
##  Anderson-Darling normality test
## 
## data:  lm1.model$residuals
## A = 2.1015, p-value = 2.163e-05

Conclusion:

• El histograma para los residuales indica una ligera asimetria positiva.
• En base a la prueba de normalidad por Anderson Darling para los residuales del modelo de regresion propuesto, se observa que no cumplen con el supuesto de normalidad. Esto a pesar de que representa una violacion a los supuestos del modelo, se puede abordar con tecnicas como la ponderacion de las variables, transformaciones logaritmicas o transformaciones aun mas complejas como las de Box y Cox.

Prueba de homocedasticidad:

• H0: Los residuos tienen varianza constante.
• H1: Los residuos no tienen varianza constante.

# Grafico de los residuales vs los valores ajustados
# (Un patron existente en este grafico relevaria la existencia de 
# heterocedasticidad)

plot(lm1.model, 1)

# Prueba de Breusch Pagan
lmtest::bptest(lm1.model)

## 
##  studentized Breusch-Pagan test
## 
## data:  lm1.model
## BP = 4.24, df = 3, p-value = 0.2367

Conclusion:

• De acuerdo a la prueba de homocedasticidad propuesta por Breusch Pagan, no se rechaza la hipotesis nula que postula la homocedasticidad de los residuales asociados al modelo estimado.

Multicolinealidad:

VIF = 1 / (1-R2)

Cuanto mayor es el FIV de una variable, mayor es la varianza del correspondiente coeficiente de regresión. Uno de los problemas de la presencia de colinealidad es la inestabilidad de las estimaciones de los coeficientes de regresión.

# Análisis de Inflación de Varianza (VIF):
car::vif(lm1.model)

Conclusion:

• El Factor Inflacionario de la Varianza (VIF) para las variables Goals, Age y CR incluidas en el modelo, son cercanas a 1 indicando la no existencia de correlacion lineal entre dichas variables.

Prueba de Autocorrelacion:

• H0: No existe autocorrelacion en el modelo.
• H1: Existe autocorrelacion en el modelo.

# Se probara la existencia o no de autocorrelacion en el modelo usando la prueba
# de Durbin Watson (D)

# Paqueteria: car
car::dwt(lm1.model, alternative = "two.sided")

##  lag Autocorrelation D-W Statistic p-value
##    1       0.4145829      1.095759       0
##  Alternative hypothesis: rho != 0

# Paqueteria: lmtest
lmtest::dwtest(lm1.model, alternative = "two.sided")

## 
##  Durbin-Watson test
## 
## data:  lm1.model
## DW = 1.0958, p-value = 2.228e-05
## alternative hypothesis: true autocorrelation is not 0

Conclusion:

• Ambos paquetes reportan un p valor inferior al 5% de significancia, esto se ve contrastando con un valor del estadistico de Durbin Watson cercano a 1 indicando la presencia de autocorrelacion positiva en el modelo.
• La violacion de este supuesto representa un serio problema en el modelo.

Identificación de posibles valores atípicos o influyentes

# Residuales studentizados:

r.stu <- abs(rstudent(lm1.model))
head(r.stu)

##         1         2         3         4         5         6 
## 0.1693924 1.0034231 0.3564059 0.7974680 0.6649062 0.3808726

# Posibles outliers en el modelo:
r.stu[r.stu > 3]

##       52 
## 3.616928

# Observaciones potencialmente influeyentes en el modelo:
summary(influence.measures(lm1.model))

## Potentially influential observations of
##   lm(formula = GBP..M. ~ Goals + Age + CR, data = BD) :
## 
##    dfb.1_ dfb.Gols dfb.Age dfb.CR dffit   cov.r   cook.d hat  
## 3  -0.07  -0.07     0.06    0.10   0.13    1.18_*  0.00   0.11
## 19  0.41  -0.25    -0.44    0.15  -0.71_*  0.92    0.12   0.10
## 36  0.23   0.03    -0.17   -0.13   0.34    0.82_*  0.03   0.02
## 51  0.51   0.30    -0.48   -0.16   0.59    0.81_*  0.08   0.05
## 52  0.20  -0.02    -0.09   -0.19   0.47    0.55_*  0.05   0.02
## 66  0.00   0.01    -0.01    0.01   0.02    1.17_*  0.00   0.10
## 77  0.26   0.46    -0.26   -0.19   0.56    0.80_*  0.07   0.05

# Grafico para las observaciones influyentes, ademas una tabla resumen con
# sus valores studentizados, y las respectivas distancias de cook.
car::influencePlot(lm1.model)

Precision del modelo

# Obteniendo los valores predichos.
Pred.GBPM <- predict(lm1.model, BD1)

# Combinando predichos y observados.
actuals_preds <- 
  dplyr::bind_cols(actuals = BD1$GBP..M., 
                   predicteds = Pred.GBPM)

# Vista de la prediccion vs lo observado.
head(actuals_preds)

# Correlacion entre los valores predichos y los observados:
correlation_accuracy <- cor(actuals_preds)
correlation_accuracy

##             actuals predicteds
## actuals    1.000000   0.410914
## predicteds 0.410914   1.000000

min_max_accuracy <- 
  mean(apply(actuals_preds, 1, min) / apply(actuals_preds, 1, max)) 

min_max_accuracy

## [1] 0.7407075

mape <- 
  mean(
    abs((actuals_preds$predicteds - actuals_preds$actuals)) / actuals_preds$actuals
    )  
mape

## [1] 0.462212

Conclusiones generales:

El modelo lineal múltiple:

GBPM = 80.9602 - 0.2221 * Goals - 1.9602 * Age - 8.2010 * CR

• Es capaz de explicar el 13.47 % de la variabilidad observada en el precio de transferencia del jugador en libras.

• El test F muestra que es significativo al 5%.

• En este caso, no se satisfacen todas las condiciones necesarias para el modelo de regresión múltiple.

• Se tienen 6 observaciones que podrian estar influyendo en el modelo.