https://github.com/cran/fda
Raw File
Tip revision: cffaee83f2132e70d363589d8be217ce70ea1e3a authored by J. O. Ramsay on 02 March 2009, 00:00:00 UTC
version 2.1.2
Tip revision: cffaee8
TaylorSpline.R
TaylorSpline <- function(object, ...) {
  UseMethod('TaylorSpline') 
}

TaylorSpline.dierckx <- function(object, ...) {
  if(require(DierckxSpline)){
    fdo <- dierckx2fd(object)
    return(TaylorSpline(fdo, ...))
  }
  else
    stop('Requires library(DierckxSpline);  not installed.') 
}

#TaylorSpline.dierckx <- function(object, ...) {
#'coming soon'
#}

TaylorSpline.fd <- function(object, ...) {
##
## 1.  object$type = 'bspline'?
##
#  if(!require(fda))stop('fda package required.')
#  
  oName <- substring(deparse(substitute(object)), 1, 33)
  type <- object$basis$type
  if(is.null(type))
    stop('is.null((', oName, ')$basis$type);  must be "bspline"') 
  if(type != 'bspline')
    stop('(', oName, ')$basis$type) = ', type[1],
         ';  must be "bspline"')
##
## 2.  knots
##
  allKnots <- knots(object, interior=FALSE, ...)
  uniqKnots <- unique(allKnots)
  nUniq <- length(uniqKnots)
  nU1 <- (nUniq-1) 
  midPts <- ((uniqKnots[-1]+uniqKnots[-nUniq])/2)
  nOrd <- norder(object)
##
## 3.  coef(object)
##
  coefObj <- as.array(coef(object)) 
  cdim <- dim(coefObj)
  cNames <- dimnames(coefObj)
  ndim <- length(cdim) 
##
## 4.  switch(ndim, ...)
##
  colNames <- paste('b', 0:(nOrd-1), sep='')
  Dnames <- paste('D', 0:(nOrd-1), sep='')
  switch(ndim,
         '1'={
           Coef <- matrix(NA, nU1, nOrd, dimnames=list(
                                           NULL, colNames) )
           Deriv <- matrix(NA, nU1, nOrd, dimnames=list(
                                            NULL, Dnames) )
           for(i in 1:nOrd){
             bi <- eval.fd(midPts, object, i-1)
             Deriv[, i] <- bi
             Coef[, i] <- bi/factorial(i-1)
           }
         }, 
         '2'={
           Coef <- array(NA, c(nU1, nOrd, cdim[2]), dimnames=
                         list(NULL, colNames, NULL) )
           Deriv <- array(NA, c(nU1, nOrd, cdim[2]), dimnames=
                         list(NULL, Dnames, NULL) )
           if(!is.null(cNames) && !is.null(cNames[[2]])){
             dimnames(Coef)[[3]] <- cNames[[2]]
             dimnames(Deriv)[[3]] <- cNames[[2]]
           }
           for(i in 1:nOrd){
             bi <- eval.fd(midPts, object, i-1)
             Deriv[,i, ] <- bi
             Coef[,i,] <- bi/factorial(i-1)
           }
         }, 
         '3'={
           Coef <- array(NA, c(nU1, nOrd, cdim[2:3]), dimnames=
                         list(NULL, colNames, NULL, NULL) )
           Deriv <- array(NA, c(nU1, nOrd, cdim[2:3]), dimnames=
                         list(NULL, Dnames, NULL, NULL) )
           if(!is.null(cNames)){
             if(!is.null(cNames[[2]])){
               dimnames(Coef)[[3]] <- cNames[[2]]
               dimnames(Deriv)[[3]] <- cNames[[2]]
             }
             if(!is.null(cNames[[3]])){
               dimnames(Coef)[[4]] <- cNames[[3]]
               dimnames(Deriv)[[4]] <- cNames[[3]]
             }
           }
           for(i in 1:nOrd){
             bi <- eval.fd(midPts, object, i-1)
             Deriv[,i, , ] <- bi
             Coef[,i, ,] <- bi/factorial(i-1)
           }
         }, 
         'other'=stop('coef(', oName, ' is neither a vector, nor ',
           'a matrix nor a 3-d array.')
         )  
##
## 4.  Done
##
  Taylor <- list(knots=allKnots, midpoints=midPts, coef=Coef,
       deriv=Deriv)
  class(Taylor) <- 'Taylor'
  Taylor 
}

#TaylorSpline.fd <- function(object, ...) {
#  if(depends(DierckxSpline)){
#    fdo <- fd2dierckx(object)
#    return(TaylorSpline(fdo, ...))
#  }
#  else
#    stop('Requires library(DierckxSpline;  not installed.') 
#}

#TaylorSpline.list <- function(object, ...){
#  comps <- sapply(object, inherits, what)
#}

TaylorSpline.fdPar <- function(object, ...){
  TaylorSpline(object$fd, ...)
}

TaylorSpline.fdSmooth <- function(object, ...){
  TaylorSpline(object$fd, ...)
}

back to top