R/fplsr.R

In ftsa: Functional Time Series Analysis

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) 
{
    type = match.arg(type)
    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)
                colnames(fitted) = rownames(Xtrain)
                residuals = t(Ytrain) - fitted
                
                Ypred_mat = as.matrix(output$Ypred)
                colnames(Ypred_mat) = 1:ncol(Ypred_mat)
                
                Xtrain_mat = as.matrix(colMeans(Xtrain))
                colnames(Xtrain_mat) = 1:ncol(Xtrain_mat)
                
                Ytrain_mat = as.matrix(colMeans(Ytrain))
                colnames(Ytrain_mat) = 1:ncol(Ytrain_mat)
                out = list(x1 = as.numeric(rownames(Xtrain)), 
                           y1 = as.numeric(colnames(Xtrain)), 
			                     ypred = fts(1:dim(Xtrain)[2], t(Xtrain), xname = data$xname, yname = data$yname),
			                     y = fts(1:dim(Ytrain)[2], t(Ytrain), xname = data$xname, yname = data$yname), 
                           Ypred = fts(1:dim(Ytrain)[2], Ypred_mat, xname = data$xname, yname = data$yname), 
			                     B = output$B, 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], Xtrain_mat, xname = data$xname, yname = data$yname), 
                           meanY = fts(1:dim(Ytrain)[2], Ytrain_mat , 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)
                colnames(fitted) = rownames(Xtrain)
                residuals = t(Ytrain) - fitted
                
                Ypred_mat = as.matrix(output$Ypred)
                colnames(Ypred_mat) = 1:ncol(Ypred_mat)
                
                Xtrain_mat = as.matrix(colMeans(Xtrain))
                colnames(Xtrain_mat) = 1:ncol(Xtrain_mat)
                
                Ytrain_mat = as.matrix(colMeans(Ytrain))
                colnames(Ytrain_mat) = 1:ncol(Ytrain_mat)
                out = list(x1 = as.numeric(rownames(Xtrain)), 
                           y1 = as.numeric(colnames(Xtrain)), 
			                     ypred = fts(1:dim(Xtrain)[2], t(Xtrain), xname = data$xname, yname = data$yname),
			                     y = fts(1:dim(Ytrain)[2], t(Ytrain), xname = data$xname, yname = data$yname), 
                           Ypred = fts(1:dim(Ytrain)[2], Ypred_mat, xname = data$xname, yname = data$yname), 
			                     B = output$B, 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], Xtrain_mat, xname = data$xname, yname = data$yname), 
                           meanY = fts(1:dim(Ytrain)[2], Ytrain_mat, 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)
            
            Ypred_mat = matrix(output$Ypred, dim(Ytrain)[2], )
            colnames(Ypred_mat) = 1:ncol(Ypred_mat)

            Xtrain_mat = as.matrix(colMeans(Xtrain))            
            colnames(Xtrain_mat) = 1:ncol(Xtrain_mat)
            
            Ytrain_mat = as.matrix(colMeans(Ytrain))
            colnames(Ytrain_mat) = 1:ncol(Ytrain_mat)
            
            fitted_mat_value = t(output$fitted.values[, , order])
            colnames(fitted_mat_value) = rownames(Xtrain)
            
            residual_mat_value = t(output$residuals[, , order])
            colnames(residual_mat_value) = rownames(Xtrain)
            
            out = list(x1 = as.numeric(rownames(Xtrain)), y1 = as.numeric(colnames(Xtrain)), 
      				         ypred = fts(1:dim(Xtrain)[2], t(Xtrain), xname = data$xname, yname = data$yname),
                       y = fts(1:dim(Ytrain)[2], t(Ytrain), xname = data$xname, yname = data$yname), 
      				         Ypred = fts(1:dim(Ytrain)[2], Ypred_mat, xname = data$xname, yname = data$yname), 
      				         P = output$P, Q = output$Q, B = output$B, T = output$T, R = output$R, 
      				         meanX = fts(1:dim(Xtrain)[2], Xtrain_mat, xname = data$xname, yname = data$yname), 
      				         meanY = fts(1:dim(Ytrain)[2], Ytrain_mat, xname = data$xname, yname = data$yname), 
      				         Yscores = output$Yscores, projection = output$projection, 
      				         fitted = fts(1:dim(Xtrain)[2], fitted_mat_value, xname = data$xname, yname = "Fitted values"), 
      				         residuals = fts(1:dim(Xtrain)[2], residual_mat_value, 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)
    }
}