[Analogue-commits] r280 - pkg/R

[noreply at r-forge.r-project.org]

Author: gsimpson
Date: 2012-08-01 23:53:13 +0200 (Wed, 01 Aug 2012)
New Revision: 280

Added:
   pkg/R/fitPCR.R
Log:
internal function wrapping key PCR matrix algebra

Added: pkg/R/fitPCR.R
===================================================================
--- pkg/R/fitPCR.R	                        (rev 0)
+++ pkg/R/fitPCR.R	2012-08-01 21:53:13 UTC (rev 280)
@@ -0,0 +1,19 @@
+`fitPCR` <- function(X, Y, ncomp, n, m) {
+    S <- seq_len(ncomp)
+    ## model coefficients
+    B <- matrix(0, nrow = m, ncol = ncomp)
+    Yhat <- matrix(0, nrow = n, ncol = ncomp)
+    ## SVD
+    SVD <- La.svd(X)
+    D <- SVD$d[S]
+    TT <- SVD$u[, S, drop = FALSE] %*% diag(D, nrow = ncomp)
+    P <- t(SVD$vt[S, , drop = FALSE])
+    tQ <- crossprod(TT, Y) / (varExpl <- D^2)
+    ## compute coefficients
+    for(b in S) {
+        bS <- seq_len(b)
+        B[, b] <- P[, bS, drop = FALSE] %*% tQ[bS, ]
+        Yhat[, b] <- TT[, bS, drop = FALSE] %*% tQ[bS, ]
+    }
+    list(Yhat = Yhat, B = B, TT = TT, P = P, tQ = tQ, varExpl = varExpl)
+}