En este laboratorio usaremos el dataset USArrests que encontramos por defecto en R. En cada fila encontramos uno de los 50 estados ordenados alfabeticamente.

states =row.names(USArrests)
states
 [1] "Alabama"        "Alaska"         "Arizona"        "Arkansas"       "California"    
 [6] "Colorado"       "Connecticut"    "Delaware"       "Florida"        "Georgia"       
[11] "Hawaii"         "Idaho"          "Illinois"       "Indiana"        "Iowa"          
[16] "Kansas"         "Kentucky"       "Louisiana"      "Maine"          "Maryland"      
[21] "Massachusetts"  "Michigan"       "Minnesota"      "Mississippi"    "Missouri"      
[26] "Montana"        "Nebraska"       "Nevada"         "New Hampshire"  "New Jersey"    
[31] "New Mexico"     "New York"       "North Carolina" "North Dakota"   "Ohio"          
[36] "Oklahoma"       "Oregon"         "Pennsylvania"   "Rhode Island"   "South Carolina"
[41] "South Dakota"   "Tennessee"      "Texas"          "Utah"           "Vermont"       
[46] "Virginia"       "Washington"     "West Virginia"  "Wisconsin"      "Wyoming"       
names(USArrests)
[1] "Murder"   "Assault"  "UrbanPop" "Rape"    

cada una de las variables tiene una media muy diferente

apply(USArrests , 2, mean)
  Murder  Assault UrbanPop     Rape 
   7.788  170.760   65.540   21.232 

las violaciones son poco mas del doble que los asesinatos y asaltos es lo mas común, luego vemos las varianzas de cada variable

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

UrbanPop nos dice el porcentaje de las personas en cada estado que viven en areas urbanas, que no es comparable con el numero de violaciones por cada 100,000 habitantes. Por lo tanto debemos estandarizar nuestras variables para poder realizar el análisis PCA sino Assaults será la predominante porque tener la mayor media y varianza. Por lo tanto es importante hacer que las variables tenga media cero y desviacion estandar cero antes del análisis. El análisis lo haremos con la función prcomp() que es una de las muchas opciones disponibles en el mercado.

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

por defeto la función escala las variables a media cero y el parámetro scale=TRUE hace que la desviación estándar sea uno

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

el componente center son las medias y scale son las desviaciones estandar de las variables que se utilizaron antes del PCA

pr.out$center
  Murder  Assault UrbanPop     Rape 
   7.788  170.760   65.540   21.232 
pr.out$scale
   Murder   Assault  UrbanPop      Rape 
 4.355510 83.337661 14.474763  9.366385 

la matriz rotation contiene en cada columna el vector PCA corresponiente

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

no necestimas multiplicar los vectores por nuestras variables originales para obtener los vectores de score pca, sino que ya se encuentran en la matriz x donde cada columna es un vector que se encuentran en el mismo orden del dataset que estamos utilizando

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

podemos graficar los primeros dos componentes

biplot (pr.out , scale =0)

el parámetro scale=0 nos asegura que las flechas esten en la escala para representar correctamente las cargas

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

también podemos extraer las desviaciones estandar de cada componente

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

la varianza de cada componente

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

la proporción de la varianza que explicada cada uno de los vectores principales

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

el primer vector explica el 62% de la varianza, el segudno explica el 24.7% y así sucesivamente. Estos datos tambien los podemos examinar de forma gráfica.

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() da la suma acumulada de un vector numerico

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