Implementación paso a paso de PCA en R usando el tutorial de Lindsay Smith

Estoy trabajando en R a través de un excelente tutorial de PCA de Lindsay I Smith y me estoy atascando en la última etapa. La secuencia de comandos R a continuación nos lleva a la etapa (en la p.19) donde los datos originales se están reconstruyendo a partir del Componente Principal (singular en este caso), que debería generar una gráfica de línea recta a lo largo del eje PCA1 (dado que los datos solo tiene 2 dimensiones, la segunda de las cuales se ha eliminado intencionalmente).

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)

Esto es lo más lejos que tengo, y todo está bien hasta ahora. Pero no puedo entender cómo se obtienen los datos para la trama final, la varianza atribuible a PCA 1, que Smith traza como:

Esto es lo que he intentado (que ignora agregar los medios originales):

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)

.. y obtuve un error:

.. porque he perdido una dimensión de datos de alguna manera en la multiplicación de matrices. Estaría muy agradecido por una idea de lo que está mal aquí.

* Editar *

Me pregunto si esta es la fórmula correcta:

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

Pero estoy un poco confundido si es así porque (a) entiendo que las rowVectorFeaturenecesidades deben reducirse a la dimensionalidad deseada (el vector propio para PCA1), y (b) no se alinea con la abline de PCA1:

Cualquier opinión muy apreciada.

Estuviste muy cerca de allí y te atrapó un problema sutil al trabajar con matrices en R. Trabajé de tu parte final_datay obtuve los resultados correctos de forma independiente. Luego eché un vistazo más de cerca a tu código. Para resumir una larga historia, donde escribiste

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

hubieras estado bien si hubieras escrito

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

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

Escribir

d_in_new_basis = as.matrix(final_data)

entonces para recuperar sus datos en su base original necesita

d_in_original_basis = d_in_new_basis %*% feat_vec

Puede poner a cero las partes de sus datos que se proyectan a lo largo del segundo componente utilizando

d_in_new_basis_approx = d_in_new_basis
d_in_new_basis_approx[,2] = 0

y luego puedes transformarte como antes

d_in_original_basis_approx = d_in_new_basis_approx %*% feat_vec

Al trazar estos en el mismo diagrama, junto con la línea del componente principal en verde, se muestra cómo funciona la aproximación.

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

Retrocedamos a lo que tenías. Esta linea estaba bien

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$

Entonces tuviste

trans_data = final_data
trans_data[,2] = 0

Esto está bien: solo está poniendo a cero las partes de sus datos que se proyectan a lo largo del segundo componente. Donde va mal es

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$

Creo que tiene la idea correcta, pero tropezó con una característica desagradable de R. Aquí nuevamente el código relevante como lo ha dicho:

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)

Básicamente final_datacontiene las coordenadas de los puntos originales con respecto al sistema de coordenadas definido por los vectores propios de la matriz de covarianza. Para reconstruir los puntos originales, se debe multiplicar cada vector propio con la coordenada transformada asociada, p. Ej.

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

que produciría las coordenadas originales del primer punto. En su pregunta se establece el segundo componente correctamente a cero, trans_data[,2] = 0. Si luego (como ya editó) calcula

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

Usted calcula la fórmula (1) para todos los puntos simultáneamente. Tu primer acercamiento

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

calcula algo diferente y solo funciona porque R elimina automáticamente el atributo de dimensión feat_vec[1,], por lo que ya no es un vector de fila, sino que se trata como un vector de columna. La transposición posterior lo convierte en un vector de fila nuevamente y esa es la razón por la cual al menos el cálculo no produce un error, pero si revisa las matemáticas verá que es algo diferente a (1). En general, es una buena idea en las multiplicaciones de matrices suprimir la caída del atributo de dimensión que puede lograrse mediante el dropparámetro, por ejemplo 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

Después de explorar este ejercicio, puede probar las formas más fáciles en R. Hay dos funciones populares para hacer PCA: princompy prcomp. La princompfunción realiza la descomposición del valor propio como lo hizo en su ejercicio. La prcompfunción utiliza la descomposición de valores singulares. Ambos métodos darán los mismos resultados casi todo el tiempo: esta respuesta explica las diferencias en R, mientras que esta respuesta explica las matemáticas . (Gracias a TooTone por los comentarios ahora integrados en esta publicación).

Aquí usamos ambos para reproducir el ejercicio en R. Primero usando 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)

Segundo uso 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)

Claramente, los signos están invertidos, pero la explicación de la variación es equivalente.