https://github.com/cran/ftsa
Tip revision: 68ba4865ce589415f9b23ce4cd7105d924b884bb authored by Han Lin Shang on 08 October 2009, 12:41:23 UTC
version 1.1
version 1.1
Tip revision: 68ba486
fplsr.R
fplsr <- function (data, order = 6, type = c("simpls",
"nipals"), unit.weights = TRUE, weight = FALSE, beta = 0.1,
interval = FALSE, method = c("delta", "boota"), alpha = 0.05,
B = 100, adjust = FALSE, backh = 10)
{
if (missing(type)){
type = "simpls"
}
rawdata = t(data$y)
n = dim(rawdata)[1]
Xtrain = rawdata[1:(n-1),]
Ytrain = rawdata[2:n,]
Xtest = as.numeric(rawdata[n,])
if (interval == FALSE){
if (type == "simpls") {
if (unit.weights == TRUE) {
output = unitsimpls(Xtrain, Ytrain, Xtest, order, weight = weight,
beta = beta)
fitted = t(output$T%*%t(output$Q)) + colMeans(Ytrain)
residuals = t(Ytrain) - fitted
out = list(x1 = as.numeric(rownames(Xtrain)), y1 = as.numeric(colnames(Xtrain)),
y = fts(1:dim(Ytrain)[2], t(Ytrain), xname = data$xname, yname = data$yname),
B = output$B, Ypred = fts(1:dim(Ytrain)[2], as.matrix(output$Ypred), xname = data$xname, yname = data$yname),
P = output$P, Q = output$Q, T = output$T, R = output$R,
fitted = fts(1:dim(Xtrain)[2], fitted, xname = data$xname, yname = "Fitted values"),
residuals = fts(1:dim(Xtrain)[2], residuals, xname = data$xname,
yname = "Residual"), meanX = fts(1:dim(Xtrain)[2], as.matrix(colMeans(Xtrain)), xname = data$xname, yname = data$yname),
meanY = fts(1:dim(Ytrain)[2], as.matrix(colMeans(Ytrain)), xname = data$xname, yname = data$yname), call = match.call())
return(structure(out, class = "fm"))
}
else {
output = simpls(Xtrain, Ytrain, Xtest, order, weight = weight,
beta = beta)
fitted = t(output$T%*%t(output$Q)) + colMeans(Ytrain)
residuals = t(Ytrain) - fitted
out = list(x1 = as.numeric(rownames(Xtrain)), y1 = as.numeric(colnames(Xtrain)),
y = fts(1:dim(Ytrain)[2], t(Ytrain), xname = data$xname, yname = data$yname),
B = output$B, Ypred = fts(1:dim(Ytrain)[2], as.matrix(output$Ypred), xname = data$xname, yname = data$yname),
P = output$P, Q = output$Q, T = output$T, R = output$R,
fitted = fts(1:dim(Xtrain)[2], fitted, xname = data$xname, yname = "Fitted values"),
residuals = fts(1:dim(Xtrain)[2], residuals, xname = data$xname,
yname = "Residual"), meanX = fts(1:dim(Xtrain)[2], as.matrix(colMeans(Xtrain)), xname = data$xname, yname = data$yname),
meanY = fts(1:dim(Ytrain)[2], as.matrix(colMeans(Ytrain)), xname = data$xname, yname = data$yname), call = match.call())
return(structure(out, class = "fm"))
}
}
else {
output = nipals(Xtrain, Ytrain, Xtest, order, weight = weight,
beta = beta)
out = list(x1 = as.numeric(rownames(Xtrain)), y1 = as.numeric(colnames(Xtrain)),
y = fts(1:dim(Ytrain)[2], t(Ytrain), xname = data$xname, yname = data$yname),
B = output$B, Ypred = fts(1:dim(Ytrain)[2], matrix(output$Ypred, dim(Ytrain)[2],), xname = data$xname, yname = data$yname),
P = output$P, Q = output$Q, T = output$T,
R = output$R, meanX = fts(1:dim(Xtrain)[2], as.matrix(colMeans(Xtrain)), xname = data$xname, yname = data$yname),
meanY = fts(1:dim(Ytrain)[2], as.matrix(colMeans(Ytrain)), xname = data$xname, yname = data$yname),
Yscores = output$Yscores, projection = output$projection,
fitted = fts(1:dim(Xtrain)[2],t(output$fitted.values[,,order]), xname = data$xname, yname = "Fitted values"),
residuals = fts(1:dim(Xtrain)[2], t(output$residuals[,,order]), xname = data$xname, yname = "Residual"),
Xvar = output$Xvar, Xtotvar = output$Xtotvar, call = match.call())
return(structure(out, class = "fm"))
}
}
else{
fplsrPI(t(Xtrain), t(Ytrain), Xtest, order, method = method, alpha = alpha, B = B, weight = weight,
beta = beta, adjust = adjust, backh = backh)
}
}