em-pca.Rmd

## PCA


The following is an EM algorithm for principal components analysis. See Murphy,
2012 Probabilistic Machine Learning 12.2.5. Some of the constructed object is
based on output from <span class="func" style = "">pca</span> function used below. 

### Data Setup

The `state.x77` is from base R, which includes various state demographics.  We
will first standardize the data.

```{r em-pca-setup}
library(tidyverse)

X = scale(state.x77)
```


###  Function

The estimating function.  Note that it uses <span class="func" style =
"">orth</span> from <span class="pack" style = "">pracma</span>, but I show the
core of the underlying code if you don't want to install it.

```{r em-pca-func}
# orth <- function(M) {
#   svdM = svd(M)
#   U    = svdM$u
#   s    = svdM$d
#   tol  = max(dim(M)) * max(s) * .Machine$double.eps
#   r    = sum(s > tol)
#   
#   U[, 1:r, drop = FALSE]
# }

em_pca <- function(
  X,
  n_comp   = 2,
  tol     = .00001,
  maxits  = 100,
  showits = TRUE
  ) {
  
  # Arguments 
  # X: numeric data
  # n_comp: number of components
  # tol = tolerance level
  # maxits: maximum iterations
  # showits: show iterations
  
  
  # starting points and other initializations
  N  = nrow(X)
  D  = ncol(X)
  L  = n_comp
  Xt = t(X)
  Z  = t(replicate(L, rnorm(N)))                 # latent variables
  W  = replicate(L, rnorm(D))                    # loadings
  it = 0
  converged = FALSE
    
  if (showits)                                                     
    cat(paste("Iterations of EM:", "\n"))
  
  # while no convergence and we haven't reached our max iterations do this stuff
  while ((!converged) & (it < maxits)) {                           
    Z_old = Z                                    # create 'old' values for comparison
    Z = solve(t(W)%*%W) %*% crossprod(W, Xt)     # E
    W = Xt%*%t(Z) %*% solve(tcrossprod(Z))       # M

    it = it + 1
    
    # if showits, show first and every 5th iteration
    if (showits & (it == 1 | it%%5 == 0))           
      cat(paste(format(it), "...", "\n", sep = ""))
    
    converged = max(abs(Z_old-Z)) <= tol
  }
  
  # calculate reconstruction error
  Xrecon_em = W %*% Z
  reconerr  = sum((Xrecon_em - t(X))^2)
  
  # orthogonalize
  W     = pracma::orth(W)     # for orthonormal basis of W; pcaMethods package has also
  evs   = eigen(cov(X %*% W))
  evals = evs$values
  evecs = evs$vectors
  
  W = W %*% evecs
  Z = X %*% W

  if (showits)                                     # Show last iteration
    cat(paste0(format(it), "...", "\n"))
  
  list(
    scores    = Z,
    loadings  = W,
    reconerr  = reconerr,
    Xrecon_em = t(Xrecon_em)
  )
}
```






### Estimation

```{r em-pca-est}
fit_em = em_pca(
  X = X,
  n_comp = 2,
  tol    = 1e-12,
  maxit  = 1000
)

str(fit_em)  # examine results
```

### Comparison

Extract reconstructed values and loadings for comparison.

```{r em-pca-extract}
Xrecon_em   = fit_em$Xrecon_em
loadings_em = fit_em$loadings
scores_em   = fit_em$scores
```

Compare results to output from <span class="pack" style = "">pcaMethods</span>, which also has probabilistic PCA (demonstrated next). Note that the signs for loadings/scores may be different in sign, but otherwise should be comparable.

```{r em-pca-compare}
library(pcaMethods)  # install via BiocManager::install("pcaMethods")

fit_pcam = pca(
  X,
  nPcs = 2,
  method = 'svd',
  scale  = 'none',
  center = FALSE
)

loadings_pcam = loadings(fit_pcam)
scores_pcam   = scores(fit_pcam)
```


Compare loadings and scores.

```{r em-pca-compare-loadings}
sum((abs(loadings_pcam) - abs(loadings_em))^2)

cbind(scores_pcam, data.frame(EM = scores_em)) %>% 
  head()
```


Calculate mean squared reconstruction error and compare.

```{r em-pca-compare-recon}
Xrecon_pcam = scores_pcam %*% t(loadings_pcam)

mean((Xrecon_em - X)^2)
mean((Xrecon_pcam - X)^2)

mean(abs(Xrecon_pcam - Xrecon_em))
```



### Visualize

```{r em-pca-vis}
# qplot(Xrecon_pcam[,1], X[,1])
# qplot(Xrecon_pcam[,2], X[,2])
qplot(Xrecon_em[,1], Xrecon_pcam[,1])
```


### Source

Original code available at
https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/EM%20Examples/EM%20for%20pca.R