Paula Cazali

Fiabilidad

El Analisis de componentes Principales se utiliza para datasets que tienen muchas variables. Con este analisis se puede reducir el numero de variables para ya poder obtener un modelo a partir de las componentes principales.

Ejercicio con mtcars

  • Usar mtcars para predecir millas por galon
  • Listar las componentes principales menos millas por galon.
  • Usando las dos componentes principales, hacer una regresion lineal para predecir las millas por galon.
library(factoextra)
library(tidyr)
library(dplyr)
library(caret)

Las componentes principales son dadas por la direccion del aigenvector de la mayor varianza. De este analisis se pueden obtener las componentes principales, esto reduce la cantidad de variables del dataset. Luego de elegir las componentes principales, ya se puede formar un modelo con esas componentes principales, pero hay que tomar en cuenta que cuando ingrese nueva data tienen que pasar por la transformacion PCA antes de utilizarla en el modelo.

head(mtcars)
train_index <- createDataPartition(mtcars$mpg, p = 0.7, list = F)
train <- mtcars[train_index,]
test <- mtcars[-train_index,]

Los argumentos de center = TRUE y scale = TRUE estandariza la data, coloca las medias en el centro y las desviaciones estandar en 1. La siguiente grafica muestra un screeplot, el cual grafica las varianzas y las dimensiones. Como se ve en la grafica, las primeras dos componentes son las que tienen mayor aporte.

mtcars_pca <- prcomp(train %>% select(-mpg), center = TRUE, scale= TRUE)
fviz_eig(mtcars_pca)

Con summary() se puede ver la importancia de cada una de las componentes. Como se ve PC1 y PC2 aportan el \(80\%\).

summary(mtcars_pca)
Importance of components:
                          PC1    PC2     PC3     PC4    PC5     PC6     PC7     PC8     PC9    PC10
Standard deviation     2.3736 1.6649 0.77933 0.56854 0.4626 0.43499 0.32435 0.29936 0.21167 0.14340
Proportion of Variance 0.5634 0.2772 0.06073 0.03232 0.0214 0.01892 0.01052 0.00896 0.00448 0.00206
Cumulative Proportion  0.5634 0.8406 0.90133 0.93366 0.9551 0.97398 0.98450 0.99346 0.99794 1.00000
fviz_pca_var(mtcars_pca,
             col.var = "cos2", # Color by contributions to the PC
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE     # Avoid text overlapping
)

fviz_pca_biplot(mtcars_pca, repel = TRUE,
                col.var = "#2E9FDF", # Variables color
                col.ind = "#696969"  # Individuals color
)

En el componente x del PCA se pueden ver todas las componentes principales, en este caso usaremos las primeras dos.

mtcars_pca$x[,1:2]
                           PC1         PC2
Mazda RX4 Wag       -0.3283417 -1.41127464
Datsun 710          -2.5434976 -0.09665827
Hornet Sportabout    2.0854542  0.97087799
Valiant             -0.1726545  2.62510966
Merc 240D           -1.7941857  1.28303194
Merc 230            -2.1583480  1.67757856
Merc 280            -0.5259851  0.12367543
Merc 280C           -0.6010210  0.25779356
Merc 450SE           2.2162853  0.92152877
Merc 450SLC          2.0328881  1.00248266
Cadillac Fleetwood   3.5491175  1.13450719
Lincoln Continental  3.6057804  1.05007926
Honda Civic         -3.5958154 -0.91726231
Toyota Corolla      -3.3590211 -0.01309697
Toyota Corona       -1.8860487  1.90283478
AMC Javelin          1.7458405  1.09225598
Camaro Z28           2.6935508 -0.33959563
Pontiac Firebird     2.4001826  1.11166067
Fiat X1-9           -3.0850657 -0.14285198
Lotus Europa        -2.6187544 -1.56289422
Ford Pantera L       1.5064908 -3.25529562
Ferrari Dino         0.3084568 -2.99189861
Maserati Bora        2.7876758 -3.99151209
Volvo 142E          -2.2629839 -0.43107609

Graficamos los valores de mpg en base a las componentes principales PC1 y PC2:

plot(mtcars_pca$x[,1:2], col = as.factor(train$mpg) ,xlim = c(-5,5), ylim=c(-5,4))
text(mtcars_pca$x[,1:2], train$mpg,pos=1 )

Ahora se va a armar un dataset que contenga la variable mpg y las componentes principales 1 y 2. Con este dataset se armara el modelo.

new_mtcars_pca <- cbind(mpg = train$mpg, mtcars_pca$x[,1:2]) %>% as_tibble()
head(new_mtcars_pca)

Creamos una regresion lineal para predecir mpg usando el primer componente principal 1 y el componente principal 2, usando el train.

fit_mtcars <- lm(mpg ~ PC1 + PC2 , data = new_mtcars_pca)
summary(fit_mtcars)

Call:
lm(formula = mpg ~ PC1 + PC2, data = new_mtcars_pca)

Residuals:
    Min      1Q  Median      3Q     Max 
-3.9443 -1.6599 -0.5279  0.9746  6.1843 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept)  20.0125     0.5591  35.795  < 2e-16 ***
PC1          -2.2920     0.2406  -9.526  4.5e-09 ***
PC2          -0.3365     0.3430  -0.981    0.338    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 2.739 on 21 degrees of freedom
Multiple R-squared:  0.8137,    Adjusted R-squared:  0.7959 
F-statistic: 45.85 on 2 and 21 DF,  p-value: 2.177e-08

Para poder usar un test para predicciones primero es necesario que el dataset de test se transforme a terminos de componentes principales. Por esa razon se utiliza predict() el PCA que se realizo con el train.

test_pca <- predict(mtcars_pca, test %>% select(-mpg))
test_pca
                         PC1         PC2        PC3         PC4         PC5        PC6         PC7         PC8         PC9
Mazda RX4         -0.3535915 -1.58319943  0.7242817  0.03252331  0.47008669  1.0623399  0.07952981  0.20696210  0.04842286
Hornet 4 Drive    -0.2236045  2.23554667  0.1848449  0.48269371 -0.12144790 -0.6125741 -0.27560081  0.13211989 -0.22336323
Duster 360         2.8733368 -0.01009127  0.4356796 -0.19810689  0.50465057 -0.4581975 -0.44943562 -0.29001243  0.28623385
Merc 450SL         2.0642290  0.90390432  0.4109033  0.20227823  0.53458807  0.1650192 -0.01307466 -0.28004366 -0.15207620
Chrysler Imperial  3.5046193  0.75756830 -0.4973392 -0.46744901 -0.72544380  0.2443670 -0.26412077  0.18604003  0.17113227
Fiat 128          -3.0582778  0.03297256  0.4676402  0.11228229 -0.40747226  0.2522092 -0.09568744 -0.03470548 -0.16878227
Dodge Challenger   2.1027513  1.22754110  1.0732512  0.69243243  0.47585961 -0.1039200  0.21259414  0.18604897 -0.07025799
Porsche 914-2     -2.0471016 -2.03306510  0.8758061 -0.22790529  0.01228979  0.5836978  1.20388952  0.20869364  0.85665266
                         PC10
Mazda RX4         -0.11842757
Hornet 4 Drive    -0.27219521
Duster 360        -0.24539235
Merc 450SL         0.12525207
Chrysler Imperial  0.19372519
Fiat 128           0.12279837
Dodge Challenger  -0.05751317
Porsche 914-2      0.45903095

Ahora ya se pueden hacer predicciones con ese test usando la regresion lineal anterior.

test_dataframe <- test_pca[,1:2] %>% as_tibble()
predict(fit_mtcars, test_dataframe)
       1        2        3        4        5        6        7        8 
21.35567 19.77274 13.43025 14.97716 11.72504 27.01093 14.77996 25.38855 
LS0tDQp0aXRsZTogIlByaW5jaXBhbCBDb21wb25lbnQgQW5hbHlzaXM6IG10Y2FycyINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCiMjIFBhdWxhIENhemFsaQ0KIyMjIEZpYWJpbGlkYWQNCg0KRWwgQW5hbGlzaXMgZGUgY29tcG9uZW50ZXMgUHJpbmNpcGFsZXMgc2UgdXRpbGl6YSBwYXJhIGRhdGFzZXRzIHF1ZSB0aWVuZW4gbXVjaGFzIHZhcmlhYmxlcy4gQ29uIGVzdGUgYW5hbGlzaXMgc2UgcHVlZGUgcmVkdWNpciBlbCBudW1lcm8gZGUgdmFyaWFibGVzIHBhcmEgeWEgcG9kZXIgb2J0ZW5lciB1biBtb2RlbG8gYSBwYXJ0aXIgZGUgbGFzIGNvbXBvbmVudGVzIHByaW5jaXBhbGVzLg0KDQoqKkVqZXJjaWNpbyBjb24gbXRjYXJzKioNCg0KKiBVc2FyIG10Y2FycyBwYXJhIHByZWRlY2lyIG1pbGxhcyBwb3IgZ2Fsb24NCiogTGlzdGFyIGxhcyBjb21wb25lbnRlcyBwcmluY2lwYWxlcyBtZW5vcyBtaWxsYXMgcG9yIGdhbG9uLg0KKiBVc2FuZG8gbGFzIGRvcyBjb21wb25lbnRlcyBwcmluY2lwYWxlcywgaGFjZXIgdW5hIHJlZ3Jlc2lvbiBsaW5lYWwgcGFyYSBwcmVkZWNpciBsYXMgbWlsbGFzIHBvciBnYWxvbi4NCg0KYGBge3J9DQpsaWJyYXJ5KGZhY3RvZXh0cmEpDQpsaWJyYXJ5KHRpZHlyKQ0KbGlicmFyeShkcGx5cikNCmxpYnJhcnkoY2FyZXQpDQpgYGANCg0KTGFzIGNvbXBvbmVudGVzIHByaW5jaXBhbGVzIHNvbiBkYWRhcyBwb3IgbGEgZGlyZWNjaW9uIGRlbCBhaWdlbnZlY3RvciBkZSBsYSBtYXlvciB2YXJpYW56YS4gRGUgZXN0ZSBhbmFsaXNpcyBzZSBwdWVkZW4gb2J0ZW5lciBsYXMgY29tcG9uZW50ZXMgcHJpbmNpcGFsZXMsIGVzdG8gcmVkdWNlIGxhIGNhbnRpZGFkIGRlIHZhcmlhYmxlcyBkZWwgZGF0YXNldC4gDQpMdWVnbyBkZSBlbGVnaXIgbGFzIGNvbXBvbmVudGVzIHByaW5jaXBhbGVzLCB5YSBzZSBwdWVkZSBmb3JtYXIgdW4gbW9kZWxvIGNvbiBlc2FzIGNvbXBvbmVudGVzIHByaW5jaXBhbGVzLCBwZXJvIGhheSBxdWUgdG9tYXIgZW4gY3VlbnRhIHF1ZSBjdWFuZG8gaW5ncmVzZSBudWV2YSBkYXRhIHRpZW5lbiBxdWUgcGFzYXIgcG9yIGxhIHRyYW5zZm9ybWFjaW9uIFBDQSBhbnRlcyBkZSB1dGlsaXphcmxhIGVuIGVsIG1vZGVsby4NCg0KYGBge3J9DQpoZWFkKG10Y2FycykNCmBgYA0KDQpgYGB7cn0NCnRyYWluX2luZGV4IDwtIGNyZWF0ZURhdGFQYXJ0aXRpb24obXRjYXJzJG1wZywgcCA9IDAuNywgbGlzdCA9IEYpDQp0cmFpbiA8LSBtdGNhcnNbdHJhaW5faW5kZXgsXQ0KdGVzdCA8LSBtdGNhcnNbLXRyYWluX2luZGV4LF0NCmBgYA0KDQoNCkxvcyBhcmd1bWVudG9zIGRlIGBjZW50ZXIgPSBUUlVFYCB5IGBzY2FsZSA9IFRSVUVgIGVzdGFuZGFyaXphIGxhIGRhdGEsIGNvbG9jYSBsYXMgbWVkaWFzIGVuIGVsIGNlbnRybyB5IGxhcyBkZXN2aWFjaW9uZXMgZXN0YW5kYXIgZW4gMS4NCkxhIHNpZ3VpZW50ZSBncmFmaWNhIG11ZXN0cmEgdW4gc2NyZWVwbG90LCBlbCBjdWFsIGdyYWZpY2EgbGFzIHZhcmlhbnphcyB5IGxhcyBkaW1lbnNpb25lcy4gDQpDb21vIHNlIHZlIGVuIGxhIGdyYWZpY2EsIGxhcyBwcmltZXJhcyBkb3MgY29tcG9uZW50ZXMgc29uIGxhcyBxdWUgdGllbmVuIG1heW9yIGFwb3J0ZS4NCmBgYHtyfQ0KbXRjYXJzX3BjYSA8LSBwcmNvbXAodHJhaW4gJT4lIHNlbGVjdCgtbXBnKSwgY2VudGVyID0gVFJVRSwgc2NhbGU9IFRSVUUpDQpmdml6X2VpZyhtdGNhcnNfcGNhKQ0KYGBgDQoNCg0KQ29uIGBzdW1tYXJ5KClgIHNlIHB1ZWRlIHZlciBsYSBpbXBvcnRhbmNpYSBkZSBjYWRhIHVuYSBkZSBsYXMgY29tcG9uZW50ZXMuIENvbW8gc2UgdmUgUEMxIHkgUEMyIGFwb3J0YW4gZWwgJDgwXCUkLg0KYGBge3J9DQpzdW1tYXJ5KG10Y2Fyc19wY2EpDQpgYGANCg0KDQpgYGB7cn0NCmZ2aXpfcGNhX3ZhcihtdGNhcnNfcGNhLA0KICAgICAgICAgICAgIGNvbC52YXIgPSAiY29zMiIsICMgQ29sb3IgYnkgY29udHJpYnV0aW9ucyB0byB0aGUgUEMNCiAgICAgICAgICAgICBncmFkaWVudC5jb2xzID0gYygiIzAwQUZCQiIsICIjRTdCODAwIiwgIiNGQzRFMDciKSwNCiAgICAgICAgICAgICByZXBlbCA9IFRSVUUgICAgICMgQXZvaWQgdGV4dCBvdmVybGFwcGluZw0KKQ0KYGBgDQoNCmBgYHtyfQ0KZnZpel9wY2FfYmlwbG90KG10Y2Fyc19wY2EsIHJlcGVsID0gVFJVRSwNCiAgICAgICAgICAgICAgICBjb2wudmFyID0gIiMyRTlGREYiLCAjIFZhcmlhYmxlcyBjb2xvcg0KICAgICAgICAgICAgICAgIGNvbC5pbmQgPSAiIzY5Njk2OSIgICMgSW5kaXZpZHVhbHMgY29sb3INCikNCmBgYA0KDQpFbiBlbCBjb21wb25lbnRlIGB4YCBkZWwgUENBIHNlIHB1ZWRlbiB2ZXIgdG9kYXMgbGFzIGNvbXBvbmVudGVzIHByaW5jaXBhbGVzLCBlbiBlc3RlIGNhc28gdXNhcmVtb3MgbGFzIHByaW1lcmFzIGRvcy4NCmBgYHtyfQ0KbXRjYXJzX3BjYSR4WywxOjJdDQpgYGANCg0KR3JhZmljYW1vcyBsb3MgdmFsb3JlcyBkZSBtcGcgZW4gYmFzZSBhIGxhcyBjb21wb25lbnRlcyBwcmluY2lwYWxlcyBgUEMxYCB5IGBQQzJgOg0KYGBge3J9DQpwbG90KG10Y2Fyc19wY2EkeFssMToyXSwgY29sID0gYXMuZmFjdG9yKHRyYWluJG1wZykgLHhsaW0gPSBjKC01LDUpLCB5bGltPWMoLTUsNCkpDQp0ZXh0KG10Y2Fyc19wY2EkeFssMToyXSwgdHJhaW4kbXBnLHBvcz0xICkNCmBgYA0KDQoNCkFob3JhIHNlIHZhIGEgYXJtYXIgdW4gZGF0YXNldCBxdWUgY29udGVuZ2EgbGEgdmFyaWFibGUgYG1wZ2AgeSBsYXMgY29tcG9uZW50ZXMgcHJpbmNpcGFsZXMgMSB5IDIuIA0KQ29uIGVzdGUgZGF0YXNldCBzZSBhcm1hcmEgZWwgbW9kZWxvLg0KYGBge3J9DQpuZXdfbXRjYXJzX3BjYSA8LSBjYmluZChtcGcgPSB0cmFpbiRtcGcsIG10Y2Fyc19wY2EkeFssMToyXSkgJT4lIGFzX3RpYmJsZSgpDQpoZWFkKG5ld19tdGNhcnNfcGNhKQ0KYGBgDQoNCg0KQ3JlYW1vcyB1bmEgcmVncmVzaW9uIGxpbmVhbCBwYXJhIHByZWRlY2lyIGBtcGdgIHVzYW5kbyBlbCBwcmltZXIgY29tcG9uZW50ZSBwcmluY2lwYWwgMSB5IGVsIGNvbXBvbmVudGUgcHJpbmNpcGFsIDIsIHVzYW5kbyBlbCB0cmFpbi4NCmBgYHtyfQ0KZml0X210Y2FycyA8LSBsbShtcGcgfiBQQzEgKyBQQzIgLCBkYXRhID0gbmV3X210Y2Fyc19wY2EpDQpzdW1tYXJ5KGZpdF9tdGNhcnMpDQpgYGANCg0KDQpQYXJhIHBvZGVyIHVzYXIgdW4gdGVzdCBwYXJhIHByZWRpY2Npb25lcyBwcmltZXJvIGVzIG5lY2VzYXJpbyBxdWUgZWwgZGF0YXNldCBkZSB0ZXN0IHNlIHRyYW5zZm9ybWUgYSB0ZXJtaW5vcyBkZSBjb21wb25lbnRlcyBwcmluY2lwYWxlcy4gUG9yIGVzYSByYXpvbiBzZSB1dGlsaXphIGBwcmVkaWN0KClgIGVsIFBDQSBxdWUgc2UgcmVhbGl6byBjb24gZWwgdHJhaW4uDQpgYGB7cn0NCnRlc3RfcGNhIDwtIHByZWRpY3QobXRjYXJzX3BjYSwgdGVzdCAlPiUgc2VsZWN0KC1tcGcpKQ0KdGVzdF9wY2ENCmBgYA0KDQoNCkFob3JhIHlhIHNlIHB1ZWRlbiBoYWNlciBwcmVkaWNjaW9uZXMgY29uIGVzZSB0ZXN0IHVzYW5kbyBsYSByZWdyZXNpb24gbGluZWFsIGFudGVyaW9yLg0KYGBge3J9DQp0ZXN0X2RhdGFmcmFtZSA8LSB0ZXN0X3BjYVssMToyXSAlPiUgYXNfdGliYmxlKCkNCnByZWRpY3QoZml0X210Y2FycywgdGVzdF9kYXRhZnJhbWUpDQpgYGANCg0KDQo=