使用Lindsay Smith的教程逐步在R中实现PCA

我正在通过Lindsay I Smith撰写的出色PCA教程从事R的工作，并且陷入了最后阶段。下面的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的方差-Smith绘制为：

这是我尝试过的（忽略添加原始方法）：

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的下限不符：

任何意见，不胜感激。

您非常接近那里，在使用R中的矩阵工作时遇到了一个微妙的问题。我从您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,])

$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$

我认为您的想法正确，但是偶然发现了R的一个令人讨厌的功能。在这里，您再次声明了相关代码：

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

探索完本练习后，您可以尝试使用R中更简单的方法。进行PCA时有两个流行的功能：princomp和和prcomp。该princomp函数会像练习中一样进行特征值分解。该prcomp函数使用奇异值分解。两种方法几乎在所有时间都将得到相同的结果：该答案说明 R 的差异，而此答案说明数学。（感谢TooTone的评论现在已集成到此帖子中。）

在这里，我们同时使用这两种方法来再现R中的练习。首先使用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)

显然，符号被翻转了，但变化的解释是等效的。