Caso 2 Comparación y evaluación de métricas de regresión lineal simple vs regresión polinomial en R

Librerías y csv

library(readr) # Para importar datos
library(dplyr) # Para filtrar   

## 
## Attaching package: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(knitr) # Para datos tabulares
library(ggplot2) # Para visualizar
library(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':
## 
##     layout

library(caret)  # Para particionar

## Loading required package: lattice

library(Metrics) # Para determinar rmse 

## 
## Attaching package: 'Metrics'

## The following objects are masked from 'package:caret':
## 
##     precision, recall

datos <- read.csv("https://raw.githubusercontent.com/rpizarrog/Analisis-Inteligente-de-datos/main/datos/datos.limpios.csv", stringsAsFactors = TRUE)
head(datos,10)

##    X.1  X              Name Age Nationality Overall Potential
## 1    1  1          L. Messi  31   Argentina      94        94
## 2    2  2 Cristiano Ronaldo  33    Portugal      94        94
## 3    3  3         Neymar Jr  26      Brazil      92        93
## 4    4  4            De Gea  27       Spain      91        93
## 5    5  5      K. De Bruyne  27     Belgium      91        92
## 6    6  6         E. Hazard  27     Belgium      91        91
## 7    7  7         L. Modric  32     Croatia      91        91
## 8    8  8      L. Su\xe1rez  31     Uruguay      91        91
## 9    9  9      Sergio Ramos  32       Spain      91        91
## 10  10 10          J. Oblak  25    Slovenia      90        93
##                   Club Preferred.Foot International.Reputation Weak.Foot
## 1         FC Barcelona           Left                        5         4
## 2             Juventus          Right                        5         4
## 3  Paris Saint-Germain          Right                        5         5
## 4    Manchester United          Right                        4         3
## 5      Manchester City          Right                        4         5
## 6              Chelsea          Right                        4         4
## 7          Real Madrid          Right                        4         4
## 8         FC Barcelona          Right                        5         4
## 9          Real Madrid          Right                        4         3
## 10  Atl\xe9tico Madrid          Right                        3         3
##    Skill.Moves Height Weight Crossing Finishing HeadingAccuracy ShortPassing
## 1            4    5'7 159lbs       84        95              70           90
## 2            5    6'2 183lbs       84        94              89           81
## 3            5    5'9 150lbs       79        87              62           84
## 4            1    6'4 168lbs       17        13              21           50
## 5            4   5'11 154lbs       93        82              55           92
## 6            4    5'8 163lbs       81        84              61           89
## 7            4    5'8 146lbs       86        72              55           93
## 8            3    6'0 190lbs       77        93              77           82
## 9            3    6'0 181lbs       66        60              91           78
## 10           1    6'2 192lbs       13        11              15           29
##    Volleys Dribbling Curve FKAccuracy LongPassing BallControl Acceleration
## 1       86        97    93         94          87          96           91
## 2       87        88    81         76          77          94           89
## 3       84        96    88         87          78          95           94
## 4       13        18    21         19          51          42           57
## 5       82        86    85         83          91          91           78
## 6       80        95    83         79          83          94           94
## 7       76        90    85         78          88          93           80
## 8       88        87    86         84          64          90           86
## 9       66        63    74         72          77          84           76
## 10      13        12    13         14          26          16           43
##    SprintSpeed Agility Reactions Balance ShotPower Jumping Stamina Strength
## 1           86      91        95      95        85      68      72       59
## 2           91      87        96      70        95      95      88       79
## 3           90      96        94      84        80      61      81       49
## 4           58      60        90      43        31      67      43       64
## 5           76      79        91      77        91      63      90       75
## 6           88      95        90      94        82      56      83       66
## 7           72      93        90      94        79      68      89       58
## 8           75      82        92      83        86      69      90       83
## 9           75      78        85      66        79      93      84       83
## 10          60      67        86      49        22      76      41       78
##    LongShots Aggression Interceptions Positioning Vision Penalties Composure
## 1         94         48            22          94     94        75        96
## 2         93         63            29          95     82        85        95
## 3         82         56            36          89     87        81        94
## 4         12         38            30          12     68        40        68
## 5         91         76            61          87     94        79        88
## 6         80         54            41          87     89        86        91
## 7         82         62            83          79     92        82        84
## 8         85         87            41          92     84        85        85
## 9         59         88            90          60     63        75        82
## 10        12         34            19          11     70        11        70
##    Marking StandingTackle SlidingTackle GKDiving GKHandling GKKicking
## 1       33             28            26        6         11        15
## 2       28             31            23        7         11        15
## 3       27             24            33        9          9        15
## 4       15             21            13       90         85        87
## 5       68             58            51       15         13         5
## 6       34             27            22       11         12         6
## 7       60             76            73       13          9         7
## 8       62             45            38       27         25        31
## 9       87             92            91       11          8         9
## 10      27             12            18       86         92        78
##    GKPositioning GKReflexes     Valor Estatura PesoKgs
## 1             14          8 110500000     1.70   72.12
## 2             14         11  77000000     1.88   83.01
## 3             15         11 118500000     1.75   68.04
## 4             88         94  72000000     1.93   76.20
## 5             10         13 102000000     1.80   69.85
## 6              8          8  93000000     1.73   73.94
## 7             14          9  67000000     1.73   66.22
## 8             33         37  80000000     1.83   86.18
## 9              7         11  51000000     1.83   82.10
## 10            88         89  68000000     1.88   87.09

Tabla de dispersión

g <- plot_ly(data = datos, 
             x = ~Overall, 
             y = ~Valor) %>%
layout(title = 'Jugadores FIFA. Dispersión de Overall y Valor')
g

## No trace type specified:
##   Based on info supplied, a 'scatter' trace seems appropriate.
##   Read more about this trace type -> https://plotly.com/r/reference/#scatter

## No scatter mode specifed:
##   Setting the mode to markers
##   Read more about this attribute -> https://plotly.com/r/reference/#scatter-mode

Datos de entrenamiento y validación

n <- nrow(datos)
set.seed(2022)

entrena <- createDataPartition(y = datos$Valor, p = 0.70, list = FALSE, times = 1)

# Datos entrenamiento
datos.entrenamiento <- datos[entrena, ]  # [renglones, columna]

# Datos validación
datos.validacion <- datos[-entrena, ]

Head(datos.entrenamiento)

kable(head(datos.entrenamiento[, c('X', 'Name', 'Overall', 'Valor')], 20), caption = "Datos de Entrenamiento. Primeros 20 registros")

Datos de Entrenamiento. Primeros 20 registros

	X	Name	Overall	Valor
1	1	L. Messi	94	110500000
2	2	Cristiano Ronaldo	94	77000000
3	3	Neymar Jr	92	118500000
4	4	De Gea	91	72000000
5	5	K. De Bruyne	91	102000000
6	6	E. Hazard	91	93000000
7	7	L. Modric	91	67000000
8	8	L. Surez	91	80000000
9	9	Sergio Ramos	91	51000000
10	10	J. Oblak	90	68000000
12	12	T. Kroos	90	76500000
13	13	D. Godn	90	44000000
14	14	David Silva	90	60000000
16	16	P. Dybala	89	89000000
17	17	H. Kane	89	83500000
19	19	M. ter Stegen	89	58000000
21	21	Sergio Busquets	89	51500000
22	22	E. Cavani	89	60000000
26	26	K. Mbapp	88	81000000
27	27	M. Salah	88	69500000

Tail(datos.entrenamiento)

kable(tail(datos.entrenamiento[, c('X', 'Name', 'Overall', 'Valor')], 20), caption = "Datos de Entrenamiento. Primeros 20 registros")

Datos de Entrenamiento. Primeros 20 registros

	X	Name	Overall	Valor
17879	17927	R. Roache	48	70000
17881	17929	J. Williams	48	50000
17883	17931	C. Maher	48	50000
17884	17932	Y. Gez	48	50000
17885	17933	D. Horton	48	40000
17886	17934	E. Tweed	48	50000
17887	17935	Zhang Yufeng	47	60000
17889	17937	L. Collins	47	60000
17891	17939	L. Watkins	47	60000
17892	17940	J. Norville-Williams	47	50000
17893	17941	S. Squire	47	50000
17894	17942	N. Fuentes	47	50000
17897	17945	K. Fujikawa	47	60000
17898	17946	D. Holland	47	60000
17899	17947	J. Livesey	47	60000
17900	17948	M. Baldisimo	47	70000
17901	17949	J. Young	47	60000
17902	17950	D. Walsh	47	60000
17906	17954	D. Walker-Rice	47	60000
17907	17955	G. Nugent	46	60000

Head(datos.validacion)

# kable(head(datos.validacion[, c('X', 'Name', 'Overall', 'Valor')], 20), caption = "Datos de Entrenamiento. Primeros 20 registros")
print("Datos de Entrenamiento. Primeros 20 registros")

## [1] "Datos de Entrenamiento. Primeros 20 registros"

head(datos.validacion[,c('X', 'Name', 'Overall', 'Valor')], 20)

##     X            Name Overall    Valor
## 11 11  R. Lewandowski      90 77000000
## 15 15     N. Kant\xe9      89 63000000
## 18 18    A. Griezmann      89 78000000
## 20 20     T. Courtois      89 53500000
## 23 23        M. Neuer      89 38000000
## 24 24    S. Ag\xfcero      89 64500000
## 25 25    G. Chiellini      89 27000000
## 41 41   S. Handanovic      88 30000000
## 42 42       G. Buffon      88  4000000
## 43 43       S. Umtiti      87 57000000
## 45 45    K. Koulibaly      87 51000000
## 51 51      D. Mertens      87 45000000
## 53 53 M. Ham\x9a\xedk      87 46500000
## 55 55        Piqu\xe9      87 34000000
## 58 58         Ederson      86 41500000
## 59 59      S. Man\xe9      86 52000000
## 67 67    T. M\xfcller      86 45000000
## 68 68          Thiago      86 45500000
## 72 72 T. Alderweireld      86 39000000
## 74 74      M. Benatia      86 30000000

Tail(datos.validacion)

kable(tail(datos.validacion[, c('X', 'Name', 'Overall', 'Valor')], 20), caption = "Datos de Entrenamiento. Primeros 20 registros")

Datos de Entrenamiento. Primeros 20 registros

	X	Name	Overall	Valor
17853	17901	R. Hughes	49	60000
17854	17902	J. Yabur	49	50000
17857	17905	Liu Guobo	48	60000
17860	17908	T. Lawal	48	60000
17862	17910	D. Szczepaniak	48	50000
17863	17911	P. Wieliczko	48	40000
17864	17912	T. Gundelund	48	50000
17865	17913	Wang Xin	48	40000
17869	17917	Wu Lei	48	40000
17874	17922	C. Hawkins	48	50000
17878	17926	T. Hillman	48	40000
17880	17928	L. Wahlstedt	48	50000
17882	17930	M. Hurst	48	40000
17888	17936	C. Ehlich	47	40000
17890	17938	A. Kaltner	47	60000
17895	17943	J. Milli	47	50000
17896	17944	S. Griffin	47	60000
17903	17951	J. Lundstram	47	60000
17904	17952	N. Christoffersson	47	60000
17905	17953	B. Worman	47	60000

Modelos de regresión

modelo.ls <- lm(formula = Valor ~ Overall, data = datos.entrenamiento)
modelo.ls

## 
## Call:
## lm(formula = Valor ~ Overall, data = datos.entrenamiento)
## 
## Coefficients:
## (Intercept)      Overall  
##   -32561108       529109

Coeficientes del modelo

a <- modelo.ls$coefficients[1]
b <- modelo.ls$coefficients[2]

paste("Valor de la abcisa a es   : ", round(a, 6))

## [1] "Valor de la abcisa a es   :  -32561107.927016"

paste("Valor de la pendiente b es: ", round(b, 6))

## [1] "Valor de la pendiente b es:  529109.218444"

Línea de tendencia del modelo y predicciones

g <- plot_ly(data = datos.entrenamiento, 
             x = ~Overall, 
             y = ~Valor, 
             name = 'Dispersión',
             type = 'scatter', 
             mode = 'markers', 
             color = I('blue')) 
g <- g %>% add_trace(x = ~Overall,
                     y = ~modelo.ls$fitted.values, name = 'Tendencia', mode = 'lines+markers', color = I('red'))
g <- g %>%
layout(title = 'Jugadores FIFA. Dispersión y Tendencia de Overall y Valor económico.')
g

predicciones <- predict(object = modelo.ls, newdata = datos.validacion)

comparaciones <- data.frame(Overall = datos.validacion$Overall, Valor = datos.validacion$Valor, predicccion = predicciones)

Predicciones

predicciones <- predict(object = modelo.ls, newdata = datos.validacion)

comparaciones <- data.frame(Overall = datos.validacion$Overall, Valor = datos.validacion$Valor, predicccion = predicciones)

Head(comparaciones,20)

kable(x = head(comparaciones, 20), caption = "Predicciones")

Predicciones

	Overall	Valor	predicccion
11	90	77000000	15058722
15	89	63000000	14529613
18	89	78000000	14529613
20	89	53500000	14529613
23	89	38000000	14529613
24	89	64500000	14529613
25	89	27000000	14529613
41	88	30000000	14000503
42	88	4000000	14000503
43	87	57000000	13471394
45	87	51000000	13471394
51	87	45000000	13471394
53	87	46500000	13471394
55	87	34000000	13471394
58	86	41500000	12942285
59	86	52000000	12942285
67	86	45000000	12942285
68	86	45500000	12942285
72	86	39000000	12942285
74	86	30000000	12942285

Tail(comparaciones,20)

kable(x = tail(comparaciones, 20), caption = "Predicciones")

Predicciones

	Overall	Valor	predicccion
17853	49	60000	-6634756
17854	49	50000	-6634756
17857	48	60000	-7163865
17860	48	60000	-7163865
17862	48	50000	-7163865
17863	48	40000	-7163865
17864	48	50000	-7163865
17865	48	40000	-7163865
17869	48	40000	-7163865
17874	48	50000	-7163865
17878	48	40000	-7163865
17880	48	50000	-7163865
17882	48	40000	-7163865
17888	47	40000	-7692975
17890	47	60000	-7692975
17895	47	50000	-7692975
17896	47	60000	-7692975
17903	47	60000	-7692975
17904	47	60000	-7692975
17905	47	60000	-7692975

Determinano métricas

res.modelo.ls <- summary(modelo.ls)
res.modelo.ls

## 
## Call:
## lm(formula = Valor ~ Overall, data = datos.entrenamiento)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
##  -9325848  -2192974   -926882   1064555 102383060 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -32561108     393188  -82.81   <2e-16 ***
## Overall        529109       5904   89.62   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 4594000 on 12535 degrees of freedom
## Multiple R-squared:  0.3905, Adjusted R-squared:  0.3905 
## F-statistic:  8031 on 1 and 12535 DF,  p-value: < 2.2e-16

RMSE

rmse.ls <- rmse(actual =comparaciones$Valor, predicted = comparaciones$predicccion)
rmse.ls

## [1] 3790297

Regresión polinómica segundo nivel

modelo.poly2 <- lm(formula = Valor ~ poly(Overall, 2), data = datos.entrenamiento, )
modelo.poly2

## 
## Call:
## lm(formula = Valor ~ poly(Overall, 2), data = datos.entrenamiento)
## 
## Coefficients:
##       (Intercept)  poly(Overall, 2)1  poly(Overall, 2)2  
##           2483040          411719109          401465284

Coeficientes del modelo

a <- modelo.poly2$coefficients[1]
b <- modelo.poly2$coefficients[2]

paste("Valor de la abcisa a es   : ", round(a, 6))

## [1] "Valor de la abcisa a es   :  2483040.201005"

paste("Valor de la pendiente b es: ", round(b, 6))

## [1] "Valor de la pendiente b es:  411719108.763639"

Curva de tendencia del modelo

g <- plot_ly(data = datos.entrenamiento, 
             x = ~Overall, 
             y = ~Valor, 
             name = 'Dispersión',
             type = 'scatter', 
             mode = 'markers', 
             color = I('blue')) 
g <- g %>% add_trace(x = ~Overall,
                     y = ~modelo.poly2$fitted.values, name = 'Tendencia', mode = 'lines+markers', color = I('red'))
g <- g %>%
layout(title = 'Jugadores FIFA. Dispersión y Tendencia de Overall y Valor económico.')
g

Predicciones

predicciones <- predict(object = modelo.poly2, newdata = datos.validacion)

comparaciones <- data.frame(Overall = datos.validacion$Overall, Valor = datos.validacion$Valor, predicccion = predicciones)

Head(comparaciones,20)

kable(x = head(comparaciones, 20), caption = "Predicciones")

Predicciones

	Overall	Valor	predicccion
11	90	77000000	40693279
15	89	63000000	37820662
18	89	78000000	37820662
20	89	53500000	37820662
23	89	38000000	37820662
24	89	64500000	37820662
25	89	27000000	37820662
41	88	30000000	35050059
42	88	4000000	35050059
43	87	57000000	32381470
45	87	51000000	32381470
51	87	45000000	32381470
53	87	46500000	32381470
55	87	34000000	32381470
58	86	41500000	29814896
59	86	52000000	29814896
67	86	45000000	29814896
68	86	45500000	29814896
72	86	39000000	29814896
74	86	30000000	29814896

Tail(comparaciones,20)

kable(x = tail(comparaciones, 20), caption = "Predicciones")

Predicciones

	Overall	Valor	predicccion
17853	49	60000	6567594
17854	49	50000	6567594
17857	48	60000	7877558
17860	48	60000	7877558
17862	48	50000	7877558
17863	48	40000	7877558
17864	48	50000	7877558
17865	48	40000	7877558
17869	48	40000	7877558
17874	48	50000	7877558
17878	48	40000	7877558
17880	48	50000	7877558
17882	48	40000	7877558
17888	47	40000	9289535
17890	47	60000	9289535
17895	47	50000	9289535
17896	47	60000	9289535
17903	47	60000	9289535
17904	47	60000	9289535
17905	47	60000	9289535

Determinando métricas

res.modelo.poly2 <- summary(modelo.poly2)
res.modelo.poly2

## 
## Call:
## lm(formula = Valor ~ poly(Overall, 2), data = datos.entrenamiento)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -20787789   -957976    379606   1274866  71755444 
## 
## Coefficients:
##                    Estimate Std. Error t value Pr(>|t|)    
## (Intercept)         2483040      25651    96.8   <2e-16 ***
## poly(Overall, 2)1 411719109    2872143   143.3   <2e-16 ***
## poly(Overall, 2)2 401465284    2872143   139.8   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 2872000 on 12534 degrees of freedom
## Multiple R-squared:  0.7618, Adjusted R-squared:  0.7618 
## F-statistic: 2.004e+04 on 2 and 12534 DF,  p-value: < 2.2e-16

RMSE

rmse.poly2 <- rmse(actual =comparaciones$Valor, predicted = comparaciones$predicccion)
rmse.poly2

## [1] 2399261

Regresión polinómica quinto nivel

modelo.poly5 <- lm(formula = Valor ~ poly(Overall, 5), data = datos.entrenamiento, )
modelo.poly5

## 
## Call:
## lm(formula = Valor ~ poly(Overall, 5), data = datos.entrenamiento)
## 
## Coefficients:
##       (Intercept)  poly(Overall, 5)1  poly(Overall, 5)2  poly(Overall, 5)3  
##           2483040          411719109          401465284          240065754  
## poly(Overall, 5)4  poly(Overall, 5)5  
##          73300131            4422343

Coeficientes del modelo

a <- modelo.poly5$coefficients[1]
b <- modelo.poly5$coefficients[2]
paste("Valor de la abcisa a es   : ", round(a, 6))

## [1] "Valor de la abcisa a es   :  2483040.201005"

paste("Valor de la pendiente b es: ", round(b, 6))

## [1] "Valor de la pendiente b es:  411719108.763635"

Curva de tendencia del modelo

g <- plot_ly(data = datos.entrenamiento, 
             x = ~Overall, 
             y = ~Valor, 
             name = 'Dispersión',
             type = 'scatter', 
             mode = 'markers', 
             color = I('blue')) 
g <- g %>% add_trace(x = ~Overall,
                     y = ~modelo.poly5$fitted.values, name = 'Tendencia', mode = 'lines+markers', color = I('red'))
g <- g %>%
layout(title = 'Jugadores FIFA. Dispersión y Tendencia de Overall y Valor económico.')
g

Predicciones

predicciones <- predict(object = modelo.poly5, newdata = datos.validacion)

comparaciones <- data.frame(Overall = datos.validacion$Overall, Valor = datos.validacion$Valor, predicccion = predicciones)

Head(comparaciones,20)

kable(x = head(comparaciones, 20), caption = "Predicciones")

Predicciones

	Overall	Valor	predicccion
11	90	77000000	69316050
15	89	63000000	60933762
18	89	78000000	60933762
20	89	53500000	60933762
23	89	38000000	60933762
24	89	64500000	60933762
25	89	27000000	60933762
41	88	30000000	53359828
42	88	4000000	53359828
43	87	57000000	46537655
45	87	51000000	46537655
51	87	45000000	46537655
53	87	46500000	46537655
55	87	34000000	46537655
58	86	41500000	40413068
59	86	52000000	40413068
67	86	45000000	40413068
68	86	45500000	40413068
72	86	39000000	40413068
74	86	30000000	40413068

Tail(comparaciones,20)

kable(x = tail(comparaciones, 20), caption = "Predicciones")

Predicciones

	Overall	Valor	predicccion
17853	49	60000	90553.05
17854	49	50000	90553.05
17857	48	60000	166366.43
17860	48	60000	166366.43
17862	48	50000	166366.43
17863	48	40000	166366.43
17864	48	50000	166366.43
17865	48	40000	166366.43
17869	48	40000	166366.43
17874	48	50000	166366.43
17878	48	40000	166366.43
17880	48	50000	166366.43
17882	48	40000	166366.43
17888	47	40000	286125.28
17890	47	60000	286125.28
17895	47	50000	286125.28
17896	47	60000	286125.28
17903	47	60000	286125.28
17904	47	60000	286125.28
17905	47	60000	286125.28

Determinando métricas

res.modelo.poly5 <- summary(modelo.poly5)
res.modelo.poly5

## 
## Call:
## lm(formula = Valor ~ poly(Overall, 5), data = datos.entrenamiento)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -35147491   -168569       531    156431  29755608 
## 
## Coefficients:
##                    Estimate Std. Error t value Pr(>|t|)    
## (Intercept)         2483040      16030 154.894   <2e-16 ***
## poly(Overall, 5)1 411719109    1794919 229.380   <2e-16 ***
## poly(Overall, 5)2 401465284    1794919 223.668   <2e-16 ***
## poly(Overall, 5)3 240065754    1794919 133.747   <2e-16 ***
## poly(Overall, 5)4  73300131    1794919  40.838   <2e-16 ***
## poly(Overall, 5)5   4422343    1794919   2.464   0.0138 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1795000 on 12531 degrees of freedom
## Multiple R-squared:  0.907,  Adjusted R-squared:  0.907 
## F-statistic: 2.444e+04 on 5 and 12531 DF,  p-value: < 2.2e-16

RMSE

rmse.poly5 <- rmse(actual =comparaciones$Valor, predicted = comparaciones$predicccion)
rmse.poly5

## [1] 1717544

Apreciación personal e Interpretación

Descripción

Esta apreciación valorará la estatura de porteros con la media que estos tengan en el videojuego, ya que, el mejor portero actualmente, Thibaut Courtois, mide 1.98 mts. Para seleccionar sólo los porteros, hice un Dataframe con el filtro de que el valor del campo GKReflexex debe ser mayor a 65, ya que ese campo corresponde a los reflejos de un portero.

Partir datos

datos.gk <- filter(datos, GKReflexes >= 65)
paste("Primeros 20 jugadores del Dataframe de porteros.")

## [1] "Primeros 20 jugadores del Dataframe de porteros."

head(datos.gk[,c("Name","Overall","Estatura")], 20)

##                 Name Overall Estatura
## 1             De Gea      91     1.93
## 2           J. Oblak      90     1.88
## 3      M. ter Stegen      89     1.88
## 4        T. Courtois      89     1.98
## 5           M. Neuer      89     1.93
## 6          H. Lloris      88     1.88
## 7      S. Handanovic      88     1.93
## 8          G. Buffon      88     1.93
## 9           K. Navas      87     1.85
## 10           Ederson      86     1.88
## 11           Alisson      85     1.91
## 12       W. Szczesny      85     1.96
## 13          A. Lopes      84     1.83
## 14          M. Perin      84     1.88
## 15           B. Leno      84     1.91
## 16 L. Hr\xe1deck\xfd      84     1.93
## 17     Sergio Asenjo      84     1.88
## 18        S. Ruffier      84     1.88
## 19     K. Schmeichel      84     1.88
## 20              Kepa      83     1.85

# datos.gk

set.seed(2002)
entrena <- createDataPartition(y = datos.gk$Overall, p = 0.70, list = FALSE, times = 1)
datos.entr <- datos.gk[entrena,]
datos.val <- datos.gk[-entrena,]

paste("Primeros 20 valores del dataframe a entrenar")

## [1] "Primeros 20 valores del dataframe a entrenar"

head(datos.entr[order(datos.entr$Overall, decreasing = TRUE),], 20) %>% select(c("Name","Overall","Estatura"))

##                 Name Overall Estatura
## 1             De Gea      91     1.93
## 2           J. Oblak      90     1.88
## 3      M. ter Stegen      89     1.88
## 4        T. Courtois      89     1.98
## 5           M. Neuer      89     1.93
## 8          G. Buffon      88     1.93
## 9           K. Navas      87     1.85
## 11           Alisson      85     1.91
## 12       W. Szczesny      85     1.96
## 14          M. Perin      84     1.88
## 16 L. Hr\xe1deck\xfd      84     1.93
## 17     Sergio Asenjo      84     1.88
## 18        S. Ruffier      84     1.88
## 19     K. Schmeichel      84     1.88
## 21       J. Pickford      83     1.85
## 22           T. Horn      83     1.93
## 23              Neto      83     1.91
## 24        O. Baumann      83     1.88
## 26    R. F\xe4hrmann      83     1.98
## 28   Rui Patr\xedcio      83     1.91

paste("Primeros 20 valores del dataframe para validar")

## [1] "Primeros 20 valores del dataframe para validar"

head(datos.val[order(datos.val$Overall, decreasing = TRUE),], 20) %>% select(c("Name","Overall","Estatura"))

##                Name Overall Estatura
## 6         H. Lloris      88     1.88
## 7     S. Handanovic      88     1.93
## 10          Ederson      86     1.88
## 13         A. Lopes      84     1.83
## 15          B. Leno      84     1.91
## 20             Kepa      83     1.85
## 25    D. Suba\x9aic      83     1.91
## 27          Ad\xe1n      83     1.91
## 30      S. Mandanda      83     1.85
## 35 Raphaelito Anjos      82     1.91
## 38      K. Casteels      82     1.98
## 39      R. B\xfcrki      82     1.88
## 44         Casillas      82     1.85
## 46       B. Lecomte      81     1.85
## 47        A. Areola      81     1.96
## 49     L. Fabianski      81     1.91
## 55          N. Pope      80     2.01
## 62        S. Romero      80     1.93
## 66          Moy\xe1      80     1.88
## 67    S. Sorrentino      80     1.85

Al parecer, el filtro funcionó bien, ya que, al menos a simple apreciación, los 20 primeros jugadores del Dataframe filtrado juegan en la posición de guardameta.

Modelo

g <- plot_ly(data = datos.entr,
             x = ~Estatura,
             y = ~Overall) %>%
  layout(title = 'Jugadores FIFA. Dispersión de valor en miles de millones y su media en el juego.')
g

## No trace type specified:
##   Based on info supplied, a 'scatter' trace seems appropriate.
##   Read more about this trace type -> https://plotly.com/r/reference/#scatter

## No scatter mode specifed:
##   Setting the mode to markers
##   Read more about this attribute -> https://plotly.com/r/reference/#scatter-mode

En la anterior gráfica podemos observar qeu los datos están muy dispersos, ya que existe una gran variedad de porteros con diferentes estaturas con diferente media.

modelo <- lm(data = datos.entr, formula = Overall ~ Estatura)
modelo

## 
## Call:
## lm(formula = Overall ~ Estatura, data = datos.entr)
## 
## Coefficients:
## (Intercept)     Estatura  
##       44.40        13.39

Coeficientes del modelo

a <- modelo$coefficients[1]
b <- modelo$coefficients[2]
paste("Valor de la abcisa a es   : ", round(a, 6))

## [1] "Valor de la abcisa a es   :  44.399511"

paste("Valor de la abcisa b es   : ", round(b, 6))

## [1] "Valor de la abcisa b es   :  13.392973"

Línea de tendencia del modelo

g <- plot_ly(data = datos.entr,
             x = ~Estatura,
             y = ~Overall,
             name = "Dispersión",
             type = "scatter",
             mode = "markers",
             color = I("Blue"))
g <- g %>% add_trace(x = ~Estatura,
                     y = ~modelo$fitted.values, name = "Tendencia", mode = "lines+markers", color = I("red"))
g <- g %>% layout(title = "Jugadores FIFA. Dispersión y Tendencia de Estatura y Media según el juego.")
g

Como podemos observar, la línea de tendencia del modelo pasa casi por el centro exacto de la gráfica, esto se debe a que en los hemisferios superior e inferior de la recta, existen casi la misma cantidad de resultados que se contrarrestan. Por ejemplo, un jugador de 1.80 mts, puede tener una media de tanto 50 puntos como de 91, según las predicciones del modelo.

Predicciones

predicciones <- predict(object = modelo, newdata = datos.val)
comparaciones <- data.frame(Nombre = datos.val$Name, Valor = datos.val$Estatura, Overall = datos.val$Overall, prediccion = predicciones)

kable(x = head(comparaciones, 20), caption = "Predicciones")

Predicciones

	Nombre	Valor	Overall	prediccion
6	H. Lloris	1.88	88	69.57830
7	S. Handanovic	1.93	88	70.24795
10	Ederson	1.88	86	69.57830
13	A. Lopes	1.83	84	68.90865
15	B. Leno	1.91	84	69.98009
20	Kepa	1.85	83	69.17651
25	D. Suba<9a>ic	1.91	83	69.98009
27	Adn	1.91	83	69.98009
30	S. Mandanda	1.85	83	69.17651
35	Raphaelito Anjos	1.91	82	69.98009
38	K. Casteels	1.98	82	70.91760
39	R. Brki	1.88	82	69.57830
44	Casillas	1.85	82	69.17651
46	B. Lecomte	1.85	81	69.17651
47	A. Areola	1.96	81	70.64974
49	L. Fabianski	1.91	81	69.98009
55	N. Pope	2.01	80	71.31939
62	S. Romero	1.93	80	70.24795
66	Moy	1.88	80	69.57830
67	S. Sorrentino	1.85	80	69.17651

Como podemos apreciar, la predicción de cualquier resultado apenas es diferente de cualquier otro, esto debido a la línea de tendencia mostrada en la gráfica anterior.

x <- c(1.60, 1.80, 2.00)

Y = a + b * x
Y

## [1] 65.82827 68.50686 71.18546

Aquí se aprecia la media que debería tener jugadores con 1.60, 1.80 y 2mts de estatura, respectivamente.

Evaluación del modelo

summary(modelo)

## 
## Call:
## lm(formula = Overall ~ Estatura, data = datos.entr)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -13.1765  -3.9087  -0.9488   3.0199  20.7521 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)   44.400      7.778   5.709 1.62e-08 ***
## Estatura      13.393      4.118   3.252   0.0012 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 5.417 on 780 degrees of freedom
## Multiple R-squared:  0.01338,    Adjusted R-squared:  0.01211 
## F-statistic: 10.57 on 1 and 780 DF,  p-value: 0.001196

Por último, podemos apreciar que el modelo no se representa para nada bien con los datos escogidos. Esto ya que obtuvimos una certeza acertada de la R cuadrada de 0.001094, osea un 0.1% de acierto. Esto contrastado con la realidad me dice que, obivamente, para calcular de una forma más correcta la media de cualquier portero, hacen falta más de un valor. Estos valores pueden ser GKDibing, GKHangling, GKKicking, etc, todos correspondientes a datos de portero, además de datos generales como la Stamina, Agility o el LongPassing.

Valores residuales

Fórmula general con el modelo

n <- nrow(datos.entr)
rmse <- sqrt(sum(modelo$residuals ^ 2) / n) 
rmse

## [1] 5.410353

Fórmula general con el dataframe comparaciones

n <- nrow(comparaciones)
rmse1 <- sqrt(sum((comparaciones$Overall - comparaciones$prediccion)^2) / n)
rmse1

## [1] 5.458249

RMSE de librería Metrics

rmse2 <- rmse(actual = comparaciones$Overall, predicted = comparaciones$prediccion)
rmse2

## [1] 5.458249

RMSE de librería Caret

rmse3 <- RMSE(obs = comparaciones$Overall, pred = comparaciones$prediccion)
rmse3

## [1] 5.458249