https://github.com/cran/ftsa
Tip revision: 2be2cac4679ad78e8ae44283f0200a83b4a2dab9 authored by Han Lin Shang on 09 November 2010, 10:17:30 UTC
version 2.1
version 2.1
Tip revision: 2be2cac
fdpca.R
fdpca = function (x, y, order = 2, ngrid = 500, method = "M", mean = mean,
level = level, lambda = 2.3262, iter = 1, ...)
{
n <- ncol(y)
m <- length(x)
if (lambda < 1)
stop("Lambda too small")
if (iter < 1)
stop("Need at least one iteration")
if (order < 0)
stop("Order must be at least 0")
if (ngrid < n)
stop("Grid should be larger than number of observations per time period.")
if (m != nrow(y))
stop("x and y of incompatible dimension")
if (order > n/2 & method != "classical") {
warning("Not enough data for robust PCA")
method <- "classical"
}
yy <- matrix(NA, nrow = ngrid, ncol = n)
xx <- seq(min(x), max(x), l = ngrid)
delta <- xx[2] - xx[1]
for (i in 1:n) {
miss <- is.na(y[, i])
yy[, i] <- spline(x[!miss], y[!miss, i], n = ngrid)$y
}
if (mean) {
if (method == "M" | method == "rapca")
ax <- L1median2(t(yy), method = "hoss")
else ax <- rowMeans(yy, na.rm = TRUE)
yy <- sweep(yy, 1, ax)
axse <- approx(xx, sqrt(apply(yy, 1, var)/n), xout = x)$y
}
else axse <- NULL
if (level) {
bx <- colMeans(yy, na.rm = TRUE)
yy <- sweep(yy, 2, bx)
}
if (level) {
coeff <- as.matrix(bx)
basis <- as.matrix(rep(1, m))
colnames(coeff) <- colnames(basis) <- "level"
}
else coeff <- basis <- NULL
if (mean) {
coeff <- cbind(rep(1, n), coeff)
basis <- cbind(approx(xx, ax, xout = x)$y, basis)
colnames(coeff)[1] <- colnames(basis)[1] <- "mean"
}
if (order == 0)
return(list(basis = basis, coeff = coeff, weights = rep(1,
n), v = rep(1, n), mean.se = axse))
if (method == "M" | method == "rapca") {
robusteig <- rapca(yy, order = order, mean = FALSE, ...)
B <- robusteig$coeff
Phi <- robusteig$basis
yyhat <- Phi %*% t(B)
v <- colSums((yy - yyhat)^2) * delta
}
else {
v <- rep(1, n)
iter <- 1
}
if (method == "rapca") {
varprop <- rep(NA, order)
w <- rep(1, order)
}
else {
for (i in 1:iter) {
medv <- median(v)
w <- ifelse(v < medv + lambda * sqrt(medv), 1, 0)
V <- repmat(w/mean(w), 1, ngrid) * t(yy)
s <- La.svd(V)
Phi <- as.matrix(t(s$vt)[, 1:order])
B <- t(yy) %*% Phi
v <- colSums((yy - Phi %*% t(B))^2) * delta
}
varprop <- s$d^2
varprop <- varprop/sum(s$d^2)
}
colnames(B) <- paste("beta", 1:order, sep = "")
coeff <- cbind(coeff, B * delta)
m <- ncol(basis)
for (i in 1:order) {
basis <- cbind(basis, approx(xx, Phi[, i], xout = x)$y/delta)
if (sum(basis[, i + m]) < 0) {
basis[, i + m] <- -basis[, i + m]
coeff[, i + m] <- -coeff[, i + m]
}
}
colnames(basis)[m + (1:order)] <- paste("phi", 1:order, sep = "")
varprop <- varprop[1:order]
yy <- yy - Phi %*% t(B)
s <- try(La.svd(t(yy)), silent = TRUE)
if (class(s) == "try-error") {
s <- svd(t(yy), LINPACK = TRUE)
s$vt <- t(s$v)
}
Phi2 <- as.matrix(t(s$vt)[, s$d > 1e-06])
m <- ncol(Phi2)
basis2 <- coeff2 <- NULL
if (m > 0) {
B2 <- t(yy) %*% Phi2
colnames(B2) <- paste("beta", order + (1:ncol(B2)), sep = "")
coeff2 <- B2 * delta
for (i in 1:m) {
basis2 <- cbind(basis2, approx(xx, Phi2[, i], xout = x)$y/delta)
if (sum(basis2[, i]) < 0) {
basis2[, i] <- -basis2[, i]
coeff2[, i] <- -coeff2[, i]
}
}
colnames(basis2) <- paste("phi", order + (1:m), sep = "")
}
return(list(basis = basis, coeff = coeff, varprop = varprop,
weights = w/mean(w), v = v, basis2 = basis2, coeff2 = coeff2,
mean.se = axse))
}