Покрокова реалізація PCA в R за допомогою підручника Ліндсі Сміт

Я працюю в R через чудовий підручник з PCA Ліндсей І Сміт, і я застрягаю на останній стадії. Сценарій R нижче приводить нас до етапу (на с. 19), де реконструюються оригінальні дані (головного компонента в цьому випадку), який повинен отримати прямий графік уздовж осі PCA1 (враховуючи, що дані має лише 2 виміри, другий з яких навмисно скидається).

d = data.frame(x=c(2.5,0.5,2.2,1.9,3.1,2.3,2.0,1.0,1.5,1.1),
               y=c(2.4,0.7,2.9,2.2,3.0,2.7,1.6,1.1,1.6,0.9))

# mean-adjusted values 
d$x_adj = d$x - mean(d$x)
d$y_adj = d$y - mean(d$y)

# calculate covariance matrix and eigenvectors/values
(cm = cov(d[,1:2]))

#### outputs #############
#          x         y
# x 0.6165556 0.6154444
# y 0.6154444 0.7165556
##########################

(e = eigen(cm))

##### outputs ##############
# $values
# [1] 1.2840277 0.0490834
#
# $vectors
#          [,1]       [,2]
# [1,] 0.6778734 -0.7351787
# [2,] 0.7351787  0.6778734
###########################


# principal component vector slopes
s1 = e$vectors[1,1] / e$vectors[2,1] # PC1
s2 = e$vectors[1,2] / e$vectors[2,2] # PC2

plot(d$x_adj, d$y_adj, asp=T, pch=16, xlab='x', ylab='y')
abline(a=0, b=s1, col='red')
abline(a=0, b=s2)

# PCA data = rowFeatureVector (transposed eigenvectors) * RowDataAdjust (mean adjusted, also transposed)
feat_vec = t(e$vectors)
row_data_adj = t(d[,3:4])
final_data = data.frame(t(feat_vec %*% row_data_adj)) # ?matmult for details
names(final_data) = c('x','y')

#### outputs ###############
# final_data
#              x           y
# 1   0.82797019 -0.17511531
# 2  -1.77758033  0.14285723
# 3   0.99219749  0.38437499
# 4   0.27421042  0.13041721
# 5   1.67580142 -0.20949846
# 6   0.91294910  0.17528244
# 7  -0.09910944 -0.34982470
# 8  -1.14457216  0.04641726
# 9  -0.43804614  0.01776463
# 10 -1.22382056 -0.16267529
############################

# final_data[[1]] = -final_data[[1]] # for some reason the x-axis data is negative the tutorial's result

plot(final_data, asp=T, xlab='PCA 1', ylab='PCA 2', pch=16)

Це наскільки я маю, і все в порядку поки що. Але я не можу зрозуміти, як отримуються дані для остаточного сюжету - відхилення, що можна віднести до PCA 1 - яке Сміт розміщує як:

Це те, що я спробував (який ігнорує додавання оригінальних засобів):

trans_data = final_data
trans_data[,2] = 0
row_orig_data = t(t(feat_vec[1,]) %*% t(trans_data))
plot(row_orig_data, asp=T, pch=16)

.. і отримав помилку:

.. тому що я якось втратив вимір даних у матричному множенні. Я був би дуже вдячний за ідею, що тут відбувається не так.

* Редагувати *

Цікаво, чи це правильна формула:

row_orig_data = t(t(feat_vec) %*% t(trans_data))
plot(row_orig_data, asp=T, pch=16, cex=.5)
abline(a=0, b=s1, col='red')

Але я трохи розгублений, якщо так, тому що (a) я розумію, що rowVectorFeatureпотрібно зменшити до потрібної розмірності (власний вектор для PCA1), і (b) він не співпадає з абляцією PCA1:

Будь-які погляди високо оцінені.

Ви були дуже майже там і вас зачепило тонке питання роботи з матрицями в Р. Я працював з вашими final_dataі отримував правильні результати самостійно. Тоді я детальніше ознайомився з вашим кодом. Якщо коротко сказати, де ви писали

row_orig_data = t(t(feat_vec[1,]) %*% t(trans_data))

у вас було б добре, якби ви писали

row_orig_data = t(t(feat_vec) %*% t(trans_data))

натомість (тому що ви зняли нуль частину, trans_dataщо проектувалася на другому власному векторі). Як це ви намагалися помножити матриця на матриці , але R не видасть повідомлення про помилку. Проблема полягає в тому, що трактується як . Спроба призведе до помилки. Наступне, можливо більше за те, що ви задумали, також працювало б2 × 10 1 × $2\times1$$2\times10$t(feat_vec[1,])$1\times2$row_orig_data = t(as.matrix(feat_vec[1,],ncol=1,nrow=2) %*% t(trans_data))non-conformable arguments

row_orig_data = t(as.matrix(feat_vec[1,],ncol=1,nrow=2) %*% t(trans_data)[1,])

оскільки він помножує матрицю матрицю (зверніть увагу, що ви могли використовувати тут оригінальну матрицю). Не потрібно робити це так, але це краще математично , тому що це показує , що ви отримуєте значення від значення на правій стороні.1 × 10 20 = 2 × 10 12 = 2 × 1 + 1 × $2\times1$$1\times10$final_data$20=2\times10$row_orig_data$12=2\times1 + 1\times10$

$(XY)^T=Y^TX^T$t(t(p) %*% t(q)) = q %*% t

$x/y$$y/x$

Пишіть

d_in_new_basis = as.matrix(final_data)

тоді для повернення ваших даних у початковій основі вам потрібно

d_in_original_basis = d_in_new_basis %*% feat_vec

Ви можете знецілити частини даних, які проектуються уздовж другого компонента, використовуючи

d_in_new_basis_approx = d_in_new_basis
d_in_new_basis_approx[,2] = 0

і ви можете потім перетворитись, як і раніше

d_in_original_basis_approx = d_in_new_basis_approx %*% feat_vec

Нанесення їх на один і той же сюжет разом із основним рядком компонента зеленим кольором показує, як спрацювало наближення.

plot(x=d_in_original_basis[,1]+mean(d$x),
     y=d_in_original_basis[,2]+mean(d$y),
     pch=16, xlab="x", ylab="y", xlim=c(0,3.5),ylim=c(0,3.5),
     main="black=original data\nred=original data restored using only a single eigenvector")
points(x=d_in_original_basis_approx[,1]+mean(d$x),
       y=d_in_original_basis_approx[,2]+mean(d$y),
       pch=16,col="red")
points(x=c(mean(d$x)-e$vectors[1,1]*10,mean(d$x)+e$vectors[1,1]*10), c(y=mean(d$y)-e$vectors[2,1]*10,mean(d$y)+e$vectors[2,1]*10), type="l",col="green")

Давайте повернемося до того, що у вас було. Цей рядок був у порядку

final_data = data.frame(t(feat_vec %*% row_data_adj))

feat_vec %*% row_data_adj$Y=S^TX$$S$$X$$Y$$Y$$X$$Y$$X$

Тоді ви мали

trans_data = final_data
trans_data[,2] = 0

Це нормально: ви просто нулюєте частини своїх даних, які проектуються уздовж другого компонента. Де йде не так

row_orig_data = t(t(feat_vec[1,]) %*% t(trans_data))

$\hat Y$$Y$$\mathbf{e}_1$t(feat_vec[1,]) %*% t(trans_data)$\mathbf{e}_1 \hat Y$

$2\times1$$2\times10$$\hat Y$$Y$$\mathbf{y}_1$$\mathbf{e}_1$$\mathbf{y}_1$$i$$\mathbf{e}_1\mathbf{y}_1$$\mathbf{e}_1$$i$

Я думаю, що ти маєш правильну ідею, але наткнувся на неприємну особливість Р. Тут ще раз відповідний фрагмент коду, як ти це заявив:

trans_data = final_data
trans_data[,2] = 0
row_orig_data = t(t(feat_vec[1,]) %*% t(trans_data))
plot(row_orig_data, asp=T, pch=16)

По суті final_dataмістить координати вихідних точок відносно системи координат, визначеної власними векторами матриці коваріації. Для реконструкції вихідних точок необхідно, таким чином, помножити кожен власний вектор на пов'язану з ним перетворену координату, наприклад

(1) final_data[1,1]*t(feat_vec[1,] + final_data[1,2]*t(feat_vec[2,])

що дало б вихідні координати першої точки. У своєму запитанні ви встановите другий компонент правильно до нуля trans_data[,2] = 0. Якщо ви потім (як ви вже відредагували) розрахунок

(2) row_orig_data = t(t(feat_vec) %*% t(trans_data))

ви обчислюєте формулу (1) для всіх точок одночасно. Ваш перший підхід

row_orig_data = t(t(feat_vec[1,]) %*% t(trans_data))

обчислює щось інше і працює лише тому, що R автоматично скидає атрибут розмірності для feat_vec[1,], тому він більше не є рядковим вектором, але трактується як вектор стовпця. Подальше транспонування знову робить його вектором рядків, і це причина, чому принаймні обчислення не призводить до помилок, але якщо ви пройдете математику, то побачите, що це щось інше, ніж (1). Загалом, в матричних множеннях є хорошою ідеєю придушити випадання атрибута розмірності, що може бути досягнуто dropпараметром, наприклад feat_vec[1,,drop=FALSE].

$\Delta y / \Delta x$

s1 = e$vectors[2,1] / e$vectors[1,1] # PC1
s2 = e$vectors[2,2] / e$vectors[1,2] # PC2

Вивчивши цю вправу, ви можете спробувати більш прості способи в Р. Є дві популярні функції для виконання PCA: princompі prcomp. princompФункція робить власне значення розкладання , як це робилося в тренуваннях. prcompФункція використовує розкладання по сингулярним значенням. Обидва методи дають однакові результати майже весь час: ця відповідь пояснює відмінності в R, тоді як ця відповідь пояснює математику . (Дякую TooTone за коментарі, які тепер інтегровані в цю публікацію.)

Тут ми використовуємо обидва для відтворення вправи в Р. Спочатку використовуючи princomp:

d = data.frame(x=c(2.5,0.5,2.2,1.9,3.1,2.3,2.0,1.0,1.5,1.1), 
               y=c(2.4,0.7,2.9,2.2,3.0,2.7,1.6,1.1,1.6,0.9))

# compute PCs
p = princomp(d,center=TRUE,retx=TRUE)

# use loadings and scores to reproduce with only first PC
loadings = t(p$loadings[,1]) 
scores = p$scores[,1] 

reproduce = scores %*% loadings  + colMeans(d)

# plots
plot(reproduce,pch=3,ylim=c(-1,4),xlim=c(-1,4))
abline(h=0,v=0,lty=3)
mtext("Original data restored using only a single eigenvector",side=3,cex=0.7)

biplot(p)

Друге використання prcomp:

d = data.frame(x=c(2.5,0.5,2.2,1.9,3.1,2.3,2.0,1.0,1.5,1.1), 
               y=c(2.4,0.7,2.9,2.2,3.0,2.7,1.6,1.1,1.6,0.9))

# compute PCs
p = prcomp(d,center=TRUE,retx=TRUE)

# use loadings and scores to reproduce with only first PC
loadings = t(p$rotation[,1])
scores = p$x[,1]

reproduce = scores %*% loadings  + colMeans(d)

# plots
plot(reproduce,pch=3,ylim=c(-1,4),xlim=c(-1,4))
abline(h=0,v=0,lty=3)
mtext("Original data restored using only a single eigenvector",side=3,cex=0.7)

biplot(p)

Очевидно, що знаки перекинуті, але пояснення варіації рівнозначне.