Analisis estadítico NBA y predicción de salarios 2021
David Rodriguez Garcia
Diciembre del 2020
much-smaller image
Análisis estadístico
Directorio de trabajo
getwd()## [1] "C:/Users/Drodrig7/Documents/R LINKEDIN NBA/SALARIOS NBA"setwd("C:/Users/Drodrig7/Documents/R LINKEDIN NBA/SALARIOS NBA")Carga conjunto de datos
Se cargan diversas librerías que se van a necesitar, así como el conjunto de datos que se ha creado para el análisis.
library(data.table)
library(corrplot)## corrplot 0.84 loadedlibrary(GGally)## Loading required package: ggplot2## Registered S3 method overwritten by 'GGally':
## method from
## +.gg ggplot2library(tidyverse)## -- Attaching packages --------------------------------------- tidyverse 1.3.0 --## v tibble 3.0.4 v dplyr 1.0.2
## v tidyr 1.1.2 v stringr 1.4.0
## v readr 1.4.0 v forcats 0.5.0
## v purrr 0.3.4## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::between() masks data.table::between()
## x dplyr::filter() masks stats::filter()
## x dplyr::first() masks data.table::first()
## x dplyr::lag() masks stats::lag()
## x dplyr::last() masks data.table::last()
## x purrr::transpose() masks data.table::transpose()library(PerformanceAnalytics)## Loading required package: xts## Loading required package: zoo##
## Attaching package: 'zoo'## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric##
## Attaching package: 'xts'## The following objects are masked from 'package:dplyr':
##
## first, last## The following objects are masked from 'package:data.table':
##
## first, last##
## Attaching package: 'PerformanceAnalytics'## The following object is masked from 'package:graphics':
##
## legendlibrary(plotly)##
## Attaching package: 'plotly'## The following object is masked from 'package:ggplot2':
##
## last_plot## The following object is masked from 'package:stats':
##
## filter## The following object is masked from 'package:graphics':
##
## layoutlibrary("readxl")
library(modeest, warn.conflicts = FALSE)## Registered S3 method overwritten by 'rmutil':
## method from
## print.response httrNBA_salary <- read_excel("DATANBA.xlsx")
head(NBA_salary)Salarios Vs Puntos
Para empezar, me gustaría poner en situación mediante un gráfico interactivo, la relación entre salarios y puntos anotados durante esta temporada.
plot_ly(data = NBA_salary, x = ~Salary, y = ~`PTS/G`, color = ~Division,
hoverinfo = "text",
text = ~paste("Jugador: ",Name,
"<br>Salario: ", format(Salary, big.mark = ","),"$",
"<br>PPG: ", round(`PTS/G`, digits = 3),
"<br>Equipo: ", Team)) %>% add_trace(type = "scatter", mode = "markers")%>%
layout(
title = "Salario vs Puntos por partido",
xaxis = list(title = "Salario"),
yaxis = list(title = "Puntos por partido")
)## Warning: `arrange_()` is deprecated as of dplyr 0.7.0.
## Please use `arrange()` instead.
## See vignette('programming') for more help
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.En este gráfico podemos ver la situación de salarios de los jugadores en cuanto a puntos anotados esta temporada, con una segmentación por divisiones. En el gráfico ya podemos visualizar una correlación positiva entre ambos factores, que más tarde profundizaremos para construir el modelo de predicción.
Vamos a explorar en un gráfico 3D, otra manera de visualizar esta relación, pero esta vez añadiendo la variable edad. Esta solo es una manera mas para visualizar la situacion de una manera grafica e interactiva.
colors <- c('#4AC6B7', '#1972A4', '#965F8A', '#FF7070', '#C61951','#99ff99')
TR<- plot_ly(NBA_salary, x=~`PTS/G`, y = ~Salary, z = ~Age, color = ~Division, size = ~Salary, colors = colors,
marker = list(symbol = 'circle', sizemode = 'diameter'), sizes = c(1, 40), text = ~paste("Jugador: ",Name,
"<br>Salario: ", format(Salary, big.mark = ","),"$",
"<br>PPG: ", round(`PTS/G`, digits = 3),
"<br>Equipo: ", Team))
TR <-TR %>% layout(title = 'Salary, Points and Age',
scene = list(xaxis = list(title = 'Points',
gridcolor = 'rgb(255, 255, 255)',
zerolinewidth = 1,
ticklen = 5,
gridwidth = 2),
yaxis = list(title = 'Salary',
gridcolor = 'rgb(255, 255, 255)',
zerolinewidth = 1,
ticklen = 5,
gridwith = 5),
zaxis = list(title = 'Age',
gridcolor = 'rgb(255, 255, 255)',
zerolinewidth = 1,
ticklen = 5,
gridwith = 2)),
paper_bgcolor = 'rgb(225, 225, 225)',
plot_bgcolor = 'rgb(255, 255, 255)')
TRTOP 10
Antes de realizar el análisis de correlaciones y la predicción, mostraremos algunos aspectos estadísticos. En primer lugar, Vamos a ver cuál es el top 10 de jugadores que cobran más caros sus puntos. Para ello en primer lugar obtenemos los puntos totales de cada jugador.
NBA_SALARY <-
NBA_salary %>%
select(1:32)%>%
mutate(Points = `PTS/G`*Games)
NBA_SALARY$Points <-ceiling(NBA_SALARY$Points)
head(NBA_SALARY)Ahora calcularemos el salario por punto de cada jugador. Además, en los jugadores que no hayan anotado ningún punto, habiendo tenido minutos indicaremos el total de su salario. Por ultimo, lo ordenaremos y mostraremos los 10 jugadores con el mayor salario por puntos y los diez con el menor.
NBA_salary_x_point <-
NBA_SALARY %>%
select(Name, Salary, Team,Points, Games,Division,Conferencia)%>%
mutate(SalaryXpoint = Salary/Points)
NBA_salary_x_point$SalaryXpoint <- ifelse((NBA_salary_x_point$Points == 0),NBA_salary_x_point$Salary,NBA_salary_x_point$SalaryXpoint)
NBA_salary_x_point$SalaryXpoint <- as.integer(round(NBA_salary_x_point$SalaryXpoint))
NBA_SALARY_X_POINT_SORT<- data.table(NBA_salary_x_point, key = "SalaryXpoint")
NBA_SALARY_X_POINT<- NBA_SALARY_X_POINT_SORT[, .SD[Name %in% tail(sort(unique(Name)), 10)], by="SalaryXpoint"]
head(arrange(NBA_SALARY_X_POINT, desc(SalaryXpoint)), n=10)head((NBA_SALARY_X_POINT),n=10)Hacemos lo mismo con los partidos, hay que especificar que en el data set que hemos montado, solo hay jugadores que han jugado, al menos un partido en esta liga, por lo que Kevin Durant o Klay Thompsosn , por ejemplo, no aparecen, aunque deberían aparecer, seguramente en los primeros puestos.
NBA_salary_x_game <-
NBA_SALARY %>%
select(Name, Salary, Team,Points, Games,Division,Conferencia )%>%
mutate(SalaryXgame = Salary/Games)
NBA_salary_x_game$SalaryXgame <- as.integer(round(NBA_salary_x_game$SalaryXgame))
NBA_SALARY_X_GAME_SORT<- data.table(NBA_salary_x_game, key = "SalaryXgame")
NBA_SALARY_X_GAME<- NBA_SALARY_X_GAME_SORT[, .SD[Name %in% tail(sort(unique(Name)), 10)], by="SalaryXgame"]
head(arrange(NBA_SALARY_X_GAME, desc(SalaryXgame)), n=10)head((NBA_SALARY_X_GAME),n=10)Representación gráfica de la distribución de los salarios
Observamos en primer lugar la distribución de los salarios en cada división, tanto salario total, por puntos y por partido.
P <- ggplot(NBA_salary, aes(x = Division, y = Salary, fill= Division)) +
geom_boxplot() + scale_y_continuous(labels = scales::comma)
P 
En un breve análisis de las cajas, vemos como la división Northwest es la que tiene a la mitad de sus jugadores con un salario inferior a los 3 millones de dólares. En la división Pacific, que pasa por ser una de las más potentes y atractivas, vemos que el 75% de los jugadores tienen salarios inferiores a 8 millones, el menor porcentaje de todas las divisiones, mientras que se aprecian un número considerable de outliers, esto se puede deber al gran número de contenders en la división, que hace acumular a grandes estrellas en sus plantillas, rodeadas de buenos jugadores que se rebajan su salario para optar al título y jugadores secudarios con salarios muy bajos.
P_point <- ggplot(NBA_SALARY_X_POINT, aes(x = Division, y = SalaryXpoint, fill= Division)) +
geom_boxplot() + scale_y_continuous(labels = scales::comma)
P_point
P_game <- ggplot(NBA_SALARY_X_GAME, aes(x = Division, y = SalaryXgame, fill= Division)) +
geom_boxplot() + scale_y_continuous(labels = scales::comma)
P_game
En esto dos gráficos vemos la distribucion de los salarios en funcion de los partidos y puntos. Como vemos no se aprecia gran cosa, mas alla de ver determinados valores atípcos como stepen curry y chandler parsons, debido a su escasa participacion en la temporada causada por sus probemas fisicos.
Medias por posición y división
Se quiere pasar a analizar algunos aspectos estadísticos por posición. En primer lugar veremos la frecuencia que encontramos en el factor “Position”
table(NBA_salary$Position)##
## C PF PF-C PF-SF PG PG-SG SF SF-C SF-PF SF-SG SG SG-PG SG-SF
## 98 93 4 1 72 1 74 1 3 2 101 2 1Vemos demasiadas posiciones, por lo que vamos simplificarlo un poco, dejando las 5 posiciones principales .
NBA_salary$Position[NBA_salary$Position == "PF-C"] <- "PF"
NBA_salary$Position[NBA_salary$Position == "PF-SF"] <- "PF"
NBA_salary$Position[NBA_salary$Position == "PG-SG"] <- "PG"
NBA_salary$Position[NBA_salary$Position == "SF-C"] <- "SF"
NBA_salary$Position[NBA_salary$Position == "SF-PF"] <- "SF"
NBA_salary$Position[NBA_salary$Position == "SF-SG"] <- "SF"
NBA_salary$Position[NBA_salary$Position == "SG-PG"] <- "SG"
NBA_salary$Position[NBA_salary$Position == "SG-SF"] <- "SG"
table(NBA_salary$Position)##
## C PF PG SF SG
## 98 98 73 80 104aggregate(NBA_salary[, 2], list(Posición = NBA_salary$Position), mean)aggregate(NBA_salary[, 10], list(Posición = NBA_salary$Position), mean)aggregate(NBA_salary[, 11], list(Posición = NBA_salary$Position), mean)Se puede observar como la posición de point guard es la posición que lidera los 3 apartados. Estamos hablando de la posición que tiene 3 de los 6 máximos anotadores de la pasada temporada como son Lillard, Doncic y Young, además de grandes superestrellas como Lebron o kyrie Irving, por lo que tiene sentido que puedan liderar la clasificación de las 4 listas. Además, y como factor decisivo, al ser la posición que engloba menos individuos, tiende a contener menos jugadores “marginales” que otras.
Analisis correlaciones
Se analiza en primer lugar la relación entre la variable salario y la de puntos por partido.
cor(NBA_salary$Salary,NBA_salary$`PTS/G`)## [1] 0.6381722cor.test(NBA_salary$Salary,NBA_salary$`PTS/G`)##
## Pearson's product-moment correlation
##
## data: NBA_salary$Salary and NBA_salary$`PTS/G`
## t = 17.603, df = 451, p-value < 2.2e-16
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
## 0.5801510 0.6897494
## sample estimates:
## cor
## 0.6381722El p-valor asociado a este contraste es <2.2e-16, por lo que rechazamos la hipótesis de que la correlación lineal entre estas dos variables sea nula. Se observa además que la correlación es positiva medio-alta, es decir el comportamiento de la variable dependiente influye en la variable independiente, aunque no con la fortaleza que esperaba.
Se pasa a construir un subconjunto de datos que contenga solo las variables cuantitativas, para poder revisar todas las correlaciones existentes.
NBA_cor <- NBA_salary[c(2,4,9:20,24,27,30)]
NBA_COR<- cor(NBA_cor)
corrplot(NBA_COR, type = "upper",method = "number", number.cex= 11/ncol(NBA_COR))
Analizamos las correlaciones con la variable salario, que son las que nos interesan más, y vemos que los puntos por partido es la que presenta una correlación más elevada, como cabía de esperar. Lo que puede sorprender es que otros indicadores importantes a la hora de destacar el desempeño de los jugadores en un partido, están por debajo de lo esperado e incluso se encuentran por debajo de otros como son los balones perdidos, es decir, según el coeficiente de correlación de Pearson, la relación, cuantos más balones perdidos más salario, es más fuerte que la relación entre salario y rebotes totales, asistencias, robos o incluso tapones. Esto tiene sentido, si analizamos la correlación entre perdidas y minutos/puntos vemos que es muy fuerte (0.87/0,77) lo cual significa que los jugadores que anotan muchos puntos también arriesgan más y acaban perdiendo más balones, además de acumular más minutos, factor que añade más oportunidades de perder balones. Por lo que se puede apreciar, eso no influye tanto a la hora de firmar grandes contratos, de hecho, solo hay que mirar la lista con los 10 jugadores con más perdidas de la liga para darse cuenta.
head(arrange(NBA_salary, desc(TOV)), n=10)Correlacion conferencias
Me gustaria revisar si hay diferencia entre conferencias en cuanto las correlaciones de los indicadores mas importantes, por lo que me voy a ayudar del grafico ggpairs para intentar visualizar si existen diferencias importantes.
cor_pairs <- NBA_salary[c(10:12,14:15,20:21,2,7)]
require(GGally)
ggpairs(cor_pairs,legend = 1,mapping = aes(colour = Conferencia),upper = list(continuous = wrap("cor",alpha = 0.9, size = 2.2))) + theme(legend.position = "bottom")
Nos centramos en analizar las relaciones entre el salario y el resto de indicadores, y en este contexto vemos cosas interesantes y es que la correlación que hay en la conferencia Este es mucho más fuerte que la que existe en la conferencia Oeste, es decir, las estadísticas individuales de los jugadores en la conferencia Este explican mucho mejor los salarios pagados que lo que podemos ver en la conferencia Oeste. La diferencia es considerable en todos ellos, destacando el 26,16% de diferencia en los puntos por partido y el 28,72% en asistencias. Entre los factores que podían explicar esto, podríamos encontrar la tendencia de la liga en los últimos años en los que los que la conferencia Oeste se presentaba como mucho más potente que la conferencia Este, hecho que ha provocado un degoteo de talento hacia la conferencia oeste durante estos últimos años. Este degoteo, a mi modo de ver, provoca que jugadores con contratos altos vayan a equipos aspirantes de la conferencia oeste y bajen sus prestaciones estadísticas al tener que compartir protagonismo y minutos con otros compañeros de más alto nivel, hecho que provocará que sus estadísticas actuales no reflejen el contrato firmado. Por otro lado, pueden existir otros factores, como que jugadores jóvenes con contratos rookies tengan desempeños superiores a su contrato, produciendo así diferencias entre conferencias. De todas maneras, se trata de una muestra muy pequeño, tan solo un año, por lo que no es representativa en el tiempo, por otro lado, la idiosincrasia de la liga con sus límites salariales, tendiera a igualar todas estas relaciones si lo miramos en una perspectiva en el tiempo.
Estadisticas por minuto
Se quiere ver si las estadísticas por minutos, en lugar de las que tenemos que son por partido, muestran una correlación más fuerte con la variable dependiente.
NBA_Mutate <-
NBA_salary %>%
select(Salary,`Min/G`,`PTS/G`,TOV,TRB,AST,BLK,STL,Conferencia,Division)%>%
mutate(`PTS/M` = `PTS/G`/`Min/G`, `TOV/M`= TOV/`Min/G`, `TRB/M` = TRB/`Min/G`, `AST/M` = AST/`Min/G`, `BLK/M`= BLK/`Min/G`, `STL/M`= STL/`Min/G`)
head(NBA_Mutate)NBA_GAME <- NBA_Mutate[c(1:2,11:16)]
head(NBA_GAME)NBA_game <- cor(NBA_GAME)
corrplot(NBA_game, type = "upper",method = "number", number.cex= 11/ncol(NBA_game))
Observamos que no es así, sino todo lo contrario, ya que se muestra una correlación mucha más débil, que explica peor el salario percibido.
Correlación por posición
Para intentar ver si en algunas posiciones hay correlación más fuerte en los indicadores, con el objetivo de probar el modelo predictivo con un conjunto de datos que muestre relaciones más significantes, se han hecho diferentes pruebas con las diferentes posiciones, viendo que tanto los centers como los small forwards existe un nivel de correlación individualmente mayor que todo en el conjunto de datos.
NBA_FILTER_C <-
NBA_salary %>%
filter(Position == "C")%>%
select(Salary,`Min/G`,`PTS/G`,TOV,TRB,AST,BLK,STL,Conferencia,Division,Position)
NBA_POSITION_C <- NBA_FILTER_C[c(1:8)]
NBA_C <- cor(NBA_POSITION_C)
corrplot(NBA_C, type = "upper",method = "number", number.cex= 11/ncol(NBA_C))
NBA_FILTER_SF <-
NBA_salary %>%
filter(Position == "SF")%>%
select(Salary,`Min/G`,`PTS/G`,TOV,TRB,AST,BLK,STL,Conferencia,Division,Position)
NBA_POSITION_SF <- NBA_FILTER_SF[c(1:8)]
NBA_SF <- cor(NBA_POSITION_SF)
corrplot(NBA_SF, type = "upper",method = "number", number.cex= 11/ncol(NBA_SF))
Ya que al segmentar las muestras pueden ser menos significativas, se decide unir estos dos grupos y formar un conjunto un poco mayor para ganar representatividad.
NBA_FILTER_SF_C <-
NBA_salary %>%
filter(Position == "SF"|Position == "C" )%>%
select(Salary,`Min/G`,`PTS/G`,TOV,TRB,AST,BLK,STL,Conferencia,Division,Position)
NBA_POSITION_SF_C <- NBA_FILTER_SF_C[c(1:8)]
NBA_SF_C <- cor(NBA_POSITION_SF_C)
corrplot(NBA_SF_C, type = "upper",method = "number", number.cex= 11/ncol(NBA_SF_C))
cor(NBA_salary$Salary,NBA_salary$`PTS/G`)## [1] 0.6381722cor.test(NBA_salary$Salary,NBA_salary$`PTS/G`)##
## Pearson's product-moment correlation
##
## data: NBA_salary$Salary and NBA_salary$`PTS/G`
## t = 17.603, df = 451, p-value < 2.2e-16
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
## 0.5801510 0.6897494
## sample estimates:
## cor
## 0.6381722cor(NBA_POSITION_SF_C$Salary,NBA_POSITION_SF_C$`PTS/G`)## [1] 0.7186168cor.test(NBA_POSITION_SF_C$Salary,NBA_POSITION_SF_C$`PTS/G`)##
## Pearson's product-moment correlation
##
## data: NBA_POSITION_SF_C$Salary and NBA_POSITION_SF_C$`PTS/G`
## t = 13.709, df = 176, p-value < 2.2e-16
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
## 0.6390814 0.7829460
## sample estimates:
## cor
## 0.7186168Observamos que existe entre el conjunto de datos inicial y este subgrupo una diferencia significativa entre la relación entre el salario y los puntos anotados, mientras que en el conjunto completo la relación entre salarios y puntos es de 0,63 en subgrupo que hemos formado es de 0,71.
Asistente, no asistente
Antes del modelo predictivo, veremos de forma gráfica una de las relaciones, concretamente la variable con relación más fuerte de este subgrupo respecto al salario, como son las asistencias. Para ello separamos los jugadores que están por encima de la media de asistencias con los que están por debajo de ella.
NBA_POSITION_SF_C_AST <- NBA_POSITION_SF_C
avg_ast <- mean(NBA_POSITION_SF_C_AST$AST)
NBA_POSITION_SF_C_AST$Asistente <- as.factor(ifelse(NBA_POSITION_SF_C_AST$AST < avg_ast,"No", "Si" ))
NBA_POSITION_SF_C_AST %>%
ggplot(aes(x= Salary, y= AST, colour = Asistente))+
geom_point() +
geom_smooth(method="lm") +
scale_x_continuous(labels = scales::comma)
Como vemos en el gráfico, los jugadores que reparten más asistencias tienden a ganar más dinero, como el coeficiente de correlación nos mostraba.
Modelo predictivo
Vamos a predecir. Se crearán dos modelos, uno con el todo el conjunto de datos y otro con el subconjunto de los pívots y small forwards.
Vamos a usar la función step para determinar la calidad del modelo. Esta función lo que hará es que me empezara construyendo el modelo desde 0 variables y a cada paso añadirá una variable explicativa, la que tenga menor AIC, esto se repetirá hasta encontrar una variable que no tenga una significancia considerable para el modelo (entorno a un 10%) y que determinara el final de los pasos y la definición del modelo final. Para ejecutar la selección del modelo mediante este paso, en primer lugar, tendremos que convertir el dataset “NBA_salary” para que solo contenga las variables cuantitativas de mayor relación (para el dataset filtrado por posición ya está hecho). En segundo lugar, tendremos un modelo sin ninguna variable explicativa y otro con todas para que así la selección del modelo empiece desde 0 y vaya añadiendo variables.
NBA_salary_2 <- NBA_cor[c(1,4:7,9,11,13)]
head(NBA_salary_2)#Sin variables explicativas
model_total_sin <- lm(formula = Salary~ 1, data=NBA_salary_2)
model_SF_C_sin <- lm(formula = Salary~ 1, data=NBA_POSITION_SF_C)
summary(model_total_sin)##
## Call:
## lm(formula = Salary ~ 1, data = NBA_salary_2)
##
## Residuals:
## Min 1Q Median 3Q Max
## -7493290 -6028373 -4097937 2467639 32582821
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 7648937 416248 18.38 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 8859000 on 452 degrees of freedomsummary(model_SF_C_sin)##
## Call:
## lm(formula = Salary ~ 1, data = NBA_POSITION_SF_C)
##
## Residuals:
## Min 1Q Median 3Q Max
## -7492988 -6028071 -4128635 3518752 25093365
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 7648635 653213 11.71 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 8715000 on 177 degrees of freedom#Con variables explicativas
model_total_con <- lm(formula = Salary~ ., data=NBA_salary_2)
model_SF_C_con <- lm(formula = Salary~ ., data=NBA_POSITION_SF_C)
summary(model_total_con)##
## Call:
## lm(formula = Salary ~ ., data = NBA_salary_2)
##
## Residuals:
## Min 1Q Median 3Q Max
## -20990096 -3651719 -813437 2491102 24289468
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1445071 930846 -1.552 0.121271
## `Min/G` -140845 88272 -1.596 0.111296
## `PTS/G` 717604 130213 5.511 6.05e-08 ***
## TOV -2097481 1094478 -1.916 0.055952 .
## TRB 804044 224122 3.588 0.000371 ***
## AST 1654428 369766 4.474 9.75e-06 ***
## STL 879833 1169707 0.752 0.452339
## BLK 1031227 1047228 0.985 0.325297
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 6573000 on 445 degrees of freedom
## Multiple R-squared: 0.458, Adjusted R-squared: 0.4495
## F-statistic: 53.73 on 7 and 445 DF, p-value: < 2.2e-16summary(model_SF_C_con)##
## Call:
## lm(formula = Salary ~ ., data = NBA_POSITION_SF_C)
##
## Residuals:
## Min 1Q Median 3Q Max
## -12915303 -3073407 -670437 2714351 19047943
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -3333736 1117366 -2.984 0.00327 **
## `Min/G` -76104 113798 -0.669 0.50455
## `PTS/G` 449393 188129 2.389 0.01800 *
## TOV 231717 1539243 0.151 0.88052
## TRB 578739 267706 2.162 0.03203 *
## AST 3937238 604690 6.511 8.08e-10 ***
## BLK 1858816 1101089 1.688 0.09321 .
## STL -1817269 1683175 -1.080 0.28182
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 5242000 on 170 degrees of freedom
## Multiple R-squared: 0.6525, Adjusted R-squared: 0.6382
## F-statistic: 45.6 on 7 and 170 DF, p-value: < 2.2e-16Una vez creados los modelos vacios y completos procedemos a ejecutar el paso stepwise de manera bidireccional
stepwise_total <- step(model_total_sin, scope = list(lower=model_total_sin, upper=model_total_con),direction = "both")## Start: AIC=14494.26
## Salary ~ 1
##
## Df Sum of Sq RSS AIC
## + `PTS/G` 1 1.4448e+16 2.1028e+16 14259
## + TOV 1 1.2495e+16 2.2982e+16 14300
## + `Min/G` 1 1.1616e+16 2.3860e+16 14317
## + AST 1 1.0490e+16 2.4987e+16 14338
## + TRB 1 8.4207e+15 2.7056e+16 14374
## + STL 1 6.5728e+15 2.8904e+16 14403
## + BLK 1 2.6966e+15 3.2780e+16 14460
## <none> 3.5476e+16 14494
##
## Step: AIC=14259.34
## Salary ~ `PTS/G`
##
## Df Sum of Sq RSS AIC
## + TRB 1 6.9499e+14 2.0333e+16 14246
## + AST 1 5.4437e+14 2.0484e+16 14250
## + BLK 1 3.1814e+14 2.0710e+16 14254
## + TOV 1 2.2108e+14 2.0807e+16 14257
## + STL 1 1.6112e+14 2.0867e+16 14258
## <none> 2.1028e+16 14259
## + `Min/G` 1 5.6485e+13 2.0972e+16 14260
## - `PTS/G` 1 1.4448e+16 3.5476e+16 14494
##
## Step: AIC=14246.12
## Salary ~ `PTS/G` + TRB
##
## Df Sum of Sq RSS AIC
## + AST 1 8.2386e+14 1.9509e+16 14229
## + TOV 1 1.4614e+14 2.0187e+16 14245
## + STL 1 1.1572e+14 2.0217e+16 14246
## <none> 2.0333e+16 14246
## + BLK 1 7.6931e+11 2.0332e+16 14248
## + `Min/G` 1 4.5678e+10 2.0333e+16 14248
## - TRB 1 6.9499e+14 2.1028e+16 14259
## - `PTS/G` 1 6.7225e+15 2.7056e+16 14374
##
## Step: AIC=14229.38
## Salary ~ `PTS/G` + TRB + AST
##
## Df Sum of Sq RSS AIC
## + TOV 1 1.2229e+14 1.9387e+16 14228
## <none> 1.9509e+16 14229
## + BLK 1 5.9627e+13 1.9450e+16 14230
## + `Min/G` 1 5.1510e+13 1.9458e+16 14230
## + STL 1 4.5928e+11 1.9509e+16 14231
## - AST 1 8.2386e+14 2.0333e+16 14246
## - TRB 1 9.7447e+14 2.0484e+16 14250
## - `PTS/G` 1 1.5489e+15 2.1058e+16 14262
##
## Step: AIC=14228.53
## Salary ~ `PTS/G` + TRB + AST + TOV
##
## Df Sum of Sq RSS AIC
## + `Min/G` 1 8.5671e+13 1.9301e+16 14228
## <none> 1.9387e+16 14228
## + BLK 1 5.0457e+13 1.9337e+16 14229
## - TOV 1 1.2229e+14 1.9509e+16 14229
## + STL 1 8.6879e+11 1.9386e+16 14230
## - AST 1 8.0002e+14 2.0187e+16 14245
## - TRB 1 1.0962e+15 2.0483e+16 14251
## - `PTS/G` 1 1.4864e+15 2.0873e+16 14260
##
## Step: AIC=14228.53
## Salary ~ `PTS/G` + TRB + AST + TOV + `Min/G`
##
## Df Sum of Sq RSS AIC
## <none> 1.9301e+16 14228
## - `Min/G` 1 8.5671e+13 1.9387e+16 14228
## + BLK 1 5.0375e+13 1.9251e+16 14229
## + STL 1 3.2924e+13 1.9268e+16 14230
## - TOV 1 1.5645e+14 1.9458e+16 14230
## - AST 1 8.8516e+14 2.0187e+16 14247
## - TRB 1 1.1687e+15 2.0470e+16 14253
## - `PTS/G` 1 1.3205e+15 2.0622e+16 14256summary(stepwise_total)##
## Call:
## lm(formula = Salary ~ `PTS/G` + TRB + AST + TOV + `Min/G`, data = NBA_salary_2)
##
## Residuals:
## Min 1Q Median 3Q Max
## -21787950 -3693228 -890723 2512855 24703534
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1427079 928922 -1.536 0.1252
## `PTS/G` 704422 127380 5.530 5.45e-08 ***
## TRB 929460 178658 5.202 3.00e-07 ***
## AST 1644334 363178 4.528 7.66e-06 ***
## TOV -2064264 1084466 -1.903 0.0576 .
## `Min/G` -110705 78594 -1.409 0.1597
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 6571000 on 447 degrees of freedom
## Multiple R-squared: 0.4559, Adjusted R-squared: 0.4499
## F-statistic: 74.92 on 5 and 447 DF, p-value: < 2.2e-16stepwise_SF_C <- step(model_SF_C_sin, scope = list(lower=model_SF_C_sin, upper=model_SF_C_con),direction = "both")## Start: AIC=5690.07
## Salary ~ 1
##
## Df Sum of Sq RSS AIC
## + AST 1 7.0310e+15 6.4122e+15 5560.3
## + `PTS/G` 1 6.9422e+15 6.5010e+15 5562.8
## + TOV 1 6.8252e+15 6.6180e+15 5565.9
## + `Min/G` 1 5.5853e+15 7.8579e+15 5596.5
## + TRB 1 5.0435e+15 8.3997e+15 5608.4
## + STL 1 2.8251e+15 1.0618e+16 5650.1
## + BLK 1 1.9809e+15 1.1462e+16 5663.7
## <none> 1.3443e+16 5690.1
##
## Step: AIC=5560.3
## Salary ~ AST
##
## Df Sum of Sq RSS AIC
## + TRB 1 1.3303e+15 5.0819e+15 5520.9
## + BLK 1 1.0888e+15 5.3233e+15 5529.2
## + `PTS/G` 1 1.0657e+15 5.3464e+15 5529.9
## + TOV 1 8.9949e+14 5.5127e+15 5535.4
## + `Min/G` 1 5.2205e+14 5.8901e+15 5547.2
## <none> 6.4122e+15 5560.3
## + STL 1 7.4204e+11 6.4114e+15 5562.3
## - AST 1 7.0310e+15 1.3443e+16 5690.1
##
## Step: AIC=5520.92
## Salary ~ AST + TRB
##
## Df Sum of Sq RSS AIC
## + `PTS/G` 1 2.5251e+14 4.8293e+15 5513.8
## + BLK 1 1.0388e+14 4.9780e+15 5519.2
## + TOV 1 8.5898e+13 4.9960e+15 5519.9
## <none> 5.0819e+15 5520.9
## + `Min/G` 1 2.1860e+13 5.0600e+15 5522.1
## + STL 1 1.7194e+13 5.0647e+15 5522.3
## - TRB 1 1.3303e+15 6.4122e+15 5560.3
## - AST 1 3.3178e+15 8.3997e+15 5608.4
##
## Step: AIC=5513.84
## Salary ~ AST + TRB + `PTS/G`
##
## Df Sum of Sq RSS AIC
## + BLK 1 7.2249e+13 4.7571e+15 5513.2
## + STL 1 6.9084e+13 4.7603e+15 5513.3
## <none> 4.8293e+15 5513.8
## + `Min/G` 1 4.7080e+13 4.7823e+15 5514.1
## + TOV 1 5.0538e+10 4.8293e+15 5515.8
## - `PTS/G` 1 2.5251e+14 5.0819e+15 5520.9
## - TRB 1 5.1707e+14 5.3464e+15 5529.9
## - AST 1 1.1960e+15 6.0253e+15 5551.2
##
## Step: AIC=5513.16
## Salary ~ AST + TRB + `PTS/G` + BLK
##
## Df Sum of Sq RSS AIC
## + STL 1 7.1469e+13 4.6856e+15 5512.5
## + `Min/G` 1 5.3550e+13 4.7035e+15 5513.1
## <none> 4.7571e+15 5513.2
## - BLK 1 7.2249e+13 4.8293e+15 5513.8
## + TOV 1 8.9487e+11 4.7562e+15 5515.1
## - TRB 1 1.5521e+14 4.9123e+15 5516.9
## - `PTS/G` 1 2.2088e+14 4.9780e+15 5519.2
## - AST 1 1.2661e+15 6.0232e+15 5553.2
##
## Step: AIC=5512.47
## Salary ~ AST + TRB + `PTS/G` + BLK + STL
##
## Df Sum of Sq RSS AIC
## <none> 4.6856e+15 5512.5
## - STL 1 7.1469e+13 4.7571e+15 5513.2
## - BLK 1 7.4634e+13 4.7603e+15 5513.3
## + `Min/G` 1 1.3504e+13 4.6721e+15 5514.0
## + TOV 1 1.8372e+12 4.6838e+15 5514.4
## - TRB 1 1.5100e+14 4.8366e+15 5516.1
## - `PTS/G` 1 2.7129e+14 4.9569e+15 5520.5
## - AST 1 1.3224e+15 6.0080e+15 5554.7summary(stepwise_SF_C)##
## Call:
## lm(formula = Salary ~ AST + TRB + `PTS/G` + BLK + STL, data = NBA_POSITION_SF_C)
##
## Residuals:
## Min 1Q Median 3Q Max
## -12888346 -2971610 -738107 2874299 19115602
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -3752884 891231 -4.211 4.09e-05 ***
## AST 3948121 566676 6.967 6.59e-11 ***
## TRB 563827 239488 2.354 0.01969 *
## `PTS/G` 397748 126040 3.156 0.00189 **
## BLK 1806713 1091544 1.655 0.09971 .
## STL -2356056 1454608 -1.620 0.10712
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 5219000 on 172 degrees of freedom
## Multiple R-squared: 0.6515, Adjusted R-squared: 0.6413
## F-statistic: 64.29 on 5 and 172 DF, p-value: < 2.2e-16Vemos en los dos modelos seleccionados, como el proceso de selección se para, en cuanto al añadir una variable, provoca que alguna de las variables ya seleccionadas deje de tener un alto grado de significancia. Por otro lado, vemos por un lado que el valor de p es menor de 0.005 por lo que podemos afirmar que en ambos se rechaza la hipótesis nula, o lo que es lo mismo los valores del modelo son significativos en el estudio del objeto. Por otro lado, observamos que el valor de r cuadrado difiere bastante entre los dos conjuntos, aunque por otro lado era de esperar. Mientras en el conjunto de datos total el modelo explica “solo” un 44% de la variación del salario en el modelo filtrado por posición explica casi un 65%. Como se ha dicho, esto era de espera ya que las correlaciones en el modelo filtrado eran mucho más fuertes que en el conjunto total de los datos.
Como último paso, creamos el modelo de predicción para cada uno de los modelos seleccionados y los customizamos para que una vez insertemos los datos del jugador elegido, el resultado sea más entendible. Por tanto, una vez creado el modelo de predicción de la función predict, vamos a introducir las estadísticas de la temporada 19/20 de algún jugador que haya acabado contrato, intentando saber cuándo debería percibir y compararlo con lo que realmente ha firmado. En este caso, vamos a escoger a dos jugadores para poder comparar los resultados, seleccionando dos jugadores que tengan realidades distintas, para poder analizar la eficacia del modelo. Los jugadores serán Serge Ibaka y Dario Saric.
NBA_salary_FIN_2 <- NBA_salary_2 %>%
rename(PTSG =`PTS/G`,
MING= `Min/G`
)
Prediccion_salario_total_STEPWISE <- function(m,Puntos,Rebotes,Asistencias,Perdidas,Minutos){
prediccion_nueva_total_STEPWISE <- predict(m, data.frame( PTSG = Puntos,TRB= Rebotes, AST = Asistencias,TOV=Perdidas,MING=Minutos))
msg <- paste(" STATS: PPG:", Puntos, ", TRB:", Rebotes, ", AST:", Asistencias,", TOV:", Perdidas,", MIN:", Minutos, " ==> Salario esperado: $", format(round(prediccion_nueva_total_STEPWISE), big.mark = ","), sep = "")
print(msg)
}
model_Saric_STEPWISE <- lm(formula = Salary ~ PTSG + TRB + AST + TOV + MING , data = NBA_salary_FIN_2)
Prediccion_salario_total_STEPWISE(model_Saric_STEPWISE, 10.7,6.2,1.9,1.3,24.7 )## [1] " STATS: PPG:10.7, TRB:6.2, AST:1.9, TOV:1.3, MIN:24.7 ==> Salario esperado: $9,579,168"model_Ibaka_STEPWISE <- lm(formula = Salary ~ PTSG + TRB + AST + TOV + MING , data = NBA_salary_FIN_2)
Prediccion_salario_total_STEPWISE(model_Ibaka_STEPWISE, 15.4,8.2,1.4,2,27 )## [1] " STATS: PPG:15.4, TRB:8.2, AST:1.4, TOV:2, MIN:27 ==> Salario esperado: $12,227,097"NBA_POSITION_SF_C_FIN <- NBA_POSITION_SF_C %>%
rename(PTSG =`PTS/G`
)
Prediccion_salario_SF_C_STEPWISE <- function(m,Asistencias,Rebotes,Puntos,Tapones,Robos){
prediccion_salario_SF_C_STEPWISE <- predict(m, data.frame(AST = Asistencias,TRB= Rebotes, PTSG = Puntos,BLK = Tapones,STL = Robos))
msg <- paste(" STATS: AST:", Asistencias, ", TRB:", Rebotes, ", PPG:", Puntos,", BLK:", Tapones,", STL:", Robos, " ==> Salario esperado: $", format(round(prediccion_salario_SF_C_STEPWISE), big.mark = ","), sep = "")
print(msg)
}
model_Saric_salario_SF_C_STEPWISE <- lm(formula = Salary ~ AST + TRB + PTSG + BLK + STL, data = NBA_POSITION_SF_C_FIN)
Prediccion_salario_SF_C_STEPWISE(model_Saric_salario_SF_C_STEPWISE, 1.9,6.2,10.7,0.2,0.6 )## [1] " STATS: AST:1.9, TRB:6.2, PPG:10.7, BLK:0.2, STL:0.6 ==> Salario esperado: $10,447,888"model_Ibaka_salario_SF_C_STEPWISE <- lm(formula = Salary ~ AST + TRB + PTSG + BLK + STL, data = NBA_POSITION_SF_C_FIN)
Prediccion_salario_SF_C_STEPWISE(model_Ibaka_salario_SF_C_STEPWISE, 1.4,8.2,15.4,0.8,0.5 )## [1] " STATS: AST:1.4, TRB:8.2, PPG:15.4, BLK:0.8, STL:0.5 ==> Salario esperado: $12,790,532"Primero comentar que el salario que van a percibir en sus nuevos contratos en la 20/21 va a ser de 9,250,000 para Dario Saric y de $9,258,000 para Serge Ibaka, por tanto, vemos como la predicción que hemos hecho funciona mejor en el caso de Dario Saric que en el Serge Ibaka. Como vemos el primer modelo, que explicaba sola un 44% de la variable, los resultados son más cercanos a la realidad que en el segundo modelo que logra explicar un 66% de la variación de la variable. En realidad, esto no es más que una práctica estadística, un juego con el que se pretende intentar acertar un valor futuro, pero está claro que si se quisiera conseguir un modelo mucho más ajustado deberíamos tener diferentes consideraciones.
Estamos manejando conjuntos de datos de poco tamaño (más aun en el conjunto filtrado) por lo que no es una muestra, bajo mi punto de vista, suficientemente representativa. Es muy posible que, aumentando la muestra a muchas más temporadas, el factor edad, por ejemplo, se convirtiera en más determinante para predecir el salario a percibir.
Hay un factor humano importante a la hora de firmar nuevos contratos y nuestro modelo no lo tiene en cuenta. El ejemplo que hemos visto de Ibaka, es un buen ejemplo ya que según nuestro modelo merecía mucho más dinero del que va a percibir y seguramente si hubiese querido lo hubiese querido, pero han existido factores personales que han influido (Aspirar a otro anillo, vivir en los Ángeles..) en la firma del contrato.