fRegress.stderr.R

fRegress.stderr <- function (y, y2cMap, SigmaE, returnMatrix = FALSE, ...) 
{
  
  #  FREGRESS.STDERR  computes standard error estimates for regression
  #       coefficient functions estimated by function FREGRESS.
  #
  #  Arguments:
  #
  #  Y            ... a list object produced by function FREGRESS with class name
  #                   'fRegress".  
  #                   This is indicated by Y in the arguments since R syntax
  #                   requires all of tghe fRegress family of functions to
  #                   use this notation.
  #  Y2CMAP       ... the matrix mapping from the vector of observed values
  #                   to the coefficients for the dependent variable.
  #                   This is output by function SMOOTH_BASIS.  If this is
  #                   supplied, confidence limits are computed, otherwise not.
  #  SIGMAE       ... Estimate of the covariances among the residuals.  This
  #                   can only be estimated after a preliminary analysis
  #                   with FREGRESS.
  #  RETURNMATRIX ... If False, a matrix in sparse storage model can be returned
  #               from a call to function BsplineS.  See this function for
  #               enabling this option.
  #
  #  Returns:
  #
  #  BETASTDERRLIST ... a list object, each list containing a fdPar object
  #                     for the standard error of a regression function.
  #  BVAR           ... the symmetric matrix of sampling variances and
  #                     covariances for the matrix of regression coefficients
  #                     for the regression functions.  These are stored
  #                     column-wise in defining BVARIANCE.
  #  C2BMAP         ... the matrix mapping from response variable coefficients
  #                     to coefficients for regression coefficients
  
  #  Last modified 16 December 2020
  
  #  retrieve objects from y
  
  yfdobj         <- y$yfdobj
  xfdlist        <- y$xfdlist
  betalist       <- y$betalist
  betaestlist    <- y$betaestlist
  yhatfdobj      <- y$yhatfdobj
  Cmat           <- y$Cmat
  Dmat           <- y$Dmat
  Cmatinv        <- y$Cmatinv
  wt             <- y$wt
  df             <- y$df
  betastderrlist <- y$betastderrlist
  YhatStderr     <- y$YhatStderr
  Bvar           <- y$Bvar
  c2bMap         <- y$c2bMap
  
  #  get number of independent variables
  
  p <- length(xfdlist)

  #  compute number of coefficients
  
  ncoef <- 0
  for (j in 1:p) {
    betaParfdj <- betalist[[j]]
    ncoefj <- betaParfdj$fd$basis$nbasis
    ncoef <- ncoef + ncoefj
  }
  
  if (inherits(yfdobj, "fdPar") || inherits(yfdobj, "fd")) {
    
    #  ----------------------------------------------------------------
    #           yfdobj is functional data object
    #  ----------------------------------------------------------------
    
    #  As of 2020, if yfdobj is an fdPar object, it is converted to an fd object.
    #  The added structure of the fdPar class is not used in any of the fRegress codes.
    #  The older versions of fda package used yfdPar as the name for the first member.
    
    if (inherits(yfdobj, "fdPar")) yfdobj <- yfdobj$fd
    
    #  get number of replications and basis information for YFDPAR
    
    N         <- dim(yfdobj$coefs)[2]
    ybasisobj <- yfdobj$basis
    rangeval  <- ybasisobj$rangeval
    ynbasis   <- ybasisobj$nbasis
    ninteg    <- max(501, 10 * ynbasis + 1)
    tinteg    <- seq(rangeval[1], rangeval[2], len = ninteg)
    deltat    <- tinteg[2] - tinteg[1]
    
    ybasismat <- eval.basis(tinteg, ybasisobj, 0, returnMatrix)
    
    #  compute BASISPRODMAT
    
    basisprodmat <- matrix(0, ncoef, ynbasis * N)
    
    mj2 <- 0
    for (j in 1:p) {
      betafdParj <- betalist[[j]]
      betabasisj <- betafdParj$fd$basis
      ncoefj <- betabasisj$nbasis
      bbasismatj <- eval.basis(tinteg, betabasisj, 0, returnMatrix)
      xfdj <- xfdlist[[j]]
      tempj <- eval.fd(tinteg, xfdj, 0, returnMatrix)
      mj1 <- mj2 + 1
      mj2 <- mj2 + ncoefj
      indexj <- mj1:mj2
      mk2 <- 0
      for (k in 1:ynbasis) {
        mk1 <- mk2 + 1
        mk2 <- mk2 + N
        indexk <- mk1:mk2
        tempk <- bbasismatj * ybasismat[, k]
        basisprodmat[indexj, indexk] <- deltat * crossprod(tempk, 
                                                           tempj)
      }
    }
    
    #  check dimensions of Y2CMAP
    
    y2cdim <- dim(y2cMap)
    if (y2cdim[1] != ynbasis || y2cdim[2] != dim(SigmaE)[1]) 
      stop("Dimensions of Y2CMAP not correct.")
    
    #  compute variances of regression coefficient function values
    
    Varc <- y2cMap %*% SigmaE %*% t(y2cMap)
    CVar <- kronecker(Varc, diag(rep(1, N)))
    C2BMap <- Cmatinv %*% basisprodmat
    Bvar <- C2BMap %*% CVar %*% t(C2BMap)
    nplot <- max(51, 10 * ynbasis + 1)
    tplot <- seq(rangeval[1], rangeval[2], len = nplot)
    betastderrlist <- vector("list", p)
    PsiMatlist <- vector("list", p)
    mj2 <- 0
    for (j in 1:p) {
      betafdParj <- betalist[[j]]
      betabasisj <- betafdParj$fd$basis
      ncoefj <- betabasisj$nbasis
      mj1 <- mj2 + 1
      mj2 <- mj2 + ncoefj
      indexj <- mj1:mj2
      bbasismat <- eval.basis(tplot, betabasisj, 0, returnMatrix)
      PsiMatlist <- bbasismat
      bvarj <- Bvar[indexj, indexj]
      bstderrj <- sqrt(diag(bbasismat %*% bvarj %*% t(bbasismat)))
      bstderrfdj <- smooth.basis(tplot, bstderrj, betabasisj)$fd
      betastderrlist[[j]] <- bstderrfdj
    }
    
    #  compute estimated variance-covariance matrix over plotting grid
    #  of fitted values
    
    YhatStderr <- matrix(0, nplot, N)
    B2YhatList <- vector("list", p)
    for (iplot in 1:nplot) {
      YhatVari <- matrix(0, N, N)
      tval <- tplot[iplot]
      for (j in 1:p) {
        Zmat <- eval.fd(tval, xfdlist[[j]])
        betabasisj <- betalist[[j]]$fd$basis
        PsiMatj <- eval.basis(tval, betabasisj)
        B2YhatMapij <- t(Zmat) %*% PsiMatj
        B2YhatList[[j]] <- B2YhatMapij
      }
      m2j <- 0
      for (j in 1:p) {
        m1j <- m2j + 1
        m2j <- m2j + betalist[[j]]$fd$basis$nbasis
        B2YhatMapij <- B2YhatList[[j]]
        m2k <- 0
        for (k in 1:p) {
          m1k <- m2k + 1
          m2k <- m2k + betalist[[k]]$fd$basis$nbasis
          B2YhatMapik <- B2YhatList[[k]]
          YhatVari <- YhatVari + 
            B2YhatMapij %*% Bvar[m1j:m2j,m1k:m2k] %*% t(B2YhatMapik)
        }
      }
      YhatStderr[iplot, ] <- matrix(sqrt(diag(YhatVari)), 1, N)
    }
  }
  
  else {
    
    #  ----------------------------------------------------------------
    #                   yfdobj is scalar or multivariate
    #  ----------------------------------------------------------------
    
    ymat <- as.matrix(yfdobj)
    N <- dim(ymat)[1]
    Zmat <- NULL
    for (j in 1:p) {
      xfdj <- xfdlist[[j]]
      if (inherits(xfdj, "fd")) {
        xcoef <- xfdj$coefs
        xbasis <- xfdj$basis
        betafdParj <- betalist[[j]]
        bbasis <- betafdParj$fd$basis
        Jpsithetaj <- inprod(xbasis, bbasis)
        Zmat <- cbind(Zmat, t(xcoef) %*% Jpsithetaj)
      }
      else if (inherits(xfdj, "numeric")) {
        Zmatj <- xfdj
        Zmat <- cbind(Zmat, Zmatj)
      }
    }
    
    #  compute linear mapping c2bMap takinging coefficients for
    #  response into coefficients for regression functions
    
    c2bMap <- Cmatinv %*% t(Zmat)
    y2bmap <- c2bMap
    Bvar <- y2bmap %*% as.matrix(SigmaE) %*% t(y2bmap)
    betastderrlist <- vector("list", p)
    mj2 <- 0
    for (j in 1:p) {
      betafdParj <- betalist[[j]]
      betabasisj <- betafdParj$fd$basis
      ncoefj <- betabasisj$nbasis
      mj1 <- mj2 + 1
      mj2 <- mj2 + ncoefj
      indexj <- mj1:mj2
      bvarj <- Bvar[indexj, indexj]
      xfdj <- xfdlist[[j]]
      if (inherits(xfdj, "fd")) {
        betarng <- betabasisj$rangeval
        ninteg <- max(c(501, 10 * ncoefj + 1))
        tinteg <- seq(betarng[1], betarng[2], len = ninteg)
        bbasismat <- eval.basis(tinteg, betabasisj, 0, 
                                returnMatrix)
        bstderrj <- sqrt(diag(bbasismat %*% bvarj %*% 
                                t(bbasismat)))
        bstderrfdj <- smooth.basis(tinteg, bstderrj, 
                                   betabasisj)$fd
      }
      else {
        bsterrj <- sqrt(diag(bvarj))
        onebasis <- create.constant.basis(betabasisj$rangeval)
        bstderrfdj <- fd(t(bstderrj), onebasis)
      }
      betastderrlist[[j]] <- bstderrfdj
    }
    
    #  compute estimated variance-covariance matrix for fitted values
    
    B2YhatList <- vector("list", p)
    YhatVari <- matrix(0, N, N)
    for (j in 1:p) {
      betabasisj <- betalist[[j]]$fd$basis
      Xfdj <- xfdlist[[j]]
      B2YhatMapij <- inprod(Xfdj, betabasisj)
      B2YhatList[[j]] <- B2YhatMapij
    }
    m2j <- 0
    for (j in 1:p) {
      m1j <- m2j + 1
      m2j <- m2j + betalist[[j]]$fd$basis$nbasis
      B2YhatMapij <- B2YhatList[[j]]
      m2k <- 0
      for (k in 1:p) {
        m1k <- m2k + 1
        m2k <- m2k + betalist[[k]]$fd$basis$nbasis
        B2YhatMapik <- B2YhatList[[k]]
        YhatVari <- YhatVari + B2YhatMapij %*% Bvar[m1j:m2j, 
                                                    m1k:m2k] %*% t(B2YhatMapik)
      }
    }
    YhatStderr <- matrix(sqrt(diag(YhatVari)), N, 1)
  }
  
  #  return output object of class fRegress
  
  fRegressList <- list(yfdobj = y$yfdobj, xfdlist = y$xfdlist, 
                       betalist = y$betalist, betaestlist = y$betaestlist, 
                       yhatfdobj = y$yhatfdobj, Cmat = y$Cmat, Dmat = y$Dmat, 
                       Cmatinv = y$Cmatinv, wt = y$wt, 
                       df = y$df, y2cMap = y2cMap, SigmaE = SigmaE, 
                       betastderrlist = betastderrlist, YhatStderr = YhatStderr, 
                       Bvar = Bvar, c2bMap = c2bMap)
  
  class(fRegressList) = "fRegress"
  return(fRegressList)
}