(дописать сюда теорию)
Загружаем нужные пакеты:
library(knitr)
opts_chunk$set(cache = TRUE) # кэшируем фрагменты кода
library(ggplot2) # для построения графиков
library(HSAUR) # нам нужен только набор данных по многоборью
# install.packages('HSAUR') # может быть нужно установить пакеты...
Загружаем интересующий нас набор данных по многоборью:
data(heptathlon)
head(heptathlon)
## hurdles highjump shot run200m longjump javelin
## Joyner-Kersee (USA) 12.69 1.86 15.80 22.56 7.27 45.66
## John (GDR) 12.85 1.80 16.23 23.65 6.71 42.56
## Behmer (GDR) 13.20 1.83 14.20 23.10 6.68 44.54
## Sablovskaite (URS) 13.61 1.80 15.23 23.92 6.25 42.78
## Choubenkova (URS) 13.51 1.74 14.76 23.93 6.32 47.46
## Schulz (GDR) 13.75 1.83 13.50 24.65 6.33 42.82
## run800m score
## Joyner-Kersee (USA) 128.5 7291
## John (GDR) 126.1 6897
## Behmer (GDR) 124.2 6858
## Sablovskaite (URS) 132.2 6540
## Choubenkova (URS) 127.9 6540
## Schulz (GDR) 125.8 6411
Корреляции исходных переменных
print(cor(heptathlon), digits = 2)
## hurdles highjump shot run200m longjump javelin run800m score
## hurdles 1.0000 -0.8114 -0.65 0.77 -0.912 -0.0078 0.78 -0.92
## highjump -0.8114 1.0000 0.44 -0.49 0.782 0.0022 -0.59 0.77
## shot -0.6513 0.4408 1.00 -0.68 0.743 0.2690 -0.42 0.80
## run200m 0.7737 -0.4877 -0.68 1.00 -0.817 -0.3330 0.62 -0.86
## longjump -0.9121 0.7824 0.74 -0.82 1.000 0.0671 -0.70 0.95
## javelin -0.0078 0.0022 0.27 -0.33 0.067 1.0000 0.02 0.25
## run800m 0.7793 -0.5912 -0.42 0.62 -0.700 0.0200 1.00 -0.77
## score -0.9232 0.7674 0.80 -0.86 0.950 0.2531 -0.77 1.00
Применяем метод главных компонент к исходным, нестандартизированным переменным. Восьмой столбец, score, нам не нужен, т.к. это не результат соревнования, а итоговый балл по многоборью.
hept.pca <- prcomp(heptathlon[, -8])
Теперь можно раздобыть сами главные компоненты:
head(hept.pca$x)
## PC1 PC2 PC3 PC4 PC5 PC6
## Joyner-Kersee (USA) -7.935 4.624 -1.9326 0.5968 0.04446 0.25607
## John (GDR) -10.244 1.477 -2.0528 -0.6828 -0.03112 -0.12716
## Behmer (GDR) -11.990 3.179 0.1944 0.3330 -0.31778 0.07528
## Sablovskaite (URS) -4.009 1.594 -1.5098 -0.4713 -0.38093 -0.15869
## Choubenkova (URS) -8.251 6.087 0.1301 -0.6374 -0.12506 -0.07747
## Schulz (GDR) -10.206 1.242 1.0195 -0.7376 -0.12410 0.14456
## PC7
## Joyner-Kersee (USA) 0.04158
## John (GDR) 0.03890
## Behmer (GDR) -0.01249
## Sablovskaite (URS) -0.05266
## Choubenkova (URS) 0.05160
## Schulz (GDR) -0.02446
Веса исходных переменных в главных компонентнах
head(hept.pca$rotation)
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## hurdles 0.069509 -0.0094891 0.22181 -0.32738 -0.8070 0.42485 -0.083123
## highjump -0.005570 0.0005647 -0.01451 0.02124 0.1401 0.09837 -0.984881
## shot -0.077906 0.1359282 -0.88374 -0.42501 -0.1044 -0.05174 -0.015650
## run200m 0.072968 -0.1012004 0.31006 -0.81585 0.4618 0.08249 0.051313
## longjump -0.040369 0.0148845 -0.18494 0.20420 0.3190 0.89459 0.142110
## javelin 0.006686 0.9852955 0.16021 -0.03217 0.0488 0.00617 0.005033
Посмотрим как первая компонента связана с итоговым результатом спортсмена
pc1 <- hept.pca$x[, 1]
plot(heptathlon$score, pc1)
cor(heptathlon$score, pc1)
## [1] -0.7847
Смотрим какую долю дисперсии объясняют главные компоненты:
summary(hept.pca)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 8.365 3.591 1.3857 0.58571 0.32382 0.14712 0.03325
## Proportion of Variance 0.821 0.151 0.0225 0.00402 0.00123 0.00025 0.00001
## Cumulative Proportion 0.821 0.972 0.9945 0.99850 0.99973 0.99999 1.00000
plot(hept.pca)
Внимательно посмотрев на сами данные замечаем, что они в существенно разных единицах…
summary(heptathlon)
## hurdles highjump shot run200m
## Min. :12.7 Min. :1.50 Min. :10.0 Min. :22.6
## 1st Qu.:13.5 1st Qu.:1.77 1st Qu.:12.3 1st Qu.:23.9
## Median :13.8 Median :1.80 Median :12.9 Median :24.8
## Mean :13.8 Mean :1.78 Mean :13.1 Mean :24.6
## 3rd Qu.:14.1 3rd Qu.:1.83 3rd Qu.:14.2 3rd Qu.:25.2
## Max. :16.4 Max. :1.86 Max. :16.2 Max. :26.6
## longjump javelin run800m score
## Min. :4.88 Min. :35.7 Min. :124 Min. :4566
## 1st Qu.:6.05 1st Qu.:39.1 1st Qu.:132 1st Qu.:5746
## Median :6.25 Median :40.3 Median :135 Median :6137
## Mean :6.15 Mean :41.5 Mean :136 Mean :6091
## 3rd Qu.:6.37 3rd Qu.:44.5 3rd Qu.:138 3rd Qu.:6351
## Max. :7.27 Max. :47.5 Max. :163 Max. :7291
Значит первая главная компонента ловила прежде всего тот факт, что результаты бега на 800 метров имеют наибольший разброс и ничего больше. Поэтому применим метод главных компонент с предварительной стандартизацией:
hept.pca2 <- prcomp(heptathlon[, -8], scale = TRUE)
График первых двух компонент с вкладом каждой переменной
biplot(hept.pca2)
На этом графике видно, например, что:
longjump, первая главная компонента падает, а вторая — практически не изменяется.longjump и hurdles предположительно отрицательно коррелированы, т.к. с ростом первой главной компоненты меняются в разные стороны.