R/fplsrPI.R

In ftsa: Functional Time Series Analysis

fplsrPI <- function(X, Y, Xtest, order, method = c("delta", "boota"), alpha = 0.05, B = 1000, weight, beta = 0.1, 
                      adjust = c(FALSE, TRUE), backh = 10)
{
  p = dim(Y)[1]
  n = ncol(Y)
  method = match.arg(method)
  if (method == "delta"){
      output = plsrPIs(X, Y, Xtest, ncomp1 = 1, ncomp = order, alpha, weight = weight, beta = beta)
  }
  else {
     if (adjust == FALSE){
         output = plsrPIsboot(X, Y, Xtest, ncomp = order, B, alpha, weight = weight, beta = beta)
     }
     if (adjust == TRUE){
           q = matrix(, p, backh)
           p = dim(Y)[1]
           if (weight == FALSE) {
               for (i in 1:backh) {
                    j = (n - backh - 1) + i
                    pred = t(Y[, 1:(j - 1)])
                    resp = t(Y[, 2:j])
                    mresp = apply(resp, 2, mean)
                    mod = plsr(pred, resp, Xtest = Y[, j], ncomp = order, 
                               type = "simpls")
                    q[, i] = mod$Ypred[, , ] 
               }
           }
           if (weight == TRUE){
               for (i in 1:backh){
                    j = (n - backh - 1) + i
                    pred = t(Y[, 1:(j - 1)])
                    resp = t(Y[, 2:j])
                    mresp = apply(resp, 2, mean)
                    mod = plsr(pred, resp, Xtest = Y[, j], ncomp = order, 
                          type = "simpls", weight = TRUE, beta = beta)
                    q[, i] = mod$Ypred[, , ]
               }
           } 
           up = up1 = down = down1 = matrix(, p, 1)
           for (i in 1:p) {
                up[i, ] = quantile(q[i, ], 1 - alpha/2, na.rm = TRUE)
                down[i, ] = quantile(q[i, ], alpha/2, na.rm = TRUE)
                up1[i, ] = quantile(Y[i, (n - backh):n], 1 - alpha/2, 
                           na.rm = TRUE)
                down1[i, ] = quantile(Y[i, (n - backh):n], alpha/2, 
                           na.rm = TRUE)
           }
           lbadj = down1/down
           ubadj = up1/up 
           oldoutput = plsrPIsboot(X, Y, Xtest, ncomp = order, B, alpha, weight = weight, beta = beta)
           lbnew = oldoutput$lb * lbadj
           ubnew = oldoutput$ub * ubadj
           output = list(lb = oldoutput$lb, ub = oldoutput$ub, lbadj = lbnew, ubadj = ubnew, 
                         lbadjfactor = lbadj, ubadjfactor = ubadj)
     }
  }
  return(output)
}