https://github.com/cran/fda
Tip revision: cffaee83f2132e70d363589d8be217ce70ea1e3a authored by J. O. Ramsay on 02 March 2009, 00:00:00 UTC
version 2.1.2
version 2.1.2
Tip revision: cffaee8
fRegress.numeric.R
fRegress.numeric <- function(y, xfdlist, betalist, wt=NULL,
y2cMap=NULL, SigmaE=NULL, ...)
{
# FREGRESS Fits a functional linear model using multiple
# functional independent variables with the dependency being
# pointwise or concurrent.
# The case of a scalar independent variable is included by treating
# it as a functional independent variable with a constant basis
# and a unit coefficient.
#
# Arguments:
# YFDPAR ... an object for the dependent variable,
# which may be:
# a functional data object,
# a functional parameter (fdPar) object, or
# a vector
# XFDLIST ... a list object of length p with each list
# containing an object for an independent variable.
# the object may be:
# a functional data object or
# a vector
# if XFDLIST is a functional data object or a vector,
# it is converted to a list of length 1.
# BETALIST ... a list object of length p with each list
# containing a functional parameter object for
# the corresponding regression function. If any of
# these objects is a functional data object, it is
# converted to the default functional parameter object.
# if BETALIST is a functional parameter object
# it is converted to a list of length 1.
# WT ... a vector of nonnegative weights for observations
# 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.
#
# Returns FREGRESSLIST ... A list containing seven members with names:
# yfdPar ... first argument of FREGRESS
# xfdlist ... second argument of FREGRESS
# betalist ... third argument of FREGRESS
# betaestlist ... estimated regression functions
# yhatfdobj ... functional data object containing fitted functions
# Cmatinv ... inverse of the coefficient matrix, needed for
# function FREGRESS.STDERR that computes standard errors
# wt ... weights for observations
# df ... degrees of freedom for fit
# Last modified 2008.12.26 by Spencer
# previously modified 11 December 2008 by Jim
# check YFDPAR and compute sample size N
yfdPar <- y
if (inherits(yfdPar, "fd")) yfdPar <- fdPar(yfdPar)
if (!(inherits(yfdPar, "fdPar") || inherits(yfdPar, "numeric")))
stop("First argument is not of class 'fd', 'fdPar' or 'numeric'.")
if (inherits(yfdPar, "fdPar")) {
yfd <- yfdPar$fd
ycoef <- yfd$coefs
N <- dim(ycoef)[2]
}
if (inherits(yfdPar, "numeric")) {
N <- length(yfdPar)
}
# get number of independent variables p
p <- length(xfdlist)
# check BETALIST
if (inherits(betalist, "fd")) betalist <- list(betalist)
if (!inherits(betalist, "list"))
stop("Argument BETALIST is not a list object.")
if (length(betalist) != p)
stop("Number of regression coefficients does not match\n",
" the number of independent variables.")
berror <- FALSE
for (j in 1:p) {
betafdParj <- betalist[[j]]
if (inherits(betafdParj, "fd") || inherits(betafdParj, "basisfd")) {
betafdParj <- fdPar(betafdParj)
betalist[[j]] <- betafdParj
}
if (!inherits(betafdParj, "fdPar")) {
print(paste("BETALIST[[",j,"]] is not a FDPAR object."))
berror <- TRUE
}
}
if (berror) stop("bad betalist.")
betafd1 <- betalist[[1]]$fd
betabasis1 <- betafd1$basis
rangeval <- betabasis1$rangeval
# check XFDLIST
if (inherits(xfdlist, "fd") || inherits(xfdlist, "numeric"))
xfdlist <- list(xfdlist)
if (!inherits(xfdlist, "list"))
stop("Argument XFDLIST is not a list object.")
# check each xfdlist member. If the object is a vector of length N,
# it is converted to a functional data object with a
# constant basis
onebasis <- create.constant.basis(rangeval)
onesfd <- fd(1,onebasis)
xerror <- FALSE
for (j in 1:p) {
xfdj <- xfdlist[[j]]
if (inherits(xfdj, "fd")) {
xcoef <- xfdj$coefs
if (length(dim(xcoef)) > 2)
stop(paste("Covariate",j,"is not univariate."))
# check size of coefficient array
Nj <- dim(xcoef)[2]
if (Nj != N) {
print(paste("Incorrect number of replications in XFDLIST",
"for covariate",j))
xerror = TRUE
}
}
if (is.numeric(xfdj)) {
if (!is.matrix(xfdj)) xfdj = as.matrix(xfdj)
Zdimj <- dim(xfdj)
if (Zdimj[1] != N) {
print(paste("Vector in XFDLIST[[",j,"]] has wrong length."))
xerror = TRUE
}
if (Zdimj[2] != 1) {
print(paste("Matrix in XFDLIST[[", j,
"]] has more than one column."))
xerror = TRUE
}
xfdlist[[j]] <- fd(matrix(xfdj,1,N), onebasis)
}
if(!(inherits(xfdlist[[j]], "fd") || is.numeric(xfdlist[[j]]))){
print(paste("XFDLIST[[", j,
"]] is neither an FD object nor numeric."))
xerror = TRUE
}
}
if (xerror) stop("bad xfdlist")
# check weights
{
if(is.null(wt)){
wt <- rep(1, N)
wtconstant <- TRUE
}
else {
if (length(wt) != N) stop("Number of weights not equal to N.")
if (any(wt < 0)) stop("Negative weights found.")
wtconstant <- (var(wt) == 0)
}
}
# --------------------------------------------------------------
# branch depending on whether the dependent variable
# is functional or scalar
# --------------------------------------------------------------
if (inherits(yfdPar, "fdPar")) {
# ----------------------------------------------------------------
# YFDPAR is a functional parameter object
# ----------------------------------------------------------------
# extract dependent variable information
yfdobj <- yfdPar$fd
ylambda <- yfdPar$lambda
yLfdobj <- yfdPar$Lfd
ycoef <- yfdobj$coefs
ycoefdim <- dim(ycoef)
N <- ycoefdim[2]
ybasisobj <- yfdobj$basis
rangeval <- ybasisobj$rangeval
ynbasis <- ybasisobj$nbasis
if (length(ycoefdim) > 2)
stop("YFDOBJ from YFDPAR is not univariate.")
# -----------------------------------------------------------
# set up the linear equations for the solution
# -----------------------------------------------------------
# compute the total number of coefficients to be estimated
ncoef <- 0
for (j in 1:p) {
betafdParj <- betalist[[j]]
if (betafdParj$estimate) {
ncoefj <- betafdParj$fd$basis$nbasis
ncoef <- ncoef + ncoefj
}
}
Cmat <- matrix(0,ncoef,ncoef)
Dmat <- rep(0,ncoef)
# loop through rows of CMAT
mj2 <- 0
for (j in 1:p) {
betafdParj <- betalist[[j]]
if (betafdParj$estimate) {
betafdj <- betafdParj$fd
betabasisj <- betafdj$basis
ncoefj <- betabasisj$nbasis
# row indices of CMAT and DMAT to fill
mj1 <- mj2 + 1
mj2 <- mj2 + ncoefj
indexj <- mj1:mj2
# compute right side of equation DMAT
xfdj <- xfdlist[[j]]
if (wtconstant) {
xyfdj <- xfdj*yfdobj
} else {
xyfdj <- (xfdj*wt)*yfdobj
}
wtfdj <- sum(xyfdj)
Dmatj <- inprod(betabasisj,onesfd,0,0,rangeval,wtfdj)
Dmat[indexj] <- Dmatj
# loop through columns of CMAT
mk2 <- 0
for (k in 1:j) {
betafdPark <- betalist[[k]]
if (betafdPark$estimate) {
betafdk <- betafdPark$fd
betabasisk <- betafdk$basis
ncoefk <- betabasisk$nbasis
# column indices of CMAT to fill
mk1 <- mk2 + 1
mk2 <- mk2 + ncoefk
indexk <- mk1:mk2
# set up two weight functions
xfdk <- xfdlist[[k]]
if (wtconstant) {
xxfdjk <- xfdj*xfdk
} else {
xxfdjk <- (xfdj*wt)*xfdk
}
wtfdjk <- sum(xxfdjk)
Cmatjk <- inprod(betabasisj, betabasisk, 0, 0, rangeval,
wtfdjk)
Cmat[indexj,indexk] <- Cmatjk
Cmat[indexk,indexj] <- t(Cmatjk)
}
}
# attach penalty term to diagonal block
lambda <- betafdParj$lambda
if (lambda > 0) {
Lfdj <- betafdParj$Lfd
Rmatj <- eval.penalty(betafdParj$fd$basis, Lfdj)
Cmat[indexj,indexj] <- Cmat[indexj,indexj] + lambda*Rmatj
}
}
}
Cmat <- (Cmat+t(Cmat))/2
# check Cmat for singularity
eigchk(Cmat)
# solve for coefficients defining BETA
Lmat <- chol(Cmat)
Lmatinv <- solve(Lmat)
Cmatinv <- Lmatinv %*% t(Lmatinv)
betacoef <- Cmatinv %*% Dmat
# set up fdPar objects for reg. fns. in BETAESTLIST
betaestlist <- betalist
mj2 <- 0
for (j in 1:p) {
betafdParj <- betalist[[j]]
if (betafdParj$estimate) {
betafdj <- betafdParj$fd
ncoefj <- betafdj$basis$nbasis
mj1 <- mj2 + 1
mj2 <- mj2 + ncoefj
indexj <- mj1:mj2
coefj <- betacoef[indexj]
betafdj$coefs <- as.matrix(coefj)
betafdParj$fd <- betafdj
}
betaestlist[[j]] <- betafdParj
}
# set up fd objects for predicted values in YHATFDOBJ
nfine <- max(501,10*ynbasis+1)
tfine <- seq(rangeval[1], rangeval[2], len=nfine)
yhatmat <- matrix(0,nfine,N)
for (j in 1:p) {
xfdj <- xfdlist[[j]]
xmatj <- eval.fd(tfine, xfdj)
betafdParj <- betaestlist[[j]]
betafdj <- betafdParj$fd
betavecj <- eval.fd(tfine, betafdj)
yhatmat <- yhatmat + xmatj*as.vector(betavecj)
}
yhatfdobj <- smooth.basis(tfine, yhatmat, ybasisobj)
# -----------------------------------------------------------------------
# Compute pointwise standard errors of regression coefficients
# if both y2cMap and SigmaE are supplied.
# -----------------------------------------------------------------------
if (!(is.null(y2cMap) || is.null(SigmaE))) {
# check dimensions of y2cMap and SigmaE
y2cdim <- dim(y2cMap)
if (y2cdim[1] != ynbasis ||
y2cdim[2] != dim(SigmaE)[1])
stop("Dimensions of Y2CMAP not correct.")
ybasismat <- eval.basis(tfine, ybasisobj)
deltat <- tfine[2] - tfine[1]
# 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(tfine, betabasisj)
xfdj <- xfdlist[[j]]
tempj <- eval.fd(tfine, xfdj)
# row indices of BASISPRODMAT to fill
mj1 <- mj2 + 1
mj2 <- mj2 + ncoefj
indexj <- mj1:mj2
# inner products of beta basis and response basis
# weighted by covariate basis functions
mk2 <- 0
for (k in 1:ynbasis) {
# row indices of BASISPRODMAT to fill
mk1 <- mk2 + 1
mk2 <- mk2 + N
indexk <- mk1:mk2
tempk <- bbasismatj*ybasismat[,k]
basisprodmat[indexj,indexk] <-
deltat*crossprod(tempk,tempj)
}
}
# compute variances of regression coefficient function values
c2bMap <- Cmatinv %*% basisprodmat
VarCoef <- y2cMap %*% SigmaE %*% t(y2cMap)
CVariance <- kronecker(VarCoef,diag(rep(1,N)))
bvar <- c2bMap %*% CVariance %*% t(c2bMap)
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
bbasismat <- eval.basis(tfine, betabasisj)
bvarj <- bvar[indexj,indexj]
bstderrj <- sqrt(diag(bbasismat %*% bvarj %*% t(bbasismat)))
bstderrfdj <- smooth.basis(tfine, bstderrj, betabasisj)$fd
betastderrlist[[j]] <- bstderrfdj
}
} else{
betastderrlist = NULL
bvar = NULL
c2bMap = NULL
}
# -------------------------------------------------------------------
# Set up output list object
# -------------------------------------------------------------------
fRegressList <-
list(yfdPar = yfdPar,
xfdlist = xfdlist,
betalist = betalist,
betaestlist = betaestlist,
yhatfdobj = yhatfdobj,
Cmatinv = Cmatinv,
wt = wt,
y2cMap = y2cMap,
SigmaE = SigmaE,
betastderrlist = betastderrlist,
bvar = bvar,
c2bMap = c2bMap)
}
# -------------------------------------------------------------------
if (inherits(yfdPar,"numeric")) {
# ----------------------------------------------------------------
# YFDPAR is scalar or multivariate
# ----------------------------------------------------------------
ymat <- as.matrix(yfdPar)
N <- dim(ymat)[1]
Zmat <- NULL
Rmat <- NULL
pjvec <- rep(0,p)
ncoef <- 0
for (j in 1:p) {
xfdj <- xfdlist[[j]]
xcoef <- xfdj$coefs
xbasis <- xfdj$basis
betafdParj <- betalist[[j]]
bbasis <- betafdParj$fd$basis
bnbasis <- bbasis$nbasis
pjvec[j] <- bnbasis
Jpsithetaj <- inprod(xbasis,bbasis)
Zmat <- cbind(Zmat,crossprod(xcoef,Jpsithetaj))
if (betafdParj$estimate) {
lambdaj <- betafdParj$lambda
if (lambdaj > 0) {
Lfdj <- betafdParj$Lfd
Rmatj <- lambdaj*eval.penalty(bbasis,Lfdj)
} else {
Rmatj <- matrix(0,bnbasis,bnbasis)
}
if (ncoef > 0) {
zeromat <- matrix(0,ncoef,bnbasis)
Rmat <- rbind(cbind(Rmat, zeromat),
cbind(t(zeromat), Rmatj))
} else {
Rmat <- Rmatj
ncoef <- ncoef + bnbasis
}
}
}
# -----------------------------------------------------------
# set up the linear equations for the solution
# -----------------------------------------------------------
# solve for coefficients defining BETA
if (any(wt != 1)) {
rtwt <- sqrt(wt)
Zmatwt <- Zmat*rtwt
ymatwt <- ymat*rtwt
Cmat <- t(Zmatwt) %*% Zmatwt + Rmat
Dmat <- t(Zmatwt) %*% ymatwt
} else {
Cmat <- t(Zmat) %*% Zmat + Rmat
Dmat <- t(Zmat) %*% ymat
}
eigchk(Cmat)
Cmatinv <- solve(Cmat)
betacoef <- Cmatinv %*% Dmat
# compute and print degrees of freedom measure
# df <- sum(diag(Zmat %*% Cmatinv %*% t(Zmat)))
hatvals = diag(Zmat %*% Cmatinv %*% t(Zmat))
df <- sum(hatvals)
# set up fdPar object for BETAESTFDPAR
betaestlist <- betalist
onebasis <- create.constant.basis(c(0,1))
mj2 <- 0
for (j in 1:p) {
betafdParj <- betalist[[j]]
betafdj <- betafdParj$fd
ncoefj <- betafdj$basis$nbasis
mj1 <- mj2 + 1
mj2 <- mj2 + ncoefj
indexj <- mj1:mj2
betacoefj <- betacoef[indexj]
if (inherits(xfdj, "fd")) {
betaestfdj <- betafdj
betaestfdj$coefs <- as.matrix(betacoefj)
betaestfdParj <- betafdParj
betaestfdParj$fd <- betaestfdj
betaestlist[[j]] <- betaestfdParj
}
else{
betaestfdj <- fd(as.matrix(t(betacoefj)),onebasis)
betaestfdParj <- betafdParj
betaestfdParj$fd <- betaestfdj
betaestlist[[j]] <- betaestfdParj
}
}
# set up fd object for predicted values
yhatmat <- matrix(0,N,1)
for (j in 1:p) {
xfdj <- xfdlist[[j]]
if (inherits(xfdj, "fd")) {
xbasis <- xfdj$basis
xnbasis <- xbasis$nbasis
xrng <- xbasis$rangeval
nfine <- max(501,10*xnbasis+1)
tfine <- seq(xrng[1], xrng[2], len=nfine)
deltat <- tfine[2]-tfine[1]
xmat <- eval.fd(tfine, xfdj)
betafdParj <- betaestlist[[j]]
betafdj <- betafdParj$fd
betamat <- eval.fd(tfine, betafdj)
fitj <- deltat*(crossprod(xmat,betamat) -
0.5*(outer(xmat[1, ],betamat[1, ]) +
outer(xmat[nfine,],betamat[nfine,])))
yhatmat <- yhatmat + fitj
} else{
betaestfdParj <- betaestlist[[j]]
betavecj <- betaestfdParj$fd$coefs
yhatmat <- yhatmat + xfdj %*% t(betavecj)
}
}
yhatfdobj <- yhatmat
# Calculate OCV and GCV scores
OCV = sum( (ymat-yhatmat)^2/(1-hatvals)^2 )
GCV = sum( (ymat-yhatmat)^2 )/( (sum(1-hatvals))^2 )
# -----------------------------------------------------------------------
# Compute pointwise standard errors of regression coefficients
# if both y2cMap and SigmaE are supplied.
# -----------------------------------------------------------------------
if (!(is.null(y2cMap) || is.null(SigmaE))) {
# check dimensions of y2cMap and SigmaE
y2cdim <- dim(y2cMap)
if (y2cdim[1] != ynbasis ||
y2cdim[2] != dim(SigmaE)[1]) stop(
"Dimensions of Y2CMAP not correct.")
# 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
nfine <- max(c(501,10*ncoefj+1))
tfine <- seq(betarng[1], betarng[2], len=nfine)
bbasismat <- eval.basis(tfine, betabasisj)
bstderrj <- sqrt(diag(bbasismat %*% bvarj %*% t(bbasismat)))
bstderrfdj <- smooth.basis(tfine, bstderrj, betabasisj)$fd
} else {
bsterrj <- sqrt(diag(bvarj))
onebasis <- create.constant.basis(betabasisj$rangeval)
bstderrfdj <- fd(t(bstderrj), onebasis)
}
betastderrlist[[j]] <- bstderrfdj
}
}
# -----------------------------------------------------------------------
# Set up output list object
# -----------------------------------------------------------------------
fRegressList <-
list(yfdPar = yfdPar,
xfdlist = xfdlist,
betalist = betalist,
betaestlist = betaestlist,
yhatfdobj = yhatfdobj,
Cmatinv = Cmatinv,
wt = wt,
df = df,
OCV = OCV,
gcv = GCV)
}
class(fRegressList) <- 'fRegress'
return(fRegressList)
}
# ------------------------------------------------------------------------
eigchk <- function(Cmat) {
# check Cmat for singularity
eigval <- eigen(Cmat)$values
ncoef <- length(eigval)
if (eigval[ncoef] < 0) {
neig <- min(length(eigval),10)
cat("\nSmallest eigenvalues:\n")
print(eigval[(ncoef-neig+1):ncoef])
cat("\nLargest eigenvalues:\n")
print(eigval[1:neig])
stop("Negative eigenvalue of coefficient matrix.")
}
if (eigval[ncoef] == 0) stop("Zero eigenvalue of coefficient matrix.")
logcondition <- log10(eigval[1]) - log10(eigval[ncoef])
if (logcondition > 12) {
warning("Near singularity in coefficient matrix.")
cat(paste("\nLog10 Eigenvalues range from\n",
log10(eigval[ncoef])," to ",log10(eigval[1]),"\n"))
}
}