https://github.com/cran/fda
Tip revision: ca5e2b4994971ec127b6a5ed2a08ce34abb2655c authored by J. O. Ramsay on 28 September 2021, 03:50:08 UTC
version 5.4.0
version 5.4.0
Tip revision: ca5e2b4
as.fd.R
as.fd <- function(x, ...) {
UseMethod('as.fd')
}
as.fd.fdSmooth <- function(x, ...){
x$fd
}
as.fd.function <- function(x, ...){
# Translate an object of class splinefun to class fd
##
## 1. check class
##
objName <- deparse(substitute(x))
{
if(length(objName)>1)
objName <- character(0)
else
if(nchar(objName)>33)
objName <- substring(objName, 1, 33)
}
if(!inherits(x, 'function'))
stop("'x' (", objName, ") is not of class function")
#
xenv <- environment(x)
xz <- get('z', xenv)
if(is.null(xz))
stop("NULL environment of 'x' (", objName,
"); therefore, it can NOT have been created by 'splinefun.'")
#
if(is.null(xz$method))
stop("'x' (", objName, ") has a NULL 'method', and therefore",
" can NOT have been created by 'splinefun.'")
# z$method: 1=periodic, 2=natural, 3=fmm (std B-Splines, I believe)
# if(xz$method!=3){
if(!(xz$method %in% 2:3)){
msg <- paste("x (", objName, ") ", sep='')
msg2 <- {
if(xz$method=="1")
paste(msg, " uses periodic B-splines, and as.fd ",
"is programmed\n to translate only B-splines ",
"with coincident boundary knots.", sep='')
else
paste(msg, "does not use B-splines as required ",
"for function 'as.fd'.")
}
stop(msg2)
}
##
## 2. Create a basis
##
Knots <- xz$x
y.x <- xz$y
basis <- create.bspline.basis(range(Knots), breaks=Knots)
fd. <- fdPar(basis, lambda=0)
nKn <- length(Knots)
nobs <- (2*nKn-1)
x. <- seq(Knots[1], Knots[nKn], length=nobs)
smooth.basis(x., x(x.), fd.)$fd
}
as.fd.smooth.spline <- function(x, ...){
# Translate an object of class smooth.spline to class fd
##
## 1. check class
##
objName <- deparse(substitute(x))
{
if(length(objName)>1)
objName <- character(0)
else
if(nchar(objName)>33)
objName <- substring(objName, 1, 33)
}
if(!inherits(x, 'smooth.spline'))
stop("'x' (", objName, ") is not of class smooth.spline")
##
## 2. Create a basis
##
Kn0 <- x$fit$knot
x0 <- min(x$x)
x1 <- max(x$x)
Knots <- (x0+(x1-x0)*Kn0[4:(length(Kn0)-3)])
# Don't use 'unique' in case 'x' has coincident interior knots.
# basis <- create.bspline.basis(breaks=Knots)
basis <- create.bspline.basis(range(Knots), breaks=Knots)
#
fd(x$fit$coef, basis)
}