.packageName <- "fda"
'+.fd' <- function(fd1, fd2)
{
	#  Arguments:
	#  FDA1  ...  A functional data object
	#  FDA2  ...  A functional data object
	#  Returns:
	#  FDASUM  ...  A functional data object that is FDA1 plus FDA2
	#  Last modified:  4 July 2001
	
    if (!(inherits(fd1, "fd") & inherits(fd2, "fd"))) stop(
      'Both arguments to + are not functional data objects.')
    coef1 <- getcoef(fd1)
    coef2 <- getcoef(fd2)
    if (any(dim(coef1) != dim(coef2))) stop(
      'Coefficient arrays are not of same dimensions for +.')
    fdsum <- create.fd(coef1+coef2, getbasis(fd1), fd1$fdnames)
    return(fdsum)
}

#  ----------------------------------------------------------------

'-.fd' <- function(fd1, fd2)
{
	#  Arguments:
	#  FDA1  ...  A functional data object
	#  FDA2  ...  A functional data object
	#  Returns:
	#  FDADIF  ...  A functional data object that is FDA1 minus FDA2
	#  Last modified:  4 July 2001
	
	if (!(inherits(fd1, "fd") & inherits(fd2, "fd"))) stop(
      'Both arguments to + are not functional data objects.')
    coef1 <- getcoef(fd1)
    coef2 <- getcoef(fd2)
    if (any(dim(coef1) != dim(coef2))) stop(
      'Coefficient arrays are not of same dimensions for -.')
    fddif <- create.fd(coef1-coef2, getbasis(fd1), fd1$fdnames)
    return(fddif)
}

#  ----------------------------------------------------------------

'*.fd' <- function(fd1, fd2)
{
 	#  Arguments:
	#  FDA1  ...  Either a functional data object or a number
	#  FDA2  ...  Either a functional data object or a number
	#  At least oneof FDA1 and FDA2 must be a functional data object.
	#  Returns:
	#  FDAPROD  ...  A functional data object that is FDA1 times FDA2
	#  Last modified:  4 July 2001
	
   if ((!(inherits(fd1, "fd") | inherits(fd2, "fd")))) stop(
      'Neither argument for * is a functional data object.')
    if (inherits(fd1, "fd") & inherits(fd2, "fd") ) {
    coef1     <- getcoef(fd1)
    coefd1    <- dim(coef1)
    coef2     <- getcoef(fd2)
    coefd2    <- dim(coef2)
    if (length(coefd1) != length(coefd2)) stop(
      'Number of dimensions of coefficient arrays do not match.')
    if (any(coefd1 != coefd2)) stop(
      'Dimensions of coefficient arrays do not match.')
    basisfd1  <- getbasis(fd1)
    basisfd2  <- getbasis(fd2)
    nbasis1   <- basisfd1$nbasis
    nbasis2   <- basisfd2$nbasis
    rangeval1 <- basisfd1$rangeval
    rangeval2 <- basisfd2$rangeval
    if (any(rangeval1 != rangeval2)) stop(
      'The ranges of the arguments are not equal.')
    neval     <- max(10*max(nbasis1,nbasis2) + 1, 101)
    evalarg   <- seq(rangeval1[1],rangeval2[2], length=neval)
    fdarray1  <- eval.fd(evalarg, fd1)
    fdarray2  <- eval.fd(evalarg, fd2)
    fdarray   <- fdarray1*fdarray2
    if (nbasis1 > nbasis2) {
      basisfd  <- basisfd1
      coefprod <- project.basis(fdarray, evalarg, basisfd)
    } else {
      basisfd  <- basisfd2
      coefprod <- project.basis(fdarray, evalarg, basisfd)
    }
    fdnames1 <- fd1$fdnames
    fdnames2 <- fd2$fdnames
    fdnames  <- fdnames1
    fdnames[[3]] <- paste(fdnames1[[3]],'*',fdnames2[[3]])
    fdprod   <- create.fd(coefprod, basisfd, fdnames)
    return(fdprod)
  } else {
    if ((!(is.numeric(fd1) | is.numeric(fd2)))) stop(
      'Neither argument for * is numeric.')
    if (is.numeric(fd1)) {
      fac <- fd1
      fd  <- fd2
    } else {
      fac <- fd2
      fd  <- fd1
    }
    coef     <- getcoef(fd)
    coefd    <- dim(coef)
    basisfd  <- getbasis(fd)
    nbasis   <- basisfd$nbasis
    rangeval <- basisfd$rangeval
    neval    <- max(10*nbasis + 1,101)
    evalarg  <- seq(rangeval[1],rangeval[2], length=neval)
    fdarray  <- fac*eval.fd(evalarg, fd)
    coefprod <- project.basis(fdarray, evalarg, basisfd)
    fdnames  <- fd$fdnames
    fdnames[[3]] <- paste(as.character(fac),'*',fdnames[[3]])
    fdprod   <- create.fd(coefprod, basisfd, fdnames)
    return(fdprod)
 }
}

#  ----------------------------------------------------------------

'/.fd' <- function(fd1, fd2)
{
  	#  Arguments:
	#  FDA1  ...  Either a functional data object or a number
	#  FDA2  ...  Either a functional data object or a number
	#  At least oneof FDA1 and FDA2 must be a functional data object.
	#  Returns:
	#  FDAPROD  ...  A functional data object that is FDA1 divided by FDA2
	#  Last modified:  4 July 2001
	
   if ((!(inherits(fd1, "fd") | inherits(fd2, "fd")))) stop(
      'Neither argument for * is a functional data object.')
    if (inherits(fd1, "fd") & inherits(fd2, "fd")) {
    coef1     <- getcoef(fd1)
    coefd1    <- dim(coef1)
    coef2     <- getcoef(fd2)
    coefd2    <- dim(coef2)
    if (length(coefd1) != length(coefd2)) stop(
      'Number of dimensions of coefficient arrays do not match.')
    if (any(coefd1 != coefd2)) stop(
      'Dimensions of coefficient arrays do not match.')
    basisfd1  <- getbasis(fd1)
    basisfd2  <- getbasis(fd2)
    nbasis1   <- basisfd1$nbasis
    nbasis2   <- basisfd2$nbasis
    rangeval1 <- basisfd1$rangeval
    rangeval2 <- basisfd2$rangeval
    if (any(rangeval1 != rangeval2)) stop(
      'The ranges of the arguments are not equal.')
    neval     <- max(10*max(nbasis1,nbasis2) + 1, 101)
    evalarg   <- seq(rangeval1[1],rangeval2[2], length=neval)
    fdarray1  <- eval.fd(evalarg, fd1)
    fdarray2  <- eval.fd(evalarg, fd2)
    fdarray   <- fdarray1/fdarray2
    if (nbasis1 > nbasis2) {
      basisfd  <- basisfd1
      coefquot <- project.basis(fdarray, evalarg, basisfd)
    } else {
      basisfd  <- basisfd2
      coefquot <- project.basis(fdarray, evalarg, basisfd)
    }
    fdnames1 <- fd1$fdnames
    fdnames2 <- fd2$fdnames
    fdnames  <- fdnames1
    fdnames[[3]] <- paste(fdnames1[[3]],'*',fdnames2[[3]])
    fdquot   <- create.fd(coefquot, basisfd, fdnames)
    return(fdquot)
  } else {
    if ((!(is.numeric(fd1) | is.numeric(fd2)))) stop(
      'Neither argument for * is numeric.')
    if (is.numeric(fd1)) {
      fac <- fd1
      fd  <- fd2
    } else {
      fac <- fd2
      fd  <- fd1
    }
    coef     <- getcoef(fd)
    coefd    <- dim(coef)
    basisfd  <- getbasis(fd)
    nbasis   <- basisfd$nbasis
    rangeval <- basisfd$rangeval
    neval    <- max(10*nbasis + 1, 101)
    evalarg  <- seq(rangeval[1],rangeval[2], length=neval)
    fdnames  <- fd$fdnames
    if (is.numeric(fd1)) {
      fdarray  <- fac/eval.fd(evalarg, fd)
      fdnames[[3]] <- paste(as.character(fac),'/',fdnames[[3]])
    } else {
      fdarray  <- eval.fd(evalarg, fd)/fac
      fdnames[[3]] <- paste(fdnames[[3]],'/',as.character(fac))
    }
    coefquot <- project.basis(fdarray, evalarg, basisfd)
    fdquot   <- create.fd(coefquot, basisfd, fdnames)
    return(fdquot)
 }
}

#  ----------------------------------------------------------------

'^.fd' <- function(fd, power)
{
   	#  Arguments:
	#  FD     ...  A functional data object
	#  POWER  ...  An exponent
	#  Returns:
	#  FDAPOWR  ...  A functional data object that is FD to the power POWER
	#  Last modified:  4 July 2001
	
  if ((!(inherits(fd, "fd")))) stop(
      'First argument for ^ is not a functional data object.')
  if ((!(is.numeric(power)))) stop(
      'Second argument for ^ is not numeric.')
  coef     <- getcoef(fd)
  coefd    <- dim(coef)
  basisfd  <- getbasis(fd)
  nbasis   <- basisfd$nbasis
  rangeval <- basisfd$rangeval
  neval    <- max(10*nbasis + 1,101)
  evalarg  <- seq(rangeval[1],rangeval[2], length=neval)
  fdnames  <- fd$fdnames
  fdarray  <- eval.fd(evalarg, fd)^power
  coefpowr <- project.basis(fdarray, evalarg, basisfd)
  fdpowr   <- create.fd(coefpowr, basisfd, fdnames)
  return(fdpowr)
}


#  ----------------------------------------------------------------

'sqrt.fd' <- function(fd)
{
   	#  Arguments:
	#  FD     ...  A functional data object
 	#  Returns:
	#  FDASQRT  ...  A functional data object that is the square root of FD
	#  Last modified:  4 July 2001
	
  if ((!(inherits(fd, "fd")))) stop(
      'First argument is not a functional data object.')
  coef     <- getcoef(fd)
  coefd    <- dim(coef)
  basisfd  <- getbasis(fd)
  nbasis   <- basisfd$nbasis
  rangeval <- basisfd$rangeval
  neval    <- max(10*nbasis + 1,101)
  evalarg  <- seq(rangeval[1],rangeval[2], length=neval)
  fdnames  <- fd$fdnames
  fdarray  <- sqrt(eval.fd(evalarg, fd))
  coefsqrt <- project.basis(fdarray, evalarg, basisfd)
  fdpowr   <- create.fd(coefsqrt, basisfd, fdnames)
  return(fdsqrt)
}
bsplineS <- function (x, breaks, norder=4, nderiv=0)
{
#  This is a wrapper function for the S-PLUS spline.des function.
#  The number of spline functions is equal to the number of
#     discrete break points, length(BREAKVALUES), plus the order, NORDER,
#           minus 2.
#  Arguments are as follows:
#  X      ... array of values at which the spline functions are to
#             evaluated
#  BREAKS ... a STRICTLY INCREASING sequence of break points or knot
#             values.  It must contain all the values of X within its
#             range.
#  NORDER ... order of spline (1 more than degree), so that 1 gives a
#             step function, 2 gives triangle functions,
#             and 4 gives cubic splines
#  NDERIV ... highest order derivative.  0 means only function values
#             are returned.
#  Return is a matrix with length(X) rows and number of columns equal to
#                   number of b-splines

#  last modified 23 October 2002

  x <- as.vector(x)
  n <- length(x)
  tol <- 1e-14
  nbreaks <- length(breaks)
  if (nbreaks < 2) stop('Number of knots less than 2.')
  if (min(diff(breaks)) <= 0 ) stop('Knots are not strictly increasing')

  if ( max(x) > max(breaks) + tol ||
       min(x) < min(breaks) - tol )
     stop('Knots do not span the values of X')
  if ( x[n] > breaks[nbreaks]) breaks[nbreaks] <- x[n]
  if ( x[1] < breaks[1]      ) breaks[1]       <- x[1]

  if (norder > 20) stop('NORDER exceeds 20.')
  if (norder <  1) stop('NORDER less than 1.')
  if (nderiv > 19) stop('NDERIV exceeds 19.')
  if (nderiv <  0) stop('NDERIV is negative.')
  if (nderiv >= norder) stop (
         'NDERIV cannot be as large as order of B-spline.')

  knots  <- c(rep(breaks[1      ],norder-1), breaks,
              rep(breaks[nbreaks],norder-1)  )
  derivs <- rep(nderiv,n)
  nbasis <- nbreaks + norder - 2
  if (nbasis > norder) {
  	  basismat <- spline.des(knots, x, norder, derivs)$design
  } else {
	  if (nbasis == norder) {
		  #  CONSTRUCT BASISMAT FROM POWERS OF X HERE 	
		  basismat <- matrix(0, n, norder)
		  basismat[,1] <- 1
		  for (i in 2:norder) basismat[,i] <- x^(i-1)			
	  } else { 
	     stop('NBASIS is less than NORDER.')
     }
  }
}
bsplinepen <- function(basisfd, Lfd=2)
{

#  Computes the Bspline penalty matrix.
#  Arguments:
#  BASISFD   ... a basis.fd object of type "bspline"
#  LFD ... either the order of derivative or a
#          nonhomogeneous linear differential operator to be penalized.
#  Returns the penalty matrix.

#  Last modified 5 December 2001

if (!(inherits(basisfd, "basis.fd"))) stop(
    "First argument is not a basis.fd object.")

type <- getbasistype(basisfd)
if (type != "bspline") stop("BASISFD not of type bspline")

norder <- basisfd$nbasis - length(basisfd$params)

#  Find the highest order derivative in LFD

if (is.numeric(Lfd)) {
    if (length(Lfd) == 1) {
      	nderiv <- Lfd
      	if (nderiv != as.integer(nderiv)) {
        	stop("Order of derivative must be an integer")
      	}
      	if (nderiv < 0) {
        	stop("Order of derivative must be 0 or positive")
      	}
    } else {
      	stop("Order of derivative must be a single number")
    }
    if (nderiv < 0) stop ("Order of derivative cannot be negative")
} else if (inherits(Lfd, "fd")) {
   	derivcoef <- getcoef(Lfd)
   	if (length(dim(derivcoef))==3) derivcoef <- derivcoef[,,1]
   	nderiv <- dim(derivcoef)[2] - 1
   	if (nderiv < 0) {
   		stop("Order of derivative must be 0 or positive")
   	}
    nderiv <- ncol(derivcoef)
} else {
    stop("Second argument must be an integer or a functional data object")
}

if (nderiv >= norder) {
	cat(paste("Derivative of order", nderiv,
                  "cannot be taken for B-spline of order", norder,"\n"))
	cat("Probable cause is a value of the nbasis argument\n")
	cat(" in function create.basis.fd that is too small.\n")
   	stop()
}

if (nderiv == norder - 1 && is.numeric(Lfd)) {
    breakvals  <- c(basisfd$rangeval[1], basisfd$params,
                    basisfd$rangeval[2])
    nbreakvals <- length(breakvals)
    norder     <- basisfd$nbasis - nbreakvals + 2
    if (nderiv >= norder) stop (
         "NDERIV cannot be as large as order of B-spline.")
    halfseq    <- (breakvals[2:nbreakvals] +
                   breakvals[1:(nbreakvals-1)])/2
    halfmat    <- bsplineS(halfseq, breakvals, norder, nderiv)
    brwidth    <- diff(breakvals)
    penaltymatrix <- t(halfmat) %*% diag(brwidth) %*% halfmat
} else {
    penaltymatrix <- inprod(basisfd, basisfd, Lfd, Lfd)
}

return( penaltymatrix )
}
'c.fd'<- function(...)
{
#
#   concatenates a number of .fd objects.  It is assumed that all the
#   objects have the same basisfd objects, and that all the coef arrays
#   have the same number of dimensions
#

#  Last modified 6 Feb 2001

  fdlist <- list(...)
  n      <- length(fdlist)
  fd1    <- fdlist[[1]]
  if(n == 1) return(fd1)
  coef    <- getcoef(fd1)
  coefd   <- dim(coefs)
  ndim    <- length(dimcoef)
  basisfd <- getbasis(fd1)
  fdnames <- getnames(fd1)
  #  check that the fd objects are consistent with each other
  if(inherits(fd1, "fd")) stop('Objects must be of class fd')
  for(j in (2:n)) {
    fdj <- fdlist[[j]]
    if(inherits(fdj, "fd")) stop('Objects must be of class fd')
    if(any(unlist(fdj[[2]]) != unlist(basisfd)))
      stop('Objects must all have the same basis')
    if(length(dim(fdj[[1]])) != ndim)
      stop('Objects must all have the same number of multiple functions')
  }
  #  concatenate by concatenate coefficient matrices
  if(ndim == 2) {
    for (j in 2:n) {
      nameslist <- dimnames(coef)
      fdj       <- fdlist[[j]]
      coefj     <- getcoef(fdj)
      coef      <- cbind(coef, coefj)
      nameslist[[2]] <- c(nameslist[[2]], dimnames(coefj)[[2]])
    }
  } else {
    for(j in (2:n)) {
      nameslist <- dimnames(coef)
      fdj       <- fdlist[[j]]
      coefj     <- getcoef(fdj)
      coef      <- c(coef, aperm(coefj, c(1, 3, 2)))
      nameslist[[2]] <- c(nameslist[[2]], dimnames(coefj)[[2]])
    }
    dim(coef) <- c(coefd[1], coefd[3], length(coef)
                  /(coefd[1] * coefd[3]))
    coef <- aperm(coef, c(1, 3, 2))
  }
  dimnames(coef) <- nameslist
  concatfd <- create.fd(coefs, basisfd, fdnames)
  return(concatfd)
}
cca.2fun.fd <- function(fd1, fd2=fd1, ncan = 2,
                         lambda1 = 0.00025, Lfd1 = 2,
                         lambda2 = lambda1, Lfd2 = Lfd1)
{
#  carry out a functional CCA with regularization using two different
#    functional data samples.  These may have different bases, and
#    different penalty functionals.  It is assumed that both are
#    univariate.
#  Arguments:
#  FD1       ... Functional data object.
#  FD2       ... Functional data object.
#  NCAN     ...  Number of pairs of canonical variates to be found
#  LAMBDA1  ...  Smoothing or regularization parameter for FD1.
#  LFD1     ... The order derivative of FD1 to be penalized if an integer, or
#           a linear differential operator if a functional data object.
#  LAMBDA2  ...  Smoothing or regularization parameter for FD2.
#  LFD2     ... The order derivative of FD2 to be penalized if an integer, or
#           a linear differential operator if a functional data object.
#
#  Returns:  A list with the entries
#  weight functions  ... A functional data object for the canonical
#                  variate weight functions
#  correlations    ... The corresponding set of canonical correlations
#  variates        ... An array of the values taken by the canonical variates
#                  (ie the scores on the variates.)  This is a 3-way array
#                       with first dimension corresponding to replicates,
#                       second to the different variates (dimension NCAN)
#                       and third (dimension 2) to the "x" and "y" scores.
#


 #  Last modified 6 Feb 2001

  if (!(inherits(fd1, "fd"))) stop("Argument FD1 not a functional data object.")
  if (!(inherits(fd2, "fd"))) stop("Argument FD2 not a functional data object.")

  ctrfd1 <- center.fd(fd1)
  coef1  <- getcoef(ctrfd1)
  coefd1 <- dim(coef1)
  ndim1  <- length(coefd1)
  nrep1      <- coefd1[2]

  ctrfd2 <- center.fd(fd2)
  coef2  <- getcoef(ctrfd2)
  coefd2 <- dim(coef2)
  ndim2  <- length(coefd2)
  nrep2      <- coefd2[2]

  if (nrep1 != nrep2) stop("Numbers of replications are not equal.")
  if (nrep1 < 2) stop("CCA not possible without replications.")
  nrep <- nrep1

  if (ndim1 > 2 || ndim2 > 2) stop("One or both functions are not univariate.")

  basisfd1   <- getbasis(fd1)
  nbasis1    <- basisfd1$nbasis
  type1      <- getbasistype(basisfd1)

  basisfd2   <- getbasis(fd2)
  nbasis2    <- basisfd2$nbasis
  type2      <- getbasistype(basisfd2)

#
#   Set up cross product matrices
#
  Jmat1 <- getbasispenalty(basisfd1, 0)
  Jmat2 <- getbasispenalty(basisfd2, 0)
  Jx    <- t(Jmat1 %*% coef1)
  Jy    <- t(Jmat2 %*% coef2)
  PVxx  <- crossprod(Jx)/nrep
  PVyy  <- crossprod(Jy)/nrep
  if (inherits(Lfd1, "fd") || (is.numeric(Lfd1) && Lfd1 >= 0)) {
    Kmat1 <- getbasispenalty(basisfd1, Lfd1)
    PVxx  <- PVxx + lambda1 * Kmat1
  }
  if (inherits(Lfd2, "fd") || (is.numeric(Lfd2) && Lfd2 >= 0)) {
    Kmat2 <- getbasispenalty(basisfd2, Lfd2)
    PVyy  <- PVyy + lambda2 * Kmat2
  }
  Vxy   <- crossprod(Jx,Jy)/nrep
  #  do eigenanalysis
  result <- geigen(Vxy, PVxx, PVyy)
  #  set up canonical correlations and coefficients for weight functions
  canwtcoef      <- array(0,c(nbasis,ncan,2))
  canwtcoef1 <- result$Lmat[,1:ncan]
  canwtcoef2 <- result$Mmat[,1:ncan]
  corrs          <- result$values
  #   Normalize the coefficients for weight functions
  for (j in 1:ncan) {
      temp <- canwtcoef1[,j]
      temp <- temp/sqrt(sum(temp^2))
      canwtcoef1[,j] <- temp
      temp <- canwtcoef2[,j]
      temp <- temp/sqrt(sum(temp^2))
      canwtcoef2[,j] <- temp
  }
  #  set up the canonical weight functions
  canwtfdnames      <- getnames(fd)
  canwtfdnames[[2]] <- paste("Can. Fn.",as.character(1:ncan))
  names(canwtfdnames)[2] <- "Canonical functions"
  names(canwtfdnames)[3] <-
            paste("CCA wt. fns. for",names(canwtfdnames)[3])
  canwtfd1 <- create.fd(canwtcoef1, basisfd1, canwtfdnames)
  canwtfd2 <- create.fd(canwtcoef2, basisfd2, canwtfdnames)
  #  set up canonical variable values
  canvarvalues      <- array(0, c(nrep, ncan, 2))
  canvarvalues[,,1] <- Jx %*% canwtcoef1
  canvarvalues[,,2] <- Jy %*% canwtcoef2
  #  set up return list
  cancorlist        <- list(canwtfd1, canwtfd2, corrs, canvarvalues)
  setOldClass("cca.2fun.fd")
  oldClass(cancorlist) <- "cca.2fun.fd"
  names(cancorlist) <- c("weight function 1", "weight function 2",
                         "correlations", "variates")
  return(cancorlist)
}
cca.fd <- function(fd, ncan = 2, lambda = 0.00025, Lfd = 2)
{
#  carry out a functional CCA with regularization.
#  Arguments:
#  FD        ... Functional data object.  It is assumed that there are
#                  two functions for each replication.
#  NCAN     ...  Number of pairs of canonical variates to be found
#  LAMBDA    ... Smoothing or regularization parameter.  The value 1 is
#                  arbitrary.  If lambda is a 2-vector then the first
#                  component will be applied to the "x" and the second to
#                  the "y" functions.
#  LFD  ... The order derivative to be penalized if an integer, or
#           a linear differential operator if a functional data object.
#
#  Returns:  A list with the entries
#  weight functions  ... A functional data object for the canonical
#                  variate weight functions
#  correlations    ... The corresponding set of canonical correlations
#  variates        ... An array of the values taken by the canonical variates
#                  (ie the scores on the variates.)  This is a 3-way array
#                       with first dimension corresponding to replicates,
#                       second to the different variates (dimension NCAN)
#                       and third (dimension 2) to the "x" and "y" scores.
#

  #  last modified 15 November 2001

  #  Check arguments

  if (!(inherits(fd, "fd"))) stop("Argument FD not a functional data object.")

  #  compute mean function and center if required

  ctrfd <- center.fd(fd)
  coef  <- getcoef(ctrfd)
  coefd <- dim(coef)
  ndim  <- length(coefd)

  if (ndim < 3 || coefd[3] == 1) stop(
     "CCA only possible with bivariate functions")
  if (coefd[3] > 2) warning("Only first two of multiple functions used")
  lambda <- c(lambda, lambda)
  if (lambda[1] <= 0 || lambda[2] <= 0) stop(
     "Smoothing parameters must be strictly positive")
  basisfd   <- getbasis(ctrfd)

  nbasis    <- basisfd$nbasis
  type      <- getbasistype(basisfd)
  nrep      <- coefd[2]
  if (nrep < 2) stop("CCA not possible without replications.")
#
#   Set up cross product matrices
#
  Jmat  <- getbasispenalty(basisfd, 0)
  Jx    <- t(Jmat %*% coef[,  , 1])
  Jy    <- t(Jmat %*% coef[,  , 2])
  PVxx  <- crossprod(Jx)/nrep
  PVyy  <- crossprod(Jy)/nrep
  if (inherits(Lfd, "fd") || (is.numeric(Lfd) && Lfd >= 0)) {
    Kmat  <- getbasispenalty(basisfd, Lfd)
    if (lambda[1] > 0) PVxx  <- PVxx + lambda[1] * Kmat
    if (lambda[2] > 0) PVyy  <- PVyy + lambda[2] * Kmat
  }
  Vxy   <- crossprod(Jx,Jy)/nrep
  #  do eigenanalysis
  result <- geigen(Vxy, PVxx, PVyy)
  #  set up canonical correlations and coefficients for weight functions
  canwtcoef      <- array(0,c(nbasis,ncan,2))
  canwtcoef[,,1] <- result$Lmat[,1:ncan]
  canwtcoef[,,2] <- result$Mmat[,1:ncan]
  corrs          <- result$values
  #   Normalize the coefficients for weight functions
  for (j in 1:ncan) for(k in 1:2) {
      temp <- canwtcoef[,j,k]
      temp <- temp/sqrt(sum(temp^2))
      canwtcoef[,j,k] <- temp
  }
  #  set up the canonical weight functions
  canwtfdnames      <- getnames(fd)
  canwtfdnames[[2]] <- paste('Can. Fn.',as.character(1:ncan))
  names(canwtfdnames)[2] <- 'Canonical functions'
  names(canwtfdnames)[3] <-
            paste('CCA wt. fns. for',names(canwtfdnames)[3])
  canwtfd           <- create.fd(canwtcoef, basisfd, canwtfdnames)
  #  set up canonical variable values
  canvarvalues      <- array(0, c(nrep, ncan, 2))
  canvarvalues[,,1] <- Jx %*% canwtcoef[,,1]
  canvarvalues[,,2] <- Jy %*% canwtcoef[,,2]
  #  set up return list
  cancorlist        <- list(canwtfd, corrs, canvarvalues)
  setOldClass("cca.fd")  
  oldClass(cancorlist) <- "cca.fd"
  names(cancorlist) <- c("weight functions", "correlations", "variates")

  return(cancorlist)
}
center.fd <- function(fd)
{
  #  remove mean function for functional observations

  #  Last modified 6 Feb 2001

  if (!(inherits(fd, "fd"))) stop('Argument  FD not a functional data object.')

  coef   <- as.array(fd[[1]])
  coefd  <- dim(coef)
  ndim   <- length(coefd)
  basis  <- fd[[2]]
  nbasis <- basis$nbasis
  if (ndim == 2) {
    coefmean <- apply(coef,1,mean)
    coef     <- sweep(coef,1,coefmean)
  } else {
    nvar <- coefd[3]
    for (j in 1:nvar) {
      coefmean <- apply(coef[,,j],1,mean)
      coef[,,j] <- sweep(coef[,,j],1,coefmean)
    }
  }
  fdnames <- fd$fdnames
  names(fdnames)[3] <- paste('Centered',names(fdnames)[3])
  centerfd <- create.fd(coef, basis, fdnames)
  return(centerfd)
}
create.basis <- function (type, rangeval, nbasis, params = paramvec)
{
  #  An alternative call to CREATE.BASIS.FD.

  create.basis.fd(type, rangeval, nbasis, params)
}
create.basis.fd <- function (type, rangeval, nbasis, params = paramvec)
{

  #  This function creates a functional data basis.
  #  Arguments
  #  TYPE     ... a string indicating the type of basis.  This may be one of
  #               "Fourier", "fourier", "Fou", "fou",
  #               "Bspline", "bspline", "Bsp", "bsp",
  #               "Polynomial","polynomial","Polyn", "polyn",
  #               "Exponential","exponential","Exp", "exp",
  #               "Polygonal", "polygonal","polyg" "polyg",
  #               "Constant","constant","Con", "con",
  #               "power","power","Pow", "pow",
  #  RANGEVAL ... an array of length 2 containing the lower and upper
  #               boundaries for the rangeval of argument values
  #  NBASIS   ... the number of basis functions
  #  PARAMS   ... If the basis is "fourier", this is a single number indicating
  #                 the period.  That is, the basis functions are periodic on
  #                 the interval [0,PARAMS] or any translation of it.
  #               If the basis is "bspline", the values are interior points at
  #                 which the piecewise polynomials join.
  #                 Note that the number of basis functions NBASIS is equal
  #                 to the order of the Bspline functions plus the number of
  #                 interior knots, that is the length of PARAMS.
  #                 This means that NBASIS must be at least 1 larger than the
  #                 length of PARAMS.
  #               If the basis is "polynomial", this is a single number "ctr"
  #                 indicating the zero value for the polynomials, which are
  #                 of the form (x - ctr)^m, m=0,...,NBASIS-1.
  #               If the basis is "exponential", this is a vector of rate
  #                 constants, and the basis functions are of the form
  #                 exp(rate*x)
  #               If the basis is "polygonal" or "constant", value(s) in PARAMS
  #                 are not used.
  #  Returns
  #  BASIS.FD  ... a functional data basis object
  #  An alternative name for this function is CREATE.BASIS, but PARAMS argument
  #     must be supplied.
  #  Specific types of bases may be set up more conveniently using functions
  #  CREATE.BSPLINE.BASIS  ...  creates a b-spline basis
  #  CREATE.FOURIER.BASIS  ...  creates a fourier basis
  #  CREATE.POLYGONal.BASIS  ...  creates a polygonal basis
  #  CREATE.POLYnomial.BASIS  ...  creates a polynomial basis
  #  CREATE.exponential.BASIS  ...  creates a exponential basis
  #  CREATE.power.BASIS  ...  creates a power basis
  #  CREATE.const.BASIS  ...  creates a const basis

  #  Last modified 25 March 2003

  #  Check TYPE

  type <- use.proper.basis(type)
  if (type == "unknown") stop ("TYPE unrecognizable.")

  #  check RANGE

  if (!rangechk(rangeval)) stop('Argument RANGEVAL is not correct.')

  #  check NBASIS

  if (!is.numeric(nbasis) || nbasis<=0)
    stop('nbasis must be a positive integer')
  nbasis <- ceiling(nbasis)

  #  Set up basis depending on type

   if (type == "fourier") {
     paramvec   <- rangeval[2] - rangeval[1]   # default value of period
     period     <- params[1]
     basisfd <- create.fourier.basis(rangeval,nbasis,period)
   }

   if (type == "bspline") {
     basisfd <- create.bspline.basis(rangeval,nbasis,4,params)
   }

   if (type == "polynomial") {
     basisfd <- create.polynomial.basis(rangeval,nbasis,params[1])
   }

   if (type == "exponential") {
     basisfd <- create.exponential.basis(rangeval,params)
   }

   if (type == "polygonal") {
     basisfd <- create.polygonal.basis(params)
   }

   if (type == "constant") {
     basisfd <- create.constant.basis(rangeval)
   }

   if (type == "power") {
     basisfd <- create.power.basis(rangeval,params)
   }

   return(basisfd)
}
create.bifd <- function (coef, sbasisfd, tbasisfd,
                         bifdnames = list(NULL, repnames, NULL ))
{

  #  This function creates a bi-functional data object.  A bi-functional datum
  #  object consists of two bases for expanding a bivariate function and
  #  a set of coefficients defining this expansion.  Each basis is contained
  #  in a "basis.fd" object.  That is, a realization of the "basis.fd" class.

  #  Arguments
  #  COEF     ... a two-, three-, or four-dimensional array containing
  #               coefficient values for the expansion of each set of bivariate
  #               function values in terms of a set of basis function values
  #               If COEF is a two-way, it is assumed that there is only
  #                 one variable and only one replication, and then
  #                 the first and second dimensions correspond to
  #                 the basis functions for the first and second argument,
  #                 respectively.
  #               If COEF is a three-way, it is assumed that there is only
  #                 one variable per replication, and then
  #                 the first and second dimensions correspond to
  #                 the basis functions for the first and second argument,
  #                 respectively, and the third dimension corresponds to
  #                 replications.
  #               If COEF is a four-way array, then the fourth dimension
  #                 corresponds to variables
  #  SBASISFD ... a functional data basis object for the first  argument s
  #  TBASISFD ... a functional data basis object for the second argument t
  #  BIFDNAMES ... A list of length 3 with members containing
  #               1. a single name for the argument domain, such as "Time"
  #               2. a vector of names for the replications or cases
  #               3. a name for the function, or a vector of names if there
  #                  are multiple functions.
  #  Returns
  #  BIFDOBS  ... a functional datum object


 #  Last modified 6 Feb 2001

  if (length(dim(coef)) == 2) {
    repnames <- NULL
  } else {
    repnames <- dimnames(coef)[3]
  }

  if (is.vector(coef) || length(dim(coef)) > 4) stop(
      " First argument not of dimension 2, 3 or 4")

  if (!(inherits(sbasisfd, "basis.fd"))) stop(
    "Argument SBASISFD must be of basis.fd class")
  if (!(inherits(tbasisfd, "basis.fd"))) stop(
    "Argument TBASISFD must be of basis.fd class")
  if (dim(coef)[1] != sbasisfd$nbasis) stop(paste(
         "First dimension does not match number of basis functions",
         "for first argument."))
  if (dim(coef)[2] != tbasisfd$nbasis) stop(paste(
         "Second dimension does not match number of basis functions",
         "for second argument."))

  bifd        <- list( coef, sbasisfd, tbasisfd, bifdnames)
  names(bifd) <- c("coefs", "sbasis", "tbasis", "bifdnames")
  setOldClass("bifd")
  oldClass(bifd) <- "bifd"

  return(bifd)
}
create.bspline.basis <- function (rangeval=c(0,1), nbasis=NULL, norder=4,
                                  breaks=NULL)
{

  #  This function creates a bspline functional data basis.
  #  Arguments
  #  RANGEVAL ... an array of length 2 containing the lower and upper
  #               boundaries for the rangeval of argument values
  #  NBASIS   ... the number of basis functions
  #  NORDER   ... order of b-splines (one higher than their degree).  The
  #                 default of 4 gives cubic splines.
  #  BREAKS   ... also called knots, these are a strictly increasing sequence
  #               of junction points between piecewise polynomial segments.
  #               They must satisfy BREAKS[1] = RANGEVAL[1] and
  #               BREAKS[NBREAKS] = RANGEVAL[2], where NBREAKS is the total
  #               number of BREAKS.  There must be at least 3 BREAKS.
  #  There is a potential for inconsistency among arguments NBASIS, NORDER, and
  #  BREAKS.  It is resolved as follows:
  #     If BREAKS is supplied, NBREAKS = length(BREAKS), and
  #     NBASIS = NBREAKS + NORDER - 2, no matter what value for NBASIS is
  #     supplied.
  #     If BREAKS is not supplied but NBASIS is, NBREAKS = NBASIS - NORDER + 2,
  #        and if this turns out to be less than 3, an error message results.
  #     If neither BREAKS nor NBASIS is supplied, NBREAKS is set to 21.
  #  Returns
  #  BASISFD  ... a functional data basis object


 #  Last modified 25 March 2003

  type <- "bspline"

  #  check RANGE

  if (!rangechk(rangeval)) stop("Argument RANGEVAL is not correct.")

  #  check NORDER

  if (!is.numeric(norder) || norder<=0) stop("norder must be positive integer")
     norder <- ceiling(norder)

  #  check for various argument configurations

  # case of complete argument
  if (!is.null(nbasis) & !is.null(breaks)) {
     nbreaks <- length(breaks)
     if(!is.numeric(nbasis) || nbasis<=0)
       stop("Argument nbasis is not correct")
     else nbasis <- ceiling(nbasis)
  }

  # case of NULL NBASIS
  if (is.null(nbasis) & !is.null(breaks)) {
    nbreaks <- length(breaks)
    nbasis  <- nbreaks + norder - 2
    if (nbasis<=0) stop("not enough break points")
  }

  # case of NULL BREAKS
  if (!(is.null(nbasis)) & is.null(breaks)) {
    if(!is.numeric(nbasis) || nbasis<=0) stop("Argument nbasis is not correct")
    else nbasis <- ceiling(nbasis)
    nbreaks <- nbasis - norder + 2
    if (nbreaks < 2) stop("Number of knots is less than 2")
    breaks  <- seq(rangeval[1], rangeval[2], len=nbreaks)
  }

  # case of NULL NBASIS and NULL BREAKS
  if (is.null(nbasis) && is.null(breaks)) {
    nbreaks <- 21
    nbasis  <- 19 + norder
    breaks  <- seq(rangeval[1], rangeval[2], len=nbreaks)
  }

  #  check NBREAKS

  if (nbreaks < 2) stop ("Number of values in BREAKS less than 2.")

  #  check BREAKS

  breaks <- sort(breaks)
  if (breaks[1] != rangeval[1]) stop(
     "Smallest value in BREAKS not equal to RANGEVAL[1].")
  if (breaks[nbreaks] != rangeval[2])   stop(
     "Largest  value in BREAKS not equal to RANGEVAL[2].")
  if (min(diff(breaks)) <= 0) stop(
     "Values in BREAKS not strictly increasing")

  #  Set up the PARAMS vector.
  #  PARAMS contains only the interior knots

  if (nbreaks > 2) {
    params <- breaks[2:(nbreaks-1)]
  } else {
    params <- NULL
  }

  #  set up basis object

  basisfd        <- list(type, rangeval, nbasis, params)
  names(basisfd) <- c("type", "rangeval", "nbasis", "params")
  class(basisfd) <- "basis.fd"

  return(basisfd)
}
create.constant.basis <- function(rangeval = c(0,1))
{
  #  This function creates a constant basis
  #  Argument:
  #  RANGEVAL ... an array of length 2 containing the lower and upper
  #  Return:
  #  BASISFD  ... a functional data basis object of type "constant"
  #

  #  Last modified 25 March 2003

  type <- "constant"

  if (!rangechk(rangeval)) stop('Argument RANGEVAL is not correct.')

  params  <- 0

  nbasis  <- 1

  #  set up basis object

  basisfd <- list(type, rangeval, nbasis, params)
  names(basisfd) <- c("type", "rangeval", "nbasis", "params")

  class(basisfd) <- "basis.fd"

  return(basisfd)
}
create.default.basis <- function(argvals, nresol, nderiv = 2, periodic = FALSE)
{
#  This function takes a vector or matrix argvals and creates a default
#   basis to be used for data observed on these arguments.
#
#  ARGVALS  ... A vector or matrix of argument values. Missing values allowed.
#
#  NRESOL   ... A number that specifies the number of the finest features or
#               events that are of interest that can occur within the
#               range of the argument values. By feature or event is
#               meant things like peaks, valleys, zero crossings,
#               plateaus, linear slopes, and so on.  NRESOL specifies
#               the amount of resolution required of the functional
#               data object.
#  NDERIV   ... A natural number, 0, 1, 2, ..., specifying the number
#               of derivatives that the functional data object must
#               have.  The default is 2.
#  PERIODIC ... If T, functions are treated as periodic, and in the
#               case of vector ARGVALS the
#               argument domain is extended below by one value to become
#                [ARGVALS[1] - (ARGVALS[N]-ARGVALS[1])/(N-1), ARGVALS[N].
#               The default is F.
#
#  Returns an object of class BASISFD, a functional data basis object

  #  Last modified 25 March 2003

  #  Check values used to set up basis

  if (is.matrix(argvals)) n <- dim(argvals)[1] else n <- length(argvals)
  rangeval <- range(argvals, na.rm = TRUE)
  if (is.integer(nresol) == FALSE) nresol <- as.integer(nresol)
  if(nresol < 1 || nresol > n) stop("NRESOL is not between 1 and N.")
  if (is.integer(nderiv) == FALSE) nderiv <- as.integer(nderiv)
  if (nderiv < 0 || nderiv > n - 1) stop("NDERIV is not between 0 and N-1.")
  if (is.logical(periodic) == FALSE) stop("PERIODIC is not a logical variable.")
  #  Set up basis object.
  if(periodic) {
    rangeval[1] <- rangeval[1] - diff(rangeval)/(n - 1)
    basisfd     <- create.fourier.basis(rangeval, nresol)
  } else {
    if(nresol == 1) {
      basisfd <- create.constant.basis(rangeval)
    } else {
      if(nderiv == 0 & nresol == n & !is.matrix(argvals)) {
        basisfd <- create.polygonal.basis(argvals)
      } else {
        basisfd <- create.bspline.basis(rangeval, nresol, nderiv + 2)
      }
    }
  }
  return(basisfd)
}
create.exponential.basis <- function (rangeval=c(0,1), ratevec=1)
{

  #  This function creates an exponential functional data basis
  #  Arguments
  #  RANGEVAL ... An array of length 2 containing the lower and upper
  #               boundaries for the rangeval of argument values
  #  NBASIS   ... The number of basis functions.  If this conflicts with
  #               the length of RATEVEC, the latter is used.
  #  RATEVEC  ... The rate parameters defining exp(ratevec[i]*x)
  #  Returns
  #  BASIS.FD  ... a functional data basis object of type "exponential"

  #  Last modified 25 March 2003

  type     <- "exponential"

  if (!rangechk(rangeval)) stop("Argument RANGEVAL is not correct.")

  if(!is.numeric(ratevec)) stop("Rate vector should be numerical vector")

  params <- sort(as.vector(ratevec))
  nbasis <- length(params)
  if(nbasis <=0) stop("RATEVEC is empty.")
  if(nbasis>1) {
        for(i in 1:(nbasis-1)) {
             if (params[i]==params[i+1])
               stop("rate value should not equal to each other")
        }
   }

  #  set up basis object

  basisfd <- list(type, rangeval, nbasis, params)
  names(basisfd) <- c("type", "rangeval", "nbasis", "params")
  class(basisfd) <- "basis.fd"

  return(basisfd)
}
create.fd <- function (coef, basisfd, fdnames=defaultnames)
{

  #  This function creates a functional data object.
  #    A functional data object consists of a basis for expanding a functional
  #    observation and a set of coefficients defining this expansion.
  #    The basis is contained in a "basis.fd" object; that is, a realization
  #    of the "basis.fd" class.

  #  Arguments
  #  COEF ... An array containing coefficient values for the expansion of each
  #             set of function values in terms of a set of basis functions.
  #           If COEF is a three-way array, then the first dimension
  #             corresponds to basis functions, the second to replications,
  #             and the third to variables.
  #           If COEF is a matrix, it is assumed that there is only
  #             one variable per replication, and then
  #                 rows    correspond to basis functions
  #                 columns correspond to replications
  #           If COEF is a vector, it is assumed that there is only one
  #             replication and one variable.
  #  BASISFD ... a functional data basis object
  #  FDNAMES  ... The analogue of the dimnames attribute of an array, this is
  #               a list of length 3 with members containing:
  #               1. a character vector of names for the argument values
  #               2. a character vector of names for the replications or cases
  #               3. a character vector of names for the functions
  #               Each of these vectors can have a name referring to the modality
  #                 of the data.  An example would be "time", "reps", "values"

  #  Returns:
  #  FD ... a functional data object

  #  Note:  Earlier versions also had members named "df" and "gcv".  These
  #         have been removed.

  #  last modified 29 April 2003

  #  check COEF and get its dimensions

  if(!is.numeric(coef)) stop("coef must be numerical vector or matrix")
  else if (is.vector(coef)) {
            coef  <- as.matrix(coef)
            coefd <- dim(coef)
            ndim  <- length(coefd)
        }
  else if (is.matrix(coef)) {
            coefd <- dim(coef)
            ndim  <- length(coefd)
        }
  else if (is.array(coef)) {
            coefd <- dim(coef)
            ndim  <- length(coefd)
        }
  else stop("argument coef is not correct")

  if (ndim > 3) stop(
      "First argument not of dimension 1, 2 or 3")

  #  check BASISFD

  if (!(inherits(basisfd, "basis.fd"))) stop(
    "Argument BASISFD must be of basis.fd class")

  if (dim(coef)[1] != basisfd$nbasis)
    stop("Number of coefficients does not match number of basis functions.")

  #  setup number of replicates and number of variables

  if (ndim > 1) nrep <- coefd[2] else nrep <- 1
  if (ndim > 2) nvar <- coefd[3] else nvar <- 1

  #  set up default fdnames

  if (ndim == 1) {
    defaultnames <- list("time", "reps", "values")
  }
  if (ndim == 2) {
    defaultnames <- list("time",
                         paste("reps",as.character(1:nrep)),
                         "values")
  }
  if (ndim == 3) {
    defaultnames <- list("time",
                         paste("reps",as.character(1:nrep)),
                         paste("values",as.character(1:nvar)) )
  }
  names(defaultnames) <- c("args", "reps", "funs")

  fd        <- list( coef, basisfd, fdnames )
  names(fd) <- c("coefs", "basis", "fdnames")
  class(fd) <- "fd"

  return(fd)
}
create.fourier.basis <- function (rangeval=c(0,1), nbasis=3, period=width)
{

  #  This function creates a fourier functional data basis.
  #  Arguments
  #  RANGEVAL ... an array of length 2 containing the lower and upper
  #               boundaries for the rangeval of argument values
  #  NBASIS   ... the number of basis functions.  If the argument value is
  #               even, it is increased by one so both sines and cosines are
  #               present for each period.  A possible underdetermination of
  #               the basis is taken care of in function PROJECT.BASIS.
  #  PERIOD   ... The period.  That is, the basis functions are periodic on
  #                 the interval [0,PARAMS] or any translation of it.
  #  Returns
  #  BASISFD  ... a functional data basis object of type "fourier"

  #  Last modified 25 March 2003

  type <- "fourier"

  if (!rangechk(rangeval)) stop("Argument RANGEVAL is not correct.")

  width <- rangeval[2] - rangeval[1]
  if ((period <= 0) || !is.numeric(period))
    stop ("Period must be positive number for a Fourier basis")
  params <- period

  #  increase the number of basis functions by one if even

  if ((nbasis <= 0) || !is.numeric(nbasis)) stop ("nBasis must be odd positive number for a Fourior basis")
  nbasis <- ceiling(nbasis)
  if (2*floor(nbasis/2) == nbasis) nbasis <- nbasis + 1

  #  set up the basis object

  basisfd         <- list(type, rangeval, nbasis, params)
  names(basisfd)  <- c("type", "rangeval", "nbasis", "params")
   class(basisfd) <- "basis.fd"

  return(basisfd)
}
create.polygonal.basis <- function (argvals=NULL)
{

  #  This function creates a polygonal functional data basis.
  #  Arguments
  #  Returns
  #  BASISFD  ... a functional data basis object

  #  Last modified 25 March 2003

  type <- "polygonal"

  if(!is.vector(argvals) || !is.numeric(argvals))
    stop("Argument atgvals is not correct")

  nbasis <- length(argvals)
  if (nbasis < 2) stop("Number of ARGVALS less than two.")
  argvals <- sort(argvals)
  if (diff(argvals)==0)
    stop("element in argvals should not equal to each other")
  rangeval <- range(argvals)
  params   <- argvals

  #  set up basis object

  basisfd        <- list(type, rangeval, nbasis, params)
  names(basisfd) <- c("type", "rangeval", "nbasis", "params")
  class(basisfd) <- "basis.fd"

  return(basisfd)
}
create.polynomial.basis <- function (rangeval=c(0,1), nbasis=2, ctr=midrange)
{

  #  This function creates a polynomial functional data basis, for
  #    polynomials of the form  (x - c)^j
  #  Arguments
  #  RANGEVAL ... an array of length 2 containing the lower and upper
  #               boundaries for the rangeval of argument values
  #  NBASIS   ... the number of basis functions
  #  CTR      ... The centering constant C.  By default, this is the mid-range
  #  Returns
  #  BASISFD  ... a functional data basis object of type "polynomial"

  #  Last modified 25 March 2003

  type     <- "polynomial"

  if (!rangechk(rangeval)) stop("Argument RANGEVAL is not correct.")
  midrange <- mean(rangeval)
  params   <- as.vector(ctr)
  if ((length(params)<=0) || !is.numeric(params))
    stop("Argument ctr is not correct")
  nbasis <- ceiling(nbasis)
  if (nbasis<=0) stop ("nbasis must be positive integer")

  #  set up basis object

  basisfd        <- list(type, rangeval, nbasis, params)
  names(basisfd) <- c("type", "rangeval", "nbasis", "params")
  class(basisfd) <- "basis.fd"

  return(basisfd)
}
create.power.basis <- function (rangeval=c(0,1), exponent=1)
{

  #  This function creates an power functional data basis
  #  Arguments
  #  RANGEVAL ... An array of length 2 containing the lower and upper
  #               boundaries for the rangeval of argument values
  #  NBASIS   ... The number of basis functions.  If this conflicts with
  #               the length of exponent, the latter is used.
  #  EXPONENT  ... The rate parameters defining x^exponent[i]
  #  Returns
  #  BASIS.FD  ... a functional data basis object of type "power"

  #  Last modified 25 March 2003

  type     <- "power"
  if (!rangechk(rangeval)) stop('Argument RANGEVAL is not correct.')
  if (!is.numeric(exponent)) stop('Argument exponent parameter is not correct')
  params   <- sort(as.vector(exponent))
  nbasis   <- length(params)
  if (nbasis<=0) stop('Argument exponent parameter is not correct')
  if (nbasis>1) {
      for(i in 1:(nbasis-1)){
         if (params[i]==params[i+1])
            stop('element in exponent should not equal to each other')
      }
   }

  #  set up basis object

  basisfd        <- list(type, rangeval, nbasis, params)
  names(basisfd) <- c("type", "rangeval", "nbasis", "params")
  class(basisfd) <- "basis.fd"

  return(basisfd)
}
cycleplot.fd <- function(fd, matplt = TRUE, nx = 128, ...)
{

#  Performs a cycle plot of a functional data object FD,
#   assuming that FD is a bivariate function...the first component
#   of which is the x-coordinate and the second the y-coordinate
#
#  If MATPLT is T, matplot is used to plot all curves in
#     a single plot.
#  Otherwise, each curve is plotted separately, and the
#     next curve is plotted when the mouse is clicked.
#  NX is the number of sampling points to use (default 128)


 #  Last modified 6 Feb 2001

  if (!(inherits(fd, "fd"))) stop(
     "First argument is not a functional data object.")

  coef  <- getcoef(fd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  if(ndim < 3) stop("Univariate functions cannot be cycle plotted")
  nbasis <- coefd[1]
  nrep <- coefd[2]
  nvar <- coefd[3]
  basisfd  <- getbasis(fd)
  if(nvar > 2)  warning("Only first two functions used")
  crvnames <- dimnames(coef)[[2]]
  varnames <- dimnames(coef)[[3]][1:2]
  rangex   <- basisfd$rangeval
  x        <- seq(rangex[1], rangex[2], length = nx)
  fdmat    <- eval.fd(x, fd)
  fdnames  <- getnames(fd)
  crvnames <- fdnames[[2]]
  varnames <- fdnames[[3]]
  if(matplt) {
    matplot(fdmat[,  , 1], fdmat[,  , 2], type = "l", lty = 1,
            xlab=varnames[1], ylab=varnames[2], ...)
  }
  if(!matplt) {
    for (irep in 1:nrep) {
      plot(fdmat[, irep, 1], fdmat[, irep, 2], type = "l",
         lty = 1, xlab=varnames[1], ylab=varnames[2],
         main = paste("Curve", irep, crvnames[irep]), ...)
      mtext("Click to advance to next plot", side = 3,
                  line = -3, outer = TRUE)
      text(locator(1), "")
    }
  }
  invisible()
}
data2fd <- function(y, argvals = seq(0, 1, len = n), basisfd,
                    fdnames = defaultnames, argnames = c("time", "reps", "values") )
{
#  DATA2FD Converts an array Y of function values plus an array
#    ARGVALS of argument values into a functional data object.
#
#  A functional data object is a sample of one or more functions, called
#    functional data observations.
#  A functional data observation consists of one or more
#    curves, each curve corresponding to a variable.
#  For example, a functional data object can be a sample of size 35 of
#    temperature functions, one for each of 35 Canadian weather stations.
#    In this case, each observations consists of a single temperature
#    function.
#  Or, for example, a functional data object can be a sample of size 35
#    of temperature and precipitation functional observations.  In this case
#    each observations consists of two curves, one for the temperature
#    and one for the precipitation variable.
#  All functional objects have a one-dimensional argument.  In the above
#    examples, this argument is time measured in months or days.
#
#  The data values used by DATA2FD to make the functional data object FDOBJ
#    are in array Y.  If each observation consists of a single curve,
#    Y is two-dimensional If each observations has multiple variables,
#    Y will be three-dimensional.  See below for further details.
#
#  DATA2FD assumes that each observation is evaluated at a set of argument
#    specified in ARGVALS. These argument values may be common to all curves,
#    in which case ARGVALS is a one-dimensional vector.  If argument values
#    vary from observation to observation, ARGVALS will be two dimensional.
#    See below for further details.
#
#  Arguments for this function are as follows.  The first three are necessary
#    and the fourth is optional.
#
#  Y ... (necessary)
#  The array Y stores curve values used to create functional data object FDOBJ.
#  Y can have one, two, or three dimensions according to whether whether
#    the sample size, the number of variables in each observation.  Its
#    dimensions are:
#     1.  argument values  ...  size = no. argument values in ARGVAL
#     2.  replications     ...  size = sample size
#     3.  variables        ...  size = no. variables per observation
#  If Y is a one-way array, either as a vector or a matrix with one column,
#     it's single non-trivial dimension = no. argument values.  If Y
#     is two-dimensional, each observation is assumed to have one variable.
#     If Y is three-dimensional, each observation is assumed to have
#     multiple variables.  Note:  a single multivariate observation must
#     be an array Y with three dimensions, the middle of which is of length 1.
#  The values in Y may be missing, indicated by NaN.  The presence of missing
#     values will slow down the computation somewhat since each observation
#     must then be processed separately.
#  Example:  For monthly temperature data for 35 weather stations,
#     Y will be 12 by 35.  For both temperature and precipitation observations,
#     Y will be 12 by 35 by 2.  For temperature/precipitation data at Montreal
#     only, Y will be 12 by 1 by 2.
#  This argument is necessary, and there is no default value.
#
#  ARGVALS  ... (necessary)
#  A set of argument values.  In most situations, these will be common to all
#    observations, and ARGVALS will be a one-dimensional vector, with one
#    element per observation.  These values need not be increasing.
#    In the weather station example for monthly data, ARGVALS is
#    a vector of length 12, with values 0.5, 1.5,..., 11.5.
#    However, ARGVALS may also be a matrix if the argument values vary from
#    observation to observation.  In this case, the second dimension is
#    the same as that of Y.  If the number of arguments also varies from
#    from observation to observation, the second dimension of ARGVALS should
#    equal the the largest number of argument values, and the elements in
#    each show should be padded out with NaN.
#    Argument values falling outside of the range specified in the
#    BASISOBJ and their corresponding values in Y will not be used,
#    but if this happens, a warning message is displayed.
#  This argument is necessary, and there is no default value.
#
#  BASISOBJ  ...  (necessary)
#    A functional data basis object created by function CREATE.BASIS.FD
#    or one of its specialized version, such as CREATE.BSPLINE.BASIS or
#    CREATE.FOURIER.BASIS.  The functional data basis object specifies
#    a basis type (eg. 'fourier' or 'bspline'), a range or argument values,
#    the number of basis functions, and fixed parameters determining these
#    basis functions (eg. period for 'fourier' bases or knots for 'bspline'
#    bases.
#    In most applications, BASISOBJ will be supplied.  If BASISOBJ is supplied,
#    the next three arguments are ignored.
#    If BASISOBJ is an essential argument, and there no default value.  But
#    see function MAKE.BASIS for a simplified technique for defining this
#    basis.  For example, function call
#         MAKE.BASIS([0,12], 7, 1)
#    could be used for the monthly temperature/precipitation data to define
#    a 'fourier' basis over an interval of 12 months containing 7 basis
#    functions (the 3rd argument species the basis to be periodic.)
#    This argument is necessary, and there is no default value.
#    Earlier releases of DATA2FD supplied additional arguments for constructing
#    a default basis, but these have been eliminated in favor of using new
#    function MAKE.BASIS.
#
#  FDNAMES  ... (optional)
#    A list of length 3 with members containing
#               1. a vector of names for the argument values
#               2. a vector of names for the replications or cases
#               3. a name for the function, or a vector of names if there
#                  are multiple functions.
#    For example, for the monthly temperature/precipitation data,
#    fdnames{1} = 'Month'
#    fdnames{2} = 'Station'
#    fdnames{3} = 'Variable'
#    By default, the string 'time', 'reps' and 'values' are used.
#
#  ARGNAMES ...
#    A vector  of type "character" of length 3 containing
#               1. the name of the argument, e.g. "time" or "age"
#               2. a description of the cases, e.g. "weather stations"
#               3. the name for the function(s), e.g."temperature" or "position"
#               These names are used as names for the members of list FDNAMES.
#
#  DATA2FD Returns the object FDOBJ of functional data class containing
#    coefficients for the expansion and the functional data basis object
#    basisfd.
#
#  DATA2FD is intended for more casual use not requiring a great deal of
#    control over the smoothness of the functional data object.  It uses
#    function PROJECT.BASIS to compute the functional data object. Indeed,
#    in the simplest and most common situation, DATA2FD consists of
#             coef  = project.basis(y, argvals, basisfd)
#             fdobj = fd(coef,basisfd,fdnames)
#    However, for more advanced applications requiring more smoothing
#    control than is possible by setting the number of basis functions in
#    basisfd, function SMOOTH.BASIS should be used.  Or, alternatively,
#    DATA2FD may first be used with a generous number of basis functions,
#    followed by smoothing using function SMOOTH.

#  Last modified:  15 May 2001

#
#  set up default fdnames, using dimnames of Y if there are any.
#
  defaultnames      <- vector("list",3)
# defaultnames[[1]] <- dimnames(argvals)[[1]]
# defaultnames[[2]] <- dimnames(y)[[2]]
# defaultnames[[3]] <- dimnames(y)[[3]]

#
#  check basisfd argument.
#
  if(!(inherits(basisfd, "basis.fd"))) stop(
      "BASISFD is not a functional data basis.")
  nbasis <- basisfd$nbasis

#
#  Make Y an array, and determine its dimensions
#
  if (is.array(y) == FALSE) y <- as.array(y)
  yd   <- dim(y)
  ndim <- length(yd)
  if (ndim == 1) {
	 y <- as.matrix(y)
	 yd <- dim(y)
	 ndim <- length(yd)
  }
  if (ndim > 3) stop(
      "Too many dimensions for argument Y.")
  #  Determine the maximum number of argument values, number of replicates, and
  #    number of variables
  n  <- yd[1]
  if (n == 1) stop(
      "Only one argument value not allowed.")
  if (ndim > 1) nrep <- yd[2] else nrep <- 1
  if (ndim > 2) nvar <- yd[3] else nvar <- 1
  if (is.null(defaultnames[[3]])) defaultnames[[3]] <- as.character(1:nvar)
  names(defaultnames)[1:length(argnames)] <- argnames

#
#  Make ARGVALS an array and check for compatibility with Y
#
  if(is.array(argvals) == FALSE) argvals <- as.array(argvals)
  argd  <- dim(argvals)
  nargd <- length(argd)
  if (nargd > 2) stop(
     "ARGVALS has too many dimensions.")
  if (argd[1] != n) stop(
    "Number of argument values incompatible with number of data.")
  if (nargd==2 && argd[2] != nrep) stop(
    paste("Matrix argvals must have same number of columns\n",
          "as the number of replicates."))
#  Issue a warning of arguments are outside of the in the basisfd.
  rangeval <- basisfd$rangeval
  temp <- c(argvals)
  temp <- temp[!is.na(temp)]
  if (min(temp) < rangeval[1] | max(temp) > rangeval[2]) {
    warning(c("Some arguments values are outside of the range in basisfd,\n",
          " and some data values will not be used."))
    if (nargd == 1) {
       index <- argvals < rangeval[1] | argvals > rangeval[2]
       argvals[index] <- NA
    } else {
       for (irep in 1:nrep) {
          index <- argvals[,irep] < rangeval[1] | argvals[,irep] > rangeval[2]
          argvals[index,irep] <- NaN
       }
    }
  }
#
# Process data differently according to whether:
#
#  First case:  ARGVALS is a vector, and no missing values in y.
#  Second case: ARGVALS is a vector, but missing values in y; in this case
#      ARGVALS is turned into a matrix, but a lot of the work
#      in PROJECT.BASIS is not repeated.
#  Third case:  ARGVALS is a matrix.
#
  if(nargd == 1) {
    if (sum(is.na(argvals)) == 0 && sum(is.na(y)) == 0) {
#  First case:  no missing values, ARGVALS a vector
#    In this case all of the work is done by function PROJECT.BASIS
      if (nbasis <= n) {
        coef <- project.basis(y, argvals, basisfd)
      } else {
        coef <- project.basis(y, argvals, basisfd, TRUE)
      }
    } else {
#  Second case: ARGVALS a vector, but missing data present
      coefd    <- yd
      coefd[1] <- nbasis
      coef     <- array(dim = coefd)
#
# set up penalty and basis matrices
#
      index    <- !is.na(argvals)
      basismat <- getbasismatrix(argvals, basisfd)
      penmat   <- getbasispenalty(basisfd)
      # add a small amount to diagonal of penalty to ensure conditioning
      penmat   <- penmat + 1e-10 * max(penmat) * diag(dim(penmat)[1])
      # add a small penalty to deal with underdetermination by data
      lambda   <- 0.0001 * sum(basismat[index,]^2)/sum(diag(penmat))
      penmat <- lambda * penmat
      if(length(coefd) == 2) {
        #  Univariate functions
        for(j in (1:nrep)) {
          yy    <- y[,j]
          index <- !is.na(yy) & !is.na(argvals)
          if (length(yy[index]) < 2) stop(
              paste("Less than 2 data values available for curve",
                    j,"."))
          Cmat  <- crossprod( basismat[index,] ) + penmat
          Dmat  <- crossprod( basismat[index,],yy[index])
          coef[, j] <- symsolve( Cmat, Dmat )
        }
      } else {
        #  Multivariate functions
        for(j in (1:nrep))  for(k in (1:nvar)) {
          yy <- y[, j, k]
          index <- !is.na(yy) & !is.na(argvals)
          if (length(yy[index]) < 2) stop(
              paste("Less than 2 data values available for curve",
                    j," and variable",k,"."))
          Cmat <- crossprod( basismat[index,] ) + penmat
          Dmat <- crossprod( basismat[index,],yy[index] )
          coef[, j, k] <- symsolve( Cmat, Dmat )
        }
      }
    }
  } else {
#
#  now deal with the case where argvals is a matrix (no missing data)
#
    coefd    <- yd
    coefd[1] <- nbasis
    coef     <- array(dim = coefd)
    argv     <- c(argvals)
    index    <- !is.na(argv)
    argv     <- unique(argv[index])
    basismat <- getbasismatrix(argv, basisfd)
    penmat   <- getbasispenalty(basisfd)
    penmat   <- penmat + 1e-10 * max(penmat) * diag(dim(penmat)[1])
    # add a small penalty to deal with underdetermination by data
    lambda1  <- 0.0001 * sum(basismat^2)/sum(diag(penmat))
    penmat1  <- lambda1 * penmat
#
    if(length(coefd) == 2) {
      #  Univariate functions
      for(j in (1:nrep)) {
        yy    <- y[, j]
        argv  <- argvals[, j]
        index <- (!is.na(yy) & !is.na(argv))
        if (length(yy[index]) < 2) stop(
              paste("Less than 2 data values available for curve",
                    j,"."))
        coef[, j] <-
            project.basis(yy[index], argv[index], basisfd, TRUE)
      }
    } else {
      #  Multivariate functions
      for(j in (1:nrep))  for(k in (1:nvar)) {
        yy <- y[, j, k]
        argv <- argvals[, j]
        index <- (!is.na(yy) & !is.na(argv))
        if (length(yy[index]) < 2) stop(
              paste("Less than 2 data values available for curve",
                    j," and variable",k,"."))
        coef[, j, k] <-
            project.basis(yy[index], argv[index], basisfd, TRUE)
      }
    }
  }
  #
  #  Now that coefficient array has been computed, create functional data object
  #
  fd <- create.fd(coef, basisfd, fdnames = fdnames)

  return(fd)
}

densityfd <- function(x, Wfdobj, Lfdobj=3, lambda=0, conv=0.0001, iterlim=20, 
                      active=2:nbasis, dbglev=1) {
# DENSITYFD estimates the density of a sample of scalar observations.

#  Arguments are:
#  X        data value array
#  WFDOBJ   functional data basis object defining initial density
#  LFDOBJ   linear differential operator defining roughness penalty
#  LAMBDA   smoothing parameter
#  CONV     convergence criterion
#  ITERLIM  iteration limit for scoring iterations
#  ACTIVE   indices among 1:NBASIS of parameters to optimize
#  DBGLEV   level of output of computation history

#  Returns:
#  A list containing
#  WFD       functional data basis object defining final density
#  C         normalizing constant for density p = exp(WFDOBJ)/C
#  FLIST     Struct object containing
#               FSTR$f     final log likelihood
#               FSTR$norm  final norm of gradient
#  ITERNUM   Number of iterations
#  ITERHIST  History of iterations

#  To plot the density function or to evaluate it, evaluate WFDOBJ,
#  exponentiate the resulting vector, and then divide by the normalizing
#  constant C.

#  last modified 10 February 2003

   if (!(inherits(Wfdobj, "fd"))) 
		stop("Argument WFDOBJ is not a functional data object.")

	basis  <- Wfdobj$basis
	nbasis <- basis$nbasis
	rangex <- basis$rangeval

	x    <- as.matrix(x)
	xdim <- dim(x)
	N    <- xdim[1]
	m    <- xdim[2]

	if (m > 2 & N > 2)
    	stop("Argument X must have either one or two columns.")

	if ((N == 1 | N == 2) & m > 1) {
    	x <- t(x)
    	n <- N
    	N <- m
    	m <- n
	}

	if (m == 1) {
    	f <- rep(1,N)
	} else {
    	f    <- x[,2]
    	fsum <- sum(f)
    	f    <- f/fsum
    	x    <- x[,1]
	}

	inrng <- (1:N)[x >= rangex[1] & x <= rangex[2]]
	if (length(inrng) != N)
    	warning("Some values in X out of range and not used.")

	x     <- x[inrng]
	f     <- f[inrng]
	nobs  <- length(x)

	#  set up some arrays

	climit    <- c(rep(-50,nbasis),rep(400,nbasis))
	cvec0     <- getcoef(Wfdobj)
	hmat      <- matrix(0,nbasis,nbasis)
	inactive  <- rep(TRUE,nbasis)
	inactive[active] <- FALSE
	ninactive <- length((1:nbasis)[inactive])
	dbgwrd    <- dbglev > 1

	#  initialize matrix Kmat defining penalty term

	if (lambda > 0)
	  	Kmat <- lambda*getbasispenalty(basis, Lfdobj)

	#  evaluate log likelihood
	#    and its derivatives with respect to these coefficients

	result <- loglfnden(x, f, basis, cvec0)
	logl   <- result[[1]]
	Dlogl  <- result[[2]]

	#  compute initial badness of fit measures

	f0    <- -logl
	gvec0 <- -Dlogl
	if (lambda > 0) {
   		gvec0 <- gvec0 + 2*(Kmat %*% cvec0)
   		f0 <- f0 + t(cvec0) %*% Kmat %*% cvec0
	}
	if (ninactive > 0) gvec0[inactive] <- 0
	Foldstr <- list(f = f0, norm = sqrt(mean(gvec0^2)))

	#  compute the initial expected Hessian

	hmat0 <- Varfnden(x, basis, cvec0)
	if (lambda > 0) hmat0 <- hmat0 + 2*Kmat
	if (ninactive > 0) {
    	hmat0[inactive,] <- 0
    	hmat0[,inactive] <- 0
    	hmat0[inactive,inactive] <- diag(rep(1,ninactive))
	}

	#  evaluate the initial update vector for correcting the initial bmat

	deltac   <- -solve(hmat0,gvec0)
	cosangle <- -sum(gvec0*deltac)/sqrt(sum(gvec0^2)*sum(deltac^2))

	#  initialize iteration status arrays

	iternum <- 0
	status <- c(iternum, Foldstr$f, -logl, Foldstr$norm)
	cat("Iteration  Criterion  Neg. Log L  Grad. Norm\n")
	cat("      ")
	cat(format(iternum))
	cat("    ")
	cat(format(status[2:4]))
	cat("\n")
	iterhist <- matrix(0,iterlim+1,length(status))
	iterhist[1,]  <- status
	if (iterlim == 0) {
    	Flist     <- Foldstr
    	iterhist <- iterhist[1,]
    	C        <- normalize.phi(basis, cvec0)
    	return( list(Wfdobj=Wfdobj, C=C, Flist=Flist, iternum=iternum, iterhist=iterhist) )
	} else {
		gvec <- gvec0
		hmat <- hmat0
	}

	#  -------  Begin iterations  -----------

	STEPMAX <- 5
	MAXSTEP <- 400
	trial   <- 1
	cvec    <- cvec0
	linemat <- matrix(0,3,5)

	for (iter in 1:iterlim) {
   		iternum <- iternum + 1
	   	#  take optimal stepsize
   		dblwrd <- c(0,0) 
		limwrd <- c(0,0)
		stpwrd <- 0 
		ind    <- 0
	   	#  compute slope
      	Flist <- Foldstr
      	linemat[2,1] <- sum(deltac*gvec)
      	#  normalize search direction vector
      	sdg     <- sqrt(sum(deltac^2))
      	deltac  <- deltac/sdg
      	dgsum   <- sum(deltac)
      	linemat[2,1] <- linemat[2,1]/sdg
      	#  return with stop condition if (initial slope is nonnegative
      	if (linemat[2,1] >= 0) {
        	print("Initial slope nonnegative.")
        	ind <- 3
        	iterhist <- iterhist[1:(iternum+1),]
        	break
      	}
      	#  return successfully if (initial slope is very small
      	if (linemat[2,1] >= -1e-5) {
        	if (dbglev>1) print("Initial slope too small") 
        	iterhist <- iterhist[1:(iternum+1),]
        	break
      	}
      	linemat[1,1:4] <- 0
      	linemat[2,1:4] <- linemat[2,1]
      	linemat[3,1:4] <- Foldstr$f
      	stepiter  <- 0
      	if (dbglev > 1) {
			#print(c(stepiter, linemat[,1]))
			cat("              ")
			cat(format(stepiter))
			cat(format(linemat[,1]))
			cat("\n")
		}
      	ips <- 0
      	#  first step set to trial
      	linemat[1,5]  <- trial
      	#  Main iteration loop for linesrch
      	for (stepiter in 1:STEPMAX) {
        	#  ensure that step does not go beyond limits on parameters
        	limflg  <- 0
        	#  check the step size
        	result <- stepchk(linemat[1,5], cvec, deltac, limwrd, ind, 
                            climit, active, dbgwrd)
			linemat[1,5] <- result[[1]]
			ind          <- result[[2]]
			limwrd       <- result[[3]]
       	if (linemat[1,5] <= 1e-9) {
          		#  Current step size too small  terminate
          		Flist   <- Foldstr
          		cvecnew <- cvec
          		gvecnew <- gvec
          		if (dbglev > 1) print(paste("Stepsize too small:", linemat[1,5]))
          		if (limflg) ind <- 1 else ind <- 4
          		break
        	}
        	cvecnew <- cvec + linemat[1,5]*deltac
        	#  compute new function value and gradient
			result  <- loglfnden(x, f, basis, cvecnew)
			logl    <- result[[1]]
			Dlogl   <- result[[2]]
        	Flist$f <- -logl
        	gvecnew <- -Dlogl
        	if (lambda > 0) {
            	gvecnew <- gvecnew + 2*Kmat %*% cvecnew
            	Flist$f <- Flist$f + t(cvecnew) %*% Kmat %*% cvecnew
        	}
        	if (ninactive > 0) gvecnew[inactive] <- 0  
        	Flist$norm <- sqrt(mean(gvecnew^2))
        	linemat[3,5] <- Flist$f
        	#  compute new directional derivative
        	linemat[2,5] <- sum(deltac*gvecnew)
      		if (dbglev > 1) {
				#print(c(stepiter, linemat[,1]))
				cat("              ")
				cat(format(stepiter))
				cat(format(linemat[,1]))
				cat("\n")
			}
        	#  compute next step
			result <- stepit(linemat, ips, ind, dblwrd, MAXSTEP, dbgwrd)
			linemat <- result[[1]]
			ips     <- result[[2]]
			ind     <- result[[3]]
			dblwrd  <- result[[4]]
        	trial   <- linemat[1,5]
        	#  ind == 0 implies convergence
        	if (ind == 0 | ind == 5) break 
        	#  end of line search loop
     	}
     	cvec <- cvecnew
     	gvec <- gvecnew
	  	Wfdobj <- putcoef(cvec, Wfdobj)
     	status <- c(iternum, Flist$f, -logl, Flist$norm)
     	iterhist[iter+1,] <- status
		cat("      ")
		cat(format(iternum))
		cat("    ")
		cat(format(status[2:4]))
		cat("\n")

     	#  test for convergence

     	if (abs(Flist$f-Foldstr$f) < conv) {
       	iterhist <- iterhist[1:(iternum+1),]
  			C <- normalize.phi(basis, cvec)
			denslist <- list("Wfdobj" = Wfdobj, "C" = C, "Flist" = Flist, 
			          			"iternum" = iternum, "iterhist" = iterhist)
			return( denslist )
     	}
     	if (Flist$f >= Foldstr$f) break 
     	#  compute the Hessian
     	hmat <- Varfnden(x, basis, cvec)
     	if (lambda > 0) hmat <- hmat + 2*Kmat
     	if (ninactive > 0) {
       	hmat[inactive,] <- 0
       	hmat[,inactive] <- 0
       	hmat[inactive,inactive] <- diag(rep(1,ninactive))
     	}
     	#  evaluate the update vector
     	deltac <- -solve(hmat,gvec)
     	cosangle  <- -sum(gvec*deltac)/sqrt(sum(gvec^2)*sum(deltac^2))
     	if (cosangle < 0) {
       	if (dbglev > 1) print("cos(angle) negative") 
       	deltac <- -gvec
     	}
     	Foldstr <- Flist
		#  end of iterations
  	}
	#  compute final normalizing constant
	print(Wfdobj)
  	C <- normalize.phi(basis, cvec)
	print(Wfdobj)
	print(C)
	denslist <- list("Wfdobj" = Wfdobj, "C" = C, "Flist" = Flist, 
			          "iternum" = iternum, "iterhist" = iterhist)
 	return( denslist )
}

#  ---------------------------------------------------------------

loglfnden <- function(x, f, basis, cvec) {
	#  Computes the log likelihood and its derivative with
	#    respect to the coefficients in CVEC
   	N       <- length(x)
   	nbasis  <- basis$nbasis
   	fmat    <- outer(f, rep(1,nbasis))
   	fsum    <- sum(f)
   	nobs    <- length(x)
   	phimat  <- getbasismatrix(x, basis)
   	cval    <- normalize.phi(basis, cvec)
   	logl    <- sum((phimat %*% cvec) * f - fsum*log(cval)/N)
   	EDW     <- outer(rep(1,nobs),expect.phi(basis, cvec, cval))
   	Dlogl   <- apply((phimat - EDW)*fmat,2,sum)
	return( list(logl, Dlogl) )
}

#  ---------------------------------------------------------------

Varfnden <- function(x, basis, cvec) {
	#  Computes the expected Hessian
   	nbasis  <- basis$nbasis
   	nobs    <- length(x)
   	cval    <- normalize.phi(basis, cvec)
   	EDw     <- outer(rep(1,nobs),expect.phi(basis, cvec, cval))
   	EDwDwt  <- nobs*expect.phiphit(basis, cvec, cval)
   	Varphi  <- EDwDwt - crossprod(EDw)
	return(Varphi)
}
	

#  ---------------------------------------------------------------

normalize.phi <- function(basis, cvec, JMAX=15, EPS=1e-7) {

#  Computes integrals of
#      p(x) = exp phi"(x) %*% cvec
#  by numerical integration using Romberg integration

#  Arguments:
#  BASIS ... Basis function object with basis functions phi.
#  CVEC  ... coefficient vector defining density, of length NBASIS
#  MU    ... mean values to be subtracted from variates
#  SIGMA ... standard deviation to define u = (x - mu)/sigma
#  RNG   ... vector of length 2 giving the interval over which the
#            integration is to take place.  Multiply a standard interval
#            like (-5,5) by sigma to make it scale free
#  JMAX  ... maximum number of allowable iterations
#  EPS   ... convergence criterion for relative stop

#  Return:
#  The integral of the function.

  	#  check arguments, and convert basis objects to functional data objects

  	if (!inherits(basis, "basis.fd") )
    	stop("First argument must be a basis function object.")

	nbasis <- basis$nbasis
  	oneb   <- matrix(1,1,nbasis)
  	rng    <- basis$rangeval

  	#  set up first iteration

  	width <- rng[2] - rng[1]
  	JMAXP <- JMAX + 1
  	h <- matrix(1,JMAXP,1)
  	h[2] <- 0.25
  	#  matrix SMAT contains the history of discrete approximations to the integral
  	smat <- matrix(0,JMAXP,1)
  	#  the first iteration uses just the }points
  	x  <- rng
  	nx <- length(x)
  	ox <- matrix(1,nx,1)
  	fx <- getbasismatrix(x, basis)
  	wx <- fx %*% cvec
  	wx[wx < -50] <- -50
  	px <- exp(wx)
  	smat[1]  <- width*sum(px)/2
  	tnm <- 0.5
  	j   <- 1

  	#  now iterate to convergence
  	for (j in 2:JMAX) {
    	tnm  <- tnm*2
    	del  <- width/tnm
    	if (j == 2) {
      		x <- (rng[1] + rng[2])/2
    	} else {
      		x <- seq(rng[1]+del/2, rng[2], del)
    	}
    	fx <- getbasismatrix(x, basis)
    	wx <- fx %*% cvec
    	wx[wx < -50] <- -50
    	px <- exp(wx)
    	smat[j] <- (smat[j-1] + width*sum(px)/tnm)/2
    	if (j >= 5) {
      		ind <- (j-4):j
			result <- polintarray(h[ind],smat[ind],0)
			ss  <- result[[1]]
			dss <- result[[2]]
      		if (!any(abs(dss) >= EPS*max(abs(ss)))) {
        		#  successful convergence
        		return(ss)
      		}
    	}
    	smat[j+1] <- smat[j]
    	h[j+1]    <- 0.25*h[j]
 	}
  	warning(paste("No convergence after ",JMAX," steps in NORMALIZE.PHI"))
	return(ss)
}

#  ---------------------------------------------------------------

expect.phi <- function(basis, cvec, Cval=1, nderiv=0, rng=rangeval, 
                     JMAX=15, EPS=1e-7) {
#  Computes expectations of basis functions with respect to density
#      p(x) <- Cval^{-1} exp t(c)*phi(x)
#  by numerical integration using Romberg integration

#  Arguments:
#  BASIS  ... A basis function object object.  
#  CVEC   ... coefficient vector defining density, of length NBASIS
#  CVAL   ... normalizing constant defining density
#  MU     ... mean value to be subtracted from variates
#  SIGMA  ... standard deviation to define u = (x - mu)/sigma
#  RNG    ... vector of length 2 giving the interval over which the
#             integration is to take place
#  NDERIV ... order of derivative required for basis function expectation
#  UWRD   ... if (T, expectation is of (D PHI)*U
#  JMAX   ... maximum number of allowable iterations
#  EPS    ... convergence criterion for relative stop

#  Return:
#  A vector SS of length NBASIS of integrals of functions.

  	#  check arguments, and convert basis objects to functional data objects

  	if (!inherits(basis, "basis.fd"))
    	stop("First argument must be a basis function object.")

  	nbasis <- basis$nbasis
  	oneb   <- matrix(1,1,nbasis)
  	rangeval <- basis$rangeval

  	#  set up first iteration

  	width <- rng[2] - rng[1]
  	JMAXP <- JMAX + 1
  	h <- matrix(1,JMAXP,1)
  	h[2] <- 0.25
  	#  matrix SMAT contains the history of discrete approximations to the integral
  	smat <- matrix(0,JMAXP,nbasis)
  	sumj <- matrix(0,1,nbasis)
  	#  the first iteration uses just the }points
  	x  <- rng
  	nx <- length(x)
  	ox <- matrix(1,nx,nx)
  	fx <- getbasismatrix(x, basis)
  	wx <- fx %*% cvec
  	wx[wx < -50] <- -50
  	px <- exp(wx)/Cval
  	if (nderiv == 0) {
    	Dfx <- fx
  	} else {
    	Dfx <- getbasismatrix(x, basis, 1)
  	}
  	sumj <- t(Dfx) %*% px
  	smat[1,]  <- width*sumj/2
  	tnm <- 0.5
  	j   <- 1

  	#  now iterate to convergence

  	for (j in 2:JMAX) {
    	tnm  <- tnm*2
    	del  <- width/tnm
    	if (j == 2) {
      		x <- (rng[1] + rng[2])/2
    	} else {
      		x <- seq(rng[1]+del/2, rng[2], del)
    	}
    	nx <- length(x)
    	fx <- getbasismatrix(x, basis)
    	wx <- fx %*% cvec
    	wx[wx < -50] <- -50
    	px <- exp(wx)/Cval
    	if (nderiv == 0) {
      		Dfx <- fx
    	} else {
      		Dfx <- getbasismatrix(x, basis, 1)
    	}
    	sumj <- t(Dfx) %*% px
    	smat[j,] <- (smat[j-1,] + width*sumj/tnm)/2
    	if (j >= 5) {
      		ind <- (j-4):j
      		temp <- smat[ind,]
			result <- polintarray(h[ind],temp,0)
			ss  <- result[[1]]
			dss <- result[[2]]
      		if (!any(abs(dss) > EPS*max(abs(ss)))) {
        		#  successful convergence
        		return(ss)
      		}
    	}
    	smat[j+1,] <- smat[j,]
    	h[j+1] <- 0.25*h[j]
  	}
  	warning(paste("No convergence after ",JMAX," steps in EXPECT.PHI"))
	return(ss)
}

#  ---------------------------------------------------------------

expect.phiphit <- function(basis, cvec, Cval=1, nderiv1=0, nderiv2=0, 
                             rng=rangeval, JMAX=15, EPS=1e-7) {

#  Computes expectations of cross product of basis functions with
#  respect to density
#      p(x) = Cval^{-1} exp t(c) %*% phi(x)
#  by numerical integration using Romberg integration

#  Arguments:
#  BASIS ... A basis function object.  
#  CVEC  ... coefficient vector defining density
#  CVAL  ... normalizing constant defining density
#  RNG   ... vector of length 2 giving the interval over which the
#            integration is to take place
#  JMAX  ... maximum number of allowable iterations
#  EPS   ... convergence criterion for relative stop

#  Return:
#  A matrix of order NBASIS of integrals of functions.

  	#  check arguments, and convert basis objects to functional data objects

  	if (!inherits(basis, "basis.fd"))
    	stop("First argument must be a basis function object.")

  	nbasis   <- basis$nbasis
  	oneb     <- matrix(1,1,nbasis)
  	rangeval <- basis$rangeval

  	#  set up first iteration

  	width <- rng[2] - rng[1]
  	JMAXP <- JMAX + 1
  	h <- matrix(1,JMAXP,1)
  	h[2] <- 0.25
  	#  matrix SMAT contains the history of discrete approximations to the integral
  	smat <- array(0,c(JMAXP,nbasis,nbasis))
  	#  the first iteration uses just the }points
  	x  <- rng
  	nx <- length(x)
  	fx <- getbasismatrix(x, basis)
  	wx <- fx %*% cvec
  	wx[wx < -50] <- -50
  	px <- exp(wx)/Cval
  	if (nderiv1 == 0) {
    	Dfx1 <- fx
  	} else {
    	Dfx1 <- getbasismatrix(x, basis, 1)
  	}
  	if (nderiv2 == 0) {
    	Dfx2 <- fx
  	} else {
    	Dfx2 <- getbasismatrix(x, basis, 1)
  	}
  	oneb <- matrix(1,1,nbasis)
  	sumj <- t(Dfx1) %*% ((px %*% oneb) * Dfx2)
  	smat[1,,]  <- width*sumj/2
  	tnm <- 0.5
  	j   <- 1

  	#  now iterate to convergence
  	for (j in 2:JMAX) {
    	tnm  <- tnm*2
    	del  <- width/tnm
    	if (j == 2) {
      		x <- (rng[1] + rng[2])/2
    	} else {
      		x <- seq(rng[1]+del/2, rng[2], del)
    	}
    	nx <- length(x)
    	fx <- getbasismatrix(x, basis)
    	wx <- fx %*% cvec
    	wx[wx < -50] <- -50
    	px <- exp(wx)/Cval
    	if (nderiv1 == 0) {
      		Dfx1 <- fx
    	} else {
      		Dfx1 <- getbasismatrix(x, basis, 1)
    	}
    	if (nderiv2 == 0) {
      		Dfx2 <- fx
    	} else {
      		Dfx2 <- getbasismatrix(x, basis, 1)
    	}
    	sumj <- t(Dfx1) %*% ((px %*% oneb) * Dfx2)
    	smat[j,,] <- (smat[j-1,,] + width*sumj/tnm)/2
    	if (j >= 5) {
      		ind <- (j-4):j
      		temp <- smat[ind,,]
	   		result <- polintarray(h[ind],temp,0)
	   		ss  <- result[[1]]
	   		dss <- result[[2]]
      		if (!any(abs(dss) > EPS*max(max(abs(ss))))) {
        		#  successful convergence
        		return(ss)
      		}
    	}
    	smat[j+1,,] <- smat[j,,]
    	h[j+1] <- 0.25*h[j]
  	}
  	warning(paste("No convergence after ",JMAX," steps in EXPECT.PHIPHIT"))
	return(ss)
}
#  ---------------------------------------------------------------

polintarray <- function(xa, ya, x0) {
  	#  YA is an array with up to 4 dimensions
  	#     with 1st dim the same length same as the vector XA
  	n     <- length(xa)
  	yadim <- dim(ya)
  	if (is.null(yadim)) {
		yadim <- n
		nydim <- 1
  	} else {
    	nydim <- length(yadim)
  	}
  	if (yadim[1] != n) stop("First dimension of YA must match XA") 
  	difx <- xa - x0
  	absxmxa <- abs(difx)
  	ns <- min((1:n)[absxmxa == min(absxmxa)])
  	cs <- ya
  	ds <- ya
  	if (nydim == 1) y <- ya[ns]  
  	if (nydim == 2) y <- ya[ns,]  
  	if (nydim == 3) y <- ya[ns,,]  
  	if (nydim == 4) y <- ya[ns,,,]  
  	ns <- ns - 1
  	for (m in 1:(n-1)) {
    	if (nydim == 1) {
      		for (i in 1:(n-m)) {
        		ho    <- difx[i]
        		hp    <- difx[i+m]
        		w     <- (cs[i+1] - ds[i])/(ho - hp)
        		ds[i] <- hp*w
        		cs[i] <- ho*w
      		}
      		if (2*ns < n-m) {
        		dy <- cs[ns+1]
      		} else {
        		dy <- ds[ns]
        		ns <- ns - 1
      		}
  		}
  		if (nydim == 2) {
      		for (i in 1:(n-m)) {
        		ho     <- difx[i]
        		hp     <- difx[i+m]
        		w      <- (cs[i+1,] - ds[i,])/(ho - hp)
        		ds[i,] <- hp*w
        		cs[i,] <- ho*w
      		}
      		if (2*ns < n-m) {
        		dy <- cs[ns+1,]
      		} else {
        		dy <- ds[ns,]
        		ns <- ns - 1
      		}
  		}
   		if (nydim == 3) {
      		for (i in 1:(n-m)) {
        		ho       <- difx[i]
        		hp       <- difx[i+m]
        		w        <- (cs[i+1,,] - ds[i,,])/(ho - hp)
        		ds[i,,] <- hp*w
        		cs[i,,] <- ho*w
      		}
      		if (2*ns < n-m) {
        		dy <- cs[ns+1,,]
      		} else {
        		dy <- ds[ns,,]
        		ns <- ns - 1
      		}
  		}
   		if (nydim == 4) {
      		for (i in 1:(n-m)) {
        		ho      <- difx[i]
        		hp      <- difx[i+m]
        		w       <- (cs[i+1,,,] - ds[i,,,])/(ho - hp)
        		ds[i,,,] <- hp*w
        		cs[i,,,] <- ho*w
      		}
      		if (2*ns < n-m) {
        		dy <- cs[ns+1,,,]

      		} else {
        		dy <- ds[ns,,,]
        		ns <- ns - 1
      		}
  		}
   		y <- y + dy
	}
   	return( list(y, dy) )
}
derivFd <- function(fd, Lfd=1)
{
  #  Applies linear differential operator LFD to functional data object FD
  #    and returns the result as functional data object DERIVFD.

  #  Last modified 6 Feb 2001

  if (!(inherits(fd, "fd"))) stop("Argument  FD not a functional data object.")

  basisfd  <- getbasis(fd)
  nbasis   <- basisfd$nbasis
  rangeval <- basisfd$rangeval

  evalarg  <- seq(rangeval[1], rangeval[2], len=10*nbasis+1)
  Lfdmat   <- eval.fd(evalarg, fd, Lfd)

  Lfdcoef  <- project.basis(Lfdmat, evalarg, basisfd)

  Dfdnames <- fd$fdnames
  Dfdnames[[3]] <- paste("D",Dfdnames[[3]])

  derivfd <- create.fd(Lfdcoef, basisfd, Dfdnames)

  return(derivfd)
}
derivchk <- function (x, y, Dy) {

  #  checks that DY is the derivative of Y by comparing it
  #  with Y's central difference estimate.
  #  The value of |DYHAT-DY|/|DY| is returned.

  n <- length(x)
  if (n < 3) stop("X does not have enough elements")
  if (n != length(y) | n != length(Dy)) stop(
        "Lengh of Y or DY not consistent with length of X")
  indup <- 3:n
  inddn <- 1:(n-2)
  indct <- 2:(n-1)
  xdiff <- x[indup]-x[inddn]
  if (min(xdiff) <= 0) stop("X not strictly increasing")
  Dyhat <- (y[indup]-y[inddn])/xdiff
  ratio <- sqrt(mean((Dyhat-Dy[indct])^2))/sqrt(mean(Dy[indct]^2))
  return(ratio)
}
derivs <- function(tnow, y, wfd) {
	#  Sets up a linear differential equation of order m 
	#  as a system of m first order equations
	#  Arguments:
	#  TNOW ... A vector of values of the independent variable t
	#  Y    ... A matrix of m values of Y corresponding to TNOW
	#  WFD  ... A functional data object containing coefficient functions
	#  Returns:
	#  DY   ... A matrix of derivative values corresponding to Y
	
	#  Last modified:  24 March 2003
	
  w  <- eval.fd(tnow,wfd)
  m  <- length(w) - 1;
  wmat <- matrix(0, m, m)
  wmat[1:(m-1),2:m] <- diag(rep(1,m-1))
  wmat[m,] <- -w[2:(m+1)]
  dy <- wmat %*% y
  return(dy)
}
df2lambda <- function(argvals, basisobj, wtvec=rep(1,n), Lfd=0, df=nbasis)
#  Convert a degree of freedom DF for a smooth to the equivalent value
#    of the smoothing parameter lambda.
{
n <- length(argvals)
nbasis <- basisobj$nbasis
if (df >= nbasis) {
   lambda <- 0
   return(lambda)
}

TOL    <- 1e-3
GOLD   <- 1.0
GLIMIT <- 2.0
TINY   <- 1.0e-20

#  find machine precision
eps <- 1
tol1 <- 1 + eps
while (tol1 > 1) {
   eps  <- eps/2
   tol1 <- 1 + eps
}
eps <- sqrt(eps)

#  ------  initialization of lambda by finding bracketing values ------------
#             a < b < c such that  fb < fa  and  fb < fc
#  first use input value for lambda unless it is zero, in which case -1
bx <- -4.0
#  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
lambda <- 10^(bx)
fb <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
#  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#  now try bracketing the minimum by using a large value and a small
#  value.  If (this doesn't work, revert to the iterative method
#  at statement 5
if (bx >= -10 &&  bx <= 5) {
#  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   cx <- 5  #  the upper limit
#  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   lambda <- 10^(cx)
   fc <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
#  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   ax <- -8  #  the lower limit
#  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   lambda <- 10^(ax)
   fa <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
}
#  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#  check to see if minimum bracketed
#print(c(ax,bx,cx,fa,fb,fc, lambda))
if (fb >= fa || fb >= fc) {
  #  Failure to bracket minimum, proceed with iterative search for
  #    bracketing values.
  #  First, as an alternative value for ax, use the input value plus 0.1
  ax <- bx + 1
  #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  lambda <- 10^(ax)
  fa <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
  #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  #  now the bracketing process begins
  if (fb > fa) {
     #  exchange ax and bx
     dum <- ax
     ax  <- bx
     bx  <- dum
     dum <- fb
     fb  <- fa
     fa  <- dum
  }
  #  first guess at cx
  cx <- bx + GOLD*(bx - ax)
  #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  lambda <- 10^(cx)
  fc <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
  #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  #  check if (three values bracket minimum
  #print(c(ax,bx,cx,fa,fb,fc, lambda))
  while (fb >= fc) {
     r <- (bx - ax)*(fb - fc)
     q <- (bx - cx)*(fb - fa)
     u <- bx -
       ((bx - cx)*q - (bx - ax)*r)/(2.0*sign(max(c(abs(q-r),TINY)))*(q-r))
     ulim <- bx + GLIMIT*(cx - bx)
     if ((bx-u)*(u-cx) > 0.0) {
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        lambda <- 10^(u)
        fu <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        if (fu < fc) {
           #  success
           ax <- bx
           bx <- u
           fa <- fb
           fb <- fu
           break
        }
        if (fu > fb) {
           #  also success
           cx <- u
           fc <- fu
           break
        }
        #  failure:  fu >= fb
        u <- cx + GOLD*(cx - bx)
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        lambda <- 10^(u)
        fu <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     }
     if ((cx - u)*(u - ulim) > 0.0) {
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        lambda <- 10^(u)
        fu <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        if (fu < fc) {
           bx <- cx
           cx <-  u
           u  <- cx + GOLD*(cx - bx)
           fb <- fc
           fc <- fu
           #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
           lambda <- 10^(u)
           fu <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
           #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        }
     }
     if ((u-ulim)*(ulim-cx) >= 0.0) {
        u <- ulim
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        lambda <- 10^(u)
        fu <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     } else {
        u <- cx + GOLD*(cx - bx)
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        lambda <- 10^(u)
        fu <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
        #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     }
     ax <- bx
     bx <- cx
     cx <- u
     fa <- fb
     fb <- fc
     fc <- fu
     #print(c(ax,bx,cx,fa,fb,fc, lambda))
  }  #  end of while loop
}
#  ---------------------------------------------------------------------
#  --------------------  bracketing successful  ------------------------
#  ---------------------------------------------------------------------
a  <- min(c(ax,cx))
b  <- max(c(ax,cx))
v  <- bx
w  <- v
x  <- v
e  <- 0.0
fx <- fb
fv <- fx
fw <- fx
#  ---------------------------------------------------------------------
#  --------------------  main loop starts here -------------------------
#  ---------------------------------------------------------------------
xm   <- 0.5*(a + b)
tol1 <- eps*abs(x) + TOL/3
tol2 <- 2*tol1
crit <- abs(x - xm) - (tol2 - 0.5*(b - a))
#print(c(crit, lambda))
while (crit > 0) {
   #  is golden-section necessary?
   if (abs(e) > tol1) {
      #  fit parabola
      r <- (x - w)*(fx - fv)
      q <- (x - v)*(fx - fw)
      p <- (x - v)*q - (x - w)*r
      q <- 2.0*(q - r)
      if (q > 0.0)   p <- -p
      q <- abs(q)
      s <- e
      e <- d
      #  is parabola acceptable?
      if (abs(p) < abs(0.5*q*s) & p > q*(a - x) & p < q*(b - x)) {
         #  a parabolic interpolation step
         d <- p/q
         u <- x + d
         #  f must not be evaluated too close to a or b
         if ((u - a) < tol2 ||  b - u < tol2) {
            if (xm - x >= 0.0) d <- tol1 else d <- -tol1
         }
      } else {
         #  a golden-section step
         if (x >= xm) e <- a - x else e <- b - x
         d <- 0.382*e
      }
   } else {
      #  a golden-section step
      if (x >= xm) e <- a - x else e <- b - x
      d <- 0.382*e
   }
#  f must not be evaluated too close to x
   if (abs(d) >=  tol1) {
      u <- x + d
   } else {
      if (d >= 0.0) u <- x + tol1 else u <- x - tol1
  }
  #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  lambda <- 10^u
  fu <- (lambda2df(argvals, basisobj, wtvec, Lfd, lambda) - df)^2
  #  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  #  update  a, b, v, w, and x
  if (fu <= fx) {
     if (u  >= x) a <- x else b <- x
     v  <- w
     w  <- x
     x  <- u
     fv <- fw
     fw <- fx
     fx <- fu
  } else {
     if (u  < x) a <- u else b <- u
     if (fu <= fw || w == x) {
        v  <- w
        w  <- u
        fv <- fw
        fw <- fu
     }
     if (fu <= fv || v == x || v == w) {
        v  <- u
        fv <- fu
     }
  }
  xm   <- 0.5*(a + b)
  tol1 <- eps*abs(x) + TOL/3
  tol2 <- 2*tol1
  crit <- abs(x - xm) - (tol2 - 0.5*(b - a))
  #print(c(crit, lambda))
#  -------------------  } of main loop  ------------------------------
}
return(lambda)
}
eval.bifd <- function(sevalarg, tevalarg, bifd, sLfd = 0, tLfd = 0) {

  #  Evaluates a bi-functional data object BIFD at argument values in arrays
  #  SEVALARG and TEVALARG.  Differential operators SLFD and TLFD are
  #     applied to BIFD if present.

  #  Last modified 6 Feb 2001

  if (!is.vector(sevalarg)) stop(
     "First argument is not a vector.")
  if (!is.vector(tevalarg)) stop(
     "Second argument is not a vector.")

  ns   <- length(sevalarg)
  nt   <- length(tevalarg)

  if (!(inherits(bifd, "bifd"))) stop("Third argument is not a bifd object")

  sbasisfd <- bifd[[2]]
  snbasis  <- sbasisfd$nbasis
  rangeval <- sbasisfd$rangeval
  if (min(sevalarg) < rangeval[1] || max(sevalarg) > rangeval[2]) stop(
    "Values of the first argument are outside of permitted range.")

  tbasisfd <- bifd[[3]]
  tnbasis  <- tbasisfd$nbasis
  rangeval <- tbasisfd$rangeval
  if (min(tevalarg) < rangeval[1] || max(tevalarg) > rangeval[2]) stop(
    "Values of the second argument are outside of permitted range.")

  coef  <- bifd[[1]]
  coefd <- dim(coef)
  ndim  <- length(coefd)

  if (is.numeric(sLfd)) {
    if (length(sLfd) == 1) {
      snderiv <- sLfd
      if (snderiv != as.integer(snderiv)) {
        stop("Order of derivative must be an integer")
      }
      if (snderiv < 0) {
        stop("Order of derivative must be 0 or positive")
      }
    } else {
      stop("Order of derivative must be a single number")
    }
    sLfd <- NULL
    if (snderiv < 0) stop ("Order of derivative cannot be negative")
  } else if (inherits(sLfd, "fd")) {
    sderivcoef <- getcoef(sLfd)
    snderiv <- ncol(sderivcoef)
  } else {
    stop("Third argument must be an integer or a functional data object")
  }

  sbasismat <- getbasismatrix(sevalarg, sbasisfd, snderiv)
  if (snderiv > 0 && !is.null(sLfd)) {
    sLfdmat <- eval.fd(sevalarg, sLfd)
    onerow <- rep(1,snbasis)
    for (j in 1:snderiv) {
      if (any(abs(sLfdmat[,j])) > 1e-7) {
        sbasismat <- sbasismat + outer(sLfdmat[,j],onerow)*
                         getbasismatrix(sevalarg, sbasisfd, j-1)
      }
    }
  }

  if (is.numeric(tLfd)) {
    if (length(tLfd) == 1) {
      tnderiv <- tLfd
      if (tnderiv != as.integer(tnderiv)) {
        stop("Order of derivative must be an integer")
      }
      if (tnderiv < 0) {
        stop("Order of derivative must be 0 or positive")
      }
    } else {
      stop("Order of derivative must be a single number")
    }
    tLfd <- NULL
    if (tnderiv < 0) stop ("Order of derivative cannot be negative")
  } else if (inherits(tLfd, "fd")) {
    tderivcoef <- getcoef(tLfd)
    tnderiv <- ncol(tderivcoef)
  } else {
    stop("Third argument must be an integer or a functional data object")
  }

  tbasismat <- getbasismatrix(tevalarg, tbasisfd, tnderiv)
  if (tnderiv > 0 && !is.null(tLfd)) {
    tLfdmat <- eval.fd(tevalarg, tLfd)
    onerow <- rep(1,tnbasis)
    for (j in 1:tnderiv) {
      if (any(abs(tLfdmat[,j])) > 1e-7) {
        tbasismat <- tbasismat + outer(tLfdmat[,j],onerow)*
                         getbasismatrix(tevalarg, tbasisfd, j-1)
      }
    }
  }

  if (ndim == 2) {
    evalbifd <- sbasismat %*% coef %*% t(tbasismat)
  }
  if (ndim == 3) {
    nrep  <- coefd[3]
    evalbifd <- array(0,c(ns,nt,nrep))
    for (i in 1:nrep) {
      evalbifd[,,i] <- sbasismat %*% coef[,,i] %*% t(tbasismat)
    }
    dimnames(evalbifd) <- list(NULL,NULL,dimnames(coef)[[3]])
  }
  if (ndim > 3) {
    nrep  <- coefd[3]
    nvar  <- coefd[4]
    evalbifd <- array(0,c(ns,nt,nrep,nvar))
    for (i in 1:nrep) for (j in 1:nvar) {
      evalbifd[,,i,j] <-
        sbasismat %*% coef[,,i,j] %*% t(tbasismat)
    }
    dimnames(evalbifd) <-
        list(NULL,NULL,dimnames(coef)[[3]],dimnames(coef)[[4]])
  }
  return(evalbifd)
}
#  ----------------------------------------------------------------------------

eval.fd <- function(evalarg, fd, Lfd=0) {

#  Evaluates a functional data observation, or the value of a linear
#  differential operator LFD applied to the object, at argument values in an array 
#  EVALARGS.
#
#  Note that this function is preferred to eval.fd() since it is so easy to confuse
#  eval.fd() with the function eval(), which is generic and will process the argument 
#  list for eval.fd, but give inappropriate results.
#
#  If LFD is a functional data object with m + 1 functions c_1, ... c_{m+1}, then it
#    is assumed to define the order m NONHOMOGENEOUS linear differential operator
#  Lx(t) = c_1(t) + c_2(t)x(t) + c_3(t)Dx(t) + ... + c_{m+1}D^{m-1}x(t) + D^m x(t).
#  This is a change from previous usage where LFD was assumed to define a HOMOGONEOUS
#  differential operator, for which the forcing function c_1(t) = 0.  
#
#  Arguments:
#  EVALARG ... Either a vector of values at which all functions are to evaluated,
#              or a matrix of values, with number of columns corresponding to
#              number of functions in argument FD.  If the number of evaluation
#              values varies from curve to curve, pad out unwanted positions in
#              each column with NA.  The number of rows is equal to the maximum
#              of number of evaluation points.
#  FD      ... Functional data object
#  LFD     ... If an integer, defines NDERIV, the order of derivative to be evaluated
#              If a functional data object, defines weight
#              functions for computing the value of a nonhomogeneous linear 
#              differential operator applied to the functions that are evaluated.
#  Note that the first two arguments may be interchanged.

#  Returns:  An array of function values corresponding to the evaluation 
#              arguments in EVALARG

#  Last modified 5 December 2001

#  Exchange the first two arguments if the first is an BASIS.FD object 
#    and the second numeric

if (is.numeric(fd) && inherits(evalarg, "fd")) {
    temp    <- fd
    fd      <- evalarg
    evalarg <- temp
}

#  Check the arguments

evaldim <- dim(evalarg)

if (!(is.numeric(evalarg)))  stop("Argument EVALARG is not numeric.")
	
if (!(length(evaldim) < 3)) stop(
   "Argument EVALARG is not a vector or a matrix.")

if (!(inherits(fd, "fd"))) stop(
     "Argument FD is not a functional data object.")

if (!(is.Lfd(Lfd))) stop(
     "Argument LFD is not a linear differential operator.")

#  Extract information about the basis

basisfd  <- getbasis(fd)
nbasis   <- basisfd$nbasis
rangeval <- basisfd$rangeval
onerow   <- rep(1,nbasis)

temp <- c(evalarg)
temp <- temp[!(is.na(temp))]
if (min(temp) < rangeval[1] || max(temp) > rangeval[2]) 
	warning(paste(
    "Values in argument EVALARG are outside of permitted range,",
    "and will be ignored."))

#  get maximum number of evaluation values

if (is.vector(evalarg)) {
	n <- length(evalarg)
} else {
	n <- evaldim[1]
}

#  Set up coefficient array for FD

coef  <- getcoef(fd)
coefd <- dim(coef)
ndim  <- length(coefd)
if (ndim <= 1) nrep <- 1 else nrep <- coefd[2]
if (ndim <= 2) nvar <- 1 else nvar <- coefd[3]

#  Set up array for function values

if (ndim <= 2) evalarray <- matrix(0,n,nrep)
	else        evalarray <- array(0,c(n,nrep,nvar))
if (ndim == 2) dimnames(evalarray) <- list(NULL,dimnames(coef)[[2]])
if (ndim == 3) dimnames(evalarray) <- list(NULL,dimnames(coef)[[2]],
	                                             dimnames(coef)[[3]])

#  Case where EVALARG is a vector of values to be used for all curves

if (is.vector(evalarg)) {

    evalarg[evalarg < rangeval[1]-1e-10] <- NA
    evalarg[evalarg > rangeval[2]+1e-10] <- NA
    basismat <- getbasismatrix(evalarg, basisfd, Lfd)

    #  evaluate the functions at arguments in EVALARG

   	if (inherits(Lfd, "fd")) {
		Lfdmat <- eval.fd(evalarg, Lfd)
		if (length(dim(Lfdmat))==3) Lfdmat <- Lfdmat[,,1]
		force <- outer(Lfdmat[,1],rep(1,nrep))
	} else {
		force <- outer(rep(0,length(evalarg)),rep(1,nrep))
	}
    if (ndim <= 2) {
	    evalarray <- force + basismat %*% coef
    } else {
       evalarray <- array(0,c(n,nrep,nvar))
       for (ivar in 1:nvar) evalarray[,,ivar] <- force + basismat %*% coef[,,ivar]
    }

} else {
	
	#  case of evaluation values varying from curve to curve
	
	for (i in 1:nrep) {
		evalargi <- evalarg[,i]
       if (all(is.na(evalargi))) stop(
            paste("All values are NA for replication",i))

		index    <- !(is.na(evalargi) | evalargi < rangeval[1] | evalargi > rangeval[2])
		evalargi <- evalargi[index]
       basismat <- getbasismatrix(evalargi, basisfd, Lfd)

   	  	if (inherits(Lfd, "fd")) {
			Lfdmat <- eval.fd(evalargi, Lfd)
			if (length(dim(Lfdmat))==3) Lfdmat <- Lfdmat[,,1]
			force <- outer(Lfdmat[,1],rep(1,nrep))
		} else {
		   	force <- outer(rep(0,length(evalargi)),rep(1,nrep))
		}
       #  evaluate the functions at arguments in EVALARG

       if (ndim == 2) {
           evalarray[  index, i] <- force + basismat %*% coef[,i]
           evalarray[!(index),i] <- NA
       }
       if (ndim == 3) {
           for (ivar in 1:nvar) {
	           evalarray[   index,i,ivar] <- force + basismat %*% coef[,i,ivar]
               evalarray[!(index),i,ivar] <- NA
           }
       }
	}
	
}

return(evalarray)

}

eval.monfd <- function(evalarg, Wfd, Lfd=0) {
  #  Evaluates a monotone functional data observation, or the value of a linear
  #  differential operator LFD applied to the object,
  #  at argument values in an array EVALARGS.
  #  Functional data object LFD, if an integer, defines NDERIV, the
  #  order of derivative to be evaluated.
  #  Functional data object LFD, if a fd object, defines weight
  #  functions for computing the value of a linear differential operator
  #  applied to the functions that are evaluated.

  #  A monotone functional data object h  is in the form

  #           h(x) = [D^{-1} exp Wfd](x)

  #  where  D^{-1} means taking the indefinite integral.
  #  The interval over which the integration takes places is defined in
  #  the basisfd object in WFD.

  coef  <- getcoef(Wfd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  if (ndim > 2) stop("WFD is not a univariate function")
  if (ndim == 2) ncurve <- coefd[2] else ncurve <- 1

  if (is.numeric(Lfd)) {
    if (length(Lfd) == 1) {
      nderiv <- Lfd
      if (nderiv != as.integer(nderiv)) {
        stop("Order of derivative must be an integer")
      }
      if (nderiv < 0) {
        stop("Order of derivative must be 0 or positive")
      }
    } else {
      stop("Order of derivative must be a single number")
    }
  } else {
    stop("General linear differential operators not implemented yet.")
  }

  n       <- length(evalarg)

  hmat <- matrix(0, n, ncurve)

  for (icurve in 1:ncurve) {
	
  if (nderiv == 0) {
    hval <- monfn(evalarg, Wfd[icurve])
    hmat[,icurve] <- hval
  }

  if (nderiv == 1) {
    Dhval <- exp(eval.fd(evalarg, Wfd[icurve]))
    hmat[,icurve] <- Dhval
  }

  if (nderiv == 2) {
    basisfd <- getbasis(Wfd)
    Dwmat   <- getbasismatrix(evalarg, basisfd, 1)
    D2hval  <- (Dwmat %*% coef) * exp(eval.fd(evalarg, Wfd[icurve]))
    hmat[,icurve] <- D2hval
  }

  if (nderiv == 3) {
    basisfd <- getbasis(Wfd)
    Dwmat   <- eval.fd(evalarg, basisfd, 1)
    D2wmat  <- eval.fd(evalarg, basisfd, 2)
    D3hval  <- ((D2wmat %*% coef) + (Dwmat %*% coef)^2) *
                 exp(eval.fd(evalarg, Wfd[icurve]))
    hmat[,icurve] <- D3hval
  }

  if (nderiv > 3) stop ("Derivatives higher than 3 not implemented.")

  }
  
  return(hmat)

}
expon <- function (x, ratevec=1, nderiv=0)
{
#  This computes values of the exponentials, or their derivatives.
#  RATEVEC is a vector containing the rate constants, or mulipliers of X
#    in the exponent of e.
#  The default is the exponential function.
#  Arguments are as follows:
#  X       ... array of values at which the polynomials are to
#             evaluated
#  RATEVEC ... a vector containing the rate constants, or mulipliers of X
#              in the exponent of e.
#  NDERIV  ... order of derivative.  0 means only function values
#             are returned.
#  Return is a matrix with length(X) rows and NRATE columns containing
#  the values of the exponential functions or their derivatives.

#  last modified 5 December 2001

  x <- as.vector(x)
  n <- length(x)
  nrate <- length(as.vector(ratevec))
  expval <- matrix(0,n,nrate)
  for (irate in 1:nrate) {
    rate <- ratevec[irate]
    expval[,irate] <- rate^nderiv * exp(rate*x)
  }
  return (expval)

}
exponpen <- function(basisfd, Lfd=2)
{

#  Computes the Exponential penalty matrix.
#  Argument:
#  BASISFD ... a basis.fd object of type "expon"
#  LFD     ... either the order of derivative or a
#                linear differential operator to be penalized.
#  Returns the penalty matrix.

#  Last modified 5 December 2001

if (!(inherits(basisfd, "basis.fd"))) stop(
    "First argument is not a basis.fd object.")

type <- getbasistype(basisfd)
if (type != "expon") stop ("Wrong basis type")

#  Find the highest order derivative in LFD

if (is.numeric(Lfd)) {
    if (length(Lfd) == 1) {
      	nderiv <- Lfd
      	if (nderiv != as.integer(nderiv)) {
        	stop("Order of derivative must be an integer")
      	}
      	if (nderiv < 0) {
        	stop("Order of derivative must be 0 or positive")
      	}
    } else {
      	stop("Order of derivative must be a single number")
    }
    if (nderiv < 0) stop ("Order of derivative cannot be negative")
} else if (inherits(Lfd, "fd")) {
   	derivcoef <- getcoef(Lfd)
   	if (length(dim(derivcoef))==3) derivcoef <- derivcoef[,,1]
   	nderiv <- dim(derivcoef)[2] - 1
   	if (nderiv < 0) {
   		stop("Order of derivative must be 0 or positive")
   	}
    nderiv <- ncol(derivcoef)
} else {
    stop("Second argument must be an integer or a functional data object")
}

#  Compute penalty matrix

if (is.numeric(Lfd)) {
    ratevec <- basisfd$params
    nrate   <- length(ratevec)
    penaltymatrix <- matrix(0,nrate,nrate)
    tl <- basisfd$rangeval[1]
    tu <- basisfd$rangeval[2]
    for (irate in 1:nrate) {
      	ratei <- ratevec[irate]
      	for (jrate in 1:irate) {
        	ratej <- ratevec[jrate]
        	ratesum <- ratei + ratej
        	if (ratesum != 0) {
          		penaltymatrix[irate,jrate] <- (ratei*ratej)^nderiv *
              	(exp(ratesum*tu) - exp(ratesum*tl)) / ratesum
        	} else {
          		if (nderiv == 0) penaltymatrix[irate,jrate] <- tu - tl
        	}
        	penaltymatrix[jrate,irate] <- penaltymatrix[irate,jrate]
      	}
	}
} else {
    penaltymatrix <- inprod(basisfd, basisfd, Lfd, Lfd)
}

return( penaltymatrix )
}
#  ----------------------------------------------------------------------------

fd2data <- function(evalarg, fd, Lfd=0) {

#  Evaluates a functional data observation, or the value of a linear
#  differential operator LFD applied to the object, at argument values in an array 
#  EVALARGS.
#
#  Note that this function is preferred to eval.fd() since it is so easy to confuse
#  eval.fd() with the function eval(), which is generic and will process the argument 
#  list for eval.fd, but give inappropriate results.
#
#  If LFD is a functional data object with m + 1 functions c_1, ... c_{m+1}, then it
#    is assumed to define the order m NONHOMOGENEOUS linear differential operator
#  Lx(t) = c_1(t) + c_2(t)x(t) + c_3(t)Dx(t) + ... + c_{m+1}D^{m-1}x(t) + D^m x(t).
#  This is a change from previous usage where LFD was assumed to define a HOMOGONEOUS
#  differential operator, for which the forcing function c_1(t) = 0.  
#
#  Arguments:
#  EVALARG ... Either a vector of values at which all functions are to evaluated,
#              or a matrix of values, with number of columns corresponding to
#              number of functions in argument FD.  If the number of evaluation
#              values varies from curve to curve, pad out unwanted positions in
#              each column with NA.  The number of rows is equal to the maximum
#              of number of evaluation points.
#  FD      ... Functional data object
#  LFD     ... If an integer, defines NDERIV, the order of derivative to be evaluated
#              If a functional data object, defines weight
#              functions for computing the value of a nonhomogeneous linear 
#              differential operator applied to the functions that are evaluated.
#  Note that the first two arguments may be interchanged.

#  Returns:  An array of function values corresponding to the evaluation 
#              arguments in EVALARG

#  Last modified 5 December 2001

#  Exchange the first two arguments if the first is an BASIS.FD object 
#    and the second numeric

if (is.numeric(fd) && inherits(evalarg, "fd")) {
    temp    <- fd
    fd      <- evalarg
    evalarg <- temp
}

#  Check the arguments

evaldim <- dim(evalarg)

if (!(is.numeric(evalarg)))  stop("Argument EVALARG is not numeric.")
	
if (!(length(evaldim) < 3)) stop(
   "Argument EVALARG is not a vector or a matrix.")

if (!(inherits(fd, "fd"))) stop(
     "Argument FD is not a functional data object.")

if (!(is.Lfd(Lfd))) stop(
     "Argument LFD is not a linear differential operator.")

#  Extract information about the basis

basisfd  <- getbasis(fd)
nbasis   <- basisfd$nbasis
rangeval <- basisfd$rangeval
onerow   <- rep(1,nbasis)

temp <- c(evalarg)
temp <- temp[!(is.na(temp))]
if (min(temp) < rangeval[1] || max(temp) > rangeval[2]) 
	warning(paste(
    "Values in argument EVALARG are outside of permitted range,",
    "and will be ignored."))

#  get maximum number of evaluation values

if (is.vector(evalarg)) {
	n <- length(evalarg)
} else {
	n <- evaldim[1]
}

#  Set up coefficient array for FD

coef  <- getcoef(fd)
coefd <- dim(coef)
ndim  <- length(coefd)
if (ndim <= 1) nrep <- 1 else nrep <- coefd[2]
if (ndim <= 2) nvar <- 1 else nvar <- coefd[3]

#  Set up array for function values

if (ndim <= 2) evalarray <- matrix(0,n,nrep)
	else        evalarray <- array(0,c(n,nrep,nvar))
if (ndim == 2) dimnames(evalarray) <- list(NULL,dimnames(coef)[[2]])
if (ndim == 3) dimnames(evalarray) <- list(NULL,dimnames(coef)[[2]],
	                                             dimnames(coef)[[3]])

#  Case where EVALARG is a vector of values to be used for all curves

if (is.vector(evalarg)) {

    evalarg[evalarg < rangeval[1]-1e-10] <- NA
    evalarg[evalarg > rangeval[2]+1e-10] <- NA
    basismat <- getbasismatrix(evalarg, basisfd, Lfd)

    #  evaluate the functions at arguments in EVALARG

   	if (inherits(Lfd, "fd")) {
		Lfdmat <- eval.fd(evalarg, Lfd)
		if (length(dim(Lfdmat))==3) Lfdmat <- Lfdmat[,,1]
		force <- outer(Lfdmat[,1],rep(1,nrep))
	} else {
		force <- outer(rep(0,length(evalarg)),rep(1,nrep))
	}
    if (ndim <= 2) {
	    evalarray <- force + basismat %*% coef
    } else {
       evalarray <- array(0,c(n,nrep,nvar))
       for (ivar in 1:nvar) evalarray[,,ivar] <- force + basismat %*% coef[,,ivar]
    }

} else {
	
	#  case of evaluation values varying from curve to curve
	
	for (i in 1:nrep) {
		evalargi <- evalarg[,i]
       if (all(is.na(evalargi))) stop(
            paste("All values are NA for replication",i))

		index    <- !(is.na(evalargi) | evalargi < rangeval[1] | evalargi > rangeval[2])
		evalargi <- evalargi[index]
       basismat <- getbasismatrix(evalargi, basisfd, Lfd)

   	  	if (inherits(Lfd, "fd")) {
			Lfdmat <- eval.fd(evalargi, Lfd)
			if (length(dim(Lfdmat))==3) Lfdmat <- Lfdmat[,,1]
			force <- outer(Lfdmat[,1],rep(1,nrep))
		} else {
		   	force <- outer(rep(0,length(evalargi)),rep(1,nrep))
		}
       #  evaluate the functions at arguments in EVALARG

       if (ndim == 2) {
           evalarray[  index, i] <- force + basismat %*% coef[,i]
           evalarray[!(index),i] <- NA
       }
       if (ndim == 3) {
           for (ivar in 1:nvar) {
	           evalarray[   index,i,ivar] <- force + basismat %*% coef[,i,ivar]
               evalarray[!(index),i,ivar] <- NA
           }
       }
	}
	
}

return(evalarray)

}

fourier <- function(x, nbasis = n, period = span, nderiv = 0)
{
  #  Computes the NDERIV derivative of the Fourier series basis
  #    for NBASIS functions with period PERIOD, these being evaluated
  #    at values in vector X
  #  Returns an N by NBASIS matrix of function values
  #  Note:  The number of basis functions always odd.  If the argument
  #   NBASIS is even, it is increased by one.

  #  last modified 8 June 99

  x      <- as.vector(x)
  n      <- length(x)
  onen   <- rep(1,n)
  xrange <- range(x)
  span   <- xrange[2] - xrange[1]
  if (nbasis <= 0) stop('NBASIS not positive')
  if (period <= 0) stop('PERIOD not positive')
  if (nderiv <  0) stop('NDERIV negative')

  if (2*(nbasis %/% 2) == nbasis) nbasis <- nbasis + 1
  basis  <- matrix(0,n,nbasis)
  omega  <- 2*pi/period
  omegax <- omega*x

  if (nderiv == 0) {
    #  The fourier series itself is required.
    basis[,1] <- 0.7071068
    j    <- seq(2,nbasis-1,2)
    k    <- j/2
    args <- outer(omegax,k)
    basis[,j]   <- sin(args)
    basis[,j+1] <- cos(args)
  } else {
    #  A derivative of the fourier series is required.
    basis[,1] <- 0.0
    if (nderiv == floor(nderiv/2)*2) {
      mval  <- nderiv/2
      ncase <- 1
    } else {
      mval <- (nderiv-1)/2
      ncase <- 2
    }
    j    <- seq(2,nbasis-1,2)
    k    <- j/2
    fac  <- outer(onen,((-1)^mval)*(k*omega)^nderiv)
    args <- outer(omegax,k)
    if (ncase == 1) {
      basis[,j]   <-  fac * sin(args)
      basis[,j+1] <-  fac * cos(args)
    } else {
      basis[,j]   <-  fac * cos(args)
      basis[,j+1] <- -fac * sin(args)
    }
  }
  basis <- basis/sqrt(period/2)
  return(basis)
}
fourierpen <- function(basisobj, Lfdobj=2)
{

  #  Computes the Fourier penalty matrix.
  #  Arguments:
  #  BASISOBJ ... a basis object of type "fourier"
  #  LFDOBJ   ... either the order of derivative or a
  #                linear differential operator to be penalized.
  #  Returns  the penalty matrix.

  #  Note:  The number of basis functions is always odd.  If BASISOBJ
  #  specifies an even number of basis functions, then the number of basis
  #  functions is increased by 1, and this function returns a matrix of
  #  order one larger.

  #  Last modified 21 January 2003

  if (!(inherits(basisobj, "basis.fd"))) stop(
    "First argument is not a basis.fd object.")

  nbasis <- basisobj$nbasis
  if (2*(nbasis %/% 2) == nbasis) basisobj$nbasis <- nbasis + 1

  type <- getbasistype(basisobj)
  if (type != "fourier") stop ("Wrong basis type")

  if (is.numeric(Lfdobj)) {
    if (length(Lfdobj) == 1) {
      nderiv <- Lfdobj
      if (nderiv != as.integer(nderiv)) {
        stop("Order of derivative must be an integer")
      }
      if (nderiv < 0) {
        stop("Order of derivative must be 0 or positive")
      }
    } else {
      stop("Order of derivative must be a single number")
    }
    if (nderiv < 0) stop ("Order of derivative cannot be negative")
  } else if (inherits(Lfdobj, "fd")) {
    derivcoef <- getcoef(Lfdobj)
    nderiv    <- ncol(derivcoef)
    Lfdbasis  <- getbasis(Lfdobj)
  } else {
    stop("Second argument must be an integer or a functional data object")
  }

  if (nderiv < 0) stop("NDERIV is negative")

  width  <- basisobj$rangeval[2] - basisobj$rangeval[1]
  period <- basisobj$params[1]

  if (period == width &&
      (is.numeric(Lfdobj) || getbasistype(Lfdbasis) == "const")) {

    #  Compute penalty matrix for penalizing integral over one period.

    pendiag <- pendiagfn(basisobj, nderiv)

    if (!is.numeric(Lfdobj)) {
      for (i in 1:nderiv) {
        if (derivcoef[1,i] != 0)
          pendiag <- pendiag + derivcoef[1,i]*pendiagfn(basisobj,i-1)
      }
    }

    penaltymatrix <- diag(pendiag)

  } else {

    #  Compute penalty matrix by numerical integration

    penaltymatrix <- inprod(basisobj, basisobj, Lfdobj, Lfdobj)

  }

  return( penaltymatrix )
}

#  ------------------------------------------------------------------

pendiagfn <- function(basisfd, nderiv) {

    nbasis  <- basisfd$nbasis
    period  <- basisfd$params[1]
    rangev  <- basisfd$rangeval
    omega   <- 2*pi/period
    halfper <- period/2
    twonde  <- 2*nderiv
    pendiag <- rep(0,nbasis)
    if (nderiv == 0) pendiag[1] <- period/2.0 else pendiag[1] <- 0
    j   <- seq(2,nbasis-1,2)
    fac <- halfper*(j*omega/2)^twonde
    pendiag[j]   <- fac
    pendiag[j+1] <- fac
    pendiag <- 2*pendiag/period
    return(pendiag)
}
geigen <- function(Amat, Bmat, Cmat)
{
  #  solve the generalized eigenanalysis problem
  #
  #    max {tr L'AM / sqrt[tr L'BL tr M'CM] w.r.t. L and M
  #
  #  Arguments:
  #  AMAT ... p by q matrix
  #  BMAT ... order p symmetric positive definite matrix
  #  CMAT ... order q symmetric positive definite matrix
  #  Returns:
  #  VALUES ... vector of length s = min(p,q) of eigenvalues
  #  LMAT   ... p by s matrix L
  #  MMAT   ... q by s matrix M

  #  last modified 18 May 2001

  Bdim <- dim(Bmat)
  Cdim <- dim(Cmat)
  if (Bdim[1] != Bdim[2]) stop('BMAT is not square')
  if (Cdim[1] != Cdim[2]) stop('CMAT is not square')
  p <- Bdim[1]
  q <- Cdim[1]
  s <- min(c(p,q))
  if (max(abs(Bmat - t(Bmat)))/max(abs(Bmat)) > 1e-10) stop(
    'BMAT not symmetric.')
  if (max(abs(Cmat - t(Cmat)))/max(abs(Cmat)) > 1e-10) stop(
    'CMAT not symmetric.')
  Bmat  <- (Bmat + t(Bmat))/2
  Cmat  <- (Cmat + t(Cmat))/2
  Bfac  <- chol(Bmat)
  Cfac  <- chol(Cmat)
  Bfacinv <- solve(Bfac)
  Cfacinv <- solve(Cfac)
  Dmat <- t(Bfacinv) %*% Amat %*% Cfacinv
  if (p >= q) {
    result <- svd(Dmat)
    values <- result$d
    Lmat <- Bfacinv %*% result$u
    Mmat <- Cfacinv %*% result$v
  } else {
    result <- svd(t(Dmat))
    values <- result$d
    Lmat <- Bfacinv %*% result$v
    Mmat <- Cfacinv %*% result$u
  }
  geigenlist <- list (values, Lmat, Mmat)
  names(geigenlist) <- c('values', 'Lmat', 'Mmat')
  return(geigenlist)
}
getbasis <- function(fd) {
  #  Extracts the basis.fd object from a functional data object FD, or,
  #    if FD is already a basis object, just returns it.

  #  Last modified 4 July 2001
  
  if (inherits(fd, "fd")) {
    basisfd <- fd[[2]]
  }  else {
    if (inherits(fd, "basis.fd")) {
      basisfd <- fd
    } else {
      stop("An object of class fd or basis.fd expected, but not found.")
    }
  }
  return(basisfd)
}
getbasismatrix <- function(evalarg, basisfd, Lfd=0) {
#  Computes the basis matrix evaluated at arguments in EVALARG associated
#    with basis.fd object BASISFD.  The basis matrix contains the values   
#    at argument value vector EVALARG of applying the nonhomogeneous 
#    linear differential operator LFD to the basis functions.  By default
#    LFD is 0, and the basis functions are simply evaluated at argument
#    values in EVALARG.
#
#  If LFD is a functional data object with m + 1 functions c_1, ... c_{m+1}, then it
#    is assumed to define the order m NONHOMOGENEOUS linear differential operator
#  Lx(t) = c_1(t) + c_2(t)x(t) + c_3(t)Dx(t) + ... + c_{m+1}D^{m-1}x(t) + D^m x(t).
#  This is a change from previous usage where LFD was assumed to define a HOMOGONEOUS
#  differential operator, for which the forcing function c_1(t) = 0.  
#
#  If the basis type is either polygonal or constant, LFD is ignored.
#
#  Arguments:
#  EVALARG ... Either a vector of values at which all functions are to evaluated,
#              or a matrix of values, with number of columns corresponding to
#              number of functions in argument FD.  If the number of evaluation
#              values varies from curve to curve, pad out unwanted positions in
#              each column with NA.  The number of rows is equal to the maximum
#              of number of evaluation points.
#  BASISFD ... A basis object
#  LFD     ... If an integer, defines NDERIV, the order of derivative to be evaluated
#              If a functional data object, defines weight
#              functions for computing the value of a nonhomogeneous linear 
#              differential operator applied to the functions that are evaluated.
#
#  Note that the first two arguments may be interchanged.
#
#  Last modified 13 December 2002
 
#  Exchange the first two arguments if the first is an BASIS.FD object 
#    and the second numeric

if (is.numeric(basisfd) && inherits(evalarg, "basis.fd")) {
    temp    <- basisfd
    basisfd <- evalarg
    evalarg <- temp
}

if (!(inherits(basisfd, "basis.fd"))) stop(
    "Second argument is not a basis object.")

type   <- getbasistype(basisfd)
nbasis <- basisfd$nbasis

#  determine the highest order of derivative NDERIV required

if (is.numeric(Lfd)) {
   	if (length(Lfd) == 1) {
      	nderiv <- Lfd
      	if (nderiv != as.integer(nderiv)) {
        	stop("Order of derivative must be an integer")
      	}
      	if (nderiv < 0) {
        	stop("Order of derivative must be 0 or positive")
      	}
   	} else {
      	stop("Order of derivative must be a single number")
   	}
   	Lfd <- NULL
   	if (nderiv < 0) stop ("Order of derivative cannot be negative")
} else if (inherits(Lfd, "fd")) {
   	derivcoef <- getcoef(Lfd)
   	if (length(dim(derivcoef))==3) derivcoef <- derivcoef[,,1]
   	nderiv <- dim(derivcoef)[2] - 1
   	if (nderiv < 0) {
   		stop("Order of derivative must be 0 or positive")
   	}
} else {
   	stop("Argument LFD must be an integer or a functional data object")
}

onerow <- rep(1,nbasis)

#  -------------------------------  Fourier basis  -------------------

if        (type == "fourier") {
   	period <- basisfd$params[1]
   	basis  <- fourier(evalarg, nbasis, period, nderiv)
   	if (nderiv > 0 && !is.null(Lfd)) {
        Lfdmat <- eval.fd(evalarg, Lfd)
        if (length(dim(Lfdmat)) == 3) Lfdmat <- Lfdmat[,,1]
        for (j in 1:nderiv) {
            if (any(abs(Lfdmat[,j+1])) > 1e-7) basis <- 
                basis + outer(Lfdmat[,j+1],onerow)*
                         fourier(evalarg, nbasis, period, j-1)
        }
    }

#  -----------------------------  B-spline basis  -------------------

} else if (type == "bspline") {
   	rangex <- basisfd$rangeval
   	breaks <- c(rangex[1], basisfd$params, rangex[2])
   	norder <- basisfd$nbasis - length(breaks) + 2
   	basis  <- bsplineS(evalarg, breaks, norder, nderiv)
   	if (nderiv > 0 && !is.null(Lfd)) {
        Lfdmat <- eval.fd(evalarg, Lfd)
        if (length(dim(Lfdmat)) == 3) Lfdmat <- Lfdmat[,,1]
        for (j in 1:nderiv) {
            if (any(abs(Lfdmat[,j+1])) > 1e-7) basis <- 
                basis + outer(Lfdmat[,j+1],onerow)*
                         bsplineS(evalarg, breaks, norder, j-1)
        }
    }

#  -----------------------------  Polynomial basis  -------------------

} else if (type == "poly") {
   	norder <- basisfd$nbasis
   	ctr    <- basisfd$params[1]
   	basis  <- polynom(evalarg, norder, nderiv, ctr)
   	if (nderiv > 0 && !is.null(Lfd)) {
        Lfdmat <- eval.fd(evalarg, Lfd)
        if (length(dim(Lfdmat)) == 3) Lfdmat <- Lfdmat[,,1]
        for (j in 1:nderiv) {
            if (any(abs(Lfdmat[,j+1])) > 1e-7) basis <- 
                basis + outer(Lfdmat[,j+1],onerow)*
                         polynom(evalarg, norder, j-1, ctr)
        }
    }

#  -----------------------------  Exponential basis  -------------------

} else if (type == "expon") {
   	basis  <- expon(evalarg, basisfd$params, nderiv)
   	if (nderiv > 0 && !is.null(Lfd)) {
        Lfdmat <- eval.fd(evalarg, Lfd)
        if (length(dim(Lfdmat)) == 3) Lfdmat <- Lfdmat[,,1]
        for (j in 1:nderiv) {
            if (any(abs(Lfdmat[,j+1])) > 1e-7) basis <- 
                basis + outer(Lfdmat[,j+1],onerow)*
                         expon(evalarg, basisfd$params, j-1)
        }
    }

#  -----------------------------  Polygonal basis  -------------------

} else if (type == "polyg") {
    basis  <- polyg(evalarg, basisfd$params)

#  -----------------------------  Power basis  -------------------

} else if (type == "power") {
    basis  <- powerbasis(evalarg, basisfd$params, nderiv)
   	if (nderiv > 0 && !is.null(Lfd)) {
        Lfdmat <- eval.fd(evalarg, Lfd)
        if (length(dim(Lfdmat)) == 3) Lfdmat <- Lfdmat[,,1]
        for (j in 1:nderiv) {
            if (any(abs(Lfdmat[,j+1])) > 1e-7) basis <- 
                basis + outer(Lfdmat[,j+1],onerow)*
                         powerbasis(evalarg, basisfd$params, j-1)
        }
    }

#  -----------------------------  Constant basis  --------------------

} else if (type == "const") {
   	basis  <- rep(1,length(evalarg))

} else {
   	stop("Basis type not recognizable")
}

if(length(evalarg) == 1) basis <- matrix(basis,1,nbasis)
return(basis)

}
getbasispenalty <- function(basisfd, Lfd=NULL)
{
#  Computes the penalty matrix  associated with basis.fd object BASISFD.
#    This is defined in terms of a linear differential operator Lfd
#    The default for Lfd depends on the nature of the basis.

#  Last modified 13 December 2002

if (!(inherits(basisfd, "basis.fd"))) stop(
    "First argument is not a basis object.")

type   <- getbasistype(basisfd)
nbasis <- basisfd$nbasis

if        (type == "fourier") {
    if (is.null(Lfd)) Lfd <- 2
    penalty <- fourierpen(basisfd, Lfd)
} else if (type == "bspline") {
    norder <- basisfd$nbasis - length( basisfd$params )
    if (is.null(Lfd)) Lfd <- as.integer(norder/2)
    penalty <- bsplinepen(basisfd, Lfd)
} else if (type == "poly")    {
    if (is.null(Lfd)) Lfd <- 2
    penalty <- polynompen(basisfd, Lfd)
} else if (type == "expon")   {
    if (is.null(Lfd)) Lfd <- 2
    penalty <- exponpen(basisfd, Lfd)
} else if (type == "polyg")   {
    if (is.null(Lfd)) Lfd <- 1
    penalty <- polygpen(basisfd, Lfd)
} else if (type == "power")   {
    if (is.null(Lfd)) Lfd <- 2
    penalty <- powerpen(basisfd, Lfd)
} else if (type == "const")   {
    if (is.null(Lfd)) Lfd <- 0
    if (Lfd == 0) {
      penalty <- basisfd$rangeval[2] - basisfd$rangeval[1]
    } else {
      penalty <- 0
    }
} else {
    stop("Basis type not recognizable")
}

return(penalty)
}
getbasistype <- function(basisfd) {
  #  Extracts the type of basis, permitting variants in spelling

  #  Last modified 6 Feb 2001
  
  if (!(inherits(basisfd, "basis.fd"))) stop(
    "First argument is not a basis object.")

  type <- basisfd$type

  if        (type == "Fourier" ||
             type == "fourier" ||
             type == "Fou"     ||
             type == "fou") {
                return("fourier")
  } else if (type == "bspline" ||
             type == "Bspline" ||
             type == "Bsp"     ||
             type == "bsp") {
                return("bspline")
  } else if (type == "poly"    ||
             type == "pol"     ||
             type == "polynomial") {
                return("poly")
  } else if (type == "exp"     ||
             type == "expon"   ||
             type == "exponential") {
                return("expon")
  } else if (type == "polygonal" ||
             type == "polyg"     ||
             type == "polygon") {
                return("polyg")
  } else if (type == "power"   ||
             type == "pow") {
                return("power")
  } else if (type == "const"   ||
             type == "con"     ||
             type == "constant") {
                return("const")
  } else {
                return("unknown")
  }
}
getcoef <- function(fd) {
  	#  Extracts the coefficient array from a functional data object FD, or,
  	#    if FD is a basis object, assigns the identity matrix as the coefficient
  	#    array

  	#  Last modified 10 Feb 2003
  
  	if (inherits(fd, "fd")) {
    	coef <- as.array(fd$coefs)
    	if (length(dim(coef)) == 1) coef <- matrix(coef, length(coef), 1)
  	}  else {
    	if (inherits(fd, "basis.fd")) {
      		coef <- diag(rep(1,fd$nbasis))
    	} else {
      		stop("An object of class fd or basis.fd expected, but not found.")
    	}
  	}
  	return(coef)
}
getnames <- function(fd) {
  #  Extracts the fdnames from a functional data object FD

  #  Last modified 6 Feb 2001

  if (inherits(fd, "fd")) {
    fdnames <- fd[[3]]
  } else {
    stop("An object of class fd or basis.fd expected, but not found.")
  }
  return(fdnames)
}
inprod <- function(fd1, fd2, Lfd1=0, Lfd2=0, JMAX=15, EPS=1e-4) {

#  computes matrix of inner products of functions by numerical integration
#    using Romberg integration

#  Arguments:
#  FD1 and FD2  ...  these may be either functional data or basis function
#                    objects.  In the latter case, a functional data object
#                    is created from a basis function object by using the
#                    identity matrix as the coefficient matrix.
#                    Both functional data objects must be univariate.
#                    If inner products for multivariate objects are needed,
#                    use a loop and call inprod(fd1[i],fd2[i]).
#  LFD1 and LFD2 ... order of derivatives for inner product for
#                    FD1 and FD2, respectively, or functional data objects
#                    defining linear differential operators
#  JMAX ...  maximum number of allowable iterations
#  EPS  ...  convergence criterion for relative error

#  Return:
#  A matrix of NREP1 by NREP2 of inner products for each possible pair
#  of functions.

#  Last modified 6 Mar 2001

  #  check arguments, and convert basis objects to functional data objects
  fdclass <- TRUE
  if (inherits(fd1, "fd") || inherits(fd1, "basis.fd")) {
    if (inherits(fd1, "basis.fd")) {
      coef1 <- diag(rep(1,fd1$nbasis))
      fd1   <- create.fd(coef1, fd1)
    } else coef1 <- getcoef(fd1)
  } else fdclass <- FALSE
  if (inherits(fd2, "fd") || inherits(fd2, "basis.fd")) {
    if (inherits(fd2, "basis.fd")) {
      coef2 <- diag(rep(1,fd2$nbasis))
      fd2 <- create.fd(coef2, fd2)
    } else coef2 <- getcoef(fd2)
  } else fdclass <- FALSE
  if (!fdclass) stop (
     paste("One or both of the first two arguments are neither",
           "functional data objects nor basis objects."))

  #  determine NREP1 and NREP2, and check for common range
  coefd1 <- dim(coef1)
  coefd2 <- dim(coef2)
  ndim1  <- length(coefd1)
  ndim2  <- length(coefd2)
  if (ndim1 > 2 || ndim2 > 2) stop(
    "Functional data objects must be univariate")
  if (ndim1 > 1) nrep1 <- coefd1[2] else nrep1 <- 1
  if (ndim2 > 1) nrep2 <- coefd2[2] else nrep2 <- 1
  range1 <- fd1$basis$rangeval
  range2 <- fd2$basis$rangeval
  if ( any(range1-range2) != 0) stop("Ranges are not equal")

  #  check for either coefficient array being zero
  if (all(c(coef1) == 0) || all(c(coef2) == 0)) return(matrix(0,nrep1,nrep2))

  #  set up first iteration
  width <- range1[2] - range1[1]
  JMAXP <- JMAX + 1
  h <- rep(1,JMAXP)
  h[2] <- 0.25
  s <- array(0,c(JMAXP,nrep1,nrep2))
  #  the first iteration uses just the endpoints
  fx1 <- eval.fd(range1, fd1, Lfd1)
  fx2 <- eval.fd(range1, fd2, Lfd2)
  s[1,,]  <- width*crossprod(fx1,fx2)/2
  tnm <- 0.5
  j <- 1

  #  now iterate to convergence
  for (j in 2:JMAX) {
    tnm <- tnm*2
    if (j == 2) {
     x <- mean(range1)
    } else {
      del <- width/tnm
      x   <- seq(range1[1]+del/2, range1[2]-del/2, del)
    }
    fx1 <- eval.fd(x, fd1, Lfd1)
    fx2 <- eval.fd(x, fd2, Lfd2)
    s[j,,] <- (s[j-1,,] + width*crossprod(fx1,fx2)/tnm)/2
    if (j >= 5) {
      ind <- (j-4):j
      result <- polintmat(h[ind],s[ind,,],0)
      ss  <- result[[1]]
      dss <- result[[2]]
      if (all(abs(dss) < EPS*max(abs(ss)))) return(ss)
    }
    s[j+1,,] <- s[j,,]
    h[j+1]   <- 0.25*h[j]
  }
  warning(paste("No convergence after",JMAX," steps in INPROD"))
}
inprod.n <- function(fd1, fd2, Lfd1=0, Lfd2=0, penrng=rangeval, wtfd=NULL,
                     JMAX=12, EPS=1e-5) {

#  computes matrix of inner products of functions by numerical integration
#    using Romberg integration

#  Arguments:
#  FD1 and FD2  ...  these may be either functional data or basis function
#                    objects.  In the latter case, a functional data object
#                    is created from a basis function object by using the
#                    identity matrix as the coefficient matrix.
#                    Both functional data objects must be univariate.
#                    If inner products for multivariate objects are needed,
#                    use a loop and call inprod(fd1[i],fd2[i]).
#  LFD1 and LFD2  ...  order of derivatives for inner product for
#                    FD1 and FD2, respectively, or functional data objects
#                    defining linear differential operators
#  PENRNG ...  vector of length 2 giving the interval over which the
#               integration is to take place
#  WTFD   ...  functional data object defining a weight function
#  JMAX ...  maximum number of allowable iterations
#  EPS  ...  convergence criterion for relative error

#  Return:
#  A matrix of NREP1 by NREP2 of inner products for each possible pair
#  of functions.


#  Last modified 6 Feb 2001

  #  check arguments, and convert basis objects to functional data objects
  fdclass <- TRUE
  if (inherits(fd1, "fd") || inherits(fd1, "basis.fd")) {
    if (inherits(fd1, "basis.fd")) {
      coef1 <- diag(rep(1,fd1$nbasis))
      fd1 <- create.fd(coef1, fd1)
    } else coef1 <- getcoef(fd1)
  } else fdclass <- FALSE
  if (inherits(fd2, "fd") || inherits(fd2, "basis.fd")) {
    if (inherits(fd2, "basis.fd")) {
      coef2 <- diag(rep(1,fd2$nbasis))
      fd2 <- create.fd(coef2, fd2)
    } else coef2 <- getcoef(fd2)
  } else fdclass <- FALSE
  if (!fdclass) stop ("The two first arguments must be functional data objects")

  if (!is.null(wtfd)) {
    wtcoef <- getcoef(wtfd)
    if (dim(wtcoef)[[2]] != 1) stop("More than one weight function found")
  }

  #  determine NREP1 and NREP2, and check for common range
  coefd1 <- dim(coef1)
  coefd2 <- dim(coef2)
  ndim1  <- length(coefd1)
  ndim2  <- length(coefd2)
  if (ndim1 > 2 || ndim2 > 2) stop(
    "Functional data objects must be univariate")
  if (ndim1 > 1) nrep1 <- coefd1[2] else nrep1 <- 1
  if (ndim2 > 1) nrep2 <- coefd2[2] else nrep2 <- 1

  rangeval <- fd1$basis$rangeval
  #  set up first iteration
  width <- penrng[2] - penrng[1]
  JMAXP <- JMAX + 1
  h <- rep(1,JMAXP)
  h[2] <- 0.25
  s <- array(0,c(JMAXP,nrep1,nrep2))
  #  the first iteration uses just the endpoints
  fx1 <- eval.fd(penrng, fd1, Lfd1)
  fx2 <- eval.fd(penrng, fd2, Lfd2)
  if (is.null(wtfd)) {
    s[1,,]  <- width*crossprod(fx1,fx2)/2
  } else {
    wt <- c(eval.fd(penrng, wtfd))
    s[1,,]  <- width*crossprod(fx1,wt*fx2)/2
  }
  tnm <- 0.5
  j <- 1
  #print(j)
  #print(round(s[j,,],2))
  cat('\nNumerical integration iterations:  .')

  #  now iterate to convergence
  for (j in 2:JMAX) {
    tnm <- tnm*2
    del <- width/tnm
    x   <- seq(penrng[1]+del/2, penrng[2]-del/2, del)
    fx1 <- eval.fd(x, fd1, Lfd1)
    fx2 <- eval.fd(x, fd2, Lfd2)
    if (is.null(wtfd)) {
      s[j,,] <- (s[j-1,,] + width*crossprod(fx1,fx2)/tnm)/2
    } else {
      wt <- c(eval.fd(x, wtfd))
      s[j,,] <- (s[j-1,,] + width*crossprod(fx1,wt*fx2)/tnm)/2
    }
    cat('.')
    #print(j)
    #print(round(s[j,,],2))
    if (j >= 5) {
      ind <- (j-4):j
      result <- polintmat(h[ind],s[ind,,],0)
      ss  <- result[[1]]
      #print(round(log10(diag(ss)),2))
      #image(ss)
      #title(paste("J =",j))
      #text(locator(1),"")
      dss <- result[[2]]
      if (all(abs(dss) < EPS*max(abs(ss)))) return(ss)
    }
    s[j+1,,] <- s[j,,]
    h[j+1]   <- 0.25*h[j]
  }
  warning(paste("No convergence after",JMAX," steps in INPROD"))
}
interpreg <- function(x, y, xeval, periodic)
{
  #  This is a wrapper function for the Fortran function interpolate.

  n      <- length(x)
  neval  <- length(xeval)
  ier    <- 0
  yeval  <- rep(0,neval)
  eeval  <- yeval
  ier    <- 0
  if (any(is.na(x))) {
    warning ("X has missing values in INTERPOLATE")
    ier <- 1
  }
  if (any(is.na(y))) {
    warning ("Y has missing values in INTERPOLATE")
    ier <- 1
  }
  if (min(x[2:n]-x[1:(n-1)]) <= 0) {
    warning ("X is not strictly increasing in INTERPOLATE")
    ier <- 1
  }
  if (min(xeval) < x[1] | max(xeval) > x[n]) {
    warning ("XEVAL is out of range in INTERPOLATE")
    IER <- 1
  }
  if (ier != 0) {
    warning("Further processing aborted in INTERPOLATE")
    return(rep(0,neval))
  }

  if (periodic) iper <- 1 else iper <- 0

  result <- .Fortran("interpreg",
         as.integer(n),
         as.double(x),      as.double(y),
         as.integer(neval), as.double(xeval), as.double(yeval),
         as.integer(iper),  as.integer(ier) )

  yeval <- result[[6]]
  ier   <- result[[8]]
  if (ier != 0) warning(paste("IER =",ier," in INTERPOLATE"))

  return (yeval)
}
is.Lfd <- function(Lfd) {
#  check whether LFD is a linear differential operator
  if (inherits(Lfd, 'fd') || (is.numeric(Lfd) && Lfd >= 0))  {
    return(TRUE)
  } else {
    return(FALSE)
  }
}
is.diag <- function (c, EPS=1e-12) {
  #  tests a matrix for being diagonal
  #  C   ... matrix to be tested
  #  EPS ... testing criterion: max off-diagonal element over min diagonal
  #          element must be less than EPS
  if (!is.matrix(c)) return(FALSE)
  cd <- dim(c)
  if (cd[1] != cd[2]) return(FALSE)
  mindg <- min(abs(diag(c)))
  maxodg <- max(abs(c - diag(diag(c))))
  if (maxodg/mindg < EPS) return(TRUE) else return(FALSE)
}
is.fd <- function(fd) {
#  check whether FD is a functional data object

#  Last modified 20 Feb 2003

  if (inherits(fd, "fd")) return(TRUE) else return(FALSE)
}
isotone <- function(y) {
	#  Compute an isotonic regression line from data in Y
	#  This is the piecewise linear line that is monotonic and 
	#  most closely approximates Y in the least squares sense.
  n    <- length(y)
  mony <- y
  eb   <- 0
  indx <- 1:(n-1)
  while (eb < n) {
    negind <- (diff(mony) < 0)
    ib <- min(indx[diff(mony) < 0])
    if (is.na(ib)) {
      bb <- eb <- n
    } else {
      bb <- eb <- ib
    } 
    while (eb < n && mony[bb] == mony[eb+1]) eb <- eb + 1
    poolflg <- -1
    while (poolflg != 0) {
      if (eb >=  n || mony[eb] <= mony[eb+1]) poolflg <- 1
      if (poolflg == -1) {
        br <- er <- eb+1
        while (er < n && mony[er+1] == mony[br]) er <- er + 1
        pmn <- (mony[bb]*(eb-bb+1) + mony[br]*(er-br+1))/(er-bb+1)
        eb <- er
        mony[bb:eb] <- pmn
        poolflg <- 1
      }
      if (poolflg == 1) {
        if (bb <= 1 || mony[bb-1] <= mony[bb]) {
          poolflg <- 0
        } else {
          bl <- el <- bb-1
          while (bl > 1 && mony[bl-1] == mony[el]) bl <- bl - 1
          pmn <- (mony[bb]*(eb-bb+1) + mony[bl]*(el-bl+1))/(eb-bl+1)
          bb <- bl
          mony[bb:eb] <- pmn
          poolflg <- -1
        }
      }
    }
  }
  return(mony)
}
lambda2df <- function (argvals, basisfd, wtvec=rep(1,n), Lfd=NULL, lambda=0)
{
  #  Computes the the degrees of freedom associated with a regularized
  #    basis smooth by calculating the trace of the smoothing matrix.

  #  Arguments for this function:
  #
  #  ARGVALS  ... A set of argument values.
  #  BASISFD  ... A basis.fd object created by function create.basis.fd.
  #  WTVEC    ... A vector of N weights, set to one by default, that can
  #               be used to differentially weight observations in the
  #               smoothing phase
  #  LFD      ... The order of derivative or a linear differential
  #               operator to be penalized in the smoothing phase.
  #               By default Lfd is set in function GETBASISPENALTY
  #  LAMBDA   ... The smoothing parameter determining the weight to be
  #               placed on the size of the derivative in smoothing.  This
  #               is 0 by default.
  #  Returns:
  #  DF    ...  a degrees of freedom measure

  #  Last modified:  17 May 2000

  n        <- length(argvals)
  nbasis   <- basisfd$nbasis
  if (lambda == 0) {
    df <- nbasis
    return( df )
  }
  if (length(wtvec) != n) stop('WTVEC of wrong length')
  if (min(wtvec) <= 0)    stop('All values of WTVEC must be positive.')
  basismat <- getbasismatrix(argvals, basisfd)
  basisw   <- basismat*outer(wtvec,rep(1,nbasis))
  Bmat     <- crossprod(basisw,basismat)
  penmat   <- getbasispenalty(basisfd, Lfd)
  Bnorm    <- sqrt(sum(c(Bmat)^2))
  pennorm  <- sqrt(sum(c(penmat)^2))
  condno   <- pennorm/Bnorm
  if (lambda*condno > 1e12) {
    lambda <- 1e12/condno
    warning(paste("lambda reduced to",lambda,"to prevent overflow"))
  }
  Cmat     <- Bmat + lambda*penmat
  Cmat     <- (Cmat + t(Cmat))/2
  if (is.diag(Cmat)) {
      Cmatinv <- diag(1/diag(Cmat))
  } else {
      Lmat    <- chol(Cmat)
      Lmatinv <- solve(Lmat)
      Cmatinv <- crossprod(t(Lmatinv))
  }
  hatmat <- Cmatinv %*% Bmat
  df <- sum(diag(hatmat))
  return( df )
}
landmarkreg <- function(fd, fd0, ximarks, x0marks=xmeanmarks, wbasis = basis,
                        Lfd=0, sparval=1e-10, monwrd=FALSE)
{
#  Arguments:
#  FD      ... functional data object for curves to be registered
#  FD0     ... functional data object for the target curve
#  XIMARKS ... N by NL array of times of interior landmarks for
#                 each observed curve
#  XOMARKS ... vector of length NL of times of interior landmarks for
#                 target curve
#  WBASIS  ... optional basis object used for estimating warp
#                 functions.  If not supplied the basis for FDOBJ is used.
#  LFD     ... integer or functional data object defining derivative
#                 or LDO value to be registered.
#  SPARVAL ... smoothing parameter used by smooth.spline
#  MONWRD  ... If T, warping functions are estimated by monotone smoothing,
#                 otherwise by regular smoothing.  The latter is faster, but
#                 not guaranteed to produce a strictly monotone warping
#                 function.  If MONWRD is 0 and an error message results
#                 indicating nonmonotonicity, rerun with MONWRD = 1.
#                 Default:  T
#  Returns:
#  FDREG   ... a functional data object for the registered curves
#  WARPFD  ... a functional data object for the warping functions


 #  Last modified 6 Feb 2001

  if (!(inherits(fd,  "fd"))) stop("Argument FD  not a functional data object.")
  if (!(inherits(fd0, "fd"))) stop("Argument FD0 not a functional data object.")

  coef  <- getcoef(fd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  nrep  <- coefd[2]

  basis    <- getbasis(fd)
  type     <- basis$type
  nbasis   <- basis$nbasis
  rangeval <- basis$rangeval

  ximarksd <- dim(ximarks)
  if (ximarksd[1] != nrep) stop(
     "Number of rows of third argument wrong.")
  nlandm <- dim(ximarks)[2]
  xmeanmarks <- apply(ximarks,2,mean)
  if (length(x0marks) != nlandm) stop(
     "Number of target landmarks not equal to number of curve landmarks.")

  if (any(ximarks <= rangeval[1]) || any(ximarks >= rangeval[2])) stop(
     "Some landmark values are not within the range.")

  n   <- min(c(101,10*nbasis))
  x   <- seq(rangeval[1],rangeval[2],length=n)
  wtn <- rep(1,n)

  y0  <- eval.fd(x, fd0, Lfd)
  y   <- eval.fd(x, fd,  Lfd)
  yregmat <- y
  hfunmat <- matrix(0,n,nrep)

  xval <- c(rangeval[1],x0marks,rangeval[2])
  nval <- length(xval)
  wval <- rep(1,nval)

  cat("Progress:  Each dot is a curve\n")
  for (irep in 1:nrep) {
    cat(".")
    #  set up landmark times for this curve
    yval   <- c(rangeval[1],ximarks[irep,],rangeval[2])
    #  smooth relation between this curve"s values and target"s values
    if (monwrd) {
       #  use monotone smoother
       result <- warpsmth(xval, yval, wval, Wfd0, wLfd, lambda)
       Wfd    <- result[[1]]
       h      <- monfn(x, Wfd, 1)
       warpfd <- data2fd(h, x, wbasis)
    } else {
       warpfd <- smooth.basis(yval, xval, wbasis, wval, 2, sparval)$fd
       #  set up warping function by evaluating at sampling values
       h <- eval.fd(x, warpfd)
       h <- h*(rangeval[2]-rangeval[1])/(h[n]-h[1])
       h <- h - h[1] + rangeval[1]
       #  check for monotonicity
       deltah <- diff(h)
       if (any(deltah) <= 0) warning(
           paste("Non-increasing warping function estimated for curve",irep))
    }
    hfunmat[,irep] <- h
    #  compute h-inverse
    if (monwrd) {
       wcoef  <- getcoef(Wfd)
       Wfdinv <- fd(-wcoef,wbasis)
       result <- warpsmth(h, x, wtn, Wfdinv, wLfd, lambda)
       Wfdinv <- result[[1]]
       hinv   <- monfn(x, Wfdinv, 1)
    } else {
       hinvfd <- smooth.basis(x, h, wbasis, wtn, 2, sparval)$fd
       hinv   <- eval.fd(x, hinvfd)
       hinv[1] <- x[1]
       hinv[n] <- x[n]
       deltahinv <- diff(hinv)
       if (any(deltahinv) <= 0) warning(
           paste("Non-increasing warping function estimated for curve",irep))
    }

    #  compute registered curves

    if (length(dim(coef)) == 2) {
      #  single variable case
      yregfd <- smooth.basis(y[,irep], hinv, basis, wtn, 2, 1e-10)$fd
      yregmat[,irep] <- eval.fd(x, yregfd)
    }
    if (length(dim(coef)) == 3) {
      #  multiple variable case
      for (ivar in 1:nvar) {
        # evaluate curve as a function of h at sampling points
        yregfd <- smooth.basis(y[,irep,ivar], hinv, basis, wtn, 2,
                      1e-10)$fd
        yregmat[,irep,ivar] <- eval.fd(x, yregfd)
       }
    }
  }

  #  create functional data objects for the registered curves

  yregcoef    <- project.basis(yregmat, x, basis)
  fdregnames  <- getnames(fd)
  names(fdregnames)[3] <- paste("Registered",names(fdregnames)[3])
  regfd       <- create.fd(yregcoef, basis, fdregnames)

  #  create functional data objects for the warping functions

  warpcoef    <- project.basis(hfunmat, x, wbasis)
  warpfdnames <- fdregnames
  names(warpfdnames)[3] <- paste("Warped",names(fdregnames)[1])
  warpfd      <- create.fd(warpcoef, wbasis, warpfdnames)

  return( list("regfd" = regfd, "warpfd" = warpfd, x) )
}
linesFd <- function(fd, Lfd=0,...)
{
  #  Plot a functional data object FD using lines in a pre-existing plot.
  #  If there are multiple variables, each curve will appear in the same plot.
  #  The remaining optional arguments are the same as those available
  #     in the regular "lines" function.

  #  Last modified 6 Feb 2001

  if (!(inherits(fd, "fd"))) stop("First argument is not a functional data object.")
  if (!is.Lfd(Lfd)) stop(
      "Second argument is not a linear differential operator.")

  coef   <- getcoef(fd)
  coefd  <- dim(coef)
  ndim   <- length(coefd)
  nbasis <- coefd[1]
  nrep   <- coefd[2]
  if (ndim > 3) nvar <- coefd[3] else nvar <- 1
  crvnames <- fd$fdnames[[2]]
  varnames <- fd$fdnames[[3]]

  basisfd <- fd[[2]]
  rangex  <- basisfd$rangeval
  x       <- seq(rangex[1],rangex[2],length=101)
  fdmat    <- eval.fd(x,fd,Lfd)

  if (length(dim(coef)) < 2) {
    lines (x,fdmat,...)
  }
  if (length(dim(coef)) ==2 ) {
    matlines (x,fdmat,...)
  }
  if (length(dim(coef)) == 3) {
    for (ivar in 1:nvar) {
      matlines (x,fdmat[,,ivar],type="l",lty=1,main=varnames[ivar],...)
    }
  }
  invisible()
}
linmod.fd <- function(xfd, yfd, wtvec=rep(1,nrep),
                      xLfd=2, yLfd=2, xlambda=0, ylambda=0, zmatrnk=p)
{

  #  This function one of three types of linear model,
  #  each model consisting of a constant term
  #  plus either a conventional independent variable matrix or a single
  #  functional independent variable.  The modeling problem may
  #  be functional either in terms of the independent variable or in
  #  terms of the dependent variable, but at least one variable must
  #  be functional.
  #  Smoothing is controlled by two parameters XLAMBDA and YLAMBDA,
  #  corresponding to the independent and dependent functional
  #  variables, respectively.

  #  Argument:
  #  XFD     ... If the independent variable is multivariate, a design matrix.
  #              If the independent variable is functional, a 'fd' object.
  #  YFD     ... If the dependent variable is multivariate, a design matrix.
  #              If the dependent variable is functional, a 'fd' object.
  #  WTVEC   ... a vector of weights
  #  XLFD    ... For the independent variable, the order derivative to be
  #              penalized if an integer, or
  #              a linear differential operator if a functional data object.
  #  YLFD    ... For the dependent variable, the order derivative to be
  #              penalized if an integer, or
  #              a linear differential operator if a functional data object.
  #  XLAMBDA ... a smoothing parameter for the independent variable
  #  YLAMBDA ... a smoothing parameter for the   dependent variable
  #  ZMATRNK ... actual rank of independent variable matrix for the
  #              functional DV/multivariate IV case

  #  Returns:  a list containing
  #  ALPHA  ... a vector of intercept values
  #  REGFD  ... a functional data object for the regression function

  #  Last modified:   4 July 2001

  #  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  #              The multivariate IV and functional DV case
  #  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  if (inherits(yfd, "fd") && !(inherits(xfd, "fd")))  {
    if (is.matrix(xfd)) {
      zmat <- as.matrix(xfd)
      fd   <- yfd
    }  else {
      stop ("First argument not a vector or a matrix.")
    }

    coef    <- getcoef(fd)
    coefd   <- dim(coef)
    ndim    <- length(coefd)
    if (ndim < 2) stop(
             "Linear modeling impossible with 1 replication")

    nrep <- nrow(zmat)
    if(ndim == 3) nvar <- coefd[3] else nvar <- 1
    basisfd <- getbasis(fd)
    nbasis  <- basisfd$nbasis

    rangewt <- range(wtvec)
    if (rangewt[1] < 0) stop("WTVEC must not contain negative values.")
    if (rangewt[1] == rangewt[2]) wtvar <- FALSE else wtvar <- TRUE

    if (length(wtvec) != nrep) stop("WTVEC of wrong length")
    if (min(wtvec) <= 0)    stop("All values of WTVEC must be positive.")
    if (ylambda < 0) warning (
       "Value of LAMBDA was negative, and 0 used instead.")
    if (ylambda > 0 && yLfd < 0) stop(
       "Order of derivative must be nonnegative.")

    if (dim(coef)[2] != nrep) stop(
       "Number of rows of ZMAT must equal number of replications")
    p    <- ncol(zmat)

    if (nvar > 1)
    {
      bcoef <- array(0,c(nbasis,p,nvar))
    } else {
      bcoef <- matrix(0,nbasis,p)
    }
    if (zmatrnk > p) stop(
       "Specified rank of ZMAT must not be greater than no. columns.")
    if (zmatrnk < p) {
      rootw   <- sqrt(wtvec)
      zmatsvd <- svd(sweep(zmat,2,rootw,"*"))
      zmatd   <- zmatsvd$d
      if (zmatd[zmatrnk] <= 0) stop("ZMAT is not of specified column rank")
      index  <- 1:zmatrnk
      zginvt <- sweep(zmatsvd$u[,index],1,zmatd[index],"/") %*%
                t(zmatsvd$v[,index])
      if (nvar == 1)
      {
        bcoef <- sweep(coef,1,rootw,"*") %*% zginvt
      } else {
        for (j in 1:nvar) {
          bcoef[,,j] <- sweep(coef[,,j],1,rootw,"*") %*% zginvt
        }
      }
    } else {
      if (nvar == 1)
      {
        bcoef <- t(lsfit(zmat,t(coef),wtvec,int=FALSE)$coef)
      } else {
        for (j in 1:nvar)
        {
          bcoef[,,j] <- t(lsfit(zmat,t(coef[,,j]),wtvec,int=FALSE)$coef)
        }
      }
    }
    yhatcoef <- bcoef %*% t(zmat)

    if (nvar > 1)
    {
      dimnames(bcoef) <- list(NULL,dimnames(zmat)[[2]],
                                 dimnames(yfd[[1]])[[3]])
    } else {
      dimnames(bcoef) <- list(NULL,dimnames(zmat)[[2]])
    }

    fdnames <- getnames(fd)

    regfdnames      <- fdnames
    regfdnames[[2]] <- paste('Reg. Coef.',1:p)
    regfdnames[[3]] <- 'Reg. Coef.'
    names(regfdnames)[2] <- 'Reg. Coefficients'
    regfd  <- create.fd (bcoef, basisfd, regfdnames)

    yhatfd <- create.fd (yhatcoef, basisfd, fdnames)

    linmodlist <- list(0, regfd, yhatfd)
    names(linmodlist) <- c('alpha', 'regfd', 'yhatfd')
    return( linmodlist )
  }

  #  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  #             The functional IV and multivariate DV case
  #  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  if (inherits(xfd, "fd") && !(inherits(yfd, "fd"))) {

    if (is.numeric(yfd)) {
      ymat <- as.matrix(yfd)
      fd   <- xfd
    }  else {
      stop (paste("Second argument not a functional data object",
                  " and is not numeric",
                  "when first argument is functional."))
    }

    coef   <- getcoef(fd)
    coefd  <- dim(coef)
    ndim   <- length(coefd)
    if (ndim < 2) stop(
             "Linear modeling impossible with 1 replication")
    if (length(dim(coef)) == 3) stop(
             "This version cannot accommodate multiple functional IVs")
    nrep <- coefd[2]
    nvar <- ncol(ymat)

    rangewt <- range(wtvec)
    if (rangewt[1] < 0) stop("WTVEC must not contain negative values.")
    if (rangewt[1] == rangewt[2]) wtvar <- FALSE else wtvar <- TRUE

    basisfd <- getbasis(fd)
    nbasis  <- basisfd$nbasis
    type    <- getbasistype(basisfd)
    if (nrow(ymat) != nrep) stop(
      "Number of rows of YMAT must equal number of replications")
    one  <- rep(1,nrep)

    if (length(wtvec) != nrep) stop("WTVEC of wrong length")
    if (xlambda < 0) warning (
              "Value of XLAMBDA was negative, and 0 used instead.")

    jmat <- inprod(basisfd, basisfd)
    zmat <- t(rbind(one,jmat %*% coef))

    bcoef <- matrix(0,nbasis,nvar)
    alpha <- rep(0,nvar)
    index <- 2:(nbasis+1)

    if (xlambda <= 0) {
      #  no smoothing required, do ordinary least squares
      if (ncol(zmat) > nrow(zmat)) stop(paste(
         "For XLAMBDA = 0, no. of basis functions exceeds",
         "number of replications. No fit possible.")
)
      if (wtvar)
      {
        temp <- sweep(zmat,2,wtvec,"*")
        Cmat <- crossprod(temp,zmat)
        Dmat <- crossprod(temp,ymat)
      } else {
        Cmat <- crossprod(zmat)
        Dmat <- crossprod(zmat,ymat)
      }
    } else {
      #  smoothing required
      kmat <- matrix(0,nbasis+1,nbasis+1)
      kmat[index,index] <- inprod(basisfd, basisfd, xLfd, xLfd)
      if (wtvar)
      {
        temp <- sweep(zmat,2,wtvec,"*")
        Cmat <- crossprod(temp,zmat) + xlambda*kmat
        Dmat <- crossprod(temp,ymat)
      } else {
        Cmat <- crossprod(zmat) + xlambda*kmat
        Dmat <- crossprod(zmat,ymat)
      }
    }
    temp  <- symsolve( Cmat, Dmat )
    yhat  <- zmat %*% temp
    bcoef <- as.matrix(temp[index,])

    alpha <- temp[1,]

    fdnames <- getnames(xfd)

    regfdnames      <- fdnames
    regfdnames[[2]] <- paste('Reg. Coef.',1:nvar)
    regfdnames[[3]] <- 'Reg. Coef.'
    names(regfdnames)[2] <- 'Reg. Coefficients'
    regfd  <- create.fd (bcoef, basisfd, regfdnames)

    linmodlist <- list(alpha, regfd, yhat)
    names(linmodlist) <- c('alpha', 'regfd', 'yhat')
    return( linmodlist )
  }

  #  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  #             The functional IV and functional DV case
  #  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

   if (inherits(xfd, "fd") && inherits(yfd, "fd")) {

    coefx   <- getcoef(xfd)
    coefy   <- getcoef(yfd)
    coefdx  <- dim(coefx)
    coefdy  <- dim(coefy)
    ndimx   <- length(coefdx)
    ndimy   <- length(coefdy)
    if (ndimx < 2) stop(
             "Linear modeling impossible with 1 replication")
    if (ndimx == 3) stop(
             "This version cannot accommodate multiple functional IVs")
    nrep <- coefdx[2]
    if (coefdy[2] != nrep) stop (
      "Numbers of observations in the first two arguments do not match.")

    rangewt <- range(wtvec)
    if (rangewt[1] < 0) stop("WTVEC must not contain negative values.")
    if (rangewt[1] == rangewt[2]) wtvar <- FALSE else wtvar <- TRUE

    basisxfd <- getbasis(xfd)
    nbasisx  <- basisxfd$nbasis
    typex    <- basisxfd$type
    rangevx  <- basisxfd$rangeval

    basisyfd <- getbasis(yfd)
    nbasisy  <- basisyfd$nbasis
    typey    <- basisyfd$type
    rangevy  <- basisyfd$rangeval

    if (length(wtvec) != nrep) stop("WTVEC of wrong length")
    if (min(wtvec) <= 0)    stop("All values of WTVEC must be positive.")
    if (xlambda < 0) warning (
              "Value of LAMBDA was negative, and 0 used instead.")

    jmatx   <- inprod(basisxfd, basisxfd)
    penmatx <- inprod(basisxfd, basisxfd, xLfd, xLfd)
    if (ndimx == 2) {
      zmatx   <- t(rbind(matrix(1,1,nrep),jmatx %*% coefx))
    } else {
      zmatx   <- t(rbind(matrix(1,1,nrep),jmatx %*% coefx[,,1]))
    }

    jmaty   <- inprod(basisyfd, basisyfd)
    penmaty <- inprod(basisyfd, basisyfd, yLfd, yLfd)

    alpha  <- rep(0,nbasisy)
    index  <- 2:(nbasisx+1)
    kmatx <- matrix(0,nbasisx+1,nbasisx+1)
    kmatx[index,index] <- penmatx
    if (wtvar) {
      zmatw <- sweep(zmatx,2,wtmat,"*")
      tempx <- solve(crossprod(zmatw,zmatx) + xlambda*kmatx)
      tempy <- solve(jmaty + ylambda*penmaty)
      gmat  <- tempx %*% crossprod(zmatw,t(coefy[,,1])) %*% jmaty %*% tempy
    } else {
      tempx <- solve(crossprod(zmatx) + xlambda*kmatx)
      tempy <- solve(jmaty + ylambda*penmaty)
      if (ndimy == 2) {
        gmat  <- tempx %*% crossprod(zmatx,t(coefy)) %*% jmaty %*% tempy
      } else {
        gmat  <- tempx %*% crossprod(zmatx,t(coefy[,,1])) %*% jmaty %*% tempy
      }
    }
    yhatcoef <- t(zmatx %*% gmat)
    bcoef <- matrix(0,nbasisx,nbasisy)
    bcoef <- gmat[index,]
    alpha <- as.matrix(gmat[1,])

    fdnames <- getnames(yfd)

    alphafdnames      <- fdnames
    alphafdnames[[2]] <- 'Intercept'
    names(alphafdnames)[2] <- 'Intercept'
    alphafd <- create.fd(alpha, basisyfd, alphafdnames)

    regfd   <- create.bifd(bcoef, basisxfd, basisyfd)
    yhatfd  <- create.fd(yhatcoef,basisyfd, fdnames)

    linmodlist <- list(alphafd, regfd, yhatfd)
    names(linmodlist) <- c('alphafd', 'regfd', 'yhatfd')
    return( linmodlist )
  }

}
make.basis <- function(rangeval, nresol, periodic=FALSE, nderiv=2) {
#MAKE.BASIS sets up a simple basis.
#  If argument PERIODIC is nonzero, the basis is of type 'fourier',
#  else it is of type 'bspline'.
#  Argument RANGEVAL determines the range of argument values.  If
#  the basis type is 'fourier', this also determines the period.
#  The number of basis functions is jointly determined by arguments
#  NRESOL and NDERIV:
#  For a 'fourier' basis, NBASIS = NRESOL.
#  For a 'bspline' basis, NBASIS = NRESOL + NDERIV + 4
#
#  Arguments are as follows:
#
#  RANGEVAL ... A vector of length 2 giving the lower and upper limits
#               on argument values, respectively.
#  NRESOL   ... The resolution required in the functions.  This means
#               the maximum number of features or events that could in
#               principle be represented in each observation.  Features
#               are things like peaks, valleys, zero crossing, or plateaus.
#               The width of a single feature may naturally not be less than
#               the minimum difference between two successive argument values.
#               Roughly speaking, NRESOL is the width of the interval in
#               RANGEVAL divided by the width of the narrowest feature that
#               requires representation.  NRESOL cannot logically exceed
#               the number N of argument values, and for noisy data it should
#               be considerably less.  A reasonable rule of thumb is to
#               NRESOL to 1/3 of the number of sampling points, if these
#               are more or less evenly spaced.
#  PERIODIC ... Is F if the functions are not periodic, and nonzero if T.
#               It is set to F by default.
#  NDERIV   ... The highest order of derivative that is needed for the
#               functional data object.  This is set to 2 by default.
#
#  Another option for a simple basis may be the polygonal basis of type 'polyg'
#    made by function CREATE.POLYGONAL.BASIS.  Only use this option if no
#    derivatives will be required.
#
#  Last modified  1 December 2000

  nresol <- floor(nresol)
  if (nresol < 0) stop("Argument NRESOL must be nonnegative.")
  if (length(rangeval) != 2) stop(
     "Argument RANGEVAL must be of length 2.")
  width <- rangeval[2] - rangeval[1]
  if  (width <= 0) stop(
     "Values in argument RANGEVAL must be strictly increasing.")

  if (periodic) {
     #  periodic basis
     nbasis   <- nresol
     basisobj <- create.fourier.basis(rangeval, nbasis, width)
  } else {
     #  B-spline basis
     nbasis   <- nresol + nderiv + 4
     basisobj <- create.bspline.basis(rangeval, nbasis)
  }
  return(basisobj)
}
meanFd <- function(fd)
{
  #  Compute mean functional data object for functional observations
  #    in argument FD

  #  Last modified 6 Feb 2001

  if (!(inherits(fd, "fd"))) stop("Argument  FD not a functional data object.")

  coef   <- getcoef(fd)
  coefd  <- dim(coef)
  ndim   <- length(coefd)
  basis  <- getbasis(fd)
  nbasis <- basis$nbasis
  if (ndim == 2) {
    coefmean  <- matrix(apply(coef,1,mean),nbasis,1)
    coefnames <- list(dimnames(coef)[[1]],"Mean")
  } else {
    nvar <- coefd[3]
    coefmean  <- array(0,c(coefd[1],1,nvar))
    for (j in 1:nvar) coefmean[,1,j] <- apply(coef[,,j],1,mean)
    coefnames <- list(dimnames(coef)[[1]], "Mean", dimnames(coef)[[3]])
  }
  fdnames <- getnames(fd)
  fdnames[[2]] <- "1"
  names(fdnames)[2] <- "Mean"
  names(fdnames)[3] <- paste("Mean",names(fdnames)[3])
  meanfd <- create.fd(coefmean, basis, fdnames)

  return(meanfd)
}
#  --------------------------------------------------------------

monfn <- function(x, Wfd, basislist=vector("list",JMAX)) {
#  evaluates a monotone function of the form
#            h(x) = [D^{-1} exp Wfd](x)
#  where  D^{-1} means taking the indefinite integral.
#  The interval over which the integration takes places is defined in
#  the basis object in Wfd.
#  Arguments:
#  X      ... argument values at which function and derivatives are evaluated
#  WFD    ... a functional data object
#  BASISLIST ... a list containing values of basis functions
#  Returns:
#  HVAL   ... value of h at input argument array X in first column.

#  Last modified 1 January 2001

  JMAX <- 15
  JMIN <- 11
  EPS  <- 1E-5

  coef  <- getcoef(Wfd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  if (ndim > 1 && coefd[2] != 1) stop("Wfd is not a single function")

  basis  <- getbasis(Wfd)
  rangeval <- basis$rangeval
 
  #  set up first iteration

  width <- rangeval[2] - rangeval[1]
  JMAXP <- JMAX + 1
  h <- rep(1,JMAXP)
  h[2] <- 0.25
  #  matrix SMAT contains the history of discrete approximations to the
  #    integral
  smat <- matrix(0,JMAXP)
  #  array TVAL contains the argument values used in the approximation
  #  array FVAL contains the integral values at these argument values,
  #     rows corresponding to argument values
  #  the first iteration uses just the endpoints
  tval <- rangeval
  j   <- 1
  if (is.null(basislist[[j]])) {
      bmat <- getbasismatrix(tval, basis)
      basislist[[j]] <- bmat
  } else {
      bmat <- basislist[[j]]
  }
  fx   <- exp(bmat %*% coef)
  fval <- fx
  smat[1,]  <- width*apply(fx,2,sum)/2
  tnm <- 0.5

  #  now iterate to convergence
  for (j in 2:JMAX) {
    tnm  <- tnm*2
    del  <- width/tnm
    tj   <- seq(rangeval[1]+del/2, rangeval[2]-del/2, del)
    tval <- c(tval, tj)
    if (is.null(basislist[[j]])) {
        bmat <- getbasismatrix(tj, basis)
        basislist[[j]] <- bmat
    } else {
        bmat <- basislist[[j]]
    }
    fx   <- exp(bmat %*% coef)
    fval <- c(fval,fx)
    smat[j] <- (smat[j-1] + width*apply(fx,2,sum)/tnm)/2
    if (j >= JMIN) {
      ind <- (j-4):j
      result <- polintmat(h[ind],smat[ind],0)
      ss  <- result[[1]]
      dss <- result[[2]]
      if (all(abs(dss) < EPS*max(abs(ss)))) {
        # successful convergence
        # sort argument values and corresponding function values
        ordind <- order(tval)
        tval   <- tval[ordind]
        fval   <- fval[ordind]
        nx     <- length(tval)
        del    <- tval[2] - tval[1]
        fval   <- del*(cumsum(fval) - 0.5*(fval[1] + fval))
        hval   <- approx(tval, fval, x)$y
        return(hval)
      }
    }
    smat[j+1] <- smat[j]
    h[j+1]    <- 0.25*h[j]
  }
  stop(paste("No convergence after",JMAX," steps in MONFN"))
}
monfneval <- function(xeval, breakvals, cvec)
{
  #  XEVAL     ... strictly increasing sequence of argument values at
  #                which monotone fn. is to be evaluated.
  #                range of XEVAL must be within range of BREAKVALS
  #  BREAKVALS ... strictly increasing sequence of break values,
  #                first is lower boundary of interval, last is upper boundary
  #  CVEC      ... vector of coefficients of hat functions

  neval <- length(xeval)

  if (neval > 1 & min(xeval[2:neval]-xeval[1:(neval-1)]) <= 0)
      stop("Arguments must be strictly increasing")

  nbreak <- length(breakvals)
  if (nbreak < 2) stop("At least two break values required.")

  if (xeval[1] < breakvals[1])
       stop("Smallest argument out of range.")
  if (xeval[neval] > breakvals[nbreak])
       stop("Largest argument out of range.")

  #  put XEVAL and BREAKVALS into the unit interval

  span      <- breakvals[nbreak] - breakvals[1]
  breaknorm <- (breakvals - breakvals[1])/span
  xnorm     <- (xeval     - breakvals[1])/span

  feval <- rep(0, neval)
  ier   <- 0

  result <- .Fortran("monfneval", as.integer(neval),  as.double(xnorm),
                              as.integer(nbreak), as.double(breaknorm),
                              as.double(cvec),    as.double(feval),
                              as.integer(ier) )
  feval <- result[[6]]
  ier   <- result[[7]]

  if (ier != 0)
    warning(c("Nonzero value of IER returned from Fortran subroutine", ier))

  return (feval)
}
#  --------------------------------------------------------------------------

mongrad <- function(x, Wfd, basislist=vector("list",JMAX)) {
#  Evaluates the gradient with respect to the coefficients in Wfd
#     of a monotone function of the form
#            h(x) = [D^{-1} exp Wfd](x)
#  where  D^{-1} means taking the indefinite integral.
#  The interval over which the integration takes places is defined in
#  the basisfd object in Wfd.
#  Arguments:
#  X      ... argument values at which function and derivatives are evaluated
#  Wfd    ... a functional data object
#  BASISLIST ... a list containing values of basis functions
#  Returns:
#  GVAL   ... value of gradient at input values in X.

#  Last modified 1 January 2001

  JMAX <- 15
  JMIN <- 11
  EPS  <- 1E-5

  coef  <- getcoef(Wfd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  if (ndim > 1 && coefd[2] != 1) stop("Wfd is not a single function")

  basisfd  <- getbasis(Wfd)
  rangeval <- basisfd$rangeval
  nbasis   <- basisfd$nbasis
  onebas   <- rep(1,nbasis)

  #  set up first iteration

  width <- rangeval[2] - rangeval[1]
  JMAXP <- JMAX + 1
  h <- rep(1,JMAXP)
  h[2] <- 0.25
  #  matrix SMAT contains the history of discrete approximations to the
  #    integral
  smat <- matrix(0,JMAXP,nbasis)
  #  array TVAL contains the argument values used in the approximation
  #  array FVAL contains the integral values at these argument values,
  #     rows corresponding to argument values
  #  the first iteration uses just the endpoints
  j   <- 1
  tval <- rangeval
  if (is.null(basislist[[j]])) {
      bmat <- getbasismatrix(tval, basisfd)
      basislist[[j]] <- bmat
  } else {
      bmat <- basislist[[j]]
  }
  fx   <- exp(bmat %*% coef)
  fval <- outer(c(fx),onebas)*bmat
  smat[1,]  <- width*apply(fval,2,sum)/2
  tnm <- 0.5

  #  now iterate to convergence
  for (j in 2:JMAX) {
    tnm  <- tnm*2
    del  <- width/tnm
    tj   <- seq(rangeval[1]+del/2, rangeval[2]-del/2, del)
    tval <- c(tval, tj)
    if (is.null(basislist[[j]])) {
        bmat <- getbasismatrix(tj, basisfd)
        basislist[[j]] <- bmat
    } else {
        bmat <- basislist[[j]]
    }
    fx   <- exp(bmat %*% coef)
    gval <- outer(c(fx),onebas)*bmat
    fval <- rbind(fval,gval)
    smat[j,] <- (smat[j-1,] + width*apply(fval,2,sum)/tnm)/2
    if (j >= max(c(5,JMIN))) {
      ind <- (j-4):j
      result <- polintmat(h[ind],smat[ind,],0)
      ss  <- result[[1]]
      dss <- result[[2]]
      if (all(abs(dss) < EPS*max(abs(ss))) || j == JMAX) {
        # successful convergence
        # sort argument values and corresponding function values
        ordind <- order(tval)
        tval   <- tval[ordind]
        fval   <- as.matrix(fval[ordind,])
        # set up partial integral values
        lval   <- outer(rep(1,length(tval)),fval[1,])
        del    <- tval[2] - tval[1]
        fval   <- del*(apply(fval,2,cumsum) - 0.5*(lval + fval))
        gval   <- matrix(0,length(x),nbasis)
        for (i in 1:nbasis) gval[,i] <- approx(tval, fval[,i], x)$y
        return(gval)
      }
    }
    smat[j+1,] <- smat[j,]
    h[j+1]     <- 0.25*h[j]
  }
  #stop(paste("No convergence after",JMAX," steps in MONGRAD"))
}
#  --------------------------------------------------------------------------

mongrad1 <- function(x, Wfd, basislist=vector("list",JMAX)) {
#  Evaluates the gradient with respect to the coefficients in Wfd
#     of a monotone function of the form
#            h(x) = [D^{-1} exp Wfd](x)
#  where  D^{-1} means taking the indefinite integral.
#  The interval over which the integration takes places is defined in
#  the basisfd object in Wfd.
#  Arguments:
#  X      ... argument values at which function and derivatives are evaluated
#  Wfd    ... a functional data object
#  BASISLIST ... a list containing values of basis functions
#  Returns:
#  GVAL   ... value of gradient at input values in X.

#  Last modified 1 January 2001

  JMAX <- 15
  JMIN <- 11
  EPS  <- 1E-5

  coef  <- getcoef(Wfd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  if (ndim > 1 && coefd[2] != 1) stop("Wfd is not a single function")

  basisfd  <- getbasis(Wfd)
  rangeval <- basisfd$rangeval
  nbasis   <- basisfd$nbasis
  onebas   <- rep(1,nbasis)

  #  set up first iteration

  width <- rangeval[2] - rangeval[1]
  JMAXP <- JMAX + 1
  h <- rep(1,JMAXP)
  h[2] <- 0.25
  #  matrix SMAT contains the history of discrete approximations to the
  #    integral
  smat <- matrix(0,JMAXP,nbasis)
  #  array TVAL contains the argument values used in the approximation
  #  array FVAL contains the integral values at these argument values,
  #     rows corresponding to argument values
  #  the first iteration uses just the endpoints
  j   <- 1
  tval <- rangeval
  if (is.null(basislist[[j]])) {
      bmat <- getbasismatrix(tval, basisfd)
      basislist[[j]] <- bmat
  } else {
      bmat <- basislist[[j]]
  }
  fx   <- exp(bmat %*% coef)
  fval <- outer(c(fx),onebas)*bmat
  smat[1,]  <- width*apply(fval,2,sum)/2
  tnm <- 0.5

  #  now iterate to convergence
  for (j in 2:JMAX) {
    tnm  <- tnm*2
    del  <- width/tnm
    tj   <- seq(rangeval[1]+del/2, rangeval[2]-del/2, del)
    tval <- c(tval, tj)
    if (is.null(basislist[[j]])) {
        bmat <- getbasismatrix(tj, basisfd)
        basislist[[j]] <- bmat
    } else {
        bmat <- basislist[[j]]
    }
    fx   <- exp(bmat %*% coef)
    gval <- outer(c(fx),onebas)*bmat
    fval <- rbind(fval,gval)
    smat[j,] <- (smat[j-1,] + width*apply(fval,2,sum)/tnm)/2
    if (j >= max(c(5,JMIN))) {
      ind <- (j-4):j
      result <- polintmat(h[ind],smat[ind,],0)
      ss  <- result[[1]]
      dss <- result[[2]]
      if (all(abs(dss) < EPS*max(abs(ss))) || j == JMAX) {
        # successful convergence
        # sort argument values and corresponding function values
        ordind <- order(tval)
        tval   <- tval[ordind]
        fval   <- as.matrix(fval[ordind,])
        # set up partial integral values
        lval   <- outer(rep(1,length(tval)),fval[1,])
        del    <- tval[2] - tval[1]
        fval   <- del*(apply(fval,2,cumsum) - 0.5*(lval + fval))
        gval   <- matrix(0,length(x),nbasis)
        for (i in 1:nbasis) gval[,i] <- approx(tval, fval[,i], x)$y
        return(gval)
      }
    }
    smat[j+1,] <- smat[j,]
    h[j+1]     <- 0.25*h[j]
  }
  #stop(paste("No convergence after",JMAX," steps in MONGRAD"))
}
monhess <- function(x, Wfd, basislist)
{
#  MONHESS evaluates the second derivative of monotone fn. wrt coefficients
#  The function is of the form h[x] <- (D^{-1} exp Wfd)(x)
#  where  D^{-1} means taking the indefinite integral.
#  The interval over which the integration takes places is defined in
#       the basis object <- WFD.
#  The derivatives with respect to the coefficients in WFD up to order
#       NDERIV are also computed, max(NDERIV) <- 2.
#  Arguments:
#  X       argument values at which function and derivatives are evaluated
#             x[1] must be at lower limit, and x(n) at upper limit.
#  WFD     a functional data object
#  Returns:
#  D2H   values of D2 h wrt c
#  TVAL  Arguments used for trapezoidal approximation to integral

#  set some constants

	#cat("\nD2cmonfn")
EPS    <- 1e-5
JMIN   <- 11
JMAX   <- 15

#  get coefficient matrix and check it

coef  <- getcoef(Wfd)
coefd <- dim(coef)
ndim  <- length(coefd)
if (ndim > 1 & coefd[2] != 1) stop("WFD is not a single function")

#  get the basis

basis    <- getbasis(Wfd)
rangeval <- basis$rangeval
nbasis   <- basis$nbasis
nbaspr   <- nbasis*(nbasis+1)/2
onebaspr <- matrix(1,1,nbaspr)

#  set up first iteration

width <- rangeval[2] - rangeval[1]
JMAXP <- JMAX + 1
h     <- matrix(1,JMAXP,1)
h[2]  <- 0.25
#  matrix SMAT contains the history of discrete approximations to the
#    integral
smatD2h <- matrix(0,JMAXP,nbaspr)
#  array TVAL contains the argument values used <- the approximation
#  array FVAL contains the integral values at these argument values,
#     rows corresponding to argument values
#  the first iteration uses just the endpoints
j    <- 1
tj   <- rangeval
tval <- tj
if (is.null(basislist[[j]])) {
    bmat <- getbasismatrix(tval, basis)
    basislist[[j]] <- bmat
} else {
    bmat <- basislist[[j]]
}
fx   <- exp(bmat %*% coef)
D2fx <- matrix(0,2,nbaspr)
m <- 0
for (ib in 1:nbasis) {
   for (jb in 1:ib) {
      m <- m + 1
      D2fx[,m] <- fx*bmat[,ib]*bmat[,jb]
   }
}
D2fval <- D2fx
smatD2h[1,] <- width*sum(D2fx)/2
tnm <- 0.5
#  now iterate to convergence
for (j in 2:JMAX) {
   tnm  <- tnm*2
   del  <- width/tnm
   hdel <- del/2
   tj   <- seq(rangeval[1]+del/2, rangeval[2]-del/2, del)
   tval <- c(tval, tj)
   if (is.null(basislist[[j]])) {
      bmat <- getbasismatrix(tj, basis)
      basislist[[j]] <- bmat
   } else {
      bmat <- basislist[[j]]
   }
   fx   <- exp(bmat%*%coef)
   D2fx <- matrix(0,length(tj),nbaspr)
   m <- 0
   for (ib in 1:nbasis) {
      for (jb in 1:ib) {
         m <- m + 1
         D2fx[,m] <- fx*bmat[,ib]*bmat[,jb]
      }
   }
   D2fval <- rbind(D2fval, D2fx)
   smatD2h[j,] <- (smatD2h[j-1,] + del*sum(D2fx))/2
   if (j >= max(c(JMIN,5))) {
      ind <- (j-4):j
      result <- polintmat(h[ind],smatD2h[ind,],0)
      D2ss   <- result[[1]]
      D2dss  <- result[[2]]
      if (all(abs(D2dss) < EPS*max(abs(D2ss)))) {
         # successful convergence
         # sort argument values and corresponding function values
         ordind <- order(tval)
         tval   <- tval[ordind] 
         D2fval   <- as.matrix(D2fval[ordind,])
         # set up partial integral values
         lval   <- outer(rep(1,length(tval)),D2fval[1,])
         del     <- tval[2] - tval[1]
         D2ifval <- del*(apply(D2fval,2,cumsum) - 0.5*(lval + D2fval))
         D2h     <- matrix(0,length(x),nbaspr)
         for (i in 1:nbaspr) D2h[,i] <- approx(tval, D2ifval[,i], x)$y
         return(D2h)
      }
    }
    h[j+1] <- 0.25*h[j]
  }
  stop(paste("No convergence after ",(JMAX)," steps in D2CMONFN"))
}

odesolv <- function(wfd, ystart=diag(rep(1,m)),
                    h0=width/100, hmin=width*1e-10, hmax=width*0.5,
                    EPS=1e-4, MAXSTP=1000)
{
#  Solve L u = 0, 
#  L being an order M homogeneous linear differential operator, 
#     (Lu)(t) = w_1(t) u(t) + w_2(t) Du(t) + ...
#                  w_m(t) D^{m-1} u(t) + D^m u(t) = 0
#  for function u and its derivatives up to order m - 1.
#  Each such solution is determined by the values of u and its 
#  m - 1 derivatives at time t = 0.  These initial conditions are
#  contained in the columns of the matrix YSTART, which has exactly
#  m rows.  The number of solutions computed by ODESOLV is equal to 
#  the number of columnsof YSTART.  In order for the solutions to be 
#  linearly independent functions, the columns of YSTART must be 
#  linearly independent.  This means that the maximum number of 
#  linearly independent solutions is m.  
#  The solution for each value of t is a matrix, y(t).  
#  Any column of y(t) contains u, Du, ... , D^{m-1} u at argument 
#  value t, for the corresponding set of starting values for these 
#  first m derivatives. It is the job of this function to estimate 
#  these values, and ODESOLV will choose a set of values of TNOW at 
#  which these can be estimated with satisfactory accuracy.
#  ODESOLV uses the Runge-Kutta method, which is a good general
#  purpose numerical method.  But it does not work well for stiff
#  systems, and it can fail for poor choices of initial conditions
#  as well as other problems.

#  Arguments:
#  WFD    ... a univariate functional data object containing m = 1 functions.
#             The weight functions w_1, ... , w_m are the functions with 
#             indices 2, 3, ..., m+1.
#             This sounds awkward, but actually WFD is assumed to define a
#             NONHOMOGENEOUS linear differential operator, with index 1 
#             corresponding to a forcing function.  ODESOLV, however, only 
#             solves the HOMOGENEOUS version of the differential equation, 
#             where the forcing function is 0 by definition.  Thus, it 
#             does not actually use WFD[1].
#  YSTART ... initial values for Y.  This is a matrix with M rows,
#             were M is the order of the operator L.  Any column of M
#             specifies intial values for derivatives 0, 1, ... M-1.  Each
#             column must specify a unique set of initial conditions.  A
#             frequent choice is the identity matrix of order M, and this is
#             the default.
#  H0     ... initial trial step size
#  HMIN   ... minimum step size
#  HMAX   ... maximum step size
#  EPS    ... error tolerance
#  MAXSTP ... maximum number of Runge Kutta steps permitted. If the equation
#             is difficult to solve, this may have to be increased.

#  Returns:
#  TP     ... vector of T values used
#  YP     ... m by m by length(TP) array of Y-values generated for
#             values in TP.

#  Note that ODESOLV calls function DERIVS in order to evaluate the 
#  differential operator.  Also, it works by redefining the order m
#  linear differential equation as a linear system of m first order 
#  differential equations.  DERIVS evaluates the right side of this
#  linear system. 

#  Last modified 14 December 2001

  	MAXWARN <- 10

  	if (!(inherits(wfd, "fd"))) stop(
			"Argument WFD not a functional data object.")
		
#  determine the order of the system m
  	wbasisfd <- getbasis(wfd)
  	wcoef    <- getcoef(wfd)
  	wcoefd   <- dim(wcoef)
  	if (length(wcoefd) > 2) stop("WFN is not a univariate object.")
  	m        <- wcoefd[2] - 1
 	if (m < 1) stop("WFD must contain at least two functions.")

#  determine the range of values over which the equation is solved

  	rangeval <- wbasisfd$rangeval
  	tbeg     <- rangeval[1]
  	tend     <- rangeval[2]
  	width    <- tend - tbeg
  	tnow     <- tbeg
  	h        <- min(c(h0, hmax))
  	tp       <- tnow

#  set up the starting values

  	ystartd  <- dim(ystart)
  	if (ystartd[1] != m) stop("YSTART has incorrect dimensions")
  	n        <- ystartd[2]
  	yp       <- c(ystart)
  	index    <- abs(yp) > 1e-10
  	y        <- ystart

#  Since ODESOLVE is slow, progress is displayed

  	cat("Progress:  each dot is 10% of interval\n")

#  initialize the solution

  	tdel  <- (tend - tbeg)/10
  	tdot  <- tdel
  	iwarn <- 0

#  solve the equation using a maximum of MAXSTP steps

  	for (nstp in 1:MAXSTP) {
		#  evaluate the right side at the current value
    	dydt  <- derivs(tnow, y, wfd)
    	yscal <- c(abs(y) + abs(h*dydt) + 1e-30)[index]
    	if (nstp > 1) {
      		tp <- c(tp,tnow)
      		yp <- c(yp,c(y))
    	}
    	if (tnow >= tdot) {
      		cat(".")
      		tdot <- tdot + tdel
    	}
    	if ((tnow+h-tend)*(tnow+h-tbeg) > 0) h <- tend-tnow
		#  take a Runge-Kutta step to the next value
    	result <-  rkqs(y, dydt, tnow, h, wfd, yscal, index, EPS)
    	tnow   <- result[[1]]
    	y      <- result[[2]]
    	h      <- result[[3]]
    	hnext  <- result[[4]]
		#  test to see if interval has been covered, and return
		#  if it has.
    	if ((tnow-tend)*(tend-tbeg) >= 0) {
      		cat(".")
      		tp <- c(tp,tnow)
      		yp <- c(yp,c(y))
      		yp <- array(yp,c(m,n,length(tp)))
      		return(list(tp, yp))
    	}
		#  test if the step is too small.
    	if (abs(hnext) < hmin) {
			warning("Stepsize smaller than minimum")
			hnext <- hmin
			iwarn <- iwarn + 1
			if (iwarn >= MAXWARN) stop("Too many warnings.")
		}
		#  test if the step is too large.
    	h <- min(c(hnext, hmax))
  	}
  	warning("Too many steps.")
}

#  ---------------------------------------------------------------

rkqs <- function(y, dydt, tnow, htry, wfd, yscal, index, EPS)
{
#  Take a single step using the Runge-Kutta procedure to 
#  control for accuracy.  The function returns the new
#  value of t, the value of the solution at t, the step
#  size, and a proposal for the next step size.
	h <- htry
	#  check the accuracy of the step
   	result <- rkck(y, dydt, tnow, h, wfd)
   	ytemp  <- result[[1]]
   	yerr   <- c(result[[2]])[index]
   	errmax <- max(abs(yerr/yscal))/EPS
	#  modify the step size if ERRMAX is too large
   	while (errmax > 1) {
        	htemp <- 0.9*h*(errmax^(-0.25))
        	h     <- max(c(abs(htemp),0.1*abs(h)))
        	tnew  <- tnow + h
        	if (tnew == tnow) stop("stepsize underflow in rkqs")
        	result <- rkck(y, dydt, tnow, h, wfd)
        	ytemp  <- result[[1]]
        	yerr   <- result[[2]]
        	errmax <- max(abs(yerr/yscal))/EPS
 	}
	# set up the proposed next step
   	if (errmax > 1.89e-4) {
        	hnext <- 0.9*h*(errmax^(-0.2))
   	} else {
        	hnext <- 5.*h
  	}
   	tnow <- tnow + h
   	y <- ytemp
  	return( list(tnow, y, h, hnext) )
}

#  ------------------------------------------------------------------

rkck <- function(y, dydt, tnow, h, wfd)
{
#  Take a single Runge-Kutta step.
#  Return the solution, and an estimate of its error.
      C1  <-   37/378
      C3  <-  250/621
      C4  <-  125/594
      C6  <-  512/1771
      DC5 <- -277/14336
      DC1 <-  C1 - 2825/27648
      DC3 <-  C3 - 18575/48384
      DC4 <-  C4 - 13525/55296
      DC6 <-  C6 - 0.25

      ytemp <- y + h*0.2*dydt
      ak2   <- derivs(tnow+0.2*h,   ytemp, wfd)
      ytemp <- y + h*(0.075*dydt  + 0.225*ak2)
      ak3   <- derivs(tnow+0.3*h,   ytemp, wfd)
      ytemp <- y + h*(0.3*dydt    - 0.9*ak2 + 1.2*ak3)
      ak4   <- derivs(tnow+0.6*h,   ytemp, wfd)
      ytemp <- y + h*(-11*dydt/54 + 2.5*ak2 + (-70*ak3+35*ak4)/27)
      ak5   <- derivs(tnow+h,       ytemp, wfd)
      ytemp <- y + h*(1631*dydt/55296  + 575*ak2/512 + 575*ak3/13824 +
                      44275*ak4/110592 + 253*ak5/4096)
      ak6   <- derivs(tnow+0.875*h, ytemp, wfd)
      yout  <- y + h*(C1*dydt + C3*ak3 + C4*ak4 + C6*ak6)
      yerr  <- h*(DC1*dydt    + DC3*ak3 + DC4*ak4 + DC5*ak5 + DC6*ak6)
      return (list( yout, yerr ) )
}
pca.fd <- function(fd, nharm = 2, lambda = 0, Lfd = 2, centerfns = TRUE)
{
#  Carry out a functional PCA with regularization
#  Arguments:
#  FD        ... Functional data object
#  NHARM     ... Number of principal components or harmonics to be kept
#  LAMBDA    ... Smoothing or regularization parameter
#  LFD       ... Either the order derivative or a linear differential operator
#                to be penalized
#  CENTERFNS ... If T, the mean function is first subtracted from each function
#
#  Returns:  An object PCAFD of class "pca.fd" with these named entries:
#  harmonics  ... A functional data object for the harmonics or eigenfunctions
#  values     ... The complete set of eigenvalues
#  scores     ... A matrix of scores on the principal components or harmonics
#  varprop    ... A vector giving the proportion of variance explained
#                 by each eigenfunction
#  meanfd     ... A functional data object giving the mean function
#

  #  Last modified:  15 November 2001

  #  Check arguments

  if (!(inherits(fd, "fd")))    stop("Argument FD  not a functional data object.")

  #  compute mean function and center if required

  meanfd <- meanFd(fd)
  if (centerfns) fd <- center.fd(fd)

  coef  <- getcoef(fd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  coefnames <- dimnames(coef)

  fdbasis <- getbasis(fd)
  nbasis  <- fdbasis$nbasis
  type    <- getbasistype(fdbasis)

  nrep <- coefd[2]
  if (nrep < 2) stop("PCA not possible without replications.")

  if (ndim == 3) {
    nvar <- coefd[3]
    ctemp <- matrix(0, nvar * nbasis, nrep)
    for(j in 1:nvar) {
      index <- 1:nbasis + (j - 1) * nbasis
      ctemp[index,  ] <- coef[,  , j]
    }
  } else {
    nvar  <- 1
    ctemp <- coef
  }

  #  set up cross product and penalty matrices

  Cmat <- crossprod(t(ctemp))/nrep
  Jmat <- getbasispenalty(fdbasis, 0)
  if(lambda > 0) {
    Kmat <- getbasispenalty(fdbasis, Lfd)
    Wmat <- Jmat + lambda * Kmat
  } else {
    Wmat <- Jmat
  }
  Wmat <- (Wmat + t(Wmat))/2

  #  compute the Choleski factor of Wmat

  Lmat    <- chol(Wmat)
  Lmatinv <- solve(Lmat)

  #  set up matrix for eigenanalysis

  if(nvar == 1) {
    if(lambda > 0) {
            Cmat <- t(Lmatinv) %*% Jmat %*% Cmat %*% Jmat %*% Lmatinv
    } else {
            Cmat <- Lmat %*% Cmat %*% t(Lmat)
    }
  } else {
    for (i in 1:nvar) {
      indexi <- 1:nbasis + (i - 1) * nbasis
      for (j in 1:nvar) {
        indexj <- 1:nbasis + (j - 1) * nbasis
        if (lambda > 0) {
          Cmat[indexi, indexj] <- t(Lmatinv) %*% Jmat %*%
          Cmat[indexi, indexj] %*% Jmat %*% Lmatinv
        } else {
          Cmat[indexi, indexj] <- Lmat %*% Cmat[indexi,indexj] %*% t(Lmat)
        }
      }
    }
  }

  #  eigenalysis

  Cmat    <- (Cmat + t(Cmat))/2
  result  <- eigen(Cmat)
  eigvalc <- result$values
  eigvecc <- as.matrix(result$vectors[, 1:nharm])
  sumvecc <- apply(eigvecc, 2, sum)
  eigvecc[,sumvecc < 0] <-  - eigvecc[, sumvecc < 0]

  varprop <- eigvalc[1:nharm]/sum(eigvalc)

  if (nvar == 1) {
    harmcoef <- Lmatinv %*% eigvecc
    harmscr  <- t(ctemp) %*% t(Lmat) %*% eigvecc
  } else {
    harmcoef <- array(0, c(nbasis, nharm, nvar))
    harmscr  <- matrix(0, nrep, nharm)
    for (j in 1:nvar) {
      index <- 1:nbasis + (j - 1) * nbasis
      temp <- eigvecc[index,  ]
      harmcoef[,  , j] <- Lmatinv %*% temp
      harmscr <- harmscr + t(ctemp[index,  ]) %*% t(Lmat) %*% temp
    }
  }
  harmnames <- rep("", nharm)
  for(i in 1:nharm)
    harmnames[i] <- paste("PC", i, sep = "")
  if(length(coefd) == 2)
    harmnames <- list(coefnames[[1]], harmnames)
  if(length(coefd) == 3)
    harmnames <- list(coefnames[[1]], harmnames, coefnames[[3]])
  harmfd   <- create.fd(harmcoef, fdbasis, harmnames)

  pcafd        <- list(harmfd, eigvalc, harmscr, varprop, meanfd)
  setOldClass("pca.fd")  
  oldClass(pcafd) <- "pca.fd"
  names(pcafd) <- c("harmonics", "values", "scores", "varprop", "meanfd")

  return(pcafd)
}
pda.fd <- function (fd, norder, wbasisfd=basisfd, n=5*nbasis,
                    estimate=c(FALSE,rep(TRUE,nord)),
                    lambda=rep(0,nordp1), wfd0=matrix(0,1,nordp1))
{

#  A function to compute the basis function expansion of the
#    estimate of the coefficient functions w_j(t) and forcing function f(t) 
#    in the nonhomogeneous linear differential operator
#
#    Lx(t) = f(t) +
#       w_0(t)x(t) + w_1(t)Dx(t) + ... + w_{m-1}D^{m-1}x(t) + w_m(t)D^m x(t)  
#
#    of order m = NORDER that minimizes in a least squares sense the residual
#    functions Lx(t).  The functions x(t) are in functional data object FD.
#  The coefficient functions are expanded in terms of the
#    basis functions specified in WBASISFD.

#  Arguments:
#  FD        ...  functional data object
#  NORDER    ...  order of the linear differential operator, that is, the order
#                 of the highest derivative.
#  WBASISFD  ...  basis object for the forcing function and weight functions.
#  N         ...  number of sampling points for numerical integration
#  ESTIMATE  ...  logical array of length NORDER + 1, if a value is T, the
#                 corresponding coefficient function is estimated, otherwise
#                 the target value is used.  The first value applies to the 
#                 forcing function, and if F, the forcing function is 0 and
#                 linear differential operator is homogeneous
#  LAMBDA    ...  a numerical array of length NORDER + 1 containing 
#                 penalty parameters for penalizing the departure of the
#                 estimated weight functions from those defined in WFD0.
#  WFD0      ...  A specification of a functional data object that is used for
#                 those weight functions and forcing function not estimated, 
#                 or as target functions toward which the estimated weight 
#                 functions and forcing function are smoothed. 
#                 WFD0 can either be a vector of NORDER + 1 constants, or a 
#                 functional data object with the same structure as WFD 
#                 that is returned by this function.

#  Returns:
#  WFD       ...  estimated weight functional data object.  It has NORDER + 1
#                 functions.  The first is the forcing function, and 
#                 the last NORDER of these are the weight functions w_j(t) 
#                 in the linear differential operator.


#  Last modified 3 December 2001

#  check the first argument

	if (!(inherits(fd, "fd"))) stop("Argument FD not a functional data object.")

	basisfd <- getbasis(fd)
	nbasis  <- basisfd$nbasis
	rangew  <- basisfd$rangeval

#  check second argument

	nord <- as.integer(norder)
	if (nord <= 0) stop("nord must be positive.")
	if (nord > 9)  stop("nord exceeds 9.")
	nordp1 <- nord + 1
	nordp2 <- nord + 2
	
#  check argument WFD0.  If it is a vector, convert this to a 
#    constant basis functional data object

	if (!(inherits(wfd0, "fd")) && is.numeric(wfd0)) {
	  	if (length(wfd0) != nordp1) stop(
	         "WFD0 is not a vector of NORDER + 1")
    	wbasis0 <- create.constant.basis(rangew)
    	wfd0 <- create.fd(wfd0, wbasis0)
	} else {
    	stop("WFD0 is neither a vector nor a functional data object")
	}

#  check which components are to be estimated and get that number

   if (length(estimate) != nordp1) 
		stop("ESTIMATE is not a vector of NORDER + 1")
  	estimate <- as.logical(estimate)
  	ncoef    <- sum(as.numeric(estimate))

#  get the dimensions of the data in FD

  	coef   <- getcoef(fd)
  	coefd  <- dim(coef)
  	if (is.null(coefd)) ndim <- 1 else ndim <- length(coefd)
  	if (ndim == 1) {
  		ncurve <- 1
  		nvar   <- 1
  	}
  	if (ndim == 2) {
    	ncurve <- coefd[2]
    	nvar   <- 1
  	}
  	if (ndim == 3) {
  		ncurve <- coefd[2]
  		nvar   <- coefd[3]
  	}

#  check and get the characteristics of the basis to be used 

  	typew   <- wbasisfd$type
  	nbasisw <- wbasisfd$nbasis
  	rangew  <- wbasisfd$rangeval

  	if (any(rangew != basisfd$rangeval)) stop(
    	"Weight function range not equal to range in FD")

  	if (typew == "bspline") {
    	nbreaksw <- length(wbasisfd$params)
    	norderw  <- nbasisw - nbreaksw
  	}

#  set up sampling values to be used in numerical integration
#    and set up matrix of basis values

  	delta    <- (rangew[2]-rangew[1])/(n-1)
  	x        <- seq(rangew[1],rangew[2],delta)
  	basismat <- getbasismatrix(x, wbasisfd)

#  set up array to hold values of function and derivatives

  	yarray <- array(0,c(n,ncurve,nordp2))
  	yarray[,,1] <- 1

#  set up array to hold coefficients for basis expansion

  	if (nvar == 1) {
   			pdacoef <- matrix(0,nbasisw,nordp1)
  	} else {
    		pdacoef <- array(0,c(nbasisw,nordp1,nvar))
  	}

#  --------------  beginning of loop through variables  -------------------

  	for (ivar in 1:nvar) {
	   #  fill yarray with values of functions
  		if (nvar == 1) {
    		for (j in 0:nord) yarray[,,j+2] <- eval.fd(x, fd, j)
  		} else {
  			for (j in 0:nord) yarray[,,j+2] <- eval.fd(x, fd[,ivar], j)
  		}

    	mi   <- 0
    	mij  <- 0
    	Swgt <- matrix(0,n,ncoef)
    	Rwgt <- matrix(0,n,ncoef*(ncoef+1)/2)
    	for (i in 1:nordp1) {
      		if(estimate[i]) {
        		mi <- mi + 1
        		index <- (1 + (mi-1)*nbasisw):(mi*nbasisw)
				#  information for right side of linear equation
        		Swgt[,mi] <- apply(yarray[,,i]*yarray[,,nordp2],1,mean)
				#  information for left side of coefficient matrix for linear equation
        		mj <- 0
        		for (j in 1:i) {
          			if(estimate[j]) {
            			mij <- mij + 1
            			Rwgt[,mij] <- apply(yarray[,,i]*yarray[,,j],1,mean)
          			}
        		}
      		}
    	}

		#  set up left and right sides of linear equation
			
    	result <- SRsetup(ncoef, nbasisw, Swgt, Rwgt, basismat)

    	Cmat <- result[[2]]
    	Dmat <- result[[1]]

		#  modify the left and right sides if smoothing is involved
			
    	if (any(lambda > 0)) {
      		Hmat <- getbasispenalty(wbasisfd,0)
			mi   <- 0
      		for (i in 1:nordp1) {
  				if(estimate[i]) {
					mi <- mi + 1
        			index <- (1 + (mi-1)*nbasisw):(mi*nbasisw)
        			if (lambda[i] > 0) {
          				Cmat[index,index] <- Cmat[index,index] - lambda[i]*Hmat
						if (any(getcoef(wfd0[i]) != 0))
         	 				Dmat[index,1] <- Dmat[index,1] + 
												lambda[i]*inprod(wbasisfd,wfd0[i])
        			}
				}
      		}
    	}

		#  solve the equation using Choleski decomposition
		
    	dvec <- symsolve( Cmat, -Dmat )

    	#  set up the coefficient matrix

  		dmat <- matrix(0,nbasisw,nordp1)
  		mi  <- 0
  		for (i in 1:nordp1) {
    		if(estimate[i]) {
      			mi <- mi + 1
      			index <- (1 + (mi-1)*nbasisw):(mi*nbasisw)
      			dmat[,i] <- dvec[index]
    		}
  		}
  		if (nvar == 1) pdacoef <- dmat else pdacoef[,,ivar] <- dmat

	}

#  --------------  end of loop through variables  -------------------

#  set up the functional data object WFD 

  	wfdnames <- getnames(fd)
  	names(wfdnames)[2] <- "Weight functions"
  	names(wfdnames)[3] <- "Weight value"
  	wfd <- create.fd(pdacoef, wbasisfd, wfdnames)

  	return( wfd )
}

#  ------------------------------------------------------------------------

SRsetup <- function(ncoef, nbasis, Swgt, Rwgt, basismat)
{
  #  sets up coefficient matrices for basis expansion of weight functions

  	Smat <- matrix(0, ncoef*nbasis, 1)
  	Rmat <- matrix(0, ncoef*nbasis, ncoef*nbasis)
  	n  <- nrow(Swgt)
  	m1 <- ncol(basismat)
  	m  <- 0
  	one <- rep(1, nrow(basismat))
  	for (i in 1:ncoef){
    	indexi <- (1:nbasis) + (i-1)*nbasis
    	temp     <- basismat * outer(Swgt[,i], rep(1,m1))
    	temp[1,] <- temp[1,]/2
    	temp[n,] <- temp[n,]/2
    	Smat[indexi] <- crossprod(temp, one)
    	for (j in 1:i) {
      		m <- m + 1
      		indexj <- (1:nbasis) + (j-1)*nbasis
      		temp     <- basismat * outer(Rwgt[,m],rep(1,m1))
      		temp[1,] <- temp[1,]/2
      		temp[n,] <- temp[n,]/2
      		Rmat[indexi,indexj] <- crossprod(temp, basismat)
      		if (i != j) Rmat[indexj,indexi] <- Rmat[indexi,indexj]
    	}
  	}
  	return (list(Smat, Rmat) )
}
pdalist  <-  function(xfdlist, ufdlist=NULL, awtlist=NULL, bwtlist=NULL,
                      norder=1, nvar=1, nforce=0, nfine=101)
{
#PDA computes the basis function expansions of the
#  estimates of the coefficient functions a_k(t) and b_j(t)
#  in the possibly nonhomogeneous linear differential operator
#
#    Lx(t) <- a_1(t)u_1(t) +  + a_k(t)u_K(t) +
#       b_0(t)x(t) + b_1(t)Dx(t) +  + b_{m-1}D^{m-1}x(t) + D^m x(t)
#
#  of order m <- NORDER that minimizes in a least squares sense the residual
#  functions f(t) <- Lx(t).
#
#  If (NORDER <- 0, PDALIST fits the varying coefficient or pointwise
#  linear model using the functions x(t) as dep}ent variables and
#  the forcing functions u(t) as indep}ent variables.  In this case,
#  there must be at least one forcing function.
#
#  The functions x(t) are in functional data object XFDOBJ.
#  The forcing functions u_k(t) are in functional data object UFDOBJ.
#  The coefficient functions for u_k(t) and x(t) are expanded in terms of the
#  basis functions specified in AWTLIST and BWTLIST, respectively.
#
#  The functions u_k(t) and x(t) are assumed to be vector valued
#    of dimension J.
#  That is, the differential equation can be a system of J equations rather
#    than a single equation.
#  Each coefficient function b_j(t) is matrix valued, with a column
#    for each scalar function in the system.

#  Arguments:
#  XFDLIST     list array of functional data objects for the functions
#                 whose derivatives define the DIFE
#                 dimensions are J and 1
#  UFDLIST     list array of independent variables or u-variables
#                 dimensions are J and K
#  AWTLIST     list array of weight function specs for u-variables
#                 dimensions are J and K
#  BWTLIST     list array of weight function specs for functions x
#                 dimensions are J, J and NORDER
#  NORDER      order of the linear differential operator, that is,
#                 the order of the highest derivative.
#  NVAR        number of variables in the linear system
#  NFORCE      number of forcing functions
#  NFINE       number of sampling points for numerical integration

#  The value in each list of XFDLIST, UFDLIST, AFDLIST and BFDLIST is a
#      scalar FD object

#  The value in each list of AWTLIST and BWTLIST is a list containing:
#       FD object containing to be used as the fixed value if (not estimated
#       ESTIMATE: T if (weight is to be estimated, F if (not.
#  We are not bothering with smoothing at this point.

#  Returns:
#  BFDLIST     list array of weights for x functions
#                 dimensions are J, J and NORDER
#  RESFDLIST   FD object for residual functions.
#  AFDLIST     list array of weights for u-variables
#                 dimension J and K

#  last modified 20 February 2003

norder <- floor(norder)
if (norder < 0) stop("NORDER is negative.")
nordp1 <- norder + 1

#  check the dimensions of UFDLIST and AWTLIST

if (is.null(ufdlist) || is.null(awtlist)) {
    afdlist <- NULL
} else {
    if (length(ufdlist) != nvar*nforce) {
        stop(paste("The number of rows of UFDLIST)",
               " does not match that of XFDLIST."))
    }
    if (length(awtlist) != nvar*nforce) {
        stop("The dimensions of AWTLIST are incorrect.")
    }
	afdlist <- vector("list", nvar*norder)
}

#  check to see if there is anything to estimate

if (norder == 0 && nforce == 0) {
    stop("There are no coefficient functions to estimate.")
}

#  check the dimensions of BWTLIST

if (norder == 0) {
    bfdlist <- NULL
}

if (norder == 1) {
    if (length(bwtlist) != nvar*nvar) {
        stop("The dimensions of BWTLIST are incorrect.")
    }
	bfdlist <- vector("list", nvar*nvar*norder)
}

if (norder > 1) {
    if (length(bwtlist) != nvar*nvar*norder) {
        stop("The dimensions of BWTLIST are incorrect.")
    }
}

#  check XFDLIST and extract NCURVE and XRANGE

for (ivar in 1:nvar) {
    if (!is.fd(xfdlist[[ivar]])) {
        stop(paste("XFDLIST",ivar,
                "is not a functional data object."))
    }
    if (ivar == 1) {	    
        xrange     <- getbasis(xfdlist[[ivar]])$rangeval
        ncurve     <- dim(getcoef(xfdlist[[ivar]]))[2]
        bfdnames   <- getnames(xfdlist[[ivar]])
        resfdnames <- bfdnames
    } else {
        if (any(getbasis(xfdlist[[ivar]])$rangeval != xrange))
            stop("Ranges are incompatible for XFDLIST.")
        if (dim(getcoef(xfdlist[[ivar]]))[2] != ncurve) 
            stop("Number of curves is incompatible for XFDLIST.")
    }
}

nbasmax <- 0  #  This will be the maximum number of basis functions

#  check UFDLIST and extract URANGE

if (nforce > 0) {
    for (ivar in 1:nvar) {
        for (iu in 1:nforce) {
            if (!is.fd(ufdlist[[(iu-1)*nforce+ivar]])) {
                stop(paste("UFDLIST{",ivar,",",iu,
                        "is not a functional data object."))
            }
            if (ivar == 1 && iu == 1) {
                urange <- getbasis(ufdlist[[(iu-1)*nforce+ivar]])$rangeval
                afdnames <- getnames(ufdlist[[(iu-1)*nforce+ivar]])
            } else {
                if (any(getbasis(ufdlist[[(iu-1)*nforce+ivar]])$rangeval != urange))
                    stop("Ranges are incompatible for UFDLIST.")
            }
        }
    }

    #  check AWTLIST and extract the max. no. basis fns.

    for (ivar in 1:nvar) {
        for (iu in 1:nforce) {
            awtlisti <- awtlist[[(iu-1)*nforce+ivar]]
            afdi       <- awtlisti[[1]]
            if (!is.fd(afdi)) {
                stop("AFDI is not a functional data object.")
            }
            basisi <- getbasis(afdi)
            if (any(basisi$rangeval != urange)) {
                stop("Ranges are incompatible for AWTLIST.")
            }
            nbasmax <- max(c(nbasmax,basisi$nbasis))
        }
    }

}

#  check BWTLIST

if (norder > 0) {
    for (ivar1 in 1:nvar) {
        for (ivar2 in 1:nvar) {
            for (j in 1:norder) {
                if (norder == 1) {
                    blist12 <- bwtlist[[(ivar2-1)*nvar+ivar1]]
                } else {
                    blist12 <-
                        bwtlist[[(j-1)*norder*nvar+(ivar2-1)*nvar+ivar1]]
                }
                if (!is.fd(blist12[[1]])) {
                    stop(paste("BWTLIST",ivar1, ",",ivar2, ",",iu,
                            "is not a functional data object."))
                }
                basisi <- getbasis(blist12[[1]])
                if (any(basisi$rangeval != xrange)) {
                    stop("Ranges are incompatible for BWTLIST.")
                }
                nbasmax <- max(c(nbasmax,basisi$nbasis))
            }
        }
    }
}

#  At this point we assume that the ranges for XFDLIST and UFDLIST
#  are the same, but this will be changed later to allow for lags.

if (nforce > 0) {
    if (any(xrange != urange)) 
        stop("Ranges for XFDLIST and UFDLIST are not compatible.")
}

#  set up sampling values to be used in numerical integration
#    and set up matrix of basis values.  The number of sampling
#  NFINE is here set to a usually workable value if too small.

if (nfine < 5*nbasmax) nfine <- 5*nbasmax

deltax <- (xrange[2]-xrange[1])/(nfine-1)
tx     <- seq(xrange[1],xrange[2],deltax)

if (nforce > 0) {
    deltau <- (urange[2]-urange[1])/(nfine-1)
    tu     <- seq(urange[1],urange[2],deltau)
}

#  set up  YARRAY to hold values of x functions and their derivatives

yarray <- array(0,c(nfine,ncurve,nvar,nordp1))
for (ivar in 1:nvar) {
    for (j in 1:nordp1) {
        yarray[,,ivar,j] <- eval.fd(tx, xfdlist[[ivar]], j-1)
    }
}

#  set up  UARRAY to hold values of u functions

if (nforce > 0) {
    uarray <- array(0,c(nfine,nforce))
    for (iu in 1:nforce) {
        uarray[,iu] <- eval.fd(tu, ufdlist[[(iu-1)*nforce+ivar]])
    }
}

#  set up array YPROD to hold mean of products of values in YARRAY

mmat  <- m2ij(nvar,nordp1)
yprod <- array(0,c(nfine,nvar,nordp1,nvar,nordp1))
for (m1 in 1:nvar*nordp1) {
    i1 <- mmat[m1,1]
    j1 <- mmat[m1,2]
    for (m2 in 1:m1) {
        i2 <- mmat[m2,1]
        j2 <- mmat[m2,2]
        if (ncurve == 1) {
            yprodval <- yarray[,1,i1,j1]*yarray[,1,i2,j2]
        } else {
            yprodval <- apply(yarray[,,i1,j1]*yarray[,,i2,j2],2,mean)
        }
        yprod[,i1,j1,i2,j2] <- yprodval
        yprod[,i2,j2,i1,j1] <- yprodval
    }
}

#  set up array YUPROD to hold mean of u-variables u times
#    x functions and their derivatives

onesncurve <- rep(1,ncurve)
if (nforce > 0) {
    yuprod <- array(0,c(nfine, nvar, nforce, nordp1))
    for (iu in 1:nforce) {
        for (i1 in 1:nvar) {
            for (j1 in 1:nordp1) {
                if (ncurve == 1) {
                    yuprodval <- yarray[,1,i1,j1]*uarray[,iu]
                } else {
                    yuprodval <-
                        apply(yarray[,,i1,j1]*
                              outer(uarray[,iu],onesncurve),2,mean)
                }
                yuprod[,i1,iu,j1] <- yuprodval
            }
        }
    }
}

#  set up array UPROD to hold mean of products of u-variables u

if (nforce > 0) {
    uprod <- array(0,c(nfine, nforce, nforce))
    for (iu in 1:nforce) {
        for (ju in 1:iu) {
            uprodval <- uarray[,iu]*uarray[,ju]
            uprod[,iu,ju] <- uprodval
            uprod[,ju,iu] <- uprodval
        }
    }
}

#  set up an index array and some arrays of 1"s

mmat  <- m2ij(nvar,norder)
onesn <- rep(1,nfine)

#  set up array to hold coefficients for basis expansions

if (nforce > 0) {
    aarray <- matrix(0,nfine,nforce)
} else {
    aarray <- NULL
}

if (norder > 0) {
    barray <- array(0,c(nfine,nvar,norder))
} else {
    barray <- NULL
}


#  --------------  beginning of loop through variables  -------------------

for (ivar in 1:nvar) {

    #  get number of coefficients to be estimated for this equation

    # loop through u-variables
    neqns  <- 0
    for (iu in 1:nforce) {
        alisti <- awtlist[[(iu-1)*nforce+ivar]]
        if (alisti[[2]]) {
            neqns <- neqns + getbasis(alisti[[1]])$nbasis
        }
    }
    # loop through x functions and their derivatives
    for (m2 in 1:nvar*norder) {
        i2 <- mmat[m2,1]
        j2 <- mmat[m2,2]
        if (norder == 1) {
            blistij <- bwtlist[[(i2-1)*nvar+ivar]]
        } else {
            blistij <- bwtlist[[(j2-1)*norder*nvar+(i2-1)*nvar+ivar]]
        }
        if (blistij[[2]]) {
            neqns <- neqns + getbasis(blistij[[1]])$nbasis
        }
    }
    if (neqns < 1) stop("Number of equations to solve is not positive.")

    #  set up coefficient array and right side array for linear equation

    cmat   <- matrix(0,neqns, neqns)
    dmat   <- matrix(0,neqns, 1)

    #  evaluate default weight functions for this variable

    for (iu in 1:nforce) {
        alisti <- awtlist[[(iu-1)*nforce+ivar]]
        aarray[,iu] <- eval.fd(tu, alisti[[1]])
    }
    for (i in 1:nvar) {
        for (j in 1:norder) {
            if (norder == 1) {
                blistij <- bwtlist[[(i-1)*nvar+ivar]]
            } else {
                blistij <- bwtlist[[(j-1)*norder*nvar+(i-1)*nvar+ivar]]
            }
            barray[,i,j] <- eval.fd(tx,blistij[[1]])
        }
    }

    #  loop through equations,
    #    corresponding to rows for CMAT and DMAT

    #  loop through equations for u-variables

    mi12 <- 0
    for (iu1 in 1:nforce) {
        alisti1   <- awtlist[[(iu1-1)*nvar+ivar]]
        if (alisti1[[2]]) {
            abasisi1    <- getbasis(alisti1[[1]])
            abasismati1 <- getbasismatrix(tu, abasisi1)
            mi11 <- mi12 + 1
            mi12 <- mi12 + abasisi1$nbasis
            indexi1 <- mi11:mi12
            #  DMAT entry for u-variable
            weighti1 <- yuprod[,ivar,iu1,nordp1]
            dmat[indexi1] <-
                trapzmat(abasismati1,onesn,deltax,weighti1)
            #  add terms corresponding to x-derivative weights
            #  that are not estimated
            for (m in 1:nvar*norder) {
                i <- mmat[m,1]
                j <- mmat[m,2]
                blistij <- bwtlist[[(j-1)*nvar*norder+(i-1)*nvar+ivar]]
                if (!blistij[[2]]) {
                    weightij <- yuprod[,ivar,k1,j]
                    dmat(indexi1) <- dmat(indexi1) + 
                        trapzmat(abasismatk1,barray[,ivar,j],deltax,weightij)
                }
            }
            #  loop through weight functions to be estimated,
            #    corresponding to columns for CMAT
            #  begin with u-variables
            mi22 <- 0
            for (iu2 in 1:nforce) {
                alisti2   <- awtlist[[(iu2-1)*nvar+ivar]]
                if (alisti2[[2]]) {
                    abasisi2    <- getbasis(alisti2[[1]])
                    abasismati2 <- getbasismatrix(tu, abasisi2)
                    weighti2    <- uprod[,iu1,iu2]
                    Cprod  <-
                        trapzmat(abasismati1, abasismati2, deltau, weighti2)
                    mi21 <- mi22 + 1
                    mi22 <- mi22 + abasisi2$nbasis
                    indexi2 <- mi21:mi22
                    #  coefficient matrix CMAT entry
                    cmat[indexi1,indexi2] <- Cprod
                }
            }
            #  remaining columns:
            #    loop through u-variable -- x-derivative pairs
            mij22 <- mi22
            for (m2 in 1:nvar*norder) {
                i2 <- mmat[m2,1]
                j2 <- mmat[m2,2]
                blistij2     <- bwtlist[[(j2-1)*norder*nvar+(i2-1)*nvar+ivar]]
                bbasisij2    <- getbasis(blistij2[[1]])
                bbasismatij2 <- getbasismatrix(tx, bbasisij2)
                weightij12   <- yuprod[,ivar,iu1,j2]
                Cprod <-
                    trapzmat(abasismati1,bbasismatij2,deltax,weightij12)
                mij21 <- mij22 + 1
                mij22 <- mij22 + bbasisij2$nbasis
                indexij2  <- mij21:mij22
                cmat[indexi1,indexij2] <- Cprod
            }
            #  add roughness penalty matrix to diaginal entries
            if (alisti1[[3]] > 0.0) {
                Lfdobj <- alistk2[[4]]
                penmat <- alistk2[[3]]*eval.penalty(abasisk1, Lfdobj)
                cmat[indexi1,indexi1] <- cmat[indexi1,indexi1] + penmat
            }
        }
    }

    #  loop through equations for x-derivatives

    mij12 <- mi12
    for (m1 in 1:nvar*norder) {
        i1 <- mmat[m1,1]
        j1 <- mmat[m1,2]
        blistij1 <- bwtlist[[(j1-1)*norder*nvar+(i1-1)*nvar+ivar]]
        if (blistij1[[2]]) {
            bbasisij1    <- getbasis(blistij1[[1]])
            bbasismatij1 <- getbasismatrix(tx,bbasisij1)
            mij11 <- mij12 + 1
            mij12 <- mij12 + bbasisij1$nbasis
            indexij1 <- mij11:mij12
            #  DMAT entry for u-variable -- x-derivative pair
            weightij1 <- yprod[,i1,j1,ivar,nordp1]
            dmat[indexij1] <-
                trapzmat(bbasismatij1,onesn,deltax,weightij1)
            #  add terms corresponding to forcing functions with
            #  unestimated coefficients
            for (k in 1:nforce) {
                alistk <- awtlist[[(k-1)*nvar+ivar]]
                if (!alistk[[2]]) {
                    weightijk      <- yuprod[,ivar,k,j1]
                    dmat[indexij1] <- dmat[indexij1] + 
                        trapzmat(bbasismatij1,aarray[,k],deltax,weightijk)
                }
            }
            #  first columns of CMAT: u-variable entries
            mi22 <- 0
            for (iu2 in 1:nforce) {
                alisti2 <- awtlist[[(iu2-1)*nvar+ivar]]
                if (alisti2[[2]]) {
                    abasisi2    <- getbasis(alisti2[[1]])
                    abasismati2 <- getbasismatrix(tx, abasisi2)
                    weighti2    <- yuprod[,i1,iu2,j1]
                    Cprod <-
                        trapzmat(bbasismatij1,abasismati2,deltax,weighti2)
                    mi21 <- mi22 + 1
                    mi22 <- mi22 + abasisi2$nbasis
                    indexi2 <- mi21:mi22
                    cmat[indexij1,indexi2] <- Cprod
                }
            }
            #  remaining columns: x-derivative pairs
            mij22 <- mi22
            for (m2 in 1:nvar*norder) {
                i2 <- mmat[m2,1]
                j2 <- mmat[m2,2]
                blistij2     <- bwtlist[[(j2-1)*norder*nvar+(i2-1)*nvar+ivar]]
                bbasisij2    <- getbasis(blistij2[[1]])
                bbasismatij2 <- getbasismatrix(tx, bbasisij2)
                weightij22   <- yprod[,i1,j1,i2,j2]
                Cprod <-
                    trapzmat(bbasismatij1,bbasismatij2,deltax,weightij22)
                mij21 <- mij22 + 1
                mij22 <- mij22 + bbasisij2$nbasis
                indexij2 <- mij21:mij22
                cmat[indexij1,indexij2] <- Cprod
            }
            #  add roughness penalty matrix to diagonal entries
            if (blistij1[[3]] > 0.0) {
                Lfdobj <- blistij1[[4]]
                penmat <- blistij1[[3]]*eval.penalty(bbasisij1, Lfdobj)
                cmat[indexij1,indexij1] <- cmat[indexij1,indexij1] + penmat
            }
        }
    }


    dvec <- -solve(cmat,dmat)

    #  set up u-function weight functions

    mi2 <- 0
    for (iu in 1:nforce) {
        alisti <- awtlist[[(iu-1)*nforce+ivar]]
        if (alisti[[2]]) {
            mi1 <- mi2 + 1
            mi2 <- mi2 + getbasis(alisti[[1]])$nbasis
            indexi <- mi1:mi2
            afdlist[[(iu-1)*nforce+ivar]] <- putcoef(dvec[indexi], alisti[[1]])
        } else {
            afdlist[[(iu-1)*nforce+ivar]] <- alisti[[1]]
        }
    }

    #  set up X-function derivative weight functions

    mij2 <- mi2
    for (m1 in 1:nvar*norder) {
        i1 <- mmat[m1,1]
        j1 <- mmat[m1,2]
        blistij <- bwtlist[[(j1-1)*norder*nvar+(i1-1)*nvar+j1]]
        if (blistij[[2]]) {
            mij1 <- mij2 + 1
            mij2 <- mij2 + getbasis(blistij[[1]])$nbasis
            indexij <- mij1:mij2
            bfdlist[[(j1-1)*nvar*nvar+(i1-1)*nvar+j1]] <- 
                                  putcoef(dvec[indexij], blistij[[1]])
        } else {
            bfdlist[[(j1-1)*nvar*nvar+(i1-1)*nvar+j1]] <- blistij[[1]]
        }
    }

}

#  --------------  end of loop through variables  -------------------

#  set up residual list RESFDLIST

resfdlist       <- list(nvar)
resfdnames[[2]] <- "Residual function"
resfdnames[[3]] <- "Residual function value"

resbasis <- getbasis(xfdlist[[1]])
for (ivar in 1:nvar) {
    #  initialize with highest order derivative for this variable
    resmat  <- eval.fd(tx, xfdlist[[ivar]], norder)
    #  add contributions from weighted u-functions
    for (iu in 1:nforce) {
        amati    <- eval.fd(tu, afdlist[[(iu-1)*nforce+ivar]])
        umati    <- eval.fd(tu, ufdlist[[(iu-1)*nforce+ivar]])
		 if (ncurve == 1) {
			aumati <- amati*umati
		 } else {
        	aumati   <- outer((amati*umati),onesncurve)
		 }
        resmat   <- resmat + aumati
    }
    #  add contributions from weighted x-function derivatives
    for (m1 in 1:nvar*norder) {
        i1 <- mmat[m1,1]
        j1 <- mmat[m1,2]
		 if (ncurve == 1) {
			bmatij <- eval.fd(tx, bfdlist[[(j1-1)*nvar*nvar+(i1-1)*nvar+j1]])
		 } else {
        	bmatij <- outer(
                    eval.fd(tx, bfdlist[[(j1-1)*nvar*nvar+(i1-1)*nvar+j1]]),
                    onesncurve)
        }
        xmatij <- eval.fd(tx, xfdlist[[i1]], j1-1)
        resmat <- resmat + bmatij*xmatij
    }
    #  set up the functional data object
    resfdi <- data2fd(resmat, tx, resbasis)
    resfdi$names <- resfdnames
    resfdlist[[ivar]] <- resfdi
}

invisible(list(bfdlist, resfdlist, afdlist))

}

#  --------------------------------------------------------------

m2ij <- function(nrow,ncol) {
#M2IJ sets up a NROW*NCOL by 2 matrix of row-col indices associated
#  with a number of matrix entries row-wise
#  Example:  m2ij(2,3) produces
#     1     1
#     1     2
#     1     3
#     2     1
#     2     2
#     2     3
	nval <- nrow*ncol
	if (nval > 0) {
    	mmat <- cbind(c(outer(rep(1,ncol),(1:nrow))),
              	    c(outer((1:ncol),rep(1,nrow))))
	} else {
    	mmat <- NULL
	}
	return(mmat)
}
pendiagfn <- function(basisfd, nderiv) {

    nbasis  <- basisfd$nbasis
    period  <- basisfd$params[1]
    rangev  <- basisfd$rangeval
    omega   <- 2*pi/period
    halfper <- period/2
    twonde  <- 2*nderiv
    pendiag <- rep(0,nbasis)
    if (nderiv == 0) pendiag[1] <- period/2.0 else pendiag[1] <- 0
    j   <- seq(2,nbasis-1,2)
    fac <- halfper*(j*omega/2)^twonde
    pendiag[j]   <- fac
    pendiag[j+1] <- fac
    pendiag <- 2*pendiag/period
    return(pendiag)
}
plotCcaFd <- function(ccafd, overplt = FALSE, jcan = 0, flip = FALSE, ...)
{
#  Plot a functional canonical correlation analysis object cca.fd
#
#  If overplt=T  then each pair of weight functions is plotted in
#     a single plot.  The line types and colours of the
#     "x" and "y" curves respectively are specified as in plotFd   .
#  If overplt=F  then the weight functions are plotted in separate
#     plots, side by side if a command like par(mfrow=c(2,2)) is
#       used.
#
#  If jcan=0, then all the pairs of variates are plotted.  Otherwise
#     only the variates jcan are plotted (eg if jcan=1, only the leading
#     variate is plotted, if jcan=c(1,3) only the first and third.)
#
#  If flip[j] is T then the jth pair of weight functions are multiplied
#     by -1.  If flip is a scalar it is replicated to the necessary length.
#
#  Other arguments are passed to plotFd
#

#  Last modified 6 Feb 2001

  if (!(inherits(ccafd, "cca.fd"))) stop("First argument not of CCA.FD class.")

  wtfd   <- ccafd[[1]]
  wtcoef <- getcoef(wtfd)
  if (jcan[1] != 0) wtcoef <- wtcoef[, jcan,  , drop = FALSE]
  wtcoef <- aperm((-1)^flip * aperm(wtcoef, c(3, 2, 1)), c(3, 2, 1))
  if (overplt) {
    wtcoef <- aperm(wtcoef, c(1, 3, 2))
    wtfd[[1]] <- wtcoef
    templabs <- wtfd$fdnames[[3]]
    wtfd$fdnames[[3]] <- wtfd$fdnames[[2]]
    wtfd$fdnames[[2]] <- templabs
    plot(wtfd, ylab = "Weight function", ...)
  } else {
    ncan <- dim(wtcoef)[2]
    for (jj in (1:ncan)) {
      wtfdtemp <- wtfd
      wtfdtemp[[1]] <- wtfdtemp[[1]][, jj,  , drop = FALSE]
      plot(wtfdtemp, ylab = "Weight function",
           sub = dimnames(wtfdtemp[[1]])[[2]], ...)
    }
  }
  invisible()
}
plotFd <- function(fd, Lfd=0, matplt=TRUE, href=TRUE, nx=101,
                    xlab=xlabel, ylab=ylabel, 
                    xlim=rangex, ylim=rangey, ...)
{
  #  Plot a functional data object FD.
  #  Arguments:
  #  FD     ... a functional data object
  #  LFD    ... linear differental operator to be applied to FD before
  #             plotting
  #  MATPLT ... If T, all curves are plotted in a single plot.
  #             Otherwise, each curve is plotted separately, and the
  #             next curve is plotted when the mouse is clicked.
  #  HREF   ... If T, a horizontal dotted line through 0 is plotted.
  #  NX     ... The number of sampling points to use for
  #             plotting.  (default 101)
  #  The remaining optional arguments are the same as those available
  #     in the regular 'plot' function.

  #  Note that for multivariate FD, a suitable matrix of plots
  #    must be set up before calling plot by using something such as
  #    par(mfrow=c(1,nvar),pty='s')

  #  Last modified 4 July 2001

  if (!(inherits(fd, "fd"))) stop('First argument is not a functional data object.')
  if (!is.Lfd(Lfd)) stop(
      "Second argument is not a linear differential operator.")

  coef   <- getcoef(fd)
  coefd  <- dim(coef)
  ndim   <- length(coefd)
  nbasis <- coefd[1]
  nrep   <- coefd[2]
  if (ndim > 2) nvar <- coefd[3] else nvar <- 1

  basisfd <- getbasis(fd)
  rangex  <- basisfd$rangeval
  x       <- seq(rangex[1],rangex[2],length=nx)
  fdmat   <- eval.fd(x, fd, Lfd)
  rangey  <- range(c(fdmat))

  xlabel   <- names(fd$fdnames)[[1]]
  ylabel   <- names(fd$fdnames)[[3]]
  if (is.character(xlabel) == FALSE) xlabel <- ''
  if (is.character(ylabel) == FALSE) ylabel <- ''
  crvnames <- fd$fdnames[[2]]
  varnames <- fd$fdnames[[3]]

  if (ndim < 2) {
    plot (x, fdmat, type='l', xlim=xlim, ylim=ylim, 
          xlab=xlab, ylab=ylab, ...)
    if (zerofind(fdmat) && href) abline(h=0,lty=2)
  }
  if (ndim ==2 ) {
    if (matplt) {
      matplot (x, fdmat, type='l', xlim=xlim, ylim=ylim, 
           xlab=xlab, ylab=ylab, ...)
      if (zerofind(fdmat) && href) abline(h=0,lty=2)
    } else  {
      for (irep in 1:nrep) {
        plot (x, fdmat[,irep], type='l', xlim=xlim, ylim=ylim, 
                xlab=xlab, ylab=ylab,
                main=paste('Curve',irep,crvnames[irep]),...)
        if (zerofind(fdmat[,irep]) && href) abline(h=0,lty=2)
        mtext('Click to advance to next set of plots',side=3,line=-3,outer=TRUE)
        text(locator(1),'')
      }
    }
  }
  if (ndim == 3) {
    if (matplt) {
      for (ivar in 1:nvar) {
        matplot (x, fdmat[,,ivar], type='l', xlim=xlim, ylim=ylim, 
                 xlab=xlab, ylab=ylab,
                 main=varnames[ivar],...)
        if (zerofind(fdmat[,,ivar]) && href) abline(h=0,lty=2)
      }
    }
    if (!matplt)  {
      for (irep in 1:nrep) {
        for (ivar in 1:nvar) {
          plot (x,fdmat[,irep,ivar],type='l', xlim=xlim, ylim=ylim, 
                xlab=xlab, ylab=ylab,
                main=paste('Curve', irep, varnames[ivar]),...)
          if (zerofind(fdmat[,irep,ivar]) && href) abline(h=0,lty=2)
        }
        mtext('Click to advance to next set of plots',side=3,line=-3,outer=TRUE)
        text(locator(1),'')
      }
    }
  }
  invisible()
}

zerofind <- function(fmat)
{
  frng <- range(fmat)
  if (frng[1] <= 0 && frng[2] >= 0) zeroin <- TRUE else zeroin <- FALSE
  return(zeroin)
}
plotPcaFd <- function(pcafd, nx = 128, pointplot = TRUE, harm = 0,
                        expand = 0, cycle = FALSE, ...)
{
#
#  Plots the harmonics produced by PCA.FD.
#
#   If pointplot=T, then the harmonics are plotted as + and -
#    otherwise lines are used.  Another thing that needs doing is an
#     arrowplot option.
#
# If harm = 0 (the default) then all the computed harmonics are plotted.
#   Otherwise those in jharm are plotted.
# If expand =0 then effect of +/- 2 standard deviations of each pc are given
#   otherwise the factor expand is used.
# If cycle=T and there are 2 variables then a cycle plot will be drawn
#  If the number of variables is anything else, cycle will be ignored.
#

#  Last modified 27 June 2001

  if (!(inherits(pcafd, "pca.fd"))) stop('Argument PCAFD is not a pca.fd object.')

  harmfd  <- pcafd[[1]]
  basisfd <- getbasis(harmfd)
  rangex  <- basisfd$rangeval
  x <- seq(rangex[1], rangex[2], length = nx)
  fdmat   <- eval.fd(x, harmfd)
  meanmat <- eval.fd(x, pcafd$meanfd)
  dimfd   <- dim(fdmat)
  nharm   <- dimfd[2]
  harm <- as.vector(harm)
  if(harm[1] == 0) harm <- (1:nharm)
  if(length(dimfd) == 2) {
    for(iharm in harm) {
      if(expand == 0) fac <- sqrt(pcafd$values[iharm]) else fac <- expand
      vecharm <- fdmat[, iharm]
      pcmat <- cbind(meanmat + fac * vecharm, meanmat - fac * vecharm)
      if (pointplot) plottype <- "p" else plottype <- "l"
      percentvar <- round(100 * pcafd$varprop[iharm], 1)
      matplot(x, pcmat, lty = 2:3, pch = "+-",
              sub = paste("PCA function", iharm,
                          "(Percentage of variability", percentvar, ")"),
              col = 2:3, type = plottype, ...)
      lines(x, meanmat)
      mtext("Click to advance to next plot", side = 3, line = -3, outer = TRUE)
      text(locator(1), "")
    }
  } else {
    if(cycle && dimfd[3] == 2) {
      meanmat <- drop(meanmat)
      for(iharm in harm) {
        if(expand == 0) {
          fac <- 2 * sqrt(pcafd$values[iharm])
        } else {
          fac <- expand
        }
        matharm <- fdmat[, iharm,  ]
        mat1 <- meanmat + fac * matharm
        mat2 <- meanmat - fac * matharm
        if (pointplot) plottype <- "p" else plottype <- "l"
        percentvar <- round(100 * pcafd$varprop[iharm],1)
        matplot(cbind(mat1[, 1], mat2[, 1]),
                cbind(mat1[, 2], mat2[, 2]), lty = 2:3, pch = "+-",
                sub = paste("PCA function", iharm,
                            "(Percentage of variability", percentvar, ")"),
                            col = 2:3, type = plottype, ...)
        lines(meanmat)
        mtext("Click to advance to next plot",
              side = 3, line = -3, outer = TRUE)
        text(locator(1), "")
      }
    } else {
      for (iharm in harm) {
        if (expand == 0) fac <- sqrt(pcafd$values[iharm]) else fac <- expand
        meanmat <- drop(meanmat)
        matharm <- fdmat[, iharm,  ]
        nvar    <- dim(matharm)[2]
        for (jvar in 1:nvar) {
          pcmat <- cbind(meanmat[, jvar] + fac * matharm[, jvar],
                         meanmat[, jvar] - fac * matharm[, jvar])
          if (pointplot) plottype <- "p" else plottype <- "l"
          percentvar <- round(100 * pcafd$varprop[iharm], 1)
          matplot(x, pcmat, lty = 2:3, pch = "+-",
                  sub = paste("PCA function", iharm,
                              "(Percentage of variability", percentvar,")"),
                  main = dimnames(fdmat)[[3]][jvar],
                  col = 2:3, type = plottype, ...)
          lines(x, meanmat[, jvar])
        }
        mtext("Click to advance to next set of plots",
              side = 3, line = -3, outer = TRUE)
        text(locator(1), "")
      }
    }
  }
  invisible()
}
plotfit.fd <- function(y, argvals, fd, rng = rangeval, index = 1:nrep, nfine = 101, residual = FALSE, sortwrd = FALSE) 
{
	#PLOTFIT plots discrete data along with a functional data object for fitting the
	#  data.  It is designed to be used after DATA2FD, SMOOTH.FD or SMOOTH.BASIS to
	#  check the fit of the data offered by the FD object.
	#  Arguments:
	#  Y        ... the data used to generate the fit
	#  ARGVALS  ... discrete argument values associated with data
	#  FD       ... a functional data object for fitting the data
	#  RNG      ... a range of argument values to be plotted
	#  INDEX    ... an index for plotting subsets of the curves (either sorted or not)
	#  NFINE    ... number of points to use for plotting curves
	#  RESIDUAL ... if T, the residuals are plotted instead of the data plus curve
	#  SORTWRD  ... sort plots by mean square error
	
	#  Last modified 4 July 2001
	
   if (!(inherits(fd, "fd"))) stop('Third argument is not a functional data object.')

	basis    <- getbasis(fd)
	rangeval <- basis$rangeval
	
	coef  <- getcoef(fd)
	coefd <- dim(coef)
	ndim  <- length(coefd)
	
	y <- as.array(y)
	n <- dim(y)[1]
		
	dimnames(y) <- NULL
	if (ndim < 2) nrep <- 1 else nrep <- coefd[2]
	if (ndim < 3) nvar <- 1 else nvar <- coefd[3]
	dim(y) <- c(n, nrep, nvar)
	
	curveno <- 1:nrep
	
	fdnames <- fd$fdnames
	argname <- names(fdnames)[1]
	if (nrep == 1) casenames <- names(fdnames)[2] else casenames <- fdnames[[2]]
	if (nvar == 1) varnames  <- names(fdnames)[3] else varnames  <- fdnames[[3]]
	if (is.null(argname)) argname <- "Argument Value"
	if (is.null(casenames) || length(casenames) != nrep) casenames <- as.character(1:nrep)
	if (is.null( varnames) || length( varnames) != nvar) varnames  <- as.character(1:nvar)

	#  compute fitted values for evalargs and fine mesh of values
	
	yhat   <- array(eval.fd(argvals, fd),c(n,nrep,nvar))
	res    <- y - yhat
	MSE    <- apply(res^2,c(2,3),mean)
	MSEsum <- apply(MSE,1,sum)
	
	#  compute fitted values for fine mesh of values
	
	xfine <- seq(rng[1], rng[2], len=nfine)
	yfine <- array(eval.fd(xfine, fd),c(nfine,nrep,nvar))
	
	#  sort cases by MSE if desired
	
	if (sortwrd && nrep > 1) {
		MSEind <- order(MSEsum)
		y      <- y    [,MSEind,]
		yhat   <- yhat [,MSEind,]
		yfine  <- yfine[,MSEind,]
		res    <- res  [,MSEind,]
		MSE    <- MSE  [ MSEind,]
		casenames  <- casenames[MSEind]
		dim(y)     <- c(n,    nrep,nvar)
		dim(yhat)  <- c(n,    nrep,nvar)
		dim(yfine) <- c(nfine,nrep,nvar)
		dim(res)   <- c(n,    nrep,nvar)
		dim(MSE)   <- c(      nrep,nvar)
	}
	
	#  set up fit and data as 3D arrays, selecting curves in INDEX
	
	y     <- y    [,index,]
	yhat  <- yhat [,index,]
	res   <- res  [,index,]
	yfine <- yfine[,index,]
	MSE   <- MSE  [ index,]
	casenames <- casenames[index]
	nrep  <- length(index)
	dim(y)     <- c(n,    nrep,nvar)
	dim(yhat)  <- c(n,    nrep,nvar)
	dim(res)   <- c(n,    nrep,nvar)
	dim(yfine) <- c(nfine,nrep,nvar)
	dim(MSE)   <- c(      nrep,nvar)
	
	#  select values in ARGVALS, Y, and YHAT within RNG
	
	argind    <- argvals >= rng[1] & argvals <= rng[2]
	argvals   <- argvals[argind]
	casenames <- casenames[argind]
	y    <- y   [argind,,]
	yhat <- yhat[argind,,]
	res  <- res [argind,,]
	n    <- length(argvals)
	dim(y)    <- c(n,nrep,nvar)
	dim(yhat) <- c(n,nrep,nvar)
	dim(res)  <- c(n,nrep,nvar)
	
	xfiind <- xfine >= rng[1] & xfine <= rng[2]
	xfine  <- xfine[xfiind]
	yfine  <- yfine[xfiind,,]
	nfine  <- length(xfine)
	dim(yfine) <- c(nfine,nrep,nvar)
		
	#  plot the results
	
	if (residual) {
		#  plot the residuals
		ylimit <- range(res)
	    for (i in 1:nrep) for (j in 1:nvar) {
		    plot(argvals, res[,i,j], xlim=rng, ylim=ylimit,
		          xlab=argname, ylab=paste("Residual for",varnames[j]),
		          main=paste("Case",casenames[i],
		                     "  RMS residual =",round(sqrt(MSE[i,j]),3)))
		    abline(h=0, lty=2)
           mtext("Click to advance to next plot",
                    side = 3, line = -3, outer = TRUE)
		    text(locator(1),"")
	    }			
	} else {
		#  plot the data and fit
		ylimit <- range(c(c(y),c(yfine)))
	    for (i in 1:nrep) for (j in 1:nvar) {
		    plot(argvals, y[,i,j], type="p", xlim=rng, ylim=ylimit, col=1,
		          xlab=argname, ylab=varnames[j],
		          main=paste("Case",casenames[i],
		                     "  RMS residual =",round(sqrt(MSE[i,j]),3)))
		    lines(xfine, yfine[,i,j], col=1)
           mtext("Click to advance to next plot",
                    side = 3, line = -3, outer = TRUE)
		    text(locator(1),"")
	    }			
	}
}
plotscores <- function(pcafd, scores = c(1, 2), xlab = NULL, ylab = NULL,
                       loc = 1, matplt2 = FALSE, ...)
{
#
#   Plot a scatter plot of the pca scores from a pca.fd object
#   If loc >0, you can then click on the plot in loc places and you'll get
#    plots of the functions with these values of the principal component
#    coefficients.
#
#  The present implementation doesn't work for multivariate functional data
#
#    pcafd      a pca.fd object
#    scores     a two dimensional vector giving the indices of the two
#                  scores to be plotted; if scores is a single number then
#                  that score will be plotted against component 1; the default
#                  is to print the first two components.
#    xlab, ylab   labels for the principal components scores scatterplot
#    loc   if an integer, the number of sample functions to be plotted.
#                  This number of clicks on the first plot are needed.
#      if a list with components x and y, the coordinates of the
#         functions to be plotted (the output from a previous call
#                  of plotscores, for instance).  No prompting will be done.
#               if 0 or NULL nothing is plotted beyond the scatterplot.
#
#    matplt2    the matplt value for the plot of the sample functions;
#               if matplt=T, the curves are plotted on the same plot;
#               if matplt=F, they are plotted separately.
#
#   ...         arguments to be passed to the pc scores scatterplot
#
#  RETURNS:   a list containing the PC scores of the plotted functions

#  Last modified 4 July 2001

   if (!(inherits(pcafd, "pca.fd"))) stop('Argument PCAFD is not a pca.fd object.')

   if(length(scores) == 1) scores <- c(1, scores)
   if(length(scores) != 2)
      scores <- c(1, 2)
   if(max(scores) > dim(pcafd$harmonics$coefs)[2]) {
      stop(paste("The pca.fd object does not contain ", max(scores),
         "components"))
   }
   if(is.null(xlab))
      xlab <- paste("PCA score ", scores[1])
   if(is.null(ylab))
      ylab <- paste("PCA score ", scores[2])
   plot(pcafd$scores[, scores], xlab = xlab, ylab = ylab, ...)
   if(is.list(loc))
      zz <- loc
   else {
      if(is.na(loc) || is.null(loc) || loc == 0)
         return(NULL)
      zz <- locator(loc)
   }
   zzmat <- rbind(zz$x, zz$y)
   coefs <- pcafd$meanfd$coefs %*% rep(1, dim(zzmat)[2]) + pcafd$harmonics$
      coefs[, scores] %*% zzmat
   fdnames <- pcafd$meanfd$fdnames
   fdnames[[2]] <- paste("Score", scores[1], "=", signif(zz$x, 2),
      "; Score", scores[2], "=", signif(zz$y, 2))
   names(fdnames)[2] <- "Sample function"
   names(fdnames)[3] <- "Function value"
   fd <- create.fd(coefs, pcafd$meanfd$basis, fdnames)
   plot(fd, matplt = matplt2)
   return(zz)
}
polintmat <- function(xa, ya, x) {
#  Polynomial extrapolion for a converging sequence
#  YA is an 3-D array with 1st D same as XA
  n     <- length(xa)
  dimya <- dim(as.array(ya))
  if (length(dimya) == 1) ya <- array(ya,c(dimya[1],1,1))
  if (length(dimya) == 2) ya <- array(ya,c(dimya[1],dimya[2],1))
  if (dimya[1] != n)      stop('First dimension of YA must match XA')
  difx <- xa - x
  absxmxa <- abs(difx)
  ns <- min((1:n)[absxmxa == min(absxmxa)])
  cs <- ds <- ya
  y  <- ya[ns,,]
  ns <- ns - 1
  for (m in 1:(n-1)) {
    for (i in 1:(n-m)) {
      ho      <- difx[i]
      hp      <- difx[i+m]
      w       <- (cs[i+1,,] - ds[i,,])/(ho - hp)
      ds[i,,] <- hp*w
      cs[i,,] <- ho*w
    }
    if (2*ns < n-m) {
      dy <- cs[ns+1,,]
    } else {
      dy <- ds[ns,,]
      ns <- ns - 1
    }
    y <- y + dy
  }
  return( list(y, dy) )
}
polyg <- function(x, argvals, nderiv=0)
{
#  Evaluates the basis for a linear interpolant or its first derivative.
#  It calls function spline.des.
#  Arguments are as follows:
#  X      ... array of values at which the spline functions are to
#             evaluated
#  ARGVAL ... a STRICTLY INCREASING sequence of argument values.
#  NDERIV ... Either 0 or 1.  0 means only function values
#             are returned; 1 means derivative values are returned
#  Return is a matrix with length(X) rows and number of columns equal to
#             number of argument values

#  last modified 8 June 1999

  x <- as.vector(x)
  n <- length(x)

  if (!is.array(argvals)) argvals <- as.array(argvals)
  if (length(dim(argvals)) != 1) stop(
     'ARGVALS is not a vector or 1-dim. array.')
  if ( (max(x) > max(argvals)) || (min(x) < min(argvals)) ) stop(
     'ARGVALS do not span the values of X.')

  nargvals <- length(argvals)
  if (min(diff(argvals)) <= 0 ) stop(
     'Break-points are not strictly increasing')

  if (!(nderiv == 0 | nderiv == 1)) stop(
     'NDERIV is neither 0 nor 1.')
  derivs    <- rep(nderiv,n)
  nbasis <- length(argvals)

  knots <- c(argvals[1], argvals, argvals[nbasis])
  basismat <- spline.des(knots, x, 2, derivs)$design

  return (basismat)
}
polygpen <- function(basisfd, Lfd=1)
{

#  Computes the polygonal penalty matrix.
#  Arguments:
#  BASISFD   ... a basis.fd object of type "bspline"
#  LFD ... either the order of derivative or a
#          linear differential operator to be penalized.
#          The highest derivative must be either 0 or 1.
#  Returns the penalty matrix.

#  Last modified 5 December 2001

if (!(inherits(basisfd, "basis.fd"))) stop(
    "First argument is not a basis.fd object.")

type <- getbasistype(basisfd)
if (type != "polyg") stop("BASISFD not of type polyg")

#  Find the highest order derivative in LFD

if (is.numeric(Lfd)) {
    if (length(Lfd) == 1) {
      	nderiv <- Lfd
      	if (nderiv != as.integer(nderiv)) {
        	stop("Order of derivative must be an integer")
      	}
      	if (nderiv < 0) {
        	stop("Order of derivative must be 0 or positive")
      	}
    } else {
      	stop("Order of derivative must be a single number")
    }
    if (nderiv < 0) stop ("Order of derivative cannot be negative")
} else if (inherits(Lfd, "fd")) {
   	derivcoef <- getcoef(Lfd)
   	if (length(dim(derivcoef))==3) derivcoef <- derivcoef[,,1]
   	nderiv <- dim(derivcoef)[2] - 1
   	if (nderiv < 0) {
   		stop("Order of derivative must be 0 or positive")
   	}
    nderiv <- ncol(derivcoef)
} else {
    stop("Second argument must be an integer or a functional data object")
}

if (nderiv > 1) stop(
    "Derivative greater than 1 cannot be taken for polygonal basis.")

if (is.numeric(Lfd)) {
    args    <- basisfd$params
    n       <- length(args)
    argdiff <- diff(args)
    penaltymatrix <- diag(rep(1,n))
    if (Lfd == 0) {
      	penaltymatrix[1,1] <- argdiff[  1]/3
      	penaltymatrix[n,n] <- argdiff[n-1]/3
      	indx <- 2:(n-1)
      	diag(penaltymatrix[indx  ,indx  ]) <- (argdiff[indx]+argdiff[indx-1])/3
      	indx <- 2:n
      	diag(penaltymatrix[indx  ,indx-1]) <- argdiff/6
      	diag(penaltymatrix[indx-1,indx  ]) <- argdiff/6
    } else {
      	argdiff <- 1/argdiff
      	penaltymatrix[1,1] <- argdiff[  1]
      	penaltymatrix[n,n] <- argdiff[n-1]
      	indx <- 2:(n-1)
      	diag(penaltymatrix[indx,  indx  ]) <- argdiff[ind]+argdiff[ind-1]
      	indx <- 2:n
      	diag(penaltymatrix[indx  ,indx-1]) <- -argdiff
      	diag(penaltymatrix[indx-1,indx  ]) <- -argdiff
    }
} else {
    penaltymatrix <- inprod(basisfd, basisfd, Lfd, Lfd)
}

return( penaltymatrix )
}
polynom <- function (x, norder=1, nderiv=0, ctr=midrange)
{
#  This computes values of the polynomials,
#        P_l(x) = (x-ctr)^l, l=0,...,NORDER-1
#  or their derivatives.
#  The degree of the highest order polynomial is one less than NORDER.
#  The default is the constant function.

#  Arguments are as follows:
#  X      ... array of values at which the polynomials are to
#             evaluated
#  NORDER ... highest degree plus one
#  NDERIV ... highest order derivative.  0 means only function values
#             are returned.
#  CTR    ... a constant shift that helps to keep the polynomials from
#             getting too ill-conditioned.  A good choice is the mid-range.
#  Return is a matrix with length(X) rows and NORDER columns containing
#  the values of the polynomials

#  last modified 8 June 1999

  x        <- as.vector(x)
  n        <- length(x)
  ndegree  <- norder - 1
  if (nderiv > ndegree) stop('NDERIV exceeds highest degree of polynomial.')
  rangex   <- range(x)
  midrange <- mean(rangex)
  lfac <- 1
  if (nderiv > 1) for (l in 2:nderiv) lfac <- lfac*l
  polyval <- matrix(0,n,norder)
  polyval[,nderiv+1] <- lfac
  if (norder > nderiv+1)
    for (l in (nderiv+2):norder)
       polyval[,l] <- polyval[,l-1]*(x-ctr)*(l-1)/(l-nderiv-1)
  return (polyval)
}
polynompen <- function(basisfd, Lfd=2)
{

#  Computes the polynomial penalty matrix for polynomials of the form
#      (x-ctr)^l
#  Arguments:
#  BASISFD   ... a basis.fd object of type "poly"
#  LFD ... either the order of derivative or a
#           nonhomogeneous linear differential operator to be penalized.
#  Returns the penalty matrix.

#  Last modified 5 December 2001

if (!(inherits(basisfd, "basis.fd"))) stop(
    "First argument is not a basis.fd object.")

type <- getbasistype(basisfd)
  if (type != "poly") stop("BASISFD not of type poly")

#  Find the highest order derivative in LFD

if (is.numeric(Lfd)) {
    if (length(Lfd) == 1) {
      	nderiv <- Lfd
      	if (nderiv != as.integer(nderiv)) {
        	stop("Order of derivative must be an integer")
      	}
      	if (nderiv < 0) {
        	stop("Order of derivative must be 0 or positive")
      	}
    } else {
      	stop("Order of derivative must be a single number")
    }
    if (nderiv < 0) stop ("Order of derivative cannot be negative")
} else if (inherits(Lfd, "fd")) {
   	derivcoef <- getcoef(Lfd)
   	if (length(dim(derivcoef))==3) derivcoef <- derivcoef[,,1]
   	nderiv <- dim(derivcoef)[2] - 1
   	if (nderiv < 0) {
   		stop("Order of derivative must be 0 or positive")
   	}
    nderiv <- ncol(derivcoef)
} else {
    stop("Second argument must be an integer or a functional data object")
}

#  Compute penalty matrix

if (is.numeric(Lfd)) {
    nbasis   <- basisfd$nbasis
    rangex   <- basisfd$rangeval
    ctr      <- basisfd$params[1]
    basismat <- getbasismatrix(rangex, basisfd, nderiv)
    penmatl  <- outer(basismat[1,],basismat[1,])*(rangex[1] - ctr)
    penmatu  <- outer(basismat[2,],basismat[2,])*(rangex[2] - ctr)
    penaltymatrix <- matrix(0,nbasis,nbasis)
    for (i in (nderiv+1):nbasis) for (j in (nderiv+1):i) {
      	penaltymatrix[i,j] <- (penmatu[i,j] - penmatl[i,j])/(i + j - 2*nderiv - 1)
      	penaltymatrix[j,i] <- penaltymatrix[i,j]
    }
} else {
    penaltymatrix <- inprod(basisfd, basisfd, Lfd, Lfd)
}

  return( penaltymatrix )
}
posfd <- function(y, argvals, Wfdobj, Lfd=3, lambda=0, conv=1e-4, iterlim=20, dbglev=1) {
# POSFD estimates a positive function fitting a sample of scalar observations.

#  Arguments are:
#  Y        array of argument values
#  ARGVALS  array of function values
#  WFDOBJ   functional data basis object defining initial density
#  LFD      linear differential operator defining roughness penalty
#  LAMBDA   smoothing parameter
#  CONV     convergence criterion
#  ITERLIM  iteration limit for scoring iterations
#  DBGLEV   level of output of computation history

#  Returns:
#  WFDOBJ    functional data basis object defining final smooth function.
#  FLIST      Struct object containing
#               FLIST$f     final log likelihood
#               FLIST$norm  final norm of gradient
#  ITERNUM   Number of iterations
#  ITERHIST  History of iterations

#  last modified 10 February 2003

   if (!(inherits(Wfdobj, "fd")))
		stop("Argument WFD not a functional data object.")

	basis  <- Wfdobj$basis
	nbasis <- basis$nbasis
	rangex <- basis$rangeval

	N  <- length(argvals)
	if (length(y) != N) stop("ARGVALS and Y are not of the same length.")
	
	#  check for argument values out of range
	
	inrng <- (1:N)[argvals >= rangex[1] & argvals <= rangex[2]]
	if (length(inrng) != N)
    	warning("Some values in argvals out of range and not used.")

	argvals <- argvals[inrng]
	y       <- y[inrng]
	nobs    <- length(argvals)

	#  set up some arrays

	climit  <- c(rep(-50,nbasis),rep(400,nbasis))
	cvec0   <- getcoef(Wfdobj)
	hmat    <- matrix(0,nbasis,nbasis)
	active  <- 1:nbasis
	dbgwrd  <- dbglev > 1

	#  initialize matrix Kmat defining penalty term

	if (lambda > 0)
	  	Kmat <- lambda*getbasispenalty(basis, Lfd)

	#  evaluate log likelihood
	#    and its derivatives with respect to these coefficients

	result <- loglfnpos(argvals, y, basis, cvec0)
	logl   <- result[[1]]
	Dlogl  <- result[[2]]

	#  compute initial badness of fit measures

	f0    <- -logl
	gvec0 <- -Dlogl
	if (lambda > 0) {
   		gvec0 <- gvec0 + 2*(Kmat %*% cvec0)
   		f0 <- f0 + t(cvec0) %*% Kmat %*% cvec0
	}
	Foldstr <- list(f = f0, norm = sqrt(mean(gvec0^2)))

	#  compute the initial expected Hessian

	hmat0 <- Varfnpos(argvals, basis, cvec0)
	if (lambda > 0) hmat0 <- hmat0 + 2*Kmat

	#  evaluate the initial update vector for correcting the initial bmat

	deltac   <- -solve(hmat0,gvec0)
	cosangle <- -sum(gvec0*deltac)/sqrt(sum(gvec0^2)*sum(deltac^2))

	#  initialize iteration status arrays

	iternum <- 0
	status <- c(iternum, Foldstr$f, -logl, Foldstr$norm)
	cat("Iteration  Criterion  Neg. Log L  Grad. Norm\n")
	cat("      ")
	cat(format(iternum))
	cat("    ")
	cat(format(status[2:4]))
	cat("\n")
	iterhist <- matrix(0,iterlim+1,length(status))
	iterhist[1,]  <- status
	if (iterlim == 0) {
    	Flist     <- Foldstr
    	iterhist <- iterhist[1,]
		return( list("Wfdobj"=Wfdobj, "Flist"=Flist, 
			          "iternum"=iternum, "iterhist"=iterhist) )
	} else {
		gvec <- gvec0
		hmat <- hmat0
	}

	#  -------  Begin iterations  -----------

	STEPMAX <- 5
	MAXSTEP <- 400
	trial   <- 1
	cvec    <- cvec0
	linemat <- matrix(0,3,5)

	for (iter in 1:iterlim) {
   		iternum <- iternum + 1
	   	#  take optimal stepsize
   		dblwrd <- c(0,0)
		limwrd <- c(0,0)
		stpwrd <- 0
		ind    <- 0
	   	#  compute slope
      	Flist <- Foldstr
      	linemat[2,1] <- sum(deltac*gvec)
      	#  normalize search direction vector
      	sdg     <- sqrt(sum(deltac^2))
      	deltac  <- deltac/sdg
      	dgsum   <- sum(deltac)
      	linemat[2,1] <- linemat[2,1]/sdg
      	#  return with stop condition if (initial slope is nonnegative
      	if (linemat[2,1] >= 0) {
        	print("Initial slope nonnegative.")
        	ind <- 3
        	iterhist <- iterhist[1:(iternum+1),]
        	break
      	}
      	#  return successfully if (initial slope is very small
      	if (linemat[2,1] >= -1e-5) {
        	if (dbglev>1) print("Initial slope too small")
        	iterhist <- iterhist[1:(iternum+1),]
        	break
      	}
      	linemat[1,1:4] <- 0
      	linemat[2,1:4] <- linemat[2,1]
      	linemat[3,1:4] <- Foldstr$f
      	stepiter  <- 0
      	if (dbglev > 1) {
			cat("              ")
			cat(format(stepiter))
			cat(format(linemat[,1]))
			cat("\n")
		}
      	ips <- 0
      	#  first step set to trial
      	linemat[1,5]  <- trial
      	#  Main iteration loop for linesrch
      	for (stepiter in 1:STEPMAX) {
        	#  ensure that step does not go beyond limits on parameters
        	limflg  <- 0
        	#  check the step size
        	result <- stepchk(linemat[1,5], cvec, deltac, limwrd, ind,
                            climit, active, dbgwrd)
			linemat[1,5] <- result[[1]]
			ind          <- result[[2]]
			limwrd       <- result[[3]]
       	if (linemat[1,5] <= 1e-9) {
          		#  Current step size too small  terminate
          		Flist    <- Foldstr
          		cvecnew <- cvec
          		gvecnew <- gvec
          		if (dbglev > 1) print(paste("Stepsize too small:", linemat[1,5]))
          		if (limflg) ind <- 1 else ind <- 4
          		break
        	}
        	cvecnew <- cvec + linemat[1,5]*deltac
        	#  compute new function value and gradient
			result <- loglfnpos(argvals, y, basis, cvecnew)
			logl  <- result[[1]]
			Dlogl <- result[[2]]
        	Flist$f  <- -logl
        	gvecnew <- -Dlogl
        	if (lambda > 0) {
            	gvecnew <- gvecnew + 2*Kmat %*% cvecnew
            	Flist$f <- Flist$f + t(cvecnew) %*% Kmat %*% cvecnew
        	}
        	Flist$norm <- sqrt(mean(gvecnew^2))
        	linemat[3,5] <- Flist$f
        	#  compute new directional derivative
        	linemat[2,5] <- sum(deltac*gvecnew)
      		if (dbglev > 1) {
				cat("              ")
				cat(format(stepiter))
				cat(format(linemat[,1]))
				cat("\n")
			}
        	#  compute next step
			result <- stepit(linemat, ips, ind, dblwrd, MAXSTEP, dbgwrd)
			linemat <- result[[1]]
			ips     <- result[[2]]
			ind     <- result[[3]]
			dblwrd  <- result[[4]]
        	trial   <- linemat[1,5]
        	#  ind == 0 implies convergence
        	if (ind == 0 | ind == 5) break
        	#  end of line search loop
     	}

     	cvec <- cvecnew
     	gvec <- gvecnew
	  	Wfdobj <- putcoef(cvec, Wfdobj)
     	status <- c(iternum, Flist$f, -logl, Flist$norm)
     	iterhist[iter+1,] <- status
		cat("      ")
		cat(format(iternum))
		cat("    ")
		cat(format(status[2:4]))
		cat("\n")
     	#  test for convergence
     	if (abs(Flist$f-Foldstr$f) < conv) {
       	iterhist <- iterhist[1:(iternum+1),]
			return( list("Wfdobj"=Wfdobj, "Flist"=Flist, 
			             "iternum"=iternum, "iterhist"=iterhist) )
     	}
     	if (Flist$f >= Foldstr$f) break
     	#  compute the Hessian
     	hmat <- Varfnpos(argvals, basis, cvec)
     	if (lambda > 0) hmat <- hmat + 2*Kmat
     	#  evaluate the update vector
     	deltac <- -solve(hmat,gvec)
     	cosangle  <- -sum(gvec*deltac)/sqrt(sum(gvec^2)*sum(deltac^2))
     	if (cosangle < 0) {
       	if (dbglev > 1) print("cos(angle) negative")
       	deltac <- -gvec
     	}
     	Foldstr <- Flist
		#  end of iterations
  	}
	#  compute final normalizing constant
	return( list("Wfdobj"=Wfdobj, "Flist"=Flist, 
			      "iternum"=iternum, "iterhist"=iterhist) )
}

#  ---------------------------------------------------------------

loglfnpos <- function(argvals, y, basis, cvec) {
	#  Computes the log likelihood and its derivative with
	#    respect to the coefficients in CVEC
   	N       <- length(argvals)
   	nbasis  <- basis$nbasis
   	phimat  <- getbasismatrix(argvals, basis)
	Wvec    <- phimat %*% cvec
	EWvec   <- exp(Wvec)
	res     <- y - EWvec
   	logl    <- -mean(res^2)
  	Dlogl   <- 2*crossprod(phimat,res*EWvec)/N
	return( list(logl, Dlogl) )
}

#  ---------------------------------------------------------------

Varfnpos <- function(argvals, basis, cvec) {
	#  Computes the expected Hessian
   	N       <- length(argvals)
   	nbasis  <- basis$nbasis
   	phimat  <- getbasismatrix(argvals, basis)
	Wvec    <- phimat %*% cvec
	EWvec   <- exp(Wvec)
	res     <- y - EWvec
	Dres    <- ((res*EWvec) %*% matrix(1,1,nbasis)) * phimat
  	D2logl  <- 2*crossprod(Dres)/N
	return(D2logl)
}
	

powerbasis <- function(x, exponents, nderiv=0) {
#POWERBASIS computes values of monomials, or their derivatives.
#  The powers of X are the NBASIS nonnegative integers in EXPONENTS.
#  The default is 1, meaning X itself.
#  Arguments are as follows:
#  X         ... vector of values at which the polynomials are to
#                evaluated
#  EXPONENTS ... vector of exponents
#  NDERIV    ... order of derivative to be returned.
#  Return is:
#  A matrix with length(X) rows and NBASIS columns containing
#    the values of the monomials or their derivatives

#  last modified 13 December 2002

	x <- as.vector(x)
	n <- length(x)

	nbasis <- length(exponents)

	powermat <- matrix(0,n,nbasis)
	if (nderiv == 0) {
    	for (ibasis in 1:nbasis)
        	powermat[,ibasis] <- x^exponents[ibasis]
	} else {
    	if (any(exponents - nderiv < 0) && any(x == 0)) {
        	stop("A negative exponent is needed and an argument value is 0.")
    	} else {
        	for (ibasis in 1:nbasis) {
            	degree <- exponents[ibasis]
            	if (nderiv <= degree) {
                	fac <- degree
                	for (ideriv in 2:nderiv) {
                    	fac <- fac*(degree-ideriv+1)
                	}
                	powermat[,ibasis] <- fac*x^(degree-nderiv)
            	}
        	}
    	}
	}
	return(powermat)
}
powerpen <- function(basisobj, Lfd=2) {
#  POWERPEN  Computes the power bais penalty matrix.
#  Arguments:
#  BASISFD  ... a monomial basis object
#  Lfd     ... either the order of derivative or a
#               linear differential operator to be penalized.
#  Returns a list the first element of which is the basis matrix
#   and the second element of which is the diagonal of the penalty matrix.

#  Last modified:  13 December 2002

	if (!(inherits(basisfd, "basis.fd"))) stop(
    	"First argument is not a basis.fd object.")

  	type <- getbasistype(basisobj)
  	rang <- basisobj$rangeval
  	if (type != "power") stop("BASISOBJ not of type POWER.")


  	exponents <- basisobj$params

  	if (!is.Lfd(Lfd))
    	stop (paste("Argument Lfd is neither a functional data object", 
             " nor an integer."))

	if (is.numeric(Lfd)) {
    	if (length(Lfd) == 1) {
      		nderiv <- Lfd
      		if (nderiv != as.integer(nderiv)) 
        		stop("Order of derivative must be an integer")
      		if (nderiv < 0) 
        		stop("Order of derivative must be 0 or positive")
    	} else {
      		stop("Order of derivative must be a single number")
    	}
    	if (nderiv < 0) 
			stop ("Order of derivative cannot be negative")

    	if (any(exponents - nderiv < 0) && rang[1] == 0)
        	stop("A negative exponent is needed and an argument value is 0.")
    	nbasis     <- basisobj$nbasis
    	penaltymat <- matrix(0,nbasis,nbasis)
    	xrange     <- basisobj$rangeval
    	for (ibasis in 1:nbasis) {
      		ideg <- exponents[ibasis]
      		if (nderiv == 0) ifac <- 1 else ifac <- ideg
			if (nderiv > 1)
				for (k in 2:nderiv) ifac <- ifac*(ideg - k + 1)
      		for (jbasis in 1:ibasis) {
        		jdeg <- exponents[jbasis]
        		if (nderiv == 0) jfac <- 1 else jfac <- jdeg
				if (nderiv > 1)
	  				for (k in 2:nderiv) jfac <- jfac*(jdeg - k + 1)
				if (ideg >= nderiv && jdeg >= nderiv) {
	  				penaltymat[ibasis,jbasis] <- ifac*jfac*  
	      				(xrange[2]^(ideg+jdeg-2*nderiv+1) -  
	       		 	 xrange[1]^(ideg+jdeg-2*nderiv+1))
	  				penaltymat[jbasis,ibasis] <- penaltymat[ibasis,jbasis]
				}
      		}
    	}
  	} else {
    	penaltymat <- inprod(basisobj, basisobj, Lfd, Lfd)
	}
	return(penaltymat)
}

printFd <- function(fd, ...)
{
  #  Prints a functional data object FD
  #  The remaining optional arguments are the same as those available
  #     in the regular "print" function.


 #  Last modified 23 March 2003

  if (inherits(fd, "fd")) {
    cat("Dimensions of data:\n")
    print(fd$fdnames)
  } else {
    stop("First argument is not a functional data object.")
  }
  cat("Coefficient Matrix:\n")
  coef <- getcoef(fd)
  print(coef)
  fbdo   <- getbasis(fd)
  type   <- fbdo$type
  params <- fbdo$params
  cat("\nBasis:\n")
  cat(paste("  Type:", type,"\n"))
  cat(paste("  Range:",fbdo$rangeval[1],"to",fbdo$rangeval[2],"\n"))
  cat(paste("  Number of basis functions:",fbdo$nbasis,"\n"))
  if (type == "fourier") cat("  Period: ")
  if (type == "bspline") cat("  Interior knots         \n")
  if (type == "expon")   cat("  Rate coefficients      \n")
  if (type == "poly")    cat("  Polynomial coefficients\n")
  if (type == "polyg")   cat("  Argument values        \n")
  cat(format(params))
  cat("\n")
}
project.basis <- function(y, argvals, basisfd, penalize=FALSE)
{
#  Arguments for this function:
#
#  Y        ... an array containing values of curves
#               If the array is a matrix, rows must correspond to argument
#               values and columns to replications, and it will be assumed
#               that there is only one variable per observation.
#               If Y is a three-dimensional array, the first dimension
#               corresponds to argument values, the second to replications,
#               and the third to variables within replications.
#               If Y is a vector, only one replicate and variable are assumed.
#  ARGVALS  ... A vector of argument values.  This must be of length
#    length(Y) if Y is a vector or dim(Y)[1] otherwise.
#  BASISFD  ... A basis.fd object
#  PENALIZE ... If T, a penalty term is used to deal with a singular
#               basis matrix.  But this is not normally needed.
#
#  Returns a coefficient vector or array. The first dimension is the number
#     of basis functions and the other dimensions (if any) match
#  the other dimensions of Y.
#

#  Last modified:  23 May 1998

#
#  Calculate the basis and penalty matrices, using the default
#   for the number of derivatives in the penalty.
#
  basismat <- getbasismatrix(argvals, basisfd)
  Bmat     <- crossprod(basismat)
  if (penalize) {
    penmat <- getbasispenalty(basisfd)
#
#  Add a very small multiple of the identity to penmat
#   and find a regularization parameter
#
    penmat <- penmat + 1e-10 * max(penmat) * diag(dim(penmat)[1])
    lambda <- (0.0001 * sum(diag(Bmat)))/sum(diag(penmat))
    Cmat <- Bmat + lambda * penmat
  } else {
    Cmat <- Bmat
  }
#
#  Do the fitting by a simple solution of the
#    equations taking into account smoothing
#
  if (is.array(y) == FALSE) y <- as.array(y)
  if(length(dim(y)) <= 2) {
    Dmat <- crossprod(basismat, y)
    coef <- symsolve(Cmat, Dmat)
  } else {
    nvar <- dim(y)[3]
    coef <- array(0, c(basisfd$nbasis, dim(y)[2], nvar))
    for(ivar in 1:nvar) {
      Dmat <- crossprod(basismat, y[,  , ivar])
      coef[,  , ivar] <- symsolve(Cmat, Dmat)
    }
  }
  return(coef)
}

#  ------------------------------------------------------------------------

ptwiseLM <- function (xfd, yfd, wbasis=xbasis, n=5*nbasisw,
                      estimate=rep(TRUE,ncoef),  constant=TRUE,
                      lambda=rep(0,ncoef), wfd0=rep(0,ncoef))
{
#  A function to compute the basis function expansion of the
#    estimate of the coefficient functions
#    for a pointwise linear model predicting the function(S)
#    in functional data object YFD from the p functions in
#    functional data object XFD.
#  The coefficient functions are expanded in terms of the
#    basis functions specified in wbasis.

#  Arguments:
#  XFD       ...  functional data object for P independent variable
#                   functions.  These must be univariate.
#  YFD       ...  functional data object for dependent variable
#                   functions
#  WBASIS    ...  basis object for regression functions.
#  N         ...  number of sampling points for numerical integration
#  ESTIMATE  ...  logical array of length P, if a value is T, the
#                 corresponding coefficient function is estimated, otherwise
#                 the target value is used.
#  CONSTANT  ...  If true, a constant function is added to the fit.
#  LAMBDA    ...  penalty parameter for penalizing the departure of the
#                 estimated weight functions from those defined in WFD0
#  WFD0      ...  A specification of a functional data object that is used for
#                 those weight functions not estimated, or as target functions
#                 toward which the estimated weight functions are smoothed. WFD0
#                 can either be a vector of NCOEF constants, or a functional
#                 data object with the same structure as WFN that is returned
#                 by this function.

#  Returns:
#  WFN       ...  estimated weight functional data object.  It has P + 1
#                 replicates if CONSTANT is T, and P otherwise

#  Last modified 6 Feb 2001

  if (!(inherits(xfd, "fd"))) stop(
       "Argument XFD not a functional data object.")
  if (!(inherits(yfd, "fd"))) stop(
       "Argument YFD not a functional data object.")

  coefx  <- as.matrix(getcoef(xfd))
  coefdx <- dim(coefx)
  ndimx  <- length(coefdx)
  ncurve <- coefdx[2]

  coefy  <- as.matrix(getcoef(yfd))
  coefdy <- dim(coefy)
  ndimy  <- length(coefdy)
  if (ndimy > 2) nvar <- coefdy[3] else nvar <- 1

  if (coefdy[2] != ncurve) stop(
      "Number of replications for XFD and YFD are not the same.")

  xbasis  <- getbasis(xfd)
  nbasisx <- xbasis$nbasis
 #nbasisx <- xbasis@nbasis
  ybasis  <- getbasis(yfd)
  nbasisy <- ybasis$nbasis
 #nbasisy <- ybasis@nbasis
  if (ndimx == 2) coefx <- array(coefx,c(nbasisx,ncurve,1))
  if (ndimx > 2) p  <- coefdx[3] else p <- 1

  typew   <- wbasis$type
  nbasisw <- wbasis$nbasis
  rangew  <- wbasis$rangeval
 #typew   <- wbasis@type
 #nbasisw <- wbasis@nbasis
 #rangew  <- wbasis@rangeval

  if (any(rangew != xbasis$rangeval)) stop(
    "Weight function range not equal to range in XFD")
 #if (any(rangew != xbasis@rangeval)) stop(
 #  "Weight function range not equal to range in XFD")

  if (typew == "bspline") {
    nbreaksw <- length(wbasis$params)
    norderw  <- nbasisw - nbreaksw
  }

  delta <- (rangew[2]-rangew[1])/(n-1)
  tfine <- seq(rangew[1],rangew[2],delta)

  yarray <- eval.fd(tfine, yfd)
  estimate <- as.logical(estimate)
  if (constant) {
    ncoef  <- length((1:(p+1))[estimate]) 
    xarray <- array(1,c(n,ncurve,p+1))
    xarray[,,2:(p+1)] <- eval.fd(tfine, xfd)
  } else {
    ncoef  <- length((1:p)[estimate])
    xarray <- eval.fd(tfine, xfd)
  }


  basismat <- getbasismatrix(tfine, wbasis)

  if (ncurve == 1) {
    DV <- -delta*yarray
    IV <- matrix(0,n,ncoef*nbasisw)
    mi <- 0
    for (i in 1:ncoef)
    {
      if(estimate[i]) {
        mi <- mi + 1
        index <- (1 + (mi-1)*nbasisw):(mi*nbasisw)
        IV[,index] <- delta*outer(xarray[,,i],rep(1,nbasisw))*basismat
      }
    }
    result <- lsfit(IV,DV,int=FALSE)
    dvec   <- result$coef
  } else {
    mi   <- 0
    mij  <- 0
    Swgt <- matrix(0,n,ncoef)
    Rwgt <- matrix(0,n,ncoef*(ncoef+1)/2)
    for (i in 1:ncoef)
    {
      if(estimate[i]) {
        mi <- mi + 1
        index <- (1 + (mi-1)*nbasisw):(mi*nbasisw)
        Swgt[,mi] <- apply(xarray[,,i]*yarray,1,mean)
        mj <- 0
        for (j in 1:i) {
          if(estimate[j]) {
	        mj <- mj + 1
            mij <- mij + 1
            Rwgt[,mij] <- apply(xarray[,,mi]*xarray[,,mj],1,mean)
          }
        }
      }
    }

    result <- SRsetup1(ncoef, nbasisw, Swgt, Rwgt, basismat)

    Cmat <- result[[2]]
    Dmat <- result[[1]]
    if (any(lambda > 0)) {
      if (!(inherits(wfd0, "fd")) && is.numeric(wfd0)) {
        if (length(wfd0) != ncoef) stop(
          "WFD0 is a vector of incorrect length")
        wcoef0 <- matrix(wfd0,nbasisw,ncoef)
        wfn0 <- create.fd(wcoef0, wbasis)
      } else {
        stop("WFN0 is neither a vector nor a FD object")
      }
      Hmat   <- getbasispenalty(wbasis)
      for (i in 1:ncoef) {
        index <- (1 + (i-1)*nbasisw):(i*nbasisw)
        if (lambda[i] > 0) {
          Cmat[index,index] <- Cmat[index,index] - lambda[i]*Hmat
          Dmat[index,1] <- Dmat[index,1] + lambda[i]*inprod(wbasis,wfn0[i])
        }
      }
    }
    dvec   <- solve(Cmat,Dmat)
  }

  dmat <- matrix(0,nbasisw,ncoef)
  mi  <- 0
  for (i in 1:ncoef)
  {
    if(estimate[i]) {
      mi <- mi + 1
      index <- (1 + (mi-1)*nbasisw):(mi*nbasisw)
      dmat[,i] <- dvec[index]
    }
  }

  wfnfd <- create.fd(dmat, wbasis)
 #wfnfd <- new("fd", coefs=dmat, basis=wbasis)
 
  return( wfnfd )
}

#  ------------------------------------------------------------------------

SRsetup1 <- function(nwgt, nbasis, Swgt, Rwgt, basismat)
{
  #  sets up coefficient matrices for basis expansion of weight functions

  Smat <- matrix(0, nwgt*nbasis, 1)
  Rmat <- matrix(0, nwgt*nbasis, nwgt*nbasis)
  n  <- nrow(Swgt)
  m1 <- ncol(basismat)
  m  <- 0
  one <- rep(1, nrow(basismat))
  for (i in 1:nwgt){
    indexi <- (1:nbasis) + (i-1)*nbasis
    temp     <- basismat * outer(Swgt[,i], rep(1,m1))
    temp[1,] <- temp[1,]/2
    temp[n,] <- temp[n,]/2
    Smat[indexi] <- crossprod(temp, one)
    for (j in 1:i) {
      m <- m + 1
      indexj <- (1:nbasis) + (j-1)*nbasis
      temp     <- basismat * outer(Rwgt[,m],rep(1,m1))
      temp[1,] <- temp[1,]/2
      temp[n,] <- temp[n,]/2
      Rmat[indexi,indexj] <- crossprod(temp, basismat)
      if (i != j) Rmat[indexj,indexi] <- Rmat[indexi,indexj]
    }
  }
  return (list(Smat, Rmat) )
}

putcoef <- function(coef, fd) {
	#  replace the coefficient matrix in a functional data object
	  
	#  Last modified 10 Feb 2003
  
  	if (inherits(fd, "fd")) {
		fd$coefs <- as.array(coef)
  	}  else {
      	stop("Argument FD is not a functional data object.")
  	}
  	return(fd)
}
rangechk <- function(rangeval) {
#  check a range vector argument

#  last modified 16 May 1999

  if (!is.vector(rangeval))       return(FALSE)
  if (length(rangeval) != 2)      return(FALSE)
  if (rangeval[1] >= rangeval[2]) return(FALSE)
  return(TRUE)
}
register <- function(x, y0, y, Dy, D2y,
                     nbreak    = 6,
                     wt        = c(0.5,rep(1, n-2),0.5),
                     breakvals = seq(x[1],x[n],length=nbreak),
                     cvec0     = rep(0,nbreak),
                     lambda    = 0,    iterlim = 20, dbglev = 1,
                     conv      = 1e-3, periodic = FALSE, critno = 2)
{

  #  This is a wrapper function for the Fortran function register.f.

  #  Arguments are:

  #  X         ...  array of N argument values
  #  Y0        ...  N by NVAR array of target function values to fit
  #  Y         ...  N by NVAR array of function values
  #                   for function to be registered
  #  DY        ...  N by NVAR array of first  derivative values
  #  D2Y       ...  N by NVAR array of second derivative values
  #  NBREAK    ...  number of break values defining the monotone warping fn.
  #                 If there is a conflict with the length of BREAKVALS,
  #                 the length of BREAKVALS will be used.
  #  WT        ...  array of length N of weights to be applied to function
  #                 values
  #  BREAKVALS ...  array of break values containing all values of X
  #  CVEC0     ...  NBREAK - 1 starting values for coefficients
  #  LAMBDA    ...  penalty parameter
  #  ITERLIM   ...  number of iteration limit
  #  DBGLEV    ...  level of output of computation history
  #  CONV      ...  convergence criterion
  #  PERIODIC  ...  if T treat the curves as periodic
  #  CRITNO    ...  if 1 least squares, if 2 log eigenvalue ratio

  #  A list is returned with the following elements:

  #  cvecstore  ... the parameters determine the transformations
  #  deltastore ... the estimated shift value for each curve is PERIODIC is T
  #  yreg       ... an array of the same size as Y of registered curve values
  #  hfun       ... warping function values, with domain and range the
  #                 same as the domain of Y

  #  check argument dimensions

  n       <- length(x)

  if (length(dim( y0)) > 2) stop(" Y0 has more than two dimensions")
  if (length(dim(  y)) > 2) stop("  Y has more than two dimensions")
  if (length(dim( Dy)) > 2) stop(" DY has more than two dimensions")
  if (length(dim(D2y)) > 2) stop("D2Y has more than two dimensions")

  y0  <- as.matrix(y0)
  y   <- as.matrix(y)
  Dy  <- as.matrix(Dy)
  D2y <- as.matrix(D2y)

  nvar <- ncol(y0)

  if (ncol(  y) != nvar) stop("  Y must have same no. cols. as Y0")
  if (ncol( Dy) != nvar) stop(" DY must have same no. cols. as Y0")
  if (ncol(D2y) != nvar) stop("D2Y must have same no. cols. as Y0")

  if (nrow(  y) != n) stop("  Y must have same no. row as Y0")
  if (nrow( Dy) != n) stop(" DY must have same no. row as Y0")
  if (nrow(D2y) != n) stop("D2Y must have same no. row as Y0")

  nbreaktemp <- length(breakvals)
  if (nbreak != nbreaktemp) nbreak <- nbreaktemp
  if (length(cvec0) != nbreak) {
       stop("BREAKVALS and CVEC0 lengths are inconsistent") }

  #  put X and BREAKVALS into the unit interval

  span      <- breakvals[nbreak] - breakvals[1]
  breaknorm <- (breakvals - breakvals[1])/span
  xnorm     <- (x         - breakvals[1])/span
  Dynorm    <- Dy*span
  D2ynorm   <- D2y*span*span

  #  check the derivatives to see if they are consistent

  for (ivar in 1:nvar) {
    ratio1 <- derivchk(xnorm,      y[,ivar],  Dynorm[,ivar])
    ratio2 <- derivchk(xnorm, Dynorm[,ivar], D2ynorm[,ivar])
#   print(c(ratio1,ratio2))
    if (ratio1 >= .3 | ratio2 >= .5) warning(
         "Derivatives appear to be inconsistent")
  }

  #  set up arrays for storing transformation values and coefficient values

  ncvec   <- nbreak-1
  ioutlev <- 0
  ier     <- 0
  iter    <- 0
  iconv   <- 0
  history <- matrix(0,2,iterlim+1)
  hfun    <- rep(0,n)
  yreg    <- y

  result <- .Fortran("register",
             as.integer(n),        as.integer(nvar),
             as.double(xnorm),     as.double(y0),
             as.double(y),         as.double(Dynorm),    as.double(D2ynorm),
             as.double(wt),
             as.integer(nbreak),   as.double(breaknorm), as.double(cvec0),
             as.integer(iterlim),  as.integer(iter),
             as.double(hfun),      as.double(yreg),
             as.double(lambda),    as.integer(periodic), as.integer(critno),
             as.double(conv),      as.integer(ioutlev),  as.integer(iconv),
             as.double(history),   as.integer(ier) )

  ier   <- result[[23]]
  if (ier != 0) stop (paste("IER =",ier))
  iconv <- result[[21]]
  if (iconv != 0) warning ("No convergence")
  if (dbglev != 0) {
    iter    <- result[[13]]
    history <- matrix(result[[22]],2,iterlim+1)[,1:(iter+1)]
    cat("Iter.  Crit.     Grad Len.\n")
    for (i in 0:iter)
     cat(format(i),"      ",format(round(history[,i+1],7)),"\n")
  }
  cvec       <- result[[11]]
  deltastore <- cvec[1]
  cvecstore  <- cvec[2:nbreak]
  hfun       <- result[[14]]
  yreg       <- matrix(result[[15]],n,nvar)

  #  compute the registered curve

  return ( list( cvecstore, deltastore, yreg, hfun ) )

}
registerfd <- function(y0fd, yfd, Wfd0, Lfdobj=2, lambda=1, 
                       conv=1e-2, iterlim=10, dbglev=1, periodic=FALSE, crit=2)
{
#REGISTERFD registers a set of curves YFD to a target function Y0FD.
#  Arguments are:
#  Y0FD    ... Functional data object for target function.  It must
#                contain a single curve, but this single curve
#                can be multivariate.
#  YFD     ... Functional data object for functions to be registered
#  WFD0    ... Functional data object for function W defining warping fns
#              Its coefficients are the starting values used in the
#                iterative computation of the final warping fns.
#                NB:  The first coefficient is is NOT used.
#                For both B-spline and Fourier bases, this first
#                coefficient determines the constant term in the expansion,
#                and, since a register function is normalized, this term
#                is, in effect, eliminated or has no influence on the
#                result.  This first position is used, however, to
#                contain the shift parameter in case the data are
#                treated as periodic.  At the end of the calculations,
#                the shift parameter is returned separately.
#  LFDOBJ  ... Linear differential operator defining roughness penalty
#                to be applied to WFD0.
#  LAMBDA  ... Smoothing parameter
#  CONV    ... Convergence criterion
#  ITERLIM  .. iteration limit for scoring iterations
#  DBGLEV  ... Level of output of computation history
#  PERIODIC .. If one, curves are periodic and a shift parameter is fit.
#              Initial value for shift parameter is taken to be 0.
#              The periodic option should ONLY be used with a Fourier
#              basis for the target function Y0FD, the functions to be
#              registered, YFD, and the functions WFD0 defining the
#              time-warping functions.
#  CRIT    ... If 1 least squares, if 2 log eigenvalue ratio.  Default is 1.
#                Default:  0
#  Returns:
#  REGSTR  ...  A list with fields
#    REGSTR$REGFD ... A functional data object for the registered curves
#    REGSTR$WFD   ... A Functional data object for function W defining
#                         warping fns
#    REGSTR$SHIFT ... Shift parameter value if curves are periodic

#  last modified 18 March 2003

#  check target function(s)

if (!(inherits(y0fd, "fd"))) 
    stop('First argument is not a functional data object.')
y0dim  <- dim(getcoef(y0fd))
ndimy0 <- length(y0dim)
if (y0dim[ndimy0] == 1) ndimy0 <- ndimy0 - 1
if (ndimy0 <= 1) nvar <- 1 else  nvar <- y0dim[ndimy0]
if (ndimy0 == 3)
   if (y0dim[2] > 1) stop("Y0FD is not a single function.")

#  check functions to be registered

if (!(inherits(yfd, "fd"))) 
    stop('Second argument is not a functional data object.')
ydim <- dim(getcoef(yfd))
ncurve <- ydim[2]
ndimy <- length(ydim)
if (ydim[ndimy] == 1) ndimy <- ndimy - 1
if (ndimy == 1)
   if (ndimy0 > 1) stop("YFD is not compatible with Y0FD.")
if (ndimy == 2)
   if (ndimy0 > 2) stop("YFD is not compatible with Y0FD.")
if (ndimy == 3)
   if (ndimy0 < 3) stop("YFD is not compatible with Y0FD.")
if (ndimy > 3) stop("YFD is more than 3-dimensional.")
ybasis  <- getbasis(yfd)
ynbasis <- ybasis$nbasis
if (periodic && !(getbasistype(ybasis) == "fourier"))
      stop("PERIODIC is true, basis not fourier type.")

#  check functions W defining warping functions

wcoef  <- getcoef(Wfd0)
wbasis <- getbasis(Wfd0)
nbasis <- wbasis$nbasis
wtype  <- getbasistype(wbasis)
rangex <- wbasis$rangeval
wdim   <- dim(wcoef)
ncoef  <- wdim[1]
ndimw  <- length(wdim)
if (wdim[ndimw] == 1) ndimw <- ndimw - 1
if (ndimw == 1 && ncurve > 1)
      stop("WFD and YFD do not have the same dimensions.")
if (ndimw == 2 && wdim[2] != ncurve)
      stop("WFD and YFD do not have the same dimensions.")
if (ndimw > 2)  stop("WFD is not univariate.")

#  set up a fine mesh of argument values

NFINEMIN <- 101
nfine <- 10*ynbasis + 1
if (nfine < NFINEMIN) nfine <- NFINEMIN
xlo   <- rangex[1]
xhi   <- rangex[2]
width <- xhi - xlo
xfine <- seq(xlo, xhi, len=nfine)

#  evaluate target curve at fine mesh of values

y0fine <- eval.fd(xfine, y0fd)

#  set up indices of coefficients that will be modified in ACTIVE

wcoef1   <- wcoef[1,]
if (periodic) {
   active   <- 1:nbasis
   wcoef[1] <- 0
   shift    <- 0
} else {
   active <- 2:nbasis
}

#  initialize matrix Kmat defining penalty term

if (lambda > 0) {
   Kmat <- getbasispenalty(wbasis, Lfdobj)
   ind  <- 2:ncoef
   Kmat <- lambda*Kmat[ind,ind]
} else {
   Kmat <- NULL
}

#  set up limits on coefficient sizes

climit <- 50*c(-rep(1,ncoef), rep(1,ncoef))

#  set up cell for storing basis function values

JMAX <- 15
basislist <- vector("list", JMAX)

yregcoef <- getcoef(yfd)

#  iterate through the curves

wcoefnew <- wcoef
if (dbglev == 0 && ncurve > 1) cat("Progress:  Each dot is a curve\n")

for (icurve in 1:ncurve) {
  if (dbglev == 0 && ncurve > 1) cat('.')
  if (dbglev >= 1 && ncurve > 1)
      cat(paste("\n\n-------  Curve ",icurve,"  --------\n"))
  if (ncurve == 1) {
    yfdi <- yfd
    Wfdi <- Wfd0
    cvec <- wcoef
  } else {
    Wfdi <- Wfd0[icurve]
    cvec <- wcoef[,icurve]
    if (nvar == 1) {
      yfdi <- yfd[icurve]
    } else {
      yfdi <- yfd[icurve,]
    }
  }

  #  evaluate curve to be registered at fine mesh

  yfine <- eval.fd(xfine, yfdi)

  #  evaluate objective function for starting coefficients

  #  first evaluate warping function and its derivative at fine mesh

  ffine  <-   monfn(xfine, Wfdi, basislist)
  Dffine <- mongrad(xfine, Wfdi, basislist)
  fmax   <- ffine[nfine]
  Dfmax  <- Dffine[nfine,]
  hfine  <- xlo + width*ffine/fmax
  Dhfine <- width*(fmax*Dffine - outer(ffine,Dfmax))/fmax^2
  hfine[1]     <- xlo
  hfine[nfine] <- xhi

  #  register curves given current Wfdi

  yregfdi <- regyfn(xfine, yfine, hfine, yfdi, Wfdi, periodic)

  #  compute initial criterion value and gradient

  Fstr <- regfngrad(xfine, y0fine, Dhfine, yregfdi, Wfdi, Kmat, periodic, crit)

  #  compute the initial expected Hessian
  if (crit == 2) {
     D2hwrtc <- monhess(xfine, Wfdi, basislist)
     D2fmax  <- D2hwrtc[nfine,]
     fmax2 <- fmax*fmax
     fmax3 <- fmax*fmax2
     m <- 1
     for (j in 2:nbasis) {
        m <- m + 1
        for (k in 2:j) {
           m <- m + 1
           D2hwrtc[,m] <- width*(2*ffine*Dfmax[j]*Dfmax[k]
                - fmax*(Dffine[,j]*Dfmax[k] + Dffine[,k]*Dfmax[j])
                + fmax2*D2hwrtc[,m] - ffine*fmax*D2fmax[m])/fmax3
        }
     }
  } else {
     D2hwrtc <- NULL
  }

  hessmat <- reghess(xfine, y0fine, Dhfine, D2hwrtc, yregfdi, Kmat, periodic, crit)

  #  evaluate the initial update vector for correcting the initial cvec

  result   <- linesearch(Fstr, hessmat, dbglev)
  deltac   <- result[[1]]
  cosangle <- result[[2]]
  #  initialize iteration status arrays

  iternum <- 0
  status <- c(iternum, Fstr$f, Fstr$norm)
  if (dbglev >= 1) {
        cat("\nIter.    Criterion   Grad Length")
        cat('\n')
        cat(iternum)
        cat("        ")
        cat(round(status[2],4))
        cat("      ")
        cat(round(status[3],4))
  }
  iterhist <- matrix(0,iterlim+1,length(status))
  iterhist[1,]  <- status
  if (iterlim == 0) break

  #  -------  Begin main iterations  -----------

  MAXSTEPITER <- 5
  MAXSTEP <- 100
  trial   <- 1
  reset   <- 0
  linemat <- matrix(0,3,5)
  cvecold <- cvec
  Foldstr <- Fstr
  dbgwrd  <- dbglev >= 2
  #  ---------------  beginning of optimization loop  -----------
  for (iter in 1:iterlim) {
      iternum <- iternum + 1
      #  set logical parameters
      dblwrd <- c(FALSE,FALSE) 
      limwrd <- c(FALSE,FALSE) 
      ind <- 0  
      ips <- 0
      #  compute slope
      linemat[2,1] <- sum(deltac*Foldstr$grad)
      #  normalize search direction vector
      sdg          <- sqrt(sum(deltac^2))
      deltac       <- deltac/sdg
      linemat[2,1] <- linemat[2,1]/sdg
      # initialize line search vectors
      linemat[,1:4] <- matrix(c(0, linemat[2,1], Fstr$f),3,1) %*% matrix(1,1,4)
      stepiter  <- 0
      if (dbglev >= 2) {
          cat('\n')
          cat(paste("                 ", stepiter, "  "))
          cat(format(round(t(linemat[,1]),4)))
      }
      #  return with stop condition if initial slope is nonnegative
      if (linemat[2,1] >= 0) {
        if (dbglev >= 2) cat("\nInitial slope nonnegative.")
        ind <- 3
        break
      }
      #  return successfully if initial slope is very small
      if (linemat[2,1] >= -min(c(1e-3,conv))) {
        if (dbglev >= 2) cat("\nInitial slope too small")
        ind <- 0
        break
      }
      #  first step set to trial
      linemat[1,5]  <- trial
      #  ------------  begin line search iteration loop  ----------
      cvecnew <- cvec
      Wfdnewi <- Wfdi
      for (stepiter in 1:MAXSTEPITER) {
        #  check the step size and modify if limits exceeded
        result <- stepchk(linemat[1,5], cvec, deltac, limwrd, ind,
                   climit, active, dbgwrd)
        linemat[1,5] <- result[[1]]
        ind          <- result[[2]]
        limwrd       <- result[[3]]
        if (ind == 1) break    # break of limit hit twice in a row
        if (linemat[1,5] <= 1e-7) {
           #  Current step size too small  terminate
           if (dbglev >= 2)
             cat("\nStepsize too small: ", round(linemat[1,5],4))
           break
        }
        #  update parameter vector
        cvecnew <- cvec + linemat[1,5]*deltac
        #  compute new function value and gradient
        Wfdnewi[[1]] <- cvecnew
        #  first evaluate warping function and its derivative at fine mesh
        cvectmp <- cvecnew
        cvectmp[1] <- 0
        Wfdtmpi <- Wfdnewi
        Wfdtmpi[[1]] <- cvectmp
        ffine  <-    monfn(xfine, Wfdtmpi, basislist)
        Dffine <- mongrad(xfine, Wfdtmpi, basislist)
        fmax   <- ffine[nfine]
        Dfmax  <- Dffine[nfine,]
        hfine  <- xlo + width*ffine/fmax
        Dhfine <- width*(fmax*Dffine - outer(ffine,Dfmax))/fmax^2
        hfine[1]     <- xlo
        hfine[nfine] <- xhi
        #  register curves given current Wfdi
        yregfdi <- regyfn(xfine, yfine, hfine, yfdi, Wfdnewi, periodic)
        Fstr    <- regfngrad(xfine, y0fine, Dhfine, yregfdi, Wfdnewi, Kmat, periodic, crit)
        linemat[3,5] <- Fstr$f
        #  compute new directional derivative
        linemat[2,5] <- sum(deltac*Fstr$grad)
        if (dbglev >= 2) {
          cat('\n')
          cat(paste("                 ", stepiter, "  "))
          cat(format(round(t(linemat[,5]),4)))
        }
        #  compute next line search step, also testing for convergence
        result  <- stepit(linemat, ips, ind, dblwrd, MAXSTEP, dbgwrd)
        linemat <- result[[1]]
        ips     <- result[[2]]
        ind     <- result[[3]]
        dblwrd  <- result[[4]]
        trial   <- linemat[1,5]
        #  ind == 0 implies convergence
        if (ind == 0 || ind == 5) break
     }
     #  ------------  end line search iteration loop  ----------
     cvec   <- cvecnew
     Wfdi   <- Wfdnewi
     #  test for function value made worse
     if (Fstr$f > Foldstr$f) {
        #  Function value worse  warn and terminate
        ier <- 1
        if (dbglev >= 2) {
          cat("Criterion increased, terminating iterations.\n")
          cat(paste("\n",round(c(Foldstr$f, Fstr$f),4)))
        }
        #  reset parameters and fit
        cvec   <- cvecold
        Wfdi[[1]] <- cvecold
        Fstr   <- Foldstr
        deltac <- -Fstr$grad
        if (dbglev > 2) {
          for (i in 1:nbasis) cat(cvec[i])
          cat("\n")
        }
        if (reset == 1) {
           #  This is the second time in a row that this
           #     has happened   quit
           if (dbglev >= 2) cat("Reset twice, terminating.\n")
            break
        } else {
           reset <- 1
        }
     } else {
        #  function value has not increased,  check for convergence
        if (abs(Foldstr$f-Fstr$f) < conv) {
           wcoef[,icurve]    <- cvec
           status <- c(iternum, Fstr$f, Fstr$norm)
           iterhist[iter+1,] <- status
           if (dbglev >= 1) {
              cat('\n')
              cat(iternum)
              cat("        ")
              cat(round(status[2],4))
              cat("      ")
              cat(round(status[3],4))
            }
           break
        }
        #  update old parameter vectors and fit structure
        cvecold <- cvec
        Foldstr <- Fstr
        #  update the expected Hessian
        if (crit == 2) {
           cvectmp <- cvec
           cvectmp[1] <- 0
           Wfdtmpi[[1]] <- cvectmp
           D2hwrtc <- monhess(xfine, Wfdtmpi, basislist)
           D2fmax  <- D2hwrtc[nfine,]
           #  normalize 2nd derivative
           fmax2 <- fmax*fmax
           fmax3 <- fmax*fmax2
           m <- 1
           for (j in 2:nbasis) {
              m <- m + 1
              for (k in 2:j) {
                 m <- m + 1
                 D2hwrtc[,m] <- width*(2*ffine*Dfmax[j]*Dfmax[k]
                - fmax*(Dffine[,j]*Dfmax[k] + Dffine[,k]*Dfmax[j])
                + fmax2*D2hwrtc[,m] - ffine*fmax*D2fmax[m])/fmax3
              }
           }
        } else {
           D2hwrtc <- NULL
        }
        hessmat <- reghess(xfine, y0fine, Dhfine, D2hwrtc, yregfdi, Kmat, periodic, crit)
        #  update the line search direction vector
        result   <- linesearch(Fstr, hessmat, dbglev)
        deltac   <- result[[1]]
        cosangle <- result[[2]]
        reset <- 0
     }
     status <- c(iternum, Fstr$f, Fstr$norm)
     iterhist[iter+1,] <- status
     if (dbglev >= 1) {
        cat('\n')
        cat(iternum)
        cat("        ")
        cat(round(status[2],4))
        cat("      ")
        cat(round(status[3],4))
     }  
   }
  #  ---------------  end of optimization loop  -----------
  wcoef[,icurve] <- cvec
  if (nvar == 1) {
     yregcoef[,icurve]  <- getcoef(yregfdi)
  } else {
     yregcoef[,icurve,] <- getcoef(yregfdi)
  }
}

#  --------------------   end of variable loop  -----------

#  create functional data objects for the registered curves

regfdnames <- getnames(yfd)
regfdnames[[3]] <- paste("Registered ",regfdnames[[3]])
ybasis  <- getbasis(yfd)
regfd   <- create.fd(yregcoef, ybasis, regfdnames)

#  create functional data objects for the warping functions

if (periodic) {
  shift <- c(wcoef[1,])
  wcoef[1,] <- wcoef1
} else {
  shift <- rep(0,ncurve)
}
Wfd <- create.fd(wcoef, wbasis)

regstr <- list("regfd"=regfd, "Wfd"=Wfd, "shift"=shift)

return(regstr)
}

#  ----------------------------------------------------------------

regfngrad <- function(xfine, y0fine, Dhwrtc, yregfd, Wfd, Kmat, periodic, crit)
{
    #cat("\nregfngrad")
  y0dim <- dim(y0fine)
  if (length(y0dim) == 3) nvar <- y0dim[3] else nvar <- 1
  nfine <- length(xfine)
  cvec  <- getcoef(Wfd)
  ncvec <- length(cvec)
  onecoef <- matrix(1,1,ncvec)

  if (periodic) {
     Dhwrtc[,1] <- 1
  } else {
     Dhwrtc[,1] <- 0
  }
  yregmat  <- eval.fd(yregfd, xfine)
  Dyregmat <- eval.fd(yregfd, xfine, 1)
  if (nvar > 1) {
     y0fine   <- y0fine[,1,]
     yregmat  <- yregmat[,1,]
     Dyregmat <- Dyregmat[,1,]
  }

  #  loop through variables computing function and gradient values

  Fval <- 0
  gvec <- matrix(0,ncvec,1)
  for (ivar in 1:nvar) {
    y0ivar  <-   y0fine[,ivar]
    ywrthi  <-  yregmat[,ivar]
    Dywrthi <- Dyregmat[,ivar]
    aa      <- mean(y0ivar^2)
    bb      <- mean(y0ivar*ywrthi)
    cc      <- mean(ywrthi^2)
    Dywrtc  <- (Dywrthi %*% onecoef)*Dhwrtc
    if (crit == 1) {
      res  <- y0ivar - ywrthi
      Fval <- Fval + aa - 2*bb + cc
      gvec <- gvec - 2*crossprod(Dywrtc, res)/nfine
    } else {
      ee   <- aa + cc
      ff   <- aa - cc
      dd   <- sqrt(ff^2 + 4*bb^2)
      Fval <- Fval + ee - dd
      Dbb  <- crossprod(Dywrtc, y0ivar)/nfine
      Dcc  <- 2.0 * crossprod(Dywrtc, ywrthi)/nfine
      Ddd  <- (4*bb*Dbb - ff*Dcc)/dd
      gvec <- gvec + (Dcc - Ddd)
    }
  }
  if (!is.null(Kmat)) {
     ind   <- 2:ncvec
     ctemp <- cvec[ind,1]
     Kctmp <- Kmat%*%ctemp
     Fval  <- Fval + t(ctemp)%*%Kctmp
     gvec[ind] <- gvec[ind] + 2*Kctmp
  }

#  set up F structure containing function value and gradient
  Fstr <- list(f=0, grad=rep(0,ncvec), norm=0)
  Fstr$f    <- Fval
  Fstr$grad <- gvec
  #  do not modify initial coefficient for B-spline and Fourier bases
  if (!periodic)  Fstr$grad[1] <- 0
  Fstr$norm <- sqrt(sum(Fstr$grad^2))
  return(Fstr)
}

#  ---------------------------------------------------------------

reghess <- function(xfine, y0fine, Dhwrtc, D2hwrtc, yregfd, Kmat,
                           periodic, crit)
{
    #cat("\nreghess")
  y0dim <- dim(y0fine)
  if (length(y0dim) == 3) nvar <- y0dim[3] else nvar <- 1
  nfine   <- length(xfine)
  ncoef   <- dim(Dhwrtc)[2]
  onecoef <- matrix(1,1,ncoef)
  npair   <- ncoef*(ncoef+1)/2

  if (periodic) {
     Dhwrtc[,1] <- 1
  } else {
     Dhwrtc[,1] <- 0
  }
  yregmat  <- eval.fd(yregfd, xfine)
  Dyregmat <- eval.fd(yregfd, xfine, 1)
  if (nvar > 1) {
     y0fine   <- y0fine[,1,]
     yregmat  <- yregmat[,1,]
     Dyregmat <- Dyregmat[,1,]
  }

  if (crit == 2) {
     D2yregmat <- eval.fd(yregfd, xfine, 2)
     if (nvar > 1) D2yregmat <- D2yregmat[,1,]
     if (periodic) {
        D2hwrtc[,1] <- 0
        for (j in 2:ncoef) {
           m <- j*(j-1)/2 + 1
           D2hwrtc[,m] <- Dhwrtc[,j]
        }
     } else {
        D2hwrtc[,1] <- 1
        for (j in 2:ncoef) {
           m <- j*(j-1)/2 + 1
           D2hwrtc[,m] <- 0
        }
     }
  }

  hessvec <- matrix(0,npair,1)
  for (ivar in 1:nvar) {
    y0i        <-   y0fine[,ivar]
    yregmati   <-  yregmat[,ivar]
    Dyregmati  <- Dyregmat[,ivar]
    Dywrtc <- ((Dyregmati %*% onecoef)*Dhwrtc)
    if (crit == 1) {
      hessmat <-  2*crossprod(Dywrtc, Dywrtc)/nfine
      m <- 0
       for (j in 1:ncoef) {
        for (k in 1:j) {
          m <- m + 1
          hessvec[m] <- hessvec[m] + hessmat[j,k]
        }
      }
    } else {
      D2yregmati <- D2yregmat[,ivar]
      aa     <- mean(y0i^2)
      bb     <- mean(y0i*yregmati)
      cc     <- mean(    yregmati^2)
      Dbb    <- crossprod(Dywrtc, y0i)/nfine
      Dcc    <- 2.0 * crossprod(Dywrtc, yregmati)/nfine
      D2bb   <- matrix(0,npair,1)
      D2cc   <- matrix(0,npair,1)
      crossprodmat <- matrix(0,nfine,npair)
      DyD2hmat     <- matrix(0,nfine,npair)
      m <- 0
      for (j in 1:ncoef) {
        for (k in 1:j) {
          m <- m + 1
          crossprodmat[,m] <- Dhwrtc[,j]*Dhwrtc[,k]*D2yregmati
          DyD2hmat[,m] <- Dyregmati*D2hwrtc[,m]
          temp <- crossprodmat[,m] + DyD2hmat[,m]
          D2bb[m] <- mean(y0i*temp)
          D2cc[m] <- 2*mean(yregmati*temp +
                     Dyregmati^2*Dhwrtc[,j]*Dhwrtc[,k])
        }
      }
      ee     <- aa + cc
      ff     <- aa - cc
      ffsq   <- ff*ff
      dd     <- sqrt(ffsq + 4*bb*bb)
      ddsq   <- dd*dd
      ddcu   <- ddsq*dd
      m <- 0
      for (j in 1:ncoef) {
        for (k in 1:j) {
          m <- m + 1
          hessvec[m] <- hessvec[m] + D2cc[m] -
            (4*Dbb[j]*Dbb[k] + 4*bb*D2bb[m] + Dcc[j]*Dcc[k] -
                   ff* D2cc[m])/dd +
            (4*bb*Dbb[j] - ff*Dcc[j])*(4*bb*Dbb[k] - ff*Dcc[k])/ddcu
        }
      }
    }
  }
  hessmat <- matrix(0,ncoef,ncoef)
  m <- 0
  for (j in 1:ncoef) {
    for (k in 1:j) {
      m <- m + 1
      hessmat[j,k] <- hessvec[m]
      hessmat[k,j] <- hessvec[m]
    }
  }
  if (!is.null(Kmat)) {
     ind <- 2:ncoef
     hessmat[ind,ind] <- hessmat[ind,ind] + 2*Kmat
  }
  if (!periodic) {
     hessmat[1,]  <- 0
     hessmat[,1]  <- 0
     hessmat[1,1] <- 1
  }
  return(hessmat)
}

#  ----------------------------------------------------------------

regyfn <- function(xfine, yfine, hfine, yfd, Wfd, periodic)
{
    #cat("\nregyfn")
coef  <- getcoef(Wfd)
shift <- coef[1]
coef[1] <- 0
Wfd[[1]] <- coef

if (all(coef == 0)) {
   if (periodic) {
      if (shift == 0) {
         yregfd <- yfd
         return(yregfd)
      }
   } else {
      yregfd <- yfd
      return(yregfd)
   }
}

#  Estimate inverse of warping function at fine mesh of values
#  28 dec 000
#  It makes no real difference which
#     interpolation method is used here.
#  Linear is faster and sure to be monotone.
#  Using WARPSMTH added nothing useful, and was abandoned.
nfine       <- length(xfine)
hinv        <- approx(hfine, xfine, xfine)$y
hinv[1]     <- xfine[1]
hinv[nfine] <- xfine[nfine]

#  carry out shift if period and shift != 0
basis  <- getbasis(yfd)
rangex <- basis$rangeval
ydim <- dim(yfine)
#if (length(ydim) == 3) yfine <- yfine[,1,]
if (periodic & shift != 0) yfine <- shifty(xfine, yfine, shift)
#  make FD object out of Y
ycoef  <- project.basis(yfine, hinv, basis, 1)
yregfd <- create.fd(ycoef, basis)
return(yregfd)
}

#  ----------------------------------------------------------------

linesearch <- function(Fstr, hessmat, dbglev)
{
deltac   <- -solve(hessmat,Fstr$grad)
cosangle <- -sum(Fstr$grad*deltac)/sqrt(sum(Fstr$grad^2)*sum(deltac^2))
if (dbglev >= 2) cat(paste("\nCos(angle) = ",round(cosangle,2)))
if (cosangle < 1e-7) {
   if (dbglev >=2) cat("\nangle negative")
   deltac <- -Fstr$grad
}
return(list(deltac, cosangle))
}

#  ---------------------------------------------------------------------

shifty <- function(x, y, shift)
{
#SHIFTY estimates value of Y for periodic data for
#       X shifted by amount SHIFT.
#  It is assumed that X spans interval over which functionis periodic.
#  Last modified 6 February 2001

ydim <- dim(y)
if (is.null(ydim)) ydim <- 1
if (length(ydim) > 3) stop("Y has more than three dimensions")

if (shift == 0) {
   yshift <- y
   return(yshift)
}

n   <- ydim[1]
xlo <- min(x)
xhi <- max(x)
wid <- xhi - xlo
if (shift > 0) {
   while (shift > xhi)  shift <- shift - wid 
   ind <- 2:n
   x2  <- c(x, x[ind]+wid)
   xshift <- x + shift
   if (length(ydim) == 1) {
      y2 <- c(y, y[ind])
      yshift <- approx(x2, y2, xshift)$y
   } 
   if (length(ydim) == 2) {
       nvar <- ydim[2]
       yshift <- matrix(0,n,nvar)
      for (ivar in 1:nvar) {
         y2 <- c(y[,ivar], y[ind,ivar])
         yshift[,ivar] <- approx(x2, y2, xshift)$y
      }
   } 
   if (length(ydim) == 3) {
       nrep <- ydim[2]
       nvar <- ydim[3]
      yshift <- array(0,c(n,nrep,nvar))
      for (irep in 1:nrep) for (ivar in 1:nvar) {
         y2 <- c(y[,irep,ivar], y[ind,irep,ivar])
         yshift[,irep,ivar] <- approx(x2, y2, xshift)$y
      }
   } 
} else {
   while (shift < xlo - wid) shift <- shift + wid
   ind <- 1:(n-1)
   x2 <- c(x[ind]-wid, x)
   xshift <- x + shift
   if (length(ydim) == 1) {
      y2 <- c(y[ind], y)
      yshift <- approx(x2, y2, xshift)$y
   } 
   if (length(ydim) == 2) {
       nvar <- ydim[2]
       yshift <- matrix(0,n,nvar)
       for (ivar in 1:nvar) {
           y2 <- c(y[ind,ivar],y[,ivar])
           yshift[,ivar] <- approx(x2, y2, xshift)$y
       }
   }
   if (length(ydim) == 3) {
       nrep <- ydim[2]
       nvar <- ydim[3]
      yshift <- array(0, c(n,nrep,nvar))
      for (irep in 1:nrep) for (ivar in 1:nvar) {
         y2 <- c(y[ind,irep,ivar], y[,irep,ivar])
         yshift[,irep,ivar] <- approx(x2, y2, xshift)$y
      }
   }
}
return(yshift)
}
shifty <- function(x, y, shift)
{
#SHIFTY estimates value of Y for periodic data for
#       X shifted by amount SHIFT.
#  It is assumed that X spans interval over which functionis periodic.
#  Last modified 6 February 2001

ydim <- dim(y)
if (is.null(ydim)) ydim <- 1
if (length(ydim) > 3) stop("Y has more than three dimensions")

if (shift == 0) {
   yshift <- y
   return(yshift)
}

n   <- ydim[1]
xlo <- min(x)
xhi <- max(x)
wid <- xhi - xlo
if (shift > 0) {
   while (shift > xhi)  shift <- shift - wid 
   ind <- 2:n
   x2  <- c(x, x[ind]+wid)
   xshift <- x + shift
   if (length(ydim) == 1) {
	  y2 <- c(y, y[ind])
      yshift <- approx(x2, y2, xshift)$y
   } 
   if (length(ydim) == 2) {
	   nvar <- ydim[2]
	   yshift <- matrix(0,n,nvar)
      for (ivar in 1:nvar) {
         y2 <- c(y[,ivar], y[ind,ivar])
         yshift[,ivar] <- approx(x2, y2, xshift)$y
      }
   } 
   if (length(ydim) == 3) {
	   nrep <- ydim[2]
	   nvar <- ydim[3]
      yshift <- array(0,c(n,nrep,nvar))
      for (irep in 1:nrep) for (ivar in 1:nvar) {
         y2 <- c(y[,irep,ivar], y[ind,irep,ivar])
         yshift[,irep,ivar] <- approx(x2, y2, xshift)$y
      }
   } 
} else {
   while (shift < xlo - wid) shift <- shift + wid
   ind <- 1:(n-1)
   x2 <- c(x[ind]-wid, x)
   xshift <- x + shift
   if (length(ydim) == 1) {
      y2 <- c(y[ind], y)
      yshift <- approx(x2, y2, xshift)$y
   } 
   if (length(ydim) == 2) {
	   nvar <- ydim[2]
	   yshift <- matrix(0,n,nvar)
	   for (ivar in 1:nvar) {
		   y2 <- c(y[ind,ivar],y[,ivar])
		   yshift[,ivar] <- approx(x2, y2, xshift)$y
	   }
   }
   if (length(ydim) == 3) {
	   nrep <- ydim[2]
	   nvar <- ydim[3]
      yshift <- array(0, c(n,nrep,nvar))
      for (irep in 1:nrep) for (ivar in 1:nvar) {
         y2 <- c(y[ind,irep,ivar], y[,irep,ivar])
         yshift[,irep,ivar] <- approx(x2, y2, xshift)$y
      }
   }
}
return(yshift)
}
smooth.Pspline <- function(x, y, w=rep(1, length(x)), norder=2,
                           df=norder+2, spar=0, method=3)
{
#  Computes order NORDER polynomial smoothing spline:  the spline
  #    is piecewise of degree 2*NORDER - 1 and the norm of the
  #    derivative of order is penalized

  #  This version is set up to call the C function smoothPspline in 
  #    file smooth.Pspline.c.  The Fortran version of this function is
  #    the subroutine Pspline in file Pspline.f.

  #  Arguments:
  #  X       ...  argument values
  #  Y       ...  N by NVAR matrix of function values to be smoothed
  #  W       ...  weights (default all one's)
  #  NORDER  ...  order of smoothing spline (default 2)
  #  D       ...  effective degrees of freedom (trace(hatmatrix))
  #                if method = 2, the smooth has this value for deg. freedom
  #  SPAR    ...  penalty parameter (default 0)
  #  METHOD  ...  smoothing method:  1  ...  fixed value of SPAR
  #                                  2  ...  fixed value of DF
  #                                  3  ...  SPAR optimizes GCV criterion
  #                                  4  ...  SPAR optimizes  CV criterion

  #  Returns:  An object of class "smooth.Pspline" containing:
  #  NORDER  ...  order of smoothing spline
  #  X       ...  argument values
  #  YSMTH   ...  N by NVAR matrix of values of the smoothed functions
  #  LEV     ...  array of N leverage values
  #  GCV     ...  generalized cross-validation coefficient
  #  CV      ...  cross-validation coefficient
  #  DF      ...  final effective degrees of freedom
  #  SPAR    ...  final smoothing parameter value
  #  MY.CALL ...  calling statement


 #  Last modified 24 January 2002

  my.call <- match.call()

  n <- length(x)
  if (is.matrix(y)) nvar <- ncol(y) else {
    nvar <- 1
    y <- as.matrix(y)
  }
  if (length(w) == 1) w <- rep(w,n)
  if (nrow(y) != n | length(w) != n) stop("Argument arrays of wrong length")
  if (method != 1 & method != 2 & method != 3 & method != 4) stop(
         "Wrong value for METHOD")
  if (norder <= 1 | norder >= 19) stop("Wrong value for NORDER")

  yhat     <- matrix(0,n,nvar)
  nworksiz <- (n-norder)*(4*norder + 3) + n
  work     <- rep(0,nworksiz)
  lev      <- rep(0,n)
  gcv      <- 0
  cv       <- 0
  dfmax    <- n
  ier      <- 0
  irerun   <- 0

  result <- .C("smoothPspline",
              as.integer(n),      as.integer(nvar),  as.integer(norder),
              as.double(x),       as.double(w),
              as.double(y),       as.double(yhat),   as.double(lev),
              as.double(gcv),     as.double(cv),     as.double(df),
              as.double(spar),    as.double(dfmax),
              as.double(work),    as.integer(method),
              as.integer(irerun), as.integer(ier) )

  ier <- result[[17]]
  if (ier == 1) stop ("N < 2*NORDER + 1")
  if (ier == 2) stop ("NORDER < 2 or NORDER > 10")
  if (ier == 3) stop ("NVAR < 1")
  if (ier == 4) stop ("SPAR < 0")
  if (ier == 5) stop ("X not strictly increasing")
  if (ier == 6) stop ("W contains nonpositive values")
  if (ier < 0 ) stop ("Singularity error in solving equations")

  ysmth  <- matrix(result[[7]],n,nvar)
  lev    <- result[[8]]
  gcv    <- result[[9]]
  cv     <- result[[10]]
  df     <- result[[11]]
  spar   <- result[[12]]
  object <- list(norder = norder, x = x, ysmth = ysmth,  lev = lev,
           gcv = gcv, cv = cv,  df = df,
     spar = spar, call = my.call)
  setOldClass("smooth.Pspline")
  oldClass(object) <- "smooth.Pspline"
  object

}


#  --------------------------------------------------------------


predictSmoothPspline <- function(splobj, xarg, nderiv = 0) {

  if(missing(xarg)) return(splobj[c("x", "ysmth")])

  x      <- splobj$x
  ysmth  <- splobj$ysmth
  norder <- 2*splobj$norder
  n    <- length(x)
  nvar <- ncol(ysmth)
  narg <- length(xarg)

  if (nderiv < 0 | nderiv >= norder) stop("Violation of NDERIV >= NORDER.")

  dy    <- matrix(0,narg,nvar)
  work  <- rep(0,(2*norder+2)*n + norder)
  ier   <- 0

  result <- .C("predictPspline",
               as.integer(n),    as.integer(narg),
               as.integer(nvar), as.integer(norder), as.integer(nderiv),
               as.double(x),     as.double(ysmth),
               as.double(xarg),  as.double(dy),
               as.double(work),  as.integer(ier) )


  ier <- result[[11]]
  if (ier == 1) stop (paste("N = ",n," not valid."))
  if (ier == 2) stop ("A problem with knots detected.")
  if (ier == 3) stop ("Singular coefficient matrix detected.")
  if (ier == 4) stop (paste("NDERIV = ",nderiv," not valid."))
  if (ier == 5) stop (paste("NORDER = ",norder," not valid."))
  if (ier == 6) stop ("X values not strictly increasing.")

  dy  <- matrix(result[[9]],narg,nvar)
  return(dy)
}

#  --------------------------------------------------------------

plotSmoothPspline <- function(splobj, ...) {
  if (is.vector(splobj$ysmth) | dim(splobj$ysmth)[[2]] == 1)
        plot (splobj$x, splobj$ysmth, ...) else
     matplot (splobj$x, splobj$ysmth, ...)
}

#  --------------------------------------------------------------

linesSmoothPspline <- function(splobj, ...) {
  if (is.vector(splobj$ysmth) | dim(splobj$ysmth)[[2]] == 1)
        lines (splobj$x, splobj$ysmth, ...) else
     matlines (splobj$x, splobj$ysmth, ...)
}

#  --------------------------------------------------------------

print.smooth.Pspline <- function(x, ...)
{
        if(!is.null(cl <- x$call)) {
                cat("Call:\n")
                dput(cl)
        }
        cat("\nSmoothing Parameter (Spar):",       format(x$spar), "\n")
        cat("Equivalent Degrees of Freedom (Df):", format(x$df),   "\n")
        cat("GCV Criterion:",                      format(x$gcv),  "\n")
        cat("CV  Criterion:",                      format(x$cv),   "\n")
        invisible(x)
}
smooth.basis <- function (y, argvals, basisfd, wtvec=rep(1,n),
                          Lfd=NULL, lambda=0,
                          fdnames=list(NULL, dimnames(y)[2], NULL))
{

  #  Arguments for this function:
  #
  #  Y        ... an array containing values of curves
  #               If the array is a matrix, rows must correspond to argument
  #               values and columns to replications, and it will be assumed
  #               that there is only one variable per observation.
  #               If Y is a three-dimensional array, the first dimension
  #               corresponds to argument values, the second to replications,
  #               and the third to variables within replications.
  #               If Y is a vector, only one replicate and variable are assumed.
  #  ARGVALS  ... A vector of argument values.
  #  BASISFD  ... A basis.fd object created by function create.basis.fd.
  #  WTVEC    ... A vector of N weights, set to one by default, that can
  #               be used to differentially weight observations in the
  #               smoothing phase
  #  LFD      ... The order of derivative or a nonhomogeneous linear differential
  #               operator to be penalized in the smoothing phase.
  #               By default Lfd is set in function GETBASISPENALTY
  #  LAMBDA   ... The smoothing parameter determining the weight to be
  #               placed on the size of the derivative in smoothing.  This
  #               is 0 by default.
  #  FDNAMES  ... A list of length 3 with members containing
  #               1. a single name for the argument domain, such as "Time"
  #               2. a vector of names for the replications or cases
  #               3. a name for the function, or a vector of names if there
  #                  are multiple functions.
  #  Returns a list containing:
  #  FD    ...  an object of class fd containing coefficients
  #  DF    ...  a degrees of freedom measure
  #  GCV   ...  a measure of lack of fit discounted for df.

  #  Last modified:  5 May 2003

  n        <- length(argvals)
  nbasis   <- basisfd$nbasis
  onebasis <- rep(1,nbasis)

  #  check WTVEC

  if (!is.vector(wtvec)) stop("WTVEC is not a vector.")
  if (length(wtvec) != n) stop("WTVEC of wrong length")
  if (min(wtvec) <= 0)    stop("All values of WTVEC must be positive.")

  #  check LAMBDA

  if (lambda < 0) {
    warning ("Value of LAMBDA was negative, and 0 used instead.")
    lambda <- 0
  }

  #  check data array Y

  data  <- as.array(y)
  datad <- dim(data)
  ndim  <- length(datad)
  if (datad[1] != n) stop("First dimension of Y not compatible with ARGVALS.")

  #  set number of curves and number of variables

  if (ndim == 1) {
    nrep <- 1
    nvar <- 1
    coef <- rep(0,nbasis)
    data <- matrix(data,datad,1)
  }
  if (ndim == 2)  {
    nrep <- ncol(data)
    nvar <- 1
    coef <- matrix(0,nbasis,nrep)
  }
  if (ndim == 3)  {
    nrep <- dim(data)[2]
    nvar <- dim(data)[3]
    coef <- array(0,c(nbasis,nrep,nvar))
  }

  #  set up matrix of basis function values

  basismat <- getbasismatrix(argvals, basisfd)

  #  set up the linear equations for smoothing

  if (n >= nbasis || lambda > 0) {

    #  The following code is for the coefficients completely determined

    basisw <- basismat*outer(wtvec,rep(1,nbasis))
    Bmat   <- crossprod(basisw,basismat)
    Bmat0  <- Bmat

    #  set up right side of equations

    if (ndim < 3) {
      	Dmat <- crossprod(basisw,data)
    } else {
	 	Dmat <- array(0, c(nbasis, ncurves, nvar))
      	for (ivar in 1:nvar) {
        	Dmat[,,ivar] <- crossprod(basisw,data[,,ivar])
      	}
    }
    if (lambda > 0) {
        #  smoothing required, set up coefficient matrix for normal equations
        penmat  <- getbasispenalty(basisfd, Lfd)
        Bnorm   <- sqrt(sum(c(Bmat)^2))
        pennorm <- sqrt(sum(c(penmat)^2))
        condno  <- pennorm/Bnorm
        if (lambda*condno > 1e12) {
          lambda <- 1e12/condno
          warning(paste("lambda reduced to",lambda,
                        "to prevent overflow"))
        }
        Bmat <- Bmat + lambda*penmat
    } else {
	  	penmat <- matrix(0,nbasis,nbasis)
       Bmat   <- Bmat
    }

    #  compute inverse of Bmat

    Bmat <- (Bmat+t(Bmat))/2
    if (is.diag(Bmat)) {
      	Bmatinv <- diag(1/diag(Bmat))
    } else {
      	Bmatinv <- solve(Bmat)
    }

    #  compute degrees of freedom of smooth

    df <- sum(diag(Bmatinv %*% Bmat0))

    #  solve normal equations for each observation

    if (ndim < 3) {
      	coef <- Bmatinv %*% Dmat
    } else {
      	for (ivar in 1:nvar) {
        	coef[,,ivar] <- Bmatinv %*% Dmat
      	}
    }

  } else {

    #  The following code is for the underdetermined coefficients:
    #     the number of basis functions exceeds the number of argument values.

    qrlist <- qr(t(basismat))
    Qmat   <- qr.Q(qrlist, complete=TRUE)
    Rmat   <- t(qr.R(qrlist))
    Q1mat  <- Qmat[,1:n]
    Q2mat  <- as.matrix(Qmat[,(n+1):nbasis])
    Hmat   <- getbasispenalty(basisfd)
    Q2tHmat   <- crossprod(Q2mat,Hmat)
    Q2tHQ2mat <- Q2tHmat %*% Q2mat
    Q2tHQ1mat <- Q2tHmat %*% Q1mat
    if (ndim < 3) {
      z1mat <- solve(Rmat,data)
      z2mat <- solve(Q2tHQ2mat, Q2tHQ1mat %*% z1mat)
      coef <- Q1mat %*% z1mat + Q2mat %*% z2mat
    } else {
      for (ivar in 1:nvar) {
        z1mat <- solve(Rmat,data[,,ivar])
        z2mat <- solve(Q2tHQ2mat, Q2tHQ1mat %*% z1mat)
        coef[,,ivar] <- Q1mat %*% z1mat + Q2mat %*% z2mat
      }
    }
  }

  #  compute error sum of squares

  if (ndim < 3) {
      	datahat <- basismat %*% coef
      	SSE <- sum((data - datahat)^2)
  } else {
      	SSE <- 0
      	for (ivar in 1:nvar) {
        	datahat <- basismat %*% coef[,,ivar]
        	SSE <- SSE + sum((data[,,ivar] - datahat)^2)
      	}
  }

  #  compute  GCV index

  if (df < n) {
    	gcv <- (SSE/n)/(nvar*(n - df)/n)^2
  } else {
    	gcv <- NA
  }

  basislabels <- as.character(1:nbasis)
  if (ndim == 1) {
    coeflabs <- list(basislabels,NULL)
    names(coeflabs) <- c("basisfns", "reps")
  }
  if (ndim == 2) {
    coeflabs <- list(basislabels, fdnames[[2]])
    names(coeflabs) <- c("basisfns", "reps")
  }
  if (ndim == 3) {
    coeflabs <- list(basislabels, fdnames[[2]], fdnames[[3]])
    names(coeflabs) <- c("basisfns", "reps", "funs")
  }
  dimnames(coef) <- coeflabs

  fd <- create.fd(coef, basisfd, fdnames = fdnames)

  smoothlist <- list( fd, df, gcv, coef, SSE, penmat )
  names(smoothlist) <- c("fd", "df", "gcv", "coef", "SSE", "penmat")
  return( smoothlist )
}
smooth.basis.n <- function (y, argvals, basisfd, wt=rep(1,n), penspecs=NULL)
{

  #  this version inputs the penalty specs as a vector of lists

  #  Arguments for this function:
  #
  #  Y        ... An array of discrete curve values to smooth.
  #  ARGVALS  ... A vector of argument  values
  #  BASISFD  ... A basis.fd object created by function create.basis.fd.
  #  WT       ... A vector of N weights, set to one by default, that can
  #               be used to differentially weight observations in the
  #               smoothing phase
  #  PENSPECS ... A list.  The members are lists, each containing:
  #    LFD      ... An order of derivative or a
  #                 linear differential operator to be penalized in the
  #                 smoothing phase.
  #                 2  by default
  #    LAMBDA   ... A smoothing parameter determining the weight
  #                 to be placed on the size of the derivative in smoothing.
  #                 This is 0 by default.
  #    PENRNG   ... A vector containing 1 or 2 elements
  #                 specifying the range over which the
  #                 integration is to be carried out.  If missing, the
  #                 full range is used.  If of length 1, the functional
  #                 is evaluated at that point rather than integrated.
  #    WTFD     ... A functional data object specifying a weight function
  #                 The default is NULL

  #  Returns an object of class fd containing coefficients
  #    for the expansion and BASISFD

  #  Last modified 16 May 1999

  n <- length(argvals)

  basismat <- getbasismatrix(argvals, basisfd)
  nbasis   <- dim(basismat)[2]
  onebasis <- rep(1,nbasis)

  if (length(wt) != n) stop("WT of wrong length")
  if (min(wt) <= 0)    stop("All values of WT must be positive.")

  data  <- as.array(y)
  datad <- dim(data)
  ndim  <- length(datad)
  if (ndim == 1) {
    nrep <- 1
    nvar <- 1
    coef <- rep(0,nbasis)
    data <- matrix(data,datad,1)
  }
  if (ndim == 2)  {
    nrep <- ncol(data)
    nvar <- 1
    coef <- matrix(0,nbasis,nrep)
  }
  if (ndim == 3)  {
    nrep <- dim(data)[2]
    nvar <- dim(data)[3]
    coef <- array(0,c(nbasis,nrep,nvar))
  }

  if (n >= nbasis) {

    #  The following code is for the coefficients completely determined
    basisw   <- basismat*outer(wt,rep(1,nbasis))
    Bmat     <- crossprod(basisw,basismat)

    if (is.null(penspecs)) {
      nspecs <- 0
    } else {
      nspecs <- length(penspecs)
    }
    Cmat <- Bmat
    if (nspecs >  0) {
      #  smoothing required, set up coefficient matrix for normal equations
      for (ispec in 1:nspecs) {
        penspec <- penspecs[[ispec]]
        penmat  <- getbasispenalty.n(basisfd, penspec)
        lambda  <- penspec$lambda
        Cmat    <- Cmat + lambda*penmat
      }
    }
    Cmat <- (Cmat + t(Cmat))/2

    #  compute inverse of Cmat

    if (is.diag(Cmat)) {
        Cmatinv <- 1/Cmat
    } else {
      Lmat    <- chol(Cmat)
      Lmatinv <- solve(Lmat)
      Cmatinv <- crossprod(t(Lmatinv))
    }

    #  compute degrees of freedom of smooth

    df <- sum(diag(Cmatinv %*% Bmat))

    #  solve normal equations for each observation

    if (ndim < 3) {
      Dmat <- crossprod(basisw,data)
      coef <- Cmatinv %*% Dmat
    } else {
      for (ivar in 1:nvar) {
        Dmat <- crossprod(basisw,data[,,ivar])
        coef[,,ivar] <- Cmatinv %*% Dmat
      }
    }

  } else {
    #  The following code is for the underdetermined coefficients:
    #     the number of basis functions exceeds the number of argument values.

    qrlist <- qr(t(basismat))
    Qmat   <- qr.Q(qrlist, complete=TRUE)
    Rmat   <- t(qr.R(qrlist))
    Q1mat  <- Qmat[,1:n]
    Q2mat  <- as.matrix(Qmat[,(n+1):nbasis])
    Hmat   <- getbasispenalty(basisfd)
    Q2tHmat   <- crossprod(Q2mat,Hmat)
    Q2tHQ2mat <- Q2tHmat %*% Q2mat
    Q2tHQ1mat <- Q2tHmat %*% Q1mat
    if (ndim < 3) {
      z1mat <- solve(Rmat,data)
      z2mat <- solve(Q2tHQ2mat, Q2tHQ1mat %*% z1mat)
      coef <- Q1mat %*% z1mat + Q2mat %*% z2mat
    } else {
      for (ivar in 1:nvar) {
        z1mat <- solve(Rmat,data[,,ivar])
        z2mat <- solve(Q2tHQ2mat, Q2tHQ1mat %*% z1mat)
        coef[,,ivar] <- Q1mat %*% z1mat + Q2mat %*% z2mat
      }
    }
    df <- n
  }

  #  compute  GCV index

  if (df < n) {
    if (ndim < 3) {
      datahat <- basismat %*% coef
      SSE <- sum((data - datahat)^2)
    } else {
      SSE <- 0
      for (ivar in 1:nvar) {
        datahat <- basismat %*% coef[,,ivar]
        SSE <- SSE + sum((data[,,ivar] - datahat)^2)
      }
    }
    gcv <- (SSE/n)/(nvar*(n - df)/n)^2
  } else {
    gcv <- NA
  }

  prefdnames <- dimnames(prefd[[1]])
  if (ndim == 1) dimnames(coef) <- NULL
  if (ndim == 2) dimnames(coef) <- list(NULL, prefdnames[[2]])
  if (ndim == 3) dimnames(coef) <- list(NULL, prefdnames[[2]], prefdnames[[3]])

  fd <- create.fd(coef, basisfd, df = df, gcv = gcv)

  return(fd)
}
smooth.fd <- function(fd, lambda = 0, Lfd = NULL, rebase = TRUE)
{
#  Smooths a functional data object.
#  Arguments for this function:
#
#  FD      ... A functional data object.
#
#  LAMBDA  ... The smoothing parameter determining the weight to be
#              placed on the size of the derivative in smoothing.  This
#              is 0 by default, but this will produce a warning
#              message that no smoothing has been carried out.
#
#  LFD     ... The order of derivative or a linear differential
#              operator to be penalized in the smoothing phase.
#              By default Lfd is set in function GETBASISPENALTY
#
#  If rebase=TRUE and the basis type is "polyg" then the basis
#    is changed to a cubic bspline  basis and before smoothing
#
#  Returns a functional data object containing a smoothed version
#    of the input functional data object
#

#  Last modified 6 Feb 2001
 
#
# Rebase to default B spline basis if rebase is T and basistype is
#    polygonal.  Then test to see if any smoothing is actually required.
#

  if (!(inherits(fd, "fd"))) stop("Argument FD not a functional data object.")

  basisfd <- getbasis(fd)
  if(rebase == TRUE && basisfd$type == "polyg") {
    fd <- data2fd(getcoef(fd), basisfd$params, fdnames = fd$fdnames)
    basisfd <- getbasis(fd)
  }
  if(lambda <= 0) {
    warning("LAMBDA was not positive. No smoothing carried out.")
    return(fd)
  }
#
#  Main smoothing step
#
  coef  <- NA * getcoef(fd)
  coefd <- dim(coef)
  ndim  <- length(coefd)
  Bmat  <- inprod(basisfd, basisfd)
#
#  set up coefficient matrix for normal equations
#
  penmat <- getbasispenalty(basisfd, Lfd)
  Cmat   <- Bmat + lambda * penmat
#
#  solve normal equations for each observation
#
  if(ndim < 3) {
    Dmat <- inprod(basisfd, fd)
    coef <- symsolve(Cmat, Dmat)
  }
  else {
    for(ivar in (1:coefd[3])) {
      Dmat <- inprod(basisfd, fd[,ivar])
      coef[,,ivar] <- symsolve(Cmat, Dmat)
    }
  }
#
#  replace coefficient matrix in fd, leaving other properties alone
#
  fd[[1]] <- coef
  return(fd)
}
smooth.monotone <- function(x, y, wt=rep(1,nobs), Wfdobj, zmat=matrix(1,nobs,1),
                            Lfdobj=1, lambda=0, conv=.0001, iterlim=20,
                            active=c(FALSE,rep(TRUE,ncvec-1)), dbglev=1) {
#  Smooths the relationship of Y to X using weights in WT by fitting a
#     monotone function of the form
#                   f(x) = b_0 + b_1 D^{-1} exp W(x)
#     where  W  is a function defined over the same range as X,
#                 W + ln b_1 = log Df and w = D W = D^2f/Df.
#  The constant term b_0 in turn can be a linear combinations of covariates:
#                         b_0 = zmat * c.
#  The fitting criterion is penalized mean squared error:
#    PENSSE(lambda) = \sum w_i[y_i - f(x_i)]^2 +
#                     \lambda * \int [L W(x)]^2 dx
#  where L is a linear differential operator defined in argument Lfdobj,
#  and w_i is a positive weight applied to the observation.
#  The function W(x) is expanded by the basis in functional data object
#    Wfdobj.   The coefficients of this expansion are called "coefficients"
#    in the comments, while the b's are called "regression coefficients"

#  Arguments:
#  X       ...  vector of argument values
#  Y       ...  vector of function values to be fit
#  WT      ...  a vector of weights
#  WFDOBJ  ...  functional data object for W(x).  It's coefficient array
#               has a single column, and these are the starting values
#               for the iterative minimization of mean squared error.
#  ZMAT    ...  a matrix of covariate values for the constant term.
#               It defaults to a column of one's
#  LFDOBJ  ...  linear differential opr defining roughness penalty to
#               be applied to WFDOBJ.  This may be either a functional data
#               object defining a linear differential operator, or a
#               nonnegative integer.  If the latter, it specifies the
#               order of derivative to be penalized.
#               LFDOBJ = 1 by default, corresponding to L = D.
#  LAMBDA  ...  smoothing parameter determining the amount of penalty,
#               0 by default.
#  CONV    ...  convergence criterion, 0.0001 by default
#  ITERLIM ...  maximum number of iterations, 20 by default
#  ACTIVE  ...  vector of 1's and 0's indicating which coefficients
#               are to be optimized (1) or remain fixed (0).  All values
#               are 1 by default, except that if a B-spline basis is used,
#               the first value is set to 0.
#  DBGLEV  ...  Controls the level of output on each iteration.  If 0,
#               no output, if 1, output at each iteration, if higher, output
#               at each line search iteration. 1 by default.

#  Returns a list containing:
#  WFDOBJ    ...  functional data object for W(x).  Its coefficients are
#                   those that optimize fit.
#  BETA      ...  final regression coefficient values
#  FNEW      ...  final function value
#  MSG       ...  final gradient norm
#  ITERNUM   ...  number of iterations
#  ITERHIST  ...  ITERNUM+1 by 5 array containing iteration history

#  Last modified 28 January 2003

  if (!(inherits(Wfdobj, "fd"))) stop('Argument WFDOBJ is not a functional data object.')

#  initialize some arrays

  nobs   <- length(x)      #  number of observations
  basis  <- getbasis(Wfdobj)  #  basis for W(x)
  nbasis <- basis$nbasis   #  number of basis functions
  type   <- basis$type

#  the starting values for the coefficients are in FD object WFDOBJ

  cvec   <- getcoef(Wfdobj)
  ncvec  <- length(cvec)

#  check some arguments

  if (any(wt < 0))  stop("One or more weights are negative.")
  if (all(wt == 0)) stop("All weights are zero.")
  zdim <- dim(zmat)
  if (zdim[1] != nobs) stop(
    "First dimension of ZMAT not correct.")

#  set up some variables

  ncov   <- zdim[2]   #  number of covariates
  ncovp1 <- ncov + 1  #  index for regression coef. for monotone fn.
  wtroot <- sqrt(wt)
  wtrtmt <- wtroot %*% matrix(1,1,ncovp1)
  yroot  <- y*wtroot
  climit <- c(-100*rep(1,nbasis), 100*rep(1,nbasis))
  inact  <- !active   #  indices of inactive coefficients

#  set up cell for storing basis function values

  JMAX <- 15
  basislist <- vector("list", JMAX)

#  initialize matrix Kmat defining penalty term

  if (lambda > 0) {
    Kmat <- lambda*getbasispenalty(basis, Lfdobj)
  } else {
    Kmat <- NULL
  }

#  Compute initial function and gradient values

  result <- fngrad.smooth.monotone(y, x, zmat, wt, Wfdobj, lambda,
                                   Kmat, inact, basislist)
  Flist  <- result[[1]]
  beta   <- result[[2]]
  Dyhat  <- result[[3]]

#  compute the initial expected Hessian

  hessmat <- hesscal.smooth.monotone(beta, Dyhat, wtroot, lambda, Kmat, inact)

#  evaluate the initial update vector for correcting the initial cvec

  result   <- linesearch.smooth.monotone(Flist, hessmat, dbglev)
  deltac   <- result[[1]]
  cosangle <- result[[2]]

#  initialize iteration status arrays

  iternum <- 0
  status  <- c(iternum, Flist$f, Flist$norm, beta)
  if (dbglev >= 1) {
    cat("\nIter.   PENSSE   Grad Length Intercept   Slope")
    cat('\n')
    cat(iternum)
    cat("        ")
    cat(round(status[2],4))
    cat("      ")
    cat(round(status[3],4))
    cat("      ")
    cat(round(beta[1],4))
    cat("      ")
    cat(round(beta[ncovp1],4))
  }
  if (dbglev == 0 && iterlim > 1) cat("Progress:  Each dot is an iteration\n")

  iterhist <- matrix(0,iterlim+1,length(status))
  iterhist[1,]  <- status
  if (iterlim == 0)
    return ( list( "Wfdobj" = Wfdobj, "beta" = beta, "Flist" = Flist, 
                 "iternum" = iternum, "iterhist" = iterhist ) )

#  -------  Begin iterations  -----------

  MAXSTEPITER <- 10
  MAXSTEP <- 100
  trial   <- 1
  reset   <- FALSE
  linemat <- matrix(0,3,5)
  betaold <- beta
  cvecold <- cvec
  Foldlist <- Flist
  dbgwrd  <- dbglev >= 2
  for (iter in 1:iterlim)
  {
     if (dbglev == 0 && iterlim > 1) cat('.')
     iternum <- iternum + 1
     #  initialize logical variables controlling line search
     dblwrd <- c(0,0)
     limwrd <- c(0,0)
     stpwrd <- 0
     ind    <- 0
     ips    <- 0
     #  compute slope at 0 for line search
     linemat[2,1] <- sum(deltac*Flist$grad)
     #  normalize search direction vector
      sdg     <- sqrt(sum(deltac^2))
      deltac  <- deltac/sdg
      dgsum   <- sum(deltac)
      linemat[2,1] <- linemat[2,1]/sdg
      # initialize line search vectors
      linemat[,1:4] <- outer(c(0, linemat[2,1], Flist$f),rep(1,4))
      stepiter <- 0
      if (dbglev >= 2) {
          cat('\n')
          cat(paste("                 ", stepiter, "  "))
          cat(format(round(t(linemat[,1]),6)))
      }
      #  return with error condition if initial slope is nonnegative
      if (linemat[2,1] >= 0) {
        if (dbgwrd >= 2) print("Initial slope nonnegative.")
        ind <- 3
        break
      }
      #  return successfully if initial slope is very small
      if (linemat[2,1] >= -1e-7) {
        if (dbglev >= 2) print("Initial slope too small")
        ind <- 0
        break
      }
      #  first step set to trial
      linemat[1,5]  <- trial
      #  Main iteration loop for linesearch
      cvecnew <- cvec
      Wfdnew  <- Wfdobj
      for (stepiter in 1:MAXSTEPITER)
      {
      #  ensure that step does not go beyond limits on parameters
        limflg  <- FALSE
        #  check the step size
        result <-
              stepchk(linemat[1,5], cvec, deltac, limwrd, ind,
                      climit, active, dbgwrd)
        linemat[1,5] <- result[[1]]
        ind          <- result[[2]]
        limwrd       <- result[[3]]
        if (linemat[1,5] <= 1e-7)
        {
          #  Current step size too small ... terminate
          if (dbglev >= 2) {
            print("Stepsize too small")
            print(avec[5])
          }
          if (limflg) ind <- 1 else ind <- 4
          break
        }
        #  compute new function value and gradient
        cvecnew <- cvec + linemat[1,5]*deltac
        Wfdnew[[1]] <- as.matrix(cvecnew)
        result  <- fngrad.smooth.monotone(y, x, zmat, wt, Wfdnew, lambda,
                                          Kmat, inact, basislist)
        Flist   <- result[[1]]
        beta    <- result[[2]]
        Dyhat   <- result[[3]]
        linemat[3,5] <- Flist$f
        #  compute new directional derivative
        linemat[2,5] <- sum(deltac*Flist$grad)
        if (dbglev >= 2) {
          cat('\n')
          cat(paste("                 ", stepiter, "  "))
          cat(format(round(t(linemat[,5]),6)))
        }
        #  compute next line search step, also test for convergence
        result  <- stepit(linemat, ips, ind, dblwrd, MAXSTEP, dbglev)
        linemat <- result[[1]]
        ips     <- result[[2]]
        ind     <- result[[3]]
        dblwrd  <- result[[4]]
        trial   <- linemat[1,5]
        #  ind == 0  mean convergence
        if (ind == 0 | ind == 5) break
     }
     #  end iteration loop
     cvec <- cvecnew
     Wfdobj  <- Wfdnew
     #  check that function value has not increased
     if (Flist$f > Foldlist$f) {
        # if it has, terminate iterations with a message
        if (dbglev >= 2) {
          cat("Criterion increased: ")
          cat(format(round(c(Foldlist$f, Flist$f),4)))
          cat("\n")
        }
        #  reset parameters and fit
        beta     <- betaold
        cvec     <- cvecold
        Wfdobj[[1]] <- cvec
        Flist    <- Foldlist
        deltac   <- -Flist$grad
        if (reset) {
          # This is the second time in a row that
          #  this has happened ... quit
          if (dbglev >= 2) cat("Reset twice, terminating.\n")
          return ( list( "Wfdobj" = Wfdobj, "beta" = beta, "Flist" = Flist, 
                 "iternum" = iternum, "iterhist" = iterhist ) )
        } else {
          reset <- TRUE
        }
     } else {
       if (abs(Foldlist$f - Flist$f) < conv) {
	       cat('\n')
	       break
       }        
       cvecold  <- cvec
       betaold  <- beta
       Foldlist <- Flist
       hessmat  <- hesscal.smooth.monotone(beta, Dyhat, wtroot, lambda, Kmat, inact)
       #  udate the line search direction
       result   <- linesearch.smooth.monotone(Flist, hessmat, dbglev)
       deltac   <- result[[1]]
       cosangle <- result[[2]]
       reset    <- FALSE
     }
     #  store iteration status
     status <- c(iternum, Flist$f, Flist$norm, beta)
     iterhist[iter+1,] <- status
     if (dbglev >= 1) {
        cat('\n')
        cat(iternum)
        cat("        ")
        cat(round(status[2],4))
        cat("      ")
        cat(round(status[3],4))
        cat("      ")
        cat(round(beta[1],4))
        cat("      ")
        cat(round(beta[ncovp1],4))
     }
  }
  return ( list( "Wfdobj" = Wfdobj, "beta" = beta, "Flist" = Flist, 
                 "iternum" = iternum, "iterhist" = iterhist ) )
}

#  ----------------------------------------------------------------

linesearch.smooth.monotone <- function(Flist, hessmat, dbglev)
{
  deltac   <- -symsolve(hessmat,Flist$grad)
  cosangle <- -sum(Flist$grad*deltac)/sqrt(sum(Flist$grad^2)*sum(deltac^2))
  if (dbglev >= 2) {
    cat(paste("\nCos(angle) =",format(round(cosangle,4))))
    if (cosangle < 1e-7) {
      if (dbglev >=2)  cat("\nCosine of angle too small\n")
      deltac <- -Flist$grad
    }
  }
  return(list(deltac, cosangle))
}

#  ----------------------------------------------------------------

fngrad.smooth.monotone <- function(y, x, zmat, wt, Wfdobj, lambda,
                                   Kmat, inact, basislist)
{
  ncov   <- ncol(zmat)
  ncovp1 <- ncov + 1
  nobs   <- length(x)
  cvec   <- getcoef(Wfdobj)
  nbasis <- length(cvec)
  h      <- monfn(x, Wfdobj, basislist)
  Dyhat  <- mongrad(x, Wfdobj, basislist)
  xmat   <- cbind(zmat,h)
  Dxmat  <- array(0,c(nobs,ncovp1,nbasis))
  Dxmat[,ncovp1,] <- Dyhat
  wtroot <- sqrt(wt)
  wtrtmt <- wtroot %*% matrix(1,1,ncovp1)
  yroot  <- y*wtroot
  xroot  <- xmat*wtrtmt
  #  compute regression coefs.
  beta   <- lsfit(xmat, y, wt, int=FALSE)$coef
  #  update fitted values
  yhat   <- xmat %*% beta
  #  update residuals and function values
  res    <- y - yhat
  f      <- mean(res^2*wt)
  grad   <- matrix(0,nbasis,1)
  for (j in 1:nbasis) {
    Dxroot <- Dxmat[,,j]*wtrtmt
    yDx <- crossprod(yroot,Dxroot) %*% beta
    xDx <- crossprod(xroot,Dxroot)
    grad[j] <- crossprod(beta,(xDx+t(xDx))) %*% beta - 2*yDx
  }
  grad <- grad/nobs
  if (lambda > 0) {
    grad <- grad +         2 * Kmat %*% cvec
    f    <- f    + t(cvec) %*% Kmat %*% cvec
  }
  if (any(inact)) grad[inact] <- 0
  norm <- sqrt(sum(grad^2)) #  gradient norm
  Flist <- list("f"=f,"grad"=grad,"norm"=norm)
  return(list(Flist, beta, Dyhat))
}

#  ----------------------------------------------------------------

hesscal.smooth.monotone <- function(beta, Dyhat, wtroot, lambda,
                                    Kmat, inact)
{
  nbet    <- length(beta)
  Dydim   <- dim(Dyhat)
  nobs    <- Dydim[1]
  nbasis  <- Dydim[2]
  temp    <- beta[nbet]*Dyhat
  temp    <- temp*(wtroot %*% matrix(1,1,nbasis))
  hessmat <- 2*crossprod(temp)/nobs
  #  adjust for penalty
  if (lambda > 0) hessmat <- hessmat + 2*Kmat
  #  adjust for inactive coefficients
  if (any(inact)) {
    eyemat               <- diag(rep(1,nbasis))
    hessmat[inact,     ] <- 0
    hessmat[     ,inact] <- 0
    hessmat[inact,inact] <- eyemat[inact,inact]
  }
  return(hessmat)
}
smooth.pos <- function(x, y, wt=rep(1,nobs), Wfdobj, Lfdobj=2, lambda=0, 
                       conv=1e-4, iterlim=20, dbglev=1) {
# SMOOTH.POS estimates a positive function fitting a sample of scalar observations.

#  Arguments are:
#  X  array of function values
#  Y        array of argument values
#  WT      ...  a vector of weights
#  WFDOBJ   functional data basis object defining initial density
#  LFDOBJ   linear differential operator defining roughness penalty
#  LAMBDA   smoothing parameter
#  CONV     convergence criterion
#  ITERLIM  iteration limit for scoring iterations
#  DBGLEV   level of output of computation history

#  Returns:
#  WFDOBJ    functional data basis object defining final smooth function.
#  FLIST     List containing
#               FLIST$f     final log likelihood
#               FLIST$norm  final norm of gradient
#  ITERNUM   Number of iterations
#  ITERHIST  History of iterations

#  last modified 1 April 2003

   if (!(inherits(Wfdobj, "fd")))
		stop("Argument WFD not a functional data object.")

	basis  <- Wfdobj$basis
	nbasis <- basis$nbasis
	rangex <- basis$rangeval

#  check some arguments

   if (any(wt < 0))  stop("One or more weights are negative.")
   if (all(wt == 0)) stop("All weights are zero.")

	N  <- length(x)
	if (length(y) != N) stop("x and Y are not of the same length.")
	
	#  check for argument values out of range
	
	inrng <- (1:N)[x >= rangex[1] & x <= rangex[2]]
	if (length(inrng) != N)
    	warning("Some values in x out of range and not used.")

	x <- x[inrng]
	y       <- y[inrng]
	nobs    <- length(x)

	#  set up some arrays

	climit  <- c(rep(-50,nbasis),rep(400,nbasis))
	cvec0   <- getcoef(Wfdobj)
	hmat    <- matrix(0,nbasis,nbasis)
	active  <- 1:nbasis
	dbgwrd  <- dbglev > 1

	#  initialize matrix Kmat defining penalty term

	if (lambda > 0)
	  	Kmat <- lambda*getbasispenalty(basis, Lfdobj)

	#  evaluate log likelihood
	#    and its derivatives with respect to these coefficients

	result <- loglfnpos(x, y, wt, basis, cvec0)
	logl   <- result[[1]]
	Dlogl  <- result[[2]]

	#  compute initial badness of fit measures

	f0    <- -logl
	gvec0 <- -Dlogl
	if (lambda > 0) {
   		gvec0 <- gvec0 + 2*(Kmat %*% cvec0)
   		f0 <- f0 + t(cvec0) %*% Kmat %*% cvec0
	}
	Foldstr <- list(f = f0, norm = sqrt(mean(gvec0^2)))

	#  compute the initial expected Hessian

	hmat0 <- Varfnpos(x, wt, basis, cvec0)
	if (lambda > 0) hmat0 <- hmat0 + 2*Kmat

	#  evaluate the initial update vector for correcting the initial bmat

	deltac   <- -solve(hmat0,gvec0)
	cosangle <- -sum(gvec0*deltac)/sqrt(sum(gvec0^2)*sum(deltac^2))

	#  initialize iteration status arrays

	iternum <- 0
	status <- c(iternum, Foldstr$f, -logl, Foldstr$norm)
	cat("Iteration  Criterion  Neg. Log L  Grad. Norm\n")
	cat("      ")
	cat(format(iternum))
	cat("    ")
	cat(format(status[2:4]))
	cat("\n")
	iterhist <- matrix(0,iterlim+1,length(status))
	iterhist[1,]  <- status
	if (iterlim == 0) {
    	Flist     <- Foldstr
    	iterhist <- iterhist[1,]
		return( list("Wfdobj"=Wfdobj, "Flist"=Flist, 
			          "iternum"=iternum, "iterhist"=iterhist) )
	} else {
		gvec <- gvec0
		hmat <- hmat0
	}

	#  -------  Begin iterations  -----------

	STEPMAX <- 5
	MAXSTEP <- 400
	trial   <- 1
	cvec    <- cvec0
	linemat <- matrix(0,3,5)

	for (iter in 1:iterlim) {
   		iternum <- iternum + 1
	   	#  take optimal stepsize
   		dblwrd <- c(0,0)
		limwrd <- c(0,0)
		stpwrd <- 0
		ind    <- 0
	   	#  compute slope
      	Flist <- Foldstr
      	linemat[2,1] <- sum(deltac*gvec)
      	#  normalize search direction vector
      	sdg     <- sqrt(sum(deltac^2))
      	deltac  <- deltac/sdg
      	dgsum   <- sum(deltac)
      	linemat[2,1] <- linemat[2,1]/sdg
      	#  return with stop condition if (initial slope is nonnegative
      	if (linemat[2,1] >= 0) {
        	print("Initial slope nonnegative.")
        	ind <- 3
        	iterhist <- iterhist[1:(iternum+1),]
        	break
      	}
      	#  return successfully if (initial slope is very small
      	if (linemat[2,1] >= -1e-5) {
        	if (dbglev>1) print("Initial slope too small")
        	iterhist <- iterhist[1:(iternum+1),]
        	break
      	}
      	linemat[1,1:4] <- 0
      	linemat[2,1:4] <- linemat[2,1]
      	linemat[3,1:4] <- Foldstr$f
      	stepiter  <- 0
      	if (dbglev > 1) {
			cat("              ")
			cat(format(stepiter))
			cat(format(linemat[,1]))
			cat("\n")
		}
      	ips <- 0
      	#  first step set to trial
      	linemat[1,5]  <- trial
      	#  Main iteration loop for linesrch
      	for (stepiter in 1:STEPMAX) {
        	#  ensure that step does not go beyond limits on parameters
        	limflg  <- 0
        	#  check the step size
        	result <- stepchk(linemat[1,5], cvec, deltac, limwrd, ind,
                            climit, active, dbgwrd)
			linemat[1,5] <- result[[1]]
			ind          <- result[[2]]
			limwrd       <- result[[3]]
       	if (linemat[1,5] <= 1e-9) {
          		#  Current step size too small  terminate
          		Flist    <- Foldstr
          		cvecnew <- cvec
          		gvecnew <- gvec
          		if (dbglev > 1) print(paste("Stepsize too small:", linemat[1,5]))
          		if (limflg) ind <- 1 else ind <- 4
          		break
        	}
        	cvecnew <- cvec + linemat[1,5]*deltac
        	#  compute new function value and gradient
			result <- loglfnpos(x, y, wt, basis, cvecnew)
			logl  <- result[[1]]
			Dlogl <- result[[2]]
        	Flist$f  <- -logl
        	gvecnew <- -Dlogl
        	if (lambda > 0) {
            	gvecnew <- gvecnew + 2*Kmat %*% cvecnew
            	Flist$f <- Flist$f + t(cvecnew) %*% Kmat %*% cvecnew
        	}
        	Flist$norm <- sqrt(mean(gvecnew^2))
        	linemat[3,5] <- Flist$f
        	#  compute new directional derivative
        	linemat[2,5] <- sum(deltac*gvecnew)
      		if (dbglev > 1) {
				cat("              ")
				cat(format(stepiter))
				cat(format(linemat[,1]))
				cat("\n")
			}
        	#  compute next step
			result <- stepit(linemat, ips, ind, dblwrd, MAXSTEP, dbgwrd)
			linemat <- result[[1]]
			ips     <- result[[2]]
			ind     <- result[[3]]
			dblwrd  <- result[[4]]
        	trial   <- linemat[1,5]
        	#  ind == 0 implies convergence
        	if (ind == 0 | ind == 5) break
        	#  end of line search loop
     	}

     	cvec <- cvecnew
     	gvec <- gvecnew
	  	Wfdobj <- putcoef(cvec, Wfdobj)
     	status <- c(iternum, Flist$f, -logl, Flist$norm)
     	iterhist[iter+1,] <- status
		cat("      ")
		cat(format(iternum))
		cat("    ")
		cat(format(status[2:4]))
		cat("\n")
     	#  test for convergence
     	if (abs(Flist$f-Foldstr$f) < conv) {
       	iterhist <- iterhist[1:(iternum+1),]
			return( list("Wfdobj"=Wfdobj, "Flist"=Flist, 
			             "iternum"=iternum, "iterhist"=iterhist) )
     	}
     	if (Flist$f >= Foldstr$f) break
     	#  compute the Hessian
     	hmat <- Varfnpos(x, wt, basis, cvec)
     	if (lambda > 0) hmat <- hmat + 2*Kmat
     	#  evaluate the update vector
     	deltac <- -solve(hmat,gvec)
     	cosangle  <- -sum(gvec*deltac)/sqrt(sum(gvec^2)*sum(deltac^2))
     	if (cosangle < 0) {
       	if (dbglev > 1) print("cos(angle) negative")
       	deltac <- -gvec
     	}
     	Foldstr <- Flist
		#  end of iterations
  	}
	#  compute final normalizing constant
	return( list("Wfdobj"=Wfdobj, "Flist"=Flist, 
			      "iternum"=iternum, "iterhist"=iterhist) )
}

#  ---------------------------------------------------------------

loglfnpos <- function(x, y, wt, basis, cvec) {
	#  Computes the log likelihood and its derivative with
	#    respect to the coefficients in CVEC
   	N       <- length(x)
   	nbasis  <- basis$nbasis
   	phimat  <- getbasismatrix(x, basis)
	Wvec    <- phimat %*% cvec
	EWvec   <- exp(Wvec)
	res     <- y - EWvec
   	logl    <- -mean(wt.*res^2)
  	Dlogl   <- 2*crossprod(phimat,wt*res*EWvec)/N
	return( list(logl, Dlogl) )
}

#  ---------------------------------------------------------------

Varfnpos <- function(x, wt, basis, cvec) {
	#  Computes the expected Hessian
   	N       <- length(x)
   	nbasis  <- basis$nbasis
   	phimat  <- getbasismatrix(x, basis)
	Wvec    <- phimat %*% cvec
	EWvec   <- exp(Wvec)
	res     <- y - EWvec
	Dres    <- ((res*EWvec) %*% matrix(1,1,nbasis)) * phimat
	D2logl  <- 2*t(Dres) %*% Dres/N
	return(D2logl)
}
	

std.fd <- function(fd)
{
  #  Compute the standard deviation functions for functional observations
  #  Argument:
  #  FD    ... a functional data object
  #  Return:
  #  STDFD ... a functional data for the standard deviation functions

  #  Last modified 6 Feb 2001

  if (!(inherits(fd, "fd"))) stop("Argument  FD not a functional data object.")

  coef     <- getcoef(fd)
  coefd    <- dim(coef)
  ndim     <- length(coefd)
  if (coefd[1] == 1) stop("Only one replication found.")

  basisfd  <- getbasis(fd)
  nbasis   <- basisfd$nbasis
  rangeval <- basisfd$rangeval
  fdnames  <- getnames(fd)

  varbifd  <- var.fd(fd)

  neval    <- 10*nbasis + 1
  evalarg  <- seq(rangeval[1], rangeval[2], length=neval)
  vararray <- eval.bifd(evalarg, evalarg, varbifd)
  nvdim    <- length(dim(vararray))

  if (ndim == 2) {
    stdmat  <- matrix(sqrt(diag(vararray)), neval, 1)
  } else {
    nvar <- coefd[3]
    stdmat <- matrix(0, neval, nvar)
    m <- 0
    for (j in 1:nvar) {
      m <- m + j
      if (nvdim == 3) {
        stdmat[,j] <- sqrt(diag(varray[,,1,m]))
      } else {
        stdmat[,j] <- sqrt(diag(varray[,,m]))
      }
    }
  }
  stdcoef <- project.basis(stdmat, evalarg, basisfd)
  names(fdnames)[2] <- "Std. Dev."
  names(fdnames)[3] <- paste("Std. Dev.",names(fdnames)[3])
  stdfd <- create.fd(stdcoef, basisfd, fdnames)
  return(stdfd)
}
stepchk <- function(oldstep, cvec, deltac, limwrd, ind,
                    climit=50*c(-rep(1,ncvec), rep(1,ncvec)),
                    active=1:ncvec, dbgwrd)
{
#  check the step size to keep parameters within boundaries
        ncvec   <- length(deltac)
        bot     <- climit[1:ncvec]
        top     <- climit[ncvec+(1:ncvec)]
        limflg  <- FALSE
        newstep <- oldstep
        stepi   <- oldstep*deltac
        stepmin <- min(stepi)
        index   <- stepi[active] == stepmin
#  ensure that step does not go beyond lower limit on parameters
        if (any(stepi[index] < bot[index]-cvec[index]) &
            any(deltac[index] != 0) )  {
          anew <- min((bot[index]-cvec[index])/deltac[index])
          if (dbgwrd) {
            print("Lower limit reached ... new step:")
            cat(c(stepiter, round(c(oldstep, anew),4)),"\n")
            cat(round(cvec + anew*deltac,4),"\n")
          }
          newstep <- anew
          limflg <- TRUE
        }
#  ensure that step does not go beyond upper limit on parameters
        stepi   <- oldstep*deltac
        stepmax <- max(stepi)
        index   <- stepi[active] == stepmax
        if (any(stepi[index] > top[index]-cvec[index]) &
            any(deltac[index] != 0) ) {
          anew <- min((top[index]-cvec[index])/deltac[index])
          if (dbgwrd) {
            print("Upper limit reached ... new step:")
            cat(c(stepiter, round(c(oldstep, anew),4)),"\n")
          }
          newstep <- anew
          limflg <- TRUE
        }
#  check whether lower limit has been reached twice in a row
        if (limflg) {
          if (limwrd) {
            ind <- 1
            break
          } else limwrd <- TRUE
        } else limwrd <- FALSE
  return(list(newstep, ind, limwrd))
}
stepit <- function(linemat, ips, ind, dblwrd, MAXSTEP, dbgwrd) {
#STEPIT computes next step size in line search algorithm
#  Arguments:
#  LINEMAT:  Row 1 contains step values
#            Row 2 contains slope values
#            Row 3 contains function values
#  IPS:      If 1, previous slope was positive
#  IND:      Termination status
#  DBLWRD:   Vector of length 2:  dblwrd[1] T means step halved
#                                 dblwrd[2] T means step doubled
#  DBGWRD:   Print out details of step
#  MAXSTEP:  maximum size of step

#  Last modified 11 January 2001

test1 <- abs(linemat[2,5]) < abs(linemat[2,1])/10
test2 <- linemat[3,5] > linemat[3,1]
test3 <- linemat[2,5] > 0
if ((test1 || !test3) && test2) {
   #  ************************************************************
   #  function is worse and either slope is satisfory or negative
   ips <- 0        #  step is halved
   if (dblwrd[2]) {
      ind < -5
      return(list(linemat, ips, ind, dblwrd))
   }
   linemat[1,5] <- min(c(linemat[1,5]/2, MAXSTEP))
   linemat[,2] <- linemat[,1]
   linemat[,3] <- linemat[,1]
   dblwrd <- c(1, 0)
   ind <- 2
   return(list(linemat, ips, ind, dblwrd))
}
#  *********************************************************
if (test1) {
   #  test1 means successful convergence
   ind <- 0
   return(list(linemat, ips, ind, dblwrd))
}
#  **********************************************************
if (test3) {
   #  Current slope is positive
   ips <- 1
   linemat[,4] <- linemat[,5]
   deltaf <- linemat[3,3] - linemat[3,5]
   z <- (3/(linemat[1,5] - linemat[1,3])) * deltaf + linemat[2,3] + linemat[2,5]
   w <- z * z - linemat[2,3] * linemat[2,5]
   if (abs(linemat[2,3] + linemat[2,5] + 2 * z) >= 1e-05 & w > 0) {
     w <- sqrt(w)
     linemat[1,5] <- linemat[1,3] + (1 - ((linemat[2,5] + w - z)/(linemat[2,5] - linemat[2,3] +
         2 * w))) * (linemat[1,5] - linemat[1,3])
   } else {
           #  linear interpolation necessary
           aerror <- linemat[1,3]
           if (linemat[1,5] > linemat[1,3]) aerror <- linemat[1,5]
           linemat[1,5] <- linemat[1,3] - linemat[2,3] *((linemat[1,5] - linemat[1,3])/(linemat[2,5] - linemat[2,3]))
           if (linemat[1,5] > 2 * aerror) linemat[1,5] <- 2 * aerror
   }
   linemat[1,5] <- min(c(linemat[1,5], MAXSTEP))
   dblwrd <- c(0,0)
   ind <- 2
   return(list(linemat, ips, ind, dblwrd))
}
#  *************************************************************
#  Current slope is negative or zero
linemat[,2] <- linemat[,3]
linemat[,3] <- linemat[,5]
if (ips == 1) {
   #  *****************************************************
   #  previous slope is positive
   deltaf <- linemat[3,5] - linemat[3,4]
   z <- (3/(linemat[1,4] - linemat[1,5])) * deltaf + linemat[2,5] + linemat[2,4]
   w <- z * z - linemat[2,5] * linemat[2,4]
   if (abs(linemat[2,5] + linemat[2,4] + 2 * z) >= 1e-05 && w > 0) {
     w <- sqrt(w)
     linemat[1,5] <- linemat[1,5] + (1 - ((linemat[2,4] + w - z)/(linemat[2,4] - linemat[2,5] + 2 * w))) * (linemat[1,4] - linemat[1,5])
   } else {
           aerror <- linemat[1,5]
           if (linemat[1,4] > linemat[1,5]) aerror <- linemat[1,4]
           linemat[1,5] <- linemat[1,5] - linemat[2,5] *((linemat[1,4] - linemat[1,5])/(linemat[2,4] - linemat[2,5]))
           if (linemat[1,5] > 2 * aerror) linemat[1,5] <- 2 * aerror
   }
   linemat[1,5] <- min(c(linemat[1,5], MAXSTEP))
   dblwrd <- c(0,0)
   ind <- 2
   return(list(linemat, ips, ind, dblwrd))
}
#  ******************************************************
if ((linemat[2,3] - linemat[2,2]) * (linemat[1,3] - linemat[1,2]) > 0) {
   #  previous slope is negative
   z <- (3/(linemat[1,3] - linemat[1,2])) * (linemat[3,2] - linemat[3,3]) + linemat[2,2] + linemat[2,3]
   w <- z * z - linemat[2,2] * linemat[2,3]
   if (abs(linemat[2,2] + linemat[2,3] + 2 * z) >= 1e-05 & w > 0) {
           w <- sqrt(w)
           linemat[1,5] <- linemat[1,2] + (1 - ((linemat[2,3] + w - z)/(linemat[2,3] - linemat[2,2] + 2 * w))) * (linemat[1,3] - linemat[1,2])
   } else {
     linemat[1,5] <- linemat[1,2] - linemat[2,2] * ((linemat[1,3] - linemat[1,2])/(linemat[2,3] - linemat[2,2]))
   }
   linemat[1,5] <- min(c(linemat[1,5], MAXSTEP))
   dblwrd <- c(0,0)
   ind <- 2
   return(list(linemat, ips, ind, dblwrd))
} else {
   #  previous slope also negative but not as much
   if (dblwrd[1]) {
           ind <- 5
           return(list(linemat, ips, ind, dblwrd))
   } else {
           linemat[1,5] <- 2 * linemat[1,5]
           linemat[1,5] <- min(c(linemat[1,5], MAXSTEP))
           dblwrd <- c(0,1)
           ind <- 2
           return(list(linemat, ips, ind, dblwrd))
   }
}
ind <- 2
return(list(linemat, ips, ind, dblwrd))
}
"[.fd" <- function(fd, ..., drop=FALSE)
{
  #  select subsets of curves in a functional data object
  
  #  last modified 7 February 2001
  
  my.call  <- match.call()
  nargvals <- nargs() - !missing(drop)
  nind <- nargvals - 1
  if (nind > 2) stop("No more than two subscripts allowed.")
  coef <- getcoef(fd)
  ndim <- length(dim(coef))
  if (ndim == 1) stop("Subscripting not allowed for a single function.")
  fdnames <- fd$fdnames
  ind <- ..1
  if (nind == 1) {
    if (ndim == 2) {
      coefselect <- as.matrix(coef[,ind])
      if (is.null(fdnames[[2]]) != TRUE) fdnames[[2]] <- fdnames[[2]][ind]
    }
    if (ndim == 3) {
      if (nargvals == 3) {
        coefselect <- coef[,ind,,drop=FALSE]
        if (is.null(fdnames[[2]]) != TRUE) fdnames[[2]] <- fdnames[[2]][ind]
        fdnames[[2]] <- fdnames[[2]][ind]
      } else {
        coefselect <- coef[,,ind]
        fdnames[[3]] <- fdnames[[3]][ind]
      }
      if (dim(coefselect)[3] == 1) coefselect <- coefselect[,,1]
    }
  }
  if (nind == 2) {
    if (ndim <  3) stop("Two subscripts only allowed for multiple variables.")
    coefselect <- coef[,..1 ,..2,drop=FALSE]
    if (dim(coefselect)[3] == 1) coefselect <- coefselect[,,1]
    if (is.null(fdnames[[2]]) != TRUE) fdnames[[2]] <- fdnames[[2]][ind]
    fdnames[[3]] <- fdnames[[3]][..2]
  }
  basisfd  <- getbasis(fd)
  fdselect <- create.fd(coefselect, basisfd, fdnames=fdnames)
  return(fdselect)
}
sumFd <- function(fd)
{
  #  Compute sum function for functional observations

  #  Last modified 6 Feb 2001

  if (!(inherits(fd, "fd"))) stop("Argument FD not a functional data object.")

  coef   <- getcoef(fd)
  coefd  <- dim(coef)
  ndim   <- length(coefd)
  basis  <- getbasis(fd)
  nbasis <- basis$nbasis
  if (ndim == 2) {
    coefsum   <- matrix(apply(coef,1,sum),nbasis,1)
    coefnames <- list(dimnames(coef)[[1]],"Sum")
  } else {
    nvar <- coefd[3]
    coefsum  <- array(0,c(coefd[1],1,nvar))
    for (j in 1:nvar) coefsum[,1,j] <- apply(coef[,,j],1,sum)
    coefnames <- list(dimnames(coef)[[1]], "Sum", dimnames(coef)[[3]])
  }
  fdnames <- getnames(fd)
  fdnames[[2]] <- "1"
  names(fdnames)[2] <- "Sum"
  names(fdnames)[3] <- paste("Sum",names(fdnames)[3])
  sumfd <- create.fd(coefsum, basis, fdnames)

  return(sumfd)
}
summaryFd <- function(fd,...)
{
  #  Summarizes a functional data object FD or a basis object
  #  The remaining optional arguments are the same as those available
  #     in the regular "summary" function.

  #  Last modified 6 Feb 2001

  if (inherits(fd, "fd")) {
    cat("Dimensions of data:\n")
    print(fd$fdnames)
  } else {
    stop("First argument is not a functional data object.")
  }

  fbdo <- getbasis(fd)
  cat("\nBasis:\n")
  cat(paste("  Type:", fbdo$type,"\n"))
  cat(paste("  Range:",fbdo$rangeval[1],"to",fbdo$rangeval[2],"\n"))
  cat(paste("  Number of basis functions:",  fbdo$nbasis,     "\n"))
  type <- getbasistype(fbdo)
  if  (type == "fourier") {
    cat(paste("  Period:",fbdo$params,"\n"))
  }
  if (type == "bspline") {
    cat("  Interior knots\n")
    print(fbdo$params)
  }
  if (type == "poly") {
    cat("  Polynomial coefficients\n")
    print(fbdo$params)
  }
  if (type == "polyg") {
    cat("  Argument values\n")
    print(fbdo$params)
  }
  if (type == "expon") {
    cat("  Rate coefficients\n")
    print(fd[[2]]$params)
  }
}
symsolve <- function(Asym, Bmat)
{
  #  solves the system ASYM X = BMAT for X where ASYM is symmetric
  #  returns X
  n <- ncol(Asym)
  if (max(abs(Asym-t(Asym)))/max(abs(Asym)) > 1e-10) {
    stop('Argument not symmetric.')
  } else {
    Asym <- (Asym + t(Asym))/2
  }
  Lmat <- chol(Asym)
  temp <- solve(t(Lmat),Bmat)
  Xmat <- backsolve(Lmat,temp)
  return(Xmat)
}
trapz.n <- function(fd, Lfd=0, rng=rangeval, wtfd=NULL,
                     JMAX=12, EPS=1e-5) {

#  computes matrix of integrals of functions or values of a
#  differential operator applied to the functions by numerical integration
#    using Romberg integration

#  Arguments:
#  FD  ...  Either functional data or basis function
#           object.  In the latter case, a functional data object
#           is created from a basis function object by using the
#           identity matrix as the coefficient matrix.
#           The functional data objects must be univariate.
#  LFD ...  Order of derivative for integration for
#           FD, respectively, or functional data objects
#           defining linear differential operators
#  RNG ...  vector of length 2 giving the interval over which the
#           integration is to take place
#  WTFD ... functional data object defining a weight function
#  JMAX ... maximum number of allowable iterations
#  EPS  ... convergence criterion for relative error

#  Return:
#  A vector of length NREP of integralss for each function.

#  Last modified 6 Feb 2001

  #  check arguments, and convert basis objects to functional data objects
  fdclass <- TRUE
  if (inherits(fd, "fd") || inherits(fd, "basis.fd")) {
    if (inherits(fd, "basis.fd")) {
      coef <- diag(rep(1,fd$nbasis))
      fd <- create.fd(coef, fd)
    } else coef <- getcoef(fd)
  } else fdclass <- FALSE
  if (!fdclass) stop ("The first argument must be functional data objects")

  if (!is.null(wtfd)) {
    wtcoef <- getcoef(wtfd)
    if (dim(wtcoef)[[2]] != 1) stop("More than one weight function found")
  }

  #  determine NREP1 and NREP2, and check for common range
  coefd <- dim(coef)
  ndim  <- length(coefd)
  if (ndim > 2) stop("Functional data object must be univariate")
  if (ndim > 1) nrep <- coefd[2] else nrep <- 1

  rangeval <- fd$basis$rangeval
  #  set up first iteration
  width <- rng[2] - rng[1]
  JMAXP <- JMAX + 1
  h <- rep(1,JMAXP)
  h[2] <- 0.25
  s <- matrix(0,c(JMAXP,nrep))
  #  the first iteration uses just the endpoints
  fx <- eval.fd(rng, fd, Lfd)
  if (is.null(wtfd)) {
    s[1,]  <- width*fx/2
  } else {
    wt <- c(eval.fd(penrng, wtfd))
    s[1,]  <- width*(wt*fx)/2
  }
  tnm <- 0.5
  j <- 1
  #print(j)
  #print(round(s[j,],2))
  cat('\n.')

  #  now iterate to convergence
  for (j in 2:JMAX) {
    tnm <- tnm*2
    del <- width/tnm
    x   <- seq(rng[1]+del/2, rng[2]-del/2, del)
    fx <- eval.fd(x, fd, Lfd)
    if (is.null(wtfd)) {
      s[j,] <- (s[j-1,] + width*fx/tnm)/2
    } else {
      wt <- c(eval.fd(x, wtfd))
      s[j,] <- (s[j-1,] + width*(wt*fx)/tnm)/2
    }
    cat('.')
    #print(j)
    #print(round(s[j,,],2))
    if (j >= 5) {
      ind <- (j-4):j
      result <- polintmat(h[ind],s[ind,],0)
      ss  <- result[[1]]
      dss <- result[[2]]
      if (all(abs(dss) < EPS*max(abs(ss)))) return(list(ss, s[j,]))
    }
    s[j+1,] <- s[j,]
    h[j+1]   <- 0.25*h[j]
  }
  warning(paste("No convergence after",JMAX," steps in INPROD"))
}
trapzmat <- function(X,Y,delta=1,wt=rep(1,n)) {
#TRAPZMAT integrates the products of two matrices of values
#   using the trapezoidal rule, assuming equal spacing
#  X is the first  matrix of values
#  Y is the second matrix of values
#  DELTA is the spacing between argument values (one by default)
#  WT is a vector of weights (ones by default)
#
#  XtWY is a matrix of integral estimates, number of rows equal to
#  number of col of X, number of cols equal to number of cols of Y

	X <- as.matrix(X)
	Y <- as.matrix(Y)
	
	n <- dim(X)[1]

	if (dim(Y)[1] != n) {
    	stop("X and Y do not have same number of rows.")
	}

	if (length(wt) != n) {
    	stop("X and WT do not have same number of rows.")
	}

	if (delta <= 0) {
    	stop("DELTA is not a positive value.")
	}

	wt[c(1,n)] <- wt[c(1,n)]/2
	wt <- wt*delta

	X <- X*outer(wt,rep(1,dim(X)[2]))
	XtWY <- crossprod(X,Y)
	return(XtWY)
}

use.proper.basis <- function(type) {
  #  recognizes type of basis by use of several variant spellings
  if(type == 'Fourier' ||
     type == 'fourier' ||
     type == 'Fou'     ||
     type == 'fou') {
                return('fourier')
        }
  else if(type == 'bspline' ||
          type == 'Bspline' ||
          type == 'Bsp'     ||
          type == 'bsp') {
                return('bspline')
        }
  else if(type == 'poly' ||
          type == 'pol'  ||
          type == 'polynomial') {
                return('poly')
        }
  else if(type == 'polyg'    ||
          type == 'polygon'  ||
          type == 'polygonal') {
                return('polyg')
        }
  else if(type == 'exp'    ||
          type == 'expon'  ||
          type == 'exponential') {
                return('expon')
        }
  else if(type == 'con'   ||
          type == 'const' ||
          type == 'const') {
                return('const')
        }
  else {
                return('unknown')
        }
}
var.fd <- function(fdx, fdy = fdx)
{
  #  compute the variance and covariance functions for functional observations

  #  Last modified 6 Feb 2001

  if (!(inherits(fdx, "fd"))) stop("Argument FDX not a functional data object.")
  if (!(inherits(fdy, "fd"))) stop("Argument FDY not a functional data object.")

  coefx   <- getcoef(fdx)
  coefdx  <- dim(coefx)
  basisx  <- getbasis(fdx)
  nbasisx <- basisx$nbasis
  coefy   <- getcoef(fdy)
  coefdy  <- dim(coefy)
  basisy  <- getbasis(fdy)
  nbasisy <- basisy$nbasis
  if (coefdx[2] != coefdy[2]) stop(
    "Number of replications are not equal.")
  if (length(coefdx) == 2) {
    if(length(coefdy) == 2) {
      coefvar <- var(t(coefx),t(coefy))
      coefnames <- list(dimnames(coefx)[[1]], dimnames(coefy)[[1]])
      varbifd <- create.bifd(coefvar, basisx, basisy, coefnames)
    } else {
      stop("Both arguments must be univariate.")
    }
  } else {
    nvar <- coefdx[3]
    npair <- nvar*(nvar+1)/2
    coefnames <- list(dimnames(coefx[[1]]), dimnames(coefx[[1]]),
                      "Covariance", rep(" ",npair))
    coefvar <- array(0,c(nbasisx,nbasisx,1,npair))
    m <- 0
    for (i in 1:nvar) for (j in 1:i) {
      m <- m + 1
      coefvar[,,1,m] <- var(t(coefx[,,i]),t(coefx[,,j]))
      dimnames(coefx)[[4]][m]  <- paste(dimnames(coefx)[[3]][i],"vs",
                                        dimnames(coefx)[[3]][j])
    }
    varbifd <- create.bifd(coefvar, basisx, basisx, coefnames)
  }
  return(varbifd)
}
varmx <- function(amat) {

  #  Does a VARIMAX rotation of a principal components solution

  #  Arguments:
  #  AMAT  ...  N by K matrix of harmonic values

  #  Returns:
  #  ROTM  ...  Rotation matrixed loadings

  n <- nrow(amat)
  k <- ncol(amat)
  rotm <- diag(k)
  if (k == 1) return(rotm)

  eps  <- 0.0011
  ccns <- 0.7071068

  varold <- 0
  varnow <- sum(apply(amat^2, 2, var))

  iter <- 0
  while (abs(varnow - varold) > 1e-7 && iter <= 50) {
    iter  <- iter + 1
    for (j in 1:(k-1)) for (l in (j+1):k) {
      avecj  <- amat[,j]
      avecl  <- amat[,l]
      uvec   <- avecj^2 - avecl^2
      tvec   <- 2*avecj*avecl
      aa <- sum(uvec)
      bb <- sum(tvec)
      cc <- sum(uvec^2 - tvec^2)
      dd <- 2*sum(uvec*tvec)
      tval <- dd - 2*aa*bb/n
      bval <- cc - (aa^2 - bb^2)/n

      if (tval == bval) {
        sin4t <- ccns
        cos4t <- ccns
      }

      if (tval < bval) {
        tan4t <- abs(tval/bval)
        if (tan4t >= eps) {
          cos4t <- 1/sqrt(1+tan4t^2)
          sin4t <- tan4t*cos4t
        } else {
          if (bval < 0) {
            sin4t <- ccns
            cos4t <- ccns
          } else {
            sin4t <- 0
            cos4t <- 1
          }
        }
      }

      if (tval > bval) {
        ctn4t <- abs(tval/bval)
        if (ctn4t >= eps) {
          sin4t <- 1/sqrt(1+ctn4t^2)
          cos4t <- ctn4t*sin4t
        } else {
          sin4t <- 1
          cos4t <- 0
        }
      }

      cos2t <- sqrt((1+cos4t)/2)
      sin2t <- sin4t/(2*cos2t)
      cost  <- sqrt((1+cos2t)/2)
      sint  <- sin2t/(2*cost)
      if (bval > 0) {
        cosp <- cost
        sinp <- sint
      } else {
        cosp <- ccns*(cost + sint)
        sinp <- ccns*abs(cost - sint)
      }
      if (tval <= 0) sinp <- -sinp

      amat[,j] <-  avecj*cosp + avecl*sinp
      amat[,l] <- -avecj*sinp + avecl*cosp
      rvecj    <- rotm[,j]
      rvecl    <- rotm[,l]
      rotm[,j] <-  rvecj * cosp + rvecl * sinp
      rotm[,l] <- -rvecj * sinp + rvecl * cosp

    }
    varold <- varnow
    varnow <- sum(apply(amat^2,2,var))
  }

  return( rotm )
}
varmx.pca.fd <- function(pcafd, nharm = scoresd[2], nx=101)
{
#
#  Apply varimax to the first NHARM components of a pca.fd object.
#  Evaluates the harmonics at NX equally spaced points.
#
#  Returns:
#  An object of class pcafd

#  Last modified 23 January 2003

  if (!(inherits(pcafd, "pca.fd"))) stop("Argument PCAFD is not a pca.fd object.")

  harmfd   <- pcafd[[1]]
  harmcoef <- getcoef(harmfd)
  coefd    <- dim(harmcoef)
  ndim     <- length(coefd)

  scoresd  <- dim(pcafd$scores)
  if (nharm > scoresd[2]) nharm <- scoresd[2]

  basisfd  <- getbasis(harmfd)
  rangex   <- basisfd$rangeval
  x        <- seq(rangex[1], rangex[2], length = nx)
  harmmat  <- eval.fd(x, harmfd)
  #  If fdmat is a 3-D array, stack into a matrix
  if (ndim == 3) {
     harmmatd <- dim(harmmat)
     dimnames(harmmat) <- NULL
     harmmat  <- aperm(harmmat, c(1, 3, 2))
     dim(harmmat) <- c(harmmatd[1] * harmmatd[3], harmmatd[2])
  }
  #  compute rotation matrix for varimax rotation of harmmat
  rotm <- varmx(harmmat)
  #  rotate coefficients and scores
  if(ndim == 2) {
    harmcoef <- harmcoef[,1:nharm]
    harmcoef <- harmcoef %*% rotm
  } else {
    harmcoef <- harmcoef[,1:nharm,]
    for(j in (1:coefd[3])) harmcoef[,,j] <- harmcoef[,,j] %*% rotm
  }
  pcafd$scores  <- pcafd$scores[,1:nharm] %*% rotm
  #  modify pcafd object
  harmfd[[1]] <- harmcoef
  pcafd[[1]]  <- harmfd
  pcafd$varprop <- apply(pcafd$scores^2, 2, mean)/sum(pcafd$values)
  setOldClass("pca.fd")  
  oldClass(pcafd) <- "pca.fd"
  return(pcafd)
}

varmx <- function(amat) {

  #  Does a VARIMAX rotation of a principal components solution

  #  Arguments:
  #  AMAT  ...  N by K matrix of harmonic values

  #  Returns:
  #  ROTM  ...  Rotation matrixed loadings

  n <- nrow(amat)
  k <- ncol(amat)
  rotm <- diag(k)
  if (k == 1) return(rotm)

  eps  <- 0.0011
  ccns <- 0.7071068

  varold <- 0
  varnow <- sum(apply(amat^2, 2, var))

  iter <- 0
  while (abs(varnow - varold) > 1e-7 && iter <= 50) {
    iter  <- iter + 1
    for (j in 1:(k-1)) for (l in (j+1):k) {
      avecj  <- amat[,j]
      avecl  <- amat[,l]
      uvec   <- avecj^2 - avecl^2
      tvec   <- 2*avecj*avecl
      aa <- sum(uvec)
      bb <- sum(tvec)
      cc <- sum(uvec^2 - tvec^2)
      dd <- 2*sum(uvec*tvec)
      tval <- dd - 2*aa*bb/n
      bval <- cc - (aa^2 - bb^2)/n

      if (tval == bval) {
        sin4t <- ccns
        cos4t <- ccns
      }

      if (tval < bval) {
        tan4t <- abs(tval/bval)
        if (tan4t >= eps) {
          cos4t <- 1/sqrt(1+tan4t^2)
          sin4t <- tan4t*cos4t
        } else {
          if (bval < 0) {
            sin4t <- ccns
            cos4t <- ccns
          } else {
            sin4t <- 0
            cos4t <- 1
          }
        }
      }

      if (tval > bval) {
        ctn4t <- abs(tval/bval)
        if (ctn4t >= eps) {
          sin4t <- 1/sqrt(1+ctn4t^2)
          cos4t <- ctn4t*sin4t
        } else {
          sin4t <- 1
          cos4t <- 0
        }
      }

      cos2t <- sqrt((1+cos4t)/2)
      sin2t <- sin4t/(2*cos2t)
      cost  <- sqrt((1+cos2t)/2)
      sint  <- sin2t/(2*cost)
      if (bval > 0) {
        cosp <- cost
        sinp <- sint
      } else {
        cosp <- ccns*(cost + sint)
        sinp <- ccns*abs(cost - sint)
      }
      if (tval <= 0) sinp <- -sinp

      amat[,j] <-  avecj*cosp + avecl*sinp
      amat[,l] <- -avecj*sinp + avecl*cosp
      rvecj    <- rotm[,j]
      rvecl    <- rotm[,l]
      rotm[,j] <-  rvecj * cosp + rvecl * sinp
      rotm[,l] <- -rvecj * sinp + rvecl * cosp

    }
    varold <- varnow
    varnow <- sum(apply(amat^2,2,var))
  }

  return( rotm )
}
warpsmth <- function(x, y, wt=rep(1,nobs), Wfd,
                            Lfd=1, lambda=0, conv=.0001, iterlim=20,
                            active=rep(TRUE,nbasis), dbglev=0) {
#WARPSMTH smooths the relationship of Y to X using weights in WT by
#  fitting a monotone function of the form
#                   f(x) = b_0 + b_1 D^{-1} exp W(x)
#     where  W  is a function defined over the same range as X,
#                 W + ln b_1 = log Df and w = D W = D^2f/Df.
#  b_0 and b_1 are chosen so that f(x_1) = y_1 and f(x_n) = y_n.
#  The fitting criterion is penalized mean squared error:
#    PENSSE(lambda) = \sum [y_i - f(x_i)]^2 +
#                     \lambda * \int [L W(x)]^2 dx
#  where L is a linear differential operator defined in argument LFD.
#  The function W(x) is expanded by the basis in functional data object
#    WFD.

#  Arguments:
#  X       ...  vector of argument values
#  Y       ...  vector of function values to be fit
#  WT      ...  a vector of weights
#  WFD     ...  functional data object for W.  It's coefficient array
#               has a single column, and these are the starting values
#               for the iterative minimization of mean squared error.
#  LFD     ...  linear differential opr defining roughness penalty to
#               be applied to W.  This may be either a functional data
#               object defining a linear differential operator, or a
#               nonnegative integer.  If the latter, it specifies the
#               order of derivative to be penalized.
#               LFD = 1 by default, corresponding to L = D.
#  LAMBDA  ...  smoothing parameter determining the amount of penalty,
#               0 by default.
#  CONV    ...  convergence criterion, 0.0001 by default
#  ITERLIM ...  maximum number of iterations, 20 by default
#  ACTIVE  ...  vector of 1's and 0's indicating which coefficients
#               are to be optimized (1) or remain fixed (0).  All values
#               are 1 by default, except that if a B-spline basis is used,
#               the first value is set to 0.
#  DBGLEV  ...  Controls the level of output on each iteration.  If 0,
#               no output, if 1, output at each iteration, if higher, output
#               at each line search iteration. 1 by default.

#  Returns a list containing:
#  WFD       ...  functional data object for W.  Its coefficients are
#                   those that optimize fit.
#  BETA      ...  final regression coefficient values
#  FNEW      ...  final function value
#  MSG       ...  final gradient norm
#  ITERNUM   ...  number of iterations
#  ITERHIST  ...  ITERNUM+1 by 5 array containing iteration history

#  Last modified 4 July 2001
  if (!(inherits(Wfd, "fd"))) stop('Argument WFD is not a functional data object.')

#  initialize some arrays

  nobs   <- length(x)      #  number of observations
  basis  <- getbasis(Wfd)  #  basis for W
  nbasis <- basis$nbasis   #  number of basis functions

#  the starting values for the coefficients are in FD object WFD

  cvec   <- getcoef(Wfd)

#  check some arguments

  if (any(wt < 0))  stop("One or more weights are negative.")
  if (all(wt == 0)) stop("All weights are zero.")

#  set up some variables

  wtroot <- sqrt(wt)
  wtrtmt <- outer(wtroot,rep(1,ncovp1))
  yroot  <- y*wtroot
  climit <- matrix(100,nbasis,2) %*% matrix(c(-1,0,0,1),2,2)
  inact  <- !active   #  indices of inactive coefficients

#  initialize matrix Kmat defining penalty term

  if (lambda > 0) {
    Kmat <- lambda*getbasispenalty(basis, Lfd)
  } else {
    Kmat <- matrix(0,nbasis,nbasis)
  }

#  Compute initial function and gradient values

  result <- warpfngrad(y, x, wt, Wfd, lambda, Kmat, inact)
  Flist  <- result[[1]]
  Dyhat  <- result[[2]]

#  compute the initial expected Hessian

  hessmat <- warphesscal(Dyhat, wtroot, lambda, Kmat, inact)

#  evaluate the initial update vector for correcting the initial cvec

  result   <- linesearch(Flist, hessmat, dbglev)
  deltac   <- result[[1]]
  cosangle <- result[[2]]

#  initialize iteration status arrays

  iternum <- 0
  status  <- c(iternum, Flist$f, Flist$norm)
  if (dbglev >= 1) {
    cat ("Iter.   PENSSE   Grad Length Intercept\n")
    cat(paste(status[1],round(status[2],4),round(status[3],4),'\n'))
  }

  iterhist <- matrix(0,iterlim+1,length(status))
  iterhist[1,]  <- status
  if (iterlim == 0)
     return( list( Wfd, Flist, iternum, iterhist ) )

#  -------  Begin iterations  -----------

  MAXSTEPITER <- 10
  MAXSTEP <- 100
  trial   <- 1
  reset   <- FALSE
  linemat <- matrix(0,3,5)
  cvecold <- cvec
  Foldlist <- Flist
  dbgwrd  <- dbglev >= 2
  for (iter in 1:iterlim)
  {
     iternum <- iternum + 1
     #  initialize logical variables controlling line search
     dblwrd <- c(0,0)
     limwrd <- c(0,0)
     stpwrd <- 0
     ind    <- 0
     ips    <- 0
     #  compute slope at 0 for line search
     linemat[2,1] <- sum(deltac*Flist$grad)
     #  normalize search direction vector
      sdg     <- sqrt(sum(deltac^2))
      deltac  <- deltac/sdg
      dgsum   <- sum(deltac)
      linemat[2,1] <- linemat[2,1]/sdg
      # initialize line search vectors
      linemat[,1:4] <- outer(c(0, linemat[2,1], Flist$f),rep(1,4))
      stepiter <- 0
      if (dbglev >= 2)
                cat(c("                  ",
                 stepiter,format(round(c(linemat[,1]),6))),"\n")
      #  return with error condition if initial slope is nonnegative
      if (linemat[2,1] >= 0) {
        if (dbgwrd >= 2) print("Initial slope nonnegative.")
        ind <- 3
        break
      }
      #  return successfully if initial slope is very small
      if (linemat[2,1] >= -1e-7) {
        if (dbglev >= 2) print("Initial slope too small")
        ind <- 0
        break
      }
      #  first step set to trial
      linemat[1,5]  <- trial
      #  Main iteration loop for linesearch
      cvecnew <- cvec
      Wfdnew  <- Wfd
      for (stepiter in 1:MAXSTEPITER)
      {
      #  ensure that step does not go beyond limits on parameters
        limflg  <- FALSE
        #  check the step size
        result <-
              stepchk(linemat[1,5], cvec, deltac, limwrd, ind,
                      climit[,1], climit[,2], dbgwrd)
        linemat[1,5] <- result[[1]]
        ind          <- result[[2]]
        limwrd       <- result[[3]]
        if (linemat[1,5] <= 1e-7)
        {
          #  Current step size too small ... terminate
          if (dbglev >= 2) {
            print("Stepsize too small")
            print(avec[5])
          }
          if (limflg) ind <- 1 else ind <- 4
          break
        }
        #  compute new function value and gradient
        cvecnew <- cvec + linemat[1,5]*deltac
        Wfdnew[[1]] <- as.matrix(cvecnew)
        result  <- warpfngrad(y, x, wt, Wfdnew, lambda, Kmat, inact)
        Flist   <- result[[1]]
        Dyhat   <- result[[2]]
        linemat[3,5] <- Flist$f
        #  compute new directional derivative
        linemat[2,5] <- sum(deltac*Flist$grad)
        if (dbglev >= 2)
              cat(paste("                  ",
                 stepiter,format(round(c(linemat[,5]),6))),"\n")
        #  compute next line search step, also test for convergence
        result  <- stepitnew(linemat, ips, ind, dblwrd, MAXSTEP, dbglev)
        linemat <- result[[1]]
        ips     <- result[[2]]
        ind     <- result[[3]]
        dblwrd  <- result[[4]]
        trial   <- linemat[1,5]
        #  ind == 0  mean convergence
        if (ind == 0 | ind == 5) break
     }
     #  end iteration loop
     cvec <- cvecnew
     Wfd  <- Wfdnew
     #  check that function value has not increased
     if (Flist$f > Foldlist$f) {
        # if it has, terminate iterations with a message
        if (dbglev >= 2) {
          cat("Criterion increased: ")
          cat(format(round(c(Foldlist$f, Flist$f),4)))
          cat("\n")
        }
        #  reset parameters and fit
        cvec     <- cvecold
        Wfd[[1]] <- cvec
        Flist    <- Foldlist
        deltac   <- -Flist$grad
        if (reset) {
          # This is the second time in a row that
          #  this has happened ... quit
          if (dbglev >= 2) cat("Reset twice, terminating.\n")
          return ( list( Wfd, Flist, iternum, iterhist) )
        } else {
          reset <- TRUE
        }
     } else {
       if (abs(Foldlist$f - Flist$f) < conv) break
       cvecold  <- cvec
       Foldlist <- Flist
       hessmat  <- warphesscal(Dyhat, wtroot, lambda, Kmat, inact)
       #  udate the line search direction
       result   <- linesearch(Flist, hessmat, dbglev)
       deltac   <- result[[1]]
       cosangle <- result[[2]]
       reset    <- FALSE
     }
     #  store iteration status
     status <- c(iternum, Flist$f, Flist$norm)
     iterhist[iter+1,] <- status
     if (dbglev >= 1)
        cat(paste(status[1],round(status[2],4),round(status[3],4),"\n"))
  }
  return ( list( Wfd, Flist, iternum, iterhist ) )
}

#  ----------------------------------------------------------------

warpfngrad <- function(y, x, wt, Wfd, lambda, Kmat, inact)
{
  nobs   <- length(x)
  cvec   <- getcoef(Wfd)
  nbasis <- length(cvec)
  h      <-   monfn(x, Wfd, TRUE);
  Dyhat  <- Dcmonfn(x, Wfd, TRUE);
  #  update residuals and function values
  res    <- y - h
  f      <- mean(res^2*wt)
  temp   <- Dyhat*outer(wt,rep(1,nbasis))
  grad   <- -2*crossprod(temp,res)/nobs
  if (lambda > 0) {
    grad <- grad +         2 * Kmat %*% cvec
    f    <- f    + t(cvec) %*% Kmat %*% cvec
  }
  if (any(inact)) grad[inact] <- 0
  norm <- sqrt(sum(Flist$grad^2)) #  gradient norm
  Flist <- list(f=f,grad=grad,norm=norm)
  return(list(Flist, Dyhat))
}

#  ----------------------------------------------------------------

warphesscal <- function(Dyhat, wtroot, lambda, Kmat, inact)
{
  Dydim   <- dim(Dyhat)
  nobs    <- Dydim[1]
  nbasis  <- Dydim[2]
  temp    <- Dyhat*outer(wtroot,rep(1,nbasis))
  hessmat <- 2*crossprod(temp)/nobs
  #  adjust for penalty
  if (lambda > 0) hessmat <- hessmat + 2*Kmat
  #  adjust for inactive coefficients
  if (any(inact)) {
    eyemat               <- diag(rep(1,nbasis))
    hessmat[inact,     ] <- 0
    hessmat[     ,inact] <- 0
    hessmat[inact,inact] <- eyemat[inact,inact]
  }
  return(hessmat)
}

zerofind <- function(fmat)
{
  frng <- range(fmat)
  if (frng[1] <= 0 && frng[2] >= 0) zeroin <- TRUE else zeroin <- FALSE
  return(zeroin)
}
