Lindsay Smith'in eğitimini kullanarak R'de PCA'nın adım adım uygulanması

Lindsay I Smith tarafından mükemmel bir PCA öğretici aracılığıyla R'de çalışıyorum ve son aşamada takılıp kalıyorum . Aşağıdaki R betiği, orijinal verilerin (bu durumda tekil) Ana Bileşen'den yeniden yapılandırıldığı (PC1) ekseni boyunca düz bir çizgi grafiği vermesi gereken aşamaya (s.19'da) götürür (veriler sadece 2 boyutu vardır, ikincisi kasıtlı olarak düşürülür).

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)

Bu benim kadarıyla ve şimdiye kadar her şey yolunda. Ama Smith'in çizdiği son çizim için PCA 1'e atfedilebilen varyans için verilerin nasıl elde edildiğini anlayamıyorum:

Bu denedim (orijinal araç eklemeyi görmezden gelir):

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)

..ve hatalı var:

Çünkü matris çarpımında bir veri boyutunu bir şekilde kaybettim. Burada neyin yanlış gittiğine dair bir fikir için çok minnettar olurum.

* Düzenle *

Bunun doğru formül olup olmadığını merak ediyorum:

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')

Ama eğer biraz kafam karıştı çünkü (a) rowVectorFeatureistenen boyutluluğa (PCA1 için özvektör) indirgenmesi gerektiğini anlıyorum ve (b) PCA1 abline ile uyuşmuyor:

Herhangi bir görüş çok takdir etmek.

Neredeyse çok oradaydınız ve R'deki matrislerle çalışırken ince bir sorunla yakalandınız. Sizden çalıştım final_datave bağımsız olarak doğru sonuçları aldım. Sonra kodunuza daha yakından baktım. Yazdığınız uzun bir hikayeyi kısaltmak için

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

yazsaydın iyi olurdun

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

bunun yerine (bunun trans_dataikinci özvektöre yansıtılan kısmını sıfırladınız ). Eğer çarpma çalıştıklarını olduğu gibi bir matris tarafından matrisinin ama R, hata verebilir vermedi. Sorun yani olarak kabul edilir . Denemek size bir hata verirdi . Aşağıdakiler, muhtemelen daha çok amaçladığınız şey boyunca,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,])

çünkü matrisini matrisiyle ( burada orijinal matrisi kullanabileceğinizi unutmayın ). Bu şekilde bunu yapmak için gerekli değildir, ama onun güzel matematiksel olarak bunu elde ettiğinizi gösterir çünkü değerleri dan sağ tarafta değerler.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$

Birisi faydalı bulabileceği için orijinal cevabımı aşağıda bıraktım ve gerekli arazileri aldığını gösteriyor. Ayrıca bazı gereksiz aktarımlardan kurtularak kodun biraz daha basit olabileceğini de gösterir: yani .$(XY)^T=Y^TX^T$t(t(p) %*% t(q)) = q %*% t

Düzenlemenizden sonra, aşağıdaki bileşenime ana bileşen satırını yeşil olarak ekledim. Sorunuzda eğimi değil olarak aldınız .y /$x/y$$y/x$

Yazmak

d_in_new_basis = as.matrix(final_data)

ardından verilerinizi orijinal temelinde geri almak için ihtiyacınız olan

d_in_original_basis = d_in_new_basis %*% feat_vec

Verilerinizin, ikinci bileşen boyunca yansıtılan kısımlarını kullanarak sıfırlayabilirsiniz.

d_in_new_basis_approx = d_in_new_basis
d_in_new_basis_approx[,2] = 0

ve sonra eskisi gibi dönüştürebilirsiniz

d_in_original_basis_approx = d_in_new_basis_approx %*% feat_vec

Bunları aynı arsa üzerine çizmek, temel bileşen çizgisi ile birlikte yeşil olarak, yaklaşıklığın nasıl çalıştığını gösterir.

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")

Sahip olduklarınızı geri sayalım. Bu çizgi iyiydi

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

Buradaki kritik bit feat_vec %*% row_data_adj, eşdeğerdir; burada , özvektörlerin matrisidir ve , satırlarınızdaki verilerinizle veri matrisinizdir ve , yeni temeldeki verilerdir. Bunun söylediği şey, ilk sırasının ( birinci özvektör tarafından tartılan sıraları) toplamı olmasıdır . Ve ikinci sırası toplamıdır ( ikinci özvektör tarafından tartılan sıraları ).S X Y Y X Y $Y=S^TX$$S$$X$$Y$$Y$$X$$Y$$X$

Sonra sen

trans_data = final_data
trans_data[,2] = 0

Sorun değil: Verilerinizin ikinci bileşen boyunca yansıtılan kısımlarını sıfırladınız. Nerede yanlış giderse

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

Yazma verilerin matris için ikinci sıradaki sıfırlarla yeni bazda, ve yazma ilk özvektöründen için, bu kodun iş sonu iner . Ye1e1$\hat Y$$Y$$\mathbf{e}_1$t(feat_vec[1,]) %*% t(trans_data)$\mathbf{e}_1 \hat Y$

Yukarıda açıklandığı gibi (burada ince R problemini fark ettim ve cevabımın ilk bölümünü yazdım), matematiksel olarak vektörünü matrisi ile . Bu matematiksel olarak çalışmaz. Yapman gereken ilk satırı almak olduğunu = ilk satırına diyoruz: . Ardından ve birlikte çarpın . sonuç inci sütun özvektördür 1 ağırlıklandırılan sadece koordinatı istediğini olan yeni bazda, içinde inci noktada.2 x 10 Y -Y Y 1 e 1 y 1 i e 1 y 1 e 1$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$

Doğru fikre sahip olduğunuzu düşünüyorum, ancak R'nin kötü bir özelliği üzerinde tökezlediniz. Burada da belirttiğiniz gibi ilgili kod parçası:

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)

Esasen final_data, kovaryans matrisinin özvektörleri tarafından tanımlanan koordinat sistemine göre orijinal noktaların koordinatlarını içerir. Orijinal noktaları yeniden yapılandırmak için, her özvektörü ilgili dönüştürülmüş koordinatla, örn.

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

bu da ilk noktanın orijinal koordinatlarını verir. Sorunuzda ikinci bileşeni doğru sıfıra ayarladınız trans_data[,2] = 0. Sonra (zaten düzenlediğiniz gibi)

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

tüm noktalar için aynı anda formül (1) hesaplarsınız. İlk yaklaşımınız

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

farklı bir şey hesaplar ve yalnızca R otomatik olarak boyut niteliğini düşürdüğü için çalışır feat_vec[1,], bu nedenle artık bir satır vektörü değildir, ancak bir sütun vektörü olarak kabul edilir. Sonraki devrik yeniden satır vektörü yapar ve en azından hesaplamanın bir hata üretmemesinin nedeni budur, ancak matematikten geçerseniz (1) 'den farklı bir şey olduğunu göreceksiniz. Genel olarak, matris çarpmalarında, dropparametre ile elde edilebilecek boyut özelliğinin düşmesini bastırmak iyi bir fikirdir , örn feat_vec[1,,drop=FALSE].

Düzenlenmiş çözümünüz doğru görünüyor, ancak PCA1 yanlışsa eğimi hesapladınız. Eğim tarafından verilir , dolayısıyla$\Delta y / \Delta x$

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

Bu egzersizi keşfettikten sonra R'deki daha kolay yolları deneyebilirsiniz . PCA yapmak için iki popüler işlev vardır: princompve prcomp. princompİşlevi egzersiz yapıldığı gibi özdeğer ayrışması. prcompİşlev tekil değer ayrışımı kullanır. Her iki yöntem de hemen hemen her zaman aynı sonuçları verecektir: bu cevap R'deki farklılıkları açıklarken, bu cevap matematiği açıklar . (Bu yayına entegre edilmiş yorumlar için TooTone'a teşekkürler .)

Burada kullanarak R. Birinci alıştırması çoğaltmak hem kullanın 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)

İkinci kullanma 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)

Tabii ki işaretler ters çevrilmiş ancak varyasyonun açıklaması eşdeğerdir.