Paula Cazali

Fiabilidad

Se usará PCA en el dataset de USArrests, el cual contiene \(50\) estados ordenados alfabeticamente.

states <- row.names(USArrests)
states
 [1] "Alabama"        "Alaska"         "Arizona"        "Arkansas"       "California"     "Colorado"       "Connecticut"   
 [8] "Delaware"       "Florida"        "Georgia"        "Hawaii"         "Idaho"          "Illinois"       "Indiana"       
[15] "Iowa"           "Kansas"         "Kentucky"       "Louisiana"      "Maine"          "Maryland"       "Massachusetts" 
[22] "Michigan"       "Minnesota"      "Mississippi"    "Missouri"       "Montana"        "Nebraska"       "Nevada"        
[29] "New Hampshire"  "New Jersey"     "New Mexico"     "New York"       "North Carolina" "North Dakota"   "Ohio"          
[36] "Oklahoma"       "Oregon"         "Pennsylvania"   "Rhode Island"   "South Carolina" "South Dakota"   "Tennessee"     
[43] "Texas"          "Utah"           "Vermont"        "Virginia"       "Washington"     "West Virginia"  "Wisconsin"     
[50] "Wyoming"       

Las variables del dataset son las siguientes:

names(USArrests)
[1] "Murder"   "Assault"  "UrbanPop" "Rape"    

Se usará la función apply() que permite aplicar una función a cada columna o fila del dataset. En este caso usaremos la función mean(). El segundo parámetro de la función apply() denota si queremos obtener la media de las filas o de las columnas, para las filas se utiliza un 1 y para las columnas un 2.

apply(USArrests, 2, var)
    Murder    Assault   UrbanPop       Rape 
  18.97047 6945.16571  209.51878   87.72916 

Las variables también tienen diferente varianza. La variable UrbanPop mide el porcentaje de población de cada estado que vive en un área urbana, que no se puede comparar con el número de violaciones en cada estado por \(100,000\) individuos. Es importante escalar las variables antes de aplicar el método de PCA, ya que se puede ver que la mayoría de los componentes principales estarían impulsadas por la variable Assault ya que tiene una media muy alta y una varianza muy grande. Por lo que primero se estandarizarán las variables para que tengan media igual a \(0\) y desviación estandar igual a \(1\) antes de aplicar PCA.

pr.out <- prcomp(USArrests, scale = TRUE)

Por defecto, la función prcomp() centra las variables para que tengan una media igual a \(0\). Usando el parámetro scale = TRUE se escalan las variables para que tengan desviación estandar igual a \(1\). El resultado de la función prcomp() contiene unas cantidades utiles.

names(pr.out)
[1] "sdev"     "rotation" "center"   "scale"    "x"       

Los componentes center y scale corresponden a las medias y a las desviaciones estandar de las variables que fueron usadas para hacer la escala para poder implementar PCA.

pr.out$center
  Murder  Assault UrbanPop     Rape 
   7.788  170.760   65.540   21.232 
pr.out$center
  Murder  Assault UrbanPop     Rape 
   7.788  170.760   65.540   21.232 

rotation es una matriz que provee los componentes principales. Cada columna de pr.out$rotation contiene el componente principal del vector.

pr.out$rotation
                PC1        PC2        PC3         PC4
Murder   -0.5358995  0.4181809 -0.3412327  0.64922780
Assault  -0.5831836  0.1879856 -0.2681484 -0.74340748
UrbanPop -0.2781909 -0.8728062 -0.3780158  0.13387773
Rape     -0.5434321 -0.1673186  0.8177779  0.08902432

Se puede ver que hay cuatro componentes principales. Usando la función prcomp() no se necesita multiplicar los datos por los vectores de los componentes principales para obtener los puntajes de los componentes.

dim(pr.out$x)
[1] 50  4

Se pueden graficar los dos primeros componentes principales:

biplot(pr.out, scale = 0)

pr.out$rotation <- -pr.out$rotation
pr.out$x <- -pr.out$x
biplot(pr.out, scale = 0)

La función prcomp() también devuelve la desviación estandar de cada componente principal. Por lo que podemos ver las desviaciones estadar:

pr.out$sdev
[1] 1.5748783 0.9948694 0.5971291 0.4164494

La varianza por cada componente principal se obtiene elevando al cuadrado esas desviaciones estandar.

pr.var <- pr.out$sdev^2
pr.var
[1] 2.4802416 0.9897652 0.3565632 0.1734301

Ahora se dividirá la varianza entre cada componente principal por el total de varianza para los cuatro componentes principales.

pve <- pr.var/sum(pr.var)
pve
[1] 0.62006039 0.24744129 0.08914080 0.04335752

Aqui se puede ver que el primer componente principal explica \(62\%\) de la varianza de la data. El siguiente componente principal explica el \(24.7\%\) de la varianza. Se puede graficar el PVE por cada componente.

plot(pve, xlab = "Principal Component", ylab = "Proportion of Variance Explained", ylim = c(0,1), type = 'b')

plot(cumsum(pve), xlab = "Principal component", ylab = "Cumulative Proportion of Variance Explained", ylim = c(0,1), type = 'b')

La función cumsum computa la suma acumulativa de los elementos de un vector numérico.

a <- c(1,2,8,-3)
cumsum(a)
[1]  1  3 11  8
LS0tDQp0aXRsZTogIkxhYiAxMC40OiBQcmluY2lwYWwgY29tcG9uZW50cyBBbmFseXNpcyINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCiMjIFBhdWxhIENhemFsaQ0KIyMjIEZpYWJpbGlkYWQNCg0KU2UgdXNhcuEgUENBIGVuIGVsIGRhdGFzZXQgZGUgYFVTQXJyZXN0c2AsIGVsIGN1YWwgY29udGllbmUgJDUwJCBlc3RhZG9zIG9yZGVuYWRvcyBhbGZhYmV0aWNhbWVudGUuDQpgYGB7cn0NCnN0YXRlcyA8LSByb3cubmFtZXMoVVNBcnJlc3RzKQ0Kc3RhdGVzDQpgYGANCg0KTGFzIHZhcmlhYmxlcyBkZWwgZGF0YXNldCBzb24gbGFzIHNpZ3VpZW50ZXM6DQpgYGB7cn0NCm5hbWVzKFVTQXJyZXN0cykNCmBgYA0KDQpTZSB1c2Fy4SBsYSBmdW5jafNuIGBhcHBseSgpYCBxdWUgcGVybWl0ZSBhcGxpY2FyIHVuYSBmdW5jafNuIGEgY2FkYSBjb2x1bW5hIG8gZmlsYSBkZWwgZGF0YXNldC4gRW4gZXN0ZSBjYXNvIHVzYXJlbW9zIGxhIGZ1bmNp824gYG1lYW4oKWAuIEVsIHNlZ3VuZG8gcGFy4W1ldHJvIGRlIGxhIGZ1bmNp824gYGFwcGx5KClgIGRlbm90YSBzaSBxdWVyZW1vcyBvYnRlbmVyIGxhIG1lZGlhIGRlIGxhcyBmaWxhcyBvIGRlIGxhcyBjb2x1bW5hcywgcGFyYSBsYXMgZmlsYXMgc2UgdXRpbGl6YSB1biAxIHkgcGFyYSBsYXMgY29sdW1uYXMgdW4gMi4gDQpgYGB7cn0NCmFwcGx5KFVTQXJyZXN0cywgMiwgdmFyKQ0KYGBgDQoNCkxhcyB2YXJpYWJsZXMgdGFtYmnpbiB0aWVuZW4gZGlmZXJlbnRlIHZhcmlhbnphLiBMYSB2YXJpYWJsZSBgVXJiYW5Qb3BgIG1pZGUgZWwgcG9yY2VudGFqZSBkZSBwb2JsYWNp824gZGUgY2FkYSBlc3RhZG8gcXVlIHZpdmUgZW4gdW4g4XJlYSB1cmJhbmEsIHF1ZSBubyBzZSBwdWVkZSBjb21wYXJhciBjb24gZWwgbvptZXJvIGRlIHZpb2xhY2lvbmVzIGVuIGNhZGEgZXN0YWRvIHBvciAkMTAwLDAwMCQgaW5kaXZpZHVvcy4gDQpFcyBpbXBvcnRhbnRlIGVzY2FsYXIgbGFzIHZhcmlhYmxlcyBhbnRlcyBkZSBhcGxpY2FyIGVsIG3pdG9kbyBkZSBQQ0EsIHlhIHF1ZSBzZSBwdWVkZSB2ZXIgcXVlIGxhIG1heW9y7WEgZGUgbG9zIGNvbXBvbmVudGVzIHByaW5jaXBhbGVzIGVzdGFy7WFuIGltcHVsc2FkYXMgcG9yIGxhIHZhcmlhYmxlIGBBc3NhdWx0YCB5YSBxdWUgdGllbmUgdW5hIG1lZGlhIG11eSBhbHRhIHkgdW5hIHZhcmlhbnphIG11eSBncmFuZGUuIFBvciBsbyBxdWUgcHJpbWVybyBzZSBlc3RhbmRhcml6YXLhbiBsYXMgdmFyaWFibGVzIHBhcmEgcXVlIHRlbmdhbiBtZWRpYSBpZ3VhbCBhICQwJCB5IGRlc3ZpYWNp824gZXN0YW5kYXIgaWd1YWwgYSAkMSQgYW50ZXMgZGUgYXBsaWNhciBQQ0EuDQpgYGB7cn0NCnByLm91dCA8LSBwcmNvbXAoVVNBcnJlc3RzLCBzY2FsZSA9IFRSVUUpDQpgYGANCg0KUG9yIGRlZmVjdG8sIGxhIGZ1bmNp824gYHByY29tcCgpYCBjZW50cmEgbGFzIHZhcmlhYmxlcyBwYXJhIHF1ZSB0ZW5nYW4gdW5hIG1lZGlhIGlndWFsIGEgJDAkLiBVc2FuZG8gZWwgcGFy4W1ldHJvIGBzY2FsZSA9IFRSVUVgIHNlIGVzY2FsYW4gbGFzIHZhcmlhYmxlcyBwYXJhIHF1ZSB0ZW5nYW4gZGVzdmlhY2nzbiBlc3RhbmRhciBpZ3VhbCBhICQxJC4gRWwgcmVzdWx0YWRvIGRlIGxhIGZ1bmNp824gYHByY29tcCgpYCBjb250aWVuZSB1bmFzIGNhbnRpZGFkZXMgdXRpbGVzLg0KYGBge3J9DQpuYW1lcyhwci5vdXQpDQpgYGANCg0KTG9zIGNvbXBvbmVudGVzIGBjZW50ZXJgIHkgYHNjYWxlYCBjb3JyZXNwb25kZW4gYSBsYXMgbWVkaWFzIHkgYSBsYXMgZGVzdmlhY2lvbmVzIGVzdGFuZGFyIGRlIGxhcyB2YXJpYWJsZXMgcXVlIGZ1ZXJvbiB1c2FkYXMgcGFyYSBoYWNlciBsYSBlc2NhbGEgcGFyYSBwb2RlciBpbXBsZW1lbnRhciBQQ0EuDQpgYGB7cn0NCnByLm91dCRjZW50ZXINCnByLm91dCRjZW50ZXINCmBgYA0KDQpgcm90YXRpb25gIGVzIHVuYSBtYXRyaXogcXVlIHByb3ZlZSBsb3MgY29tcG9uZW50ZXMgcHJpbmNpcGFsZXMuIENhZGEgY29sdW1uYSBkZSBgcHIub3V0JHJvdGF0aW9uYCBjb250aWVuZSBlbCBjb21wb25lbnRlIHByaW5jaXBhbCBkZWwgdmVjdG9yLg0KYGBge3J9DQpwci5vdXQkcm90YXRpb24NCmBgYA0KDQpTZSBwdWVkZSB2ZXIgcXVlIGhheSBjdWF0cm8gY29tcG9uZW50ZXMgcHJpbmNpcGFsZXMuIFVzYW5kbyBsYSBmdW5jafNuIGBwcmNvbXAoKWAgbm8gc2UgbmVjZXNpdGEgbXVsdGlwbGljYXIgbG9zIGRhdG9zIHBvciBsb3MgdmVjdG9yZXMgZGUgbG9zIGNvbXBvbmVudGVzIHByaW5jaXBhbGVzIHBhcmEgb2J0ZW5lciBsb3MgcHVudGFqZXMgZGUgbG9zIGNvbXBvbmVudGVzLg0KYGBge3J9DQpkaW0ocHIub3V0JHgpDQpgYGANCg0KU2UgcHVlZGVuIGdyYWZpY2FyIGxvcyBkb3MgcHJpbWVyb3MgY29tcG9uZW50ZXMgcHJpbmNpcGFsZXM6DQpgYGB7cn0NCmJpcGxvdChwci5vdXQsIHNjYWxlID0gMCkNCmBgYA0KDQpgYGB7cn0NCnByLm91dCRyb3RhdGlvbiA8LSAtcHIub3V0JHJvdGF0aW9uDQpwci5vdXQkeCA8LSAtcHIub3V0JHgNCmJpcGxvdChwci5vdXQsIHNjYWxlID0gMCkNCmBgYA0KTGEgZnVuY2nzbiBgcHJjb21wKClgIHRhbWJp6W4gZGV2dWVsdmUgbGEgZGVzdmlhY2nzbiBlc3RhbmRhciBkZSBjYWRhIGNvbXBvbmVudGUgcHJpbmNpcGFsLiBQb3IgbG8gcXVlIHBvZGVtb3MgdmVyIGxhcyBkZXN2aWFjaW9uZXMgZXN0YWRhcjoNCmBgYHtyfQ0KcHIub3V0JHNkZXYNCmBgYA0KTGEgdmFyaWFuemEgcG9yIGNhZGEgY29tcG9uZW50ZSBwcmluY2lwYWwgc2Ugb2J0aWVuZSBlbGV2YW5kbyBhbCBjdWFkcmFkbyBlc2FzIGRlc3ZpYWNpb25lcyBlc3RhbmRhci4NCmBgYHtyfQ0KcHIudmFyIDwtIHByLm91dCRzZGV2XjINCnByLnZhcg0KYGBgDQpBaG9yYSBzZSBkaXZpZGly4SBsYSB2YXJpYW56YSBlbnRyZSBjYWRhIGNvbXBvbmVudGUgcHJpbmNpcGFsIHBvciBlbCB0b3RhbCBkZSB2YXJpYW56YSBwYXJhIGxvcyBjdWF0cm8gY29tcG9uZW50ZXMgcHJpbmNpcGFsZXMuDQpgYGB7cn0NCnB2ZSA8LSBwci52YXIvc3VtKHByLnZhcikNCnB2ZQ0KYGBgDQpBcXVpIHNlIHB1ZWRlIHZlciBxdWUgZWwgcHJpbWVyIGNvbXBvbmVudGUgcHJpbmNpcGFsIGV4cGxpY2EgJDYyXCUkIGRlIGxhIHZhcmlhbnphIGRlIGxhIGRhdGEuIEVsIHNpZ3VpZW50ZSBjb21wb25lbnRlIHByaW5jaXBhbCBleHBsaWNhIGVsICQyNC43XCUkIGRlIGxhIHZhcmlhbnphLiBTZSBwdWVkZSBncmFmaWNhciBlbCBQVkUgcG9yIGNhZGEgY29tcG9uZW50ZS4NCmBgYHtyfQ0KcGxvdChwdmUsIHhsYWIgPSAiUHJpbmNpcGFsIENvbXBvbmVudCIsIHlsYWIgPSAiUHJvcG9ydGlvbiBvZiBWYXJpYW5jZSBFeHBsYWluZWQiLCB5bGltID0gYygwLDEpLCB0eXBlID0gJ2InKQ0KcGxvdChjdW1zdW0ocHZlKSwgeGxhYiA9ICJQcmluY2lwYWwgY29tcG9uZW50IiwgeWxhYiA9ICJDdW11bGF0aXZlIFByb3BvcnRpb24gb2YgVmFyaWFuY2UgRXhwbGFpbmVkIiwgeWxpbSA9IGMoMCwxKSwgdHlwZSA9ICdiJykNCmBgYA0KTGEgZnVuY2nzbiBgY3Vtc3VtYCBjb21wdXRhIGxhIHN1bWEgYWN1bXVsYXRpdmEgZGUgbG9zIGVsZW1lbnRvcyBkZSB1biB2ZWN0b3IgbnVt6XJpY28uDQpgYGB7cn0NCmEgPC0gYygxLDIsOCwtMykNCmN1bXN1bShhKQ0KYGBgDQoNCg0KDQoNCg0KDQoNCg0KDQo=