Skip to content

Commit

Permalink
bug report fixed
Browse files Browse the repository at this point in the history
  • Loading branch information
James Ramsay authored and James Ramsay committed Mar 15, 2024
1 parent daf2214 commit d5e51f4
Show file tree
Hide file tree
Showing 3 changed files with 103 additions and 61 deletions.
4 changes: 2 additions & 2 deletions DESCRIPTION
View file
@@ -1,6 +1,6 @@
Package: fda
Version: 6.1.8
Date: 2024-03-05
Version: 6.1.9
Date: 2024-03-15
Title: Functional Data Analysis
Authors@R: c(person("James", "Ramsay", role=c("aut","cre"),
email="ramsay@psych.mcgill.ca"),
Expand Down
158 changes: 100 additions & 58 deletions R/Data2fd.R
View file
Expand Up @@ -2,138 +2,168 @@ Data2fd <- function(argvals=NULL, y=NULL, basisobj=NULL, nderiv=NULL,
lambda=3e-8/diff(as.numeric(range(argvals))),
fdnames=NULL, covariates=NULL, method="chol") {

# Last modified 1 March 2024
# Last modified 15 March 2024 by Jim

#. Tests five situations requiring modification or termination.
#. Data2fd is a simplified version of other smoothing functions that allows
#. neophytes or those in a hurry to smooth data successfully even though
#. one or more of its arguments is deficient in commonly occurring ways.

#. First invoke function argvalSwap() to see if any arguments are
#. illegitimate, and repair them if possible.

#. Five situations requiring modification or termination:
#. 1. if argvals and y should be swapped
# 2. if argvals is now NULL, build argvals and basisobj
# 3. if the dimensions argvals and y as.array match, build basisobj
#. 4. if length(dimy) < length(dima) swap argvals and y and their
# dimensions dimy and dima
#. 5. if basisobj has the wrong class, search other classes for the
# basis object, and change. Otherwise terminate.

argChk <- argvalsySwap(argvals, y, basisobj)

# check that argvals are numeric

if(!is.numeric(AV <- argChk$argvals)){
if(is.null(AV))
stop('is.null(argChk$argvals); should be numeric')
# terminal message
if(is.null(AV)) stop('is.null(argChk$argvals); should be numeric')
#. otherwise alert message
cat('argChk$argvals is not numeric.\n')
cat('class(argChk$argvals) = ', class(AV), '\n')
}
print(AV)
}

#. Success and smoothing ... S3 object of class fdSmooth is returned
#. S3 object of class fdSmooth is returned by function smooth.basisPar()

smBasis <- smooth.basisPar(argChk$argvals, argChk$y,
fdSmoothobj <- smooth.basisPar(argChk$argvals, argChk$y,
fdobj=basisobj, Lfdobj=nderiv, lambda=lambda,
fdnames=fdnames,
covariates=covariates, method="chol")
return(smBasis$fd)

# return only the fd component

return(fdSmoothobj$fd)

}

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

## 2020-01-16: Spencer Graves makes argvalsySwap
## An internal function that tests for 6 situations that require modification
## with a warning, or a terminal error message

argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {

# Last modified 15 March 2024 by Jim

if (inherits(basisobj, 'basisfd')) rangeval <- basisobj$rangeval

##. --------------------------------------------------------------------------
## Section 1. if(is.null(y)) use argvals for y
## 1. If argument argvals is NULL, swap it with y
##. --------------------------------------------------------------------------

if(is.null(y)){
if(is.null(argvals)) stop("'y' is missing with no default")
# Store argvals as y and alert
cat("'y' is missing, using 'argvals'\n")
y <- argvals
y <- argvals
argvals <- NULL
}

##. --------------------------------------------------------------------------
## Section 2. test for missing argvals, if so construct a sequence
## 2. If argument argvals is now NULL, then:
## if basisobj is null, use default basis object
## else if basisobj is numeric, default basis object
## if length of basis object is > 1 default basis object
## else default basis object with order = numeric value
## else if basisobj is "fd" basisobj = fd$basis
## else if basisobj is "fdPar" basisobj = fdPar$fd$basis
## else stop with message
## set rangevalue to basisobj$rangeval but stop if is NULL
## return with warning all three arguments
##. --------------------------------------------------------------------------

dimy <- dim(as.array(y))
if(is.null(argvals)) {
# the following code block is run if TRUE
{ # beginning of code block
if (is.null(argvals)) {
{
if(is.null(basisobj)){
basisobj <- create.bspline.basis(basisobj)
} else {
if(is.numeric(basisobj)) {
if(length(basisobj)>1){
if(length(basisobj) > 1) {
basisobj <- create.bspline.basis(basisobj)
} else
} else
basisobj <- create.bspline.basis(norder=basisobj)
}
else {
if(inherits(basisobj, 'fd')){
if(inherits(basisobj, 'fd')) {
basisobj <- basisobj$basis
} else
} else
if(inherits(basisobj, 'fdPar'))
basisobj <- basisobj$fd$basis
}
}
} #. end of code block
# This is executed whether or not the previous was
#. locate the range from basisobj
a01 <- basisobj$rangeval
# if range is null, error message and stop
if(is.null(a01))
}
rangeval <- basisobj$rangeval
if(is.null(rangeval))
stop('basisobj does not have a required rangeval component.')
#
n <- dimy[1]
cat(paste("'argvals' is missing; using seq(", a01[1],
", ", a01[2], ", length=", n, ")\n"))
# construct the argval sequence
argvals <- seq(a01[1], a01[2], length=n)

#. alert message
cat(paste("'argvals' is missing; using seq(", rangeval[1],
", ", rangeval[2], ", length=", n, ")\n"))
argvals <- seq(rangeval[1], rangeval[2], length=n)
return(list(argvals=argvals, y=y, basisobj=basisobj))

}

##. --------------------------------------------------------------------------
## 3. swapping y and argvals
## 3. dimy and dima are dimensions of argvals and y as array objects
## If they match, proceed as in step 2 to construct basisobj
## else stop with message
##. --------------------------------------------------------------------------

dima <- dim(as.array(argvals))
{ # First line in code block
if(length(dimy) == length(dima)) {
dima <- dim(as.array(argvals))
{
if(length(dimy) == length(dima)){
if(any(dimy != dima))
#. terminal message
stop("dimensions of 'argvals' and 'y' must be compatible;\n",
" dim(argvals) = ", paste(dima, collapse=' x '),
"; dim(y) = ", paste(dimy, collapse=' x ') )
# Check basisobj
{ # First line in code block
{
if(inherits(basisobj, 'fd')) basisobj <- basisobj$basis
else {
if(inherits(basisobj, 'fdPar'))
basisobj <- basisobj$fd$basis
else {
if(inherits(basisobj, 'array')) {
fd. <- fd(basisobj)
if(inherits(basisobj, 'array')){
fd. <- fd(basisobj)
basisobj <- fd.$basis
} else {
}
else {
if(inherits(basisobj, 'integer'))
basisobj <- create.bspline.basis(argvals, norder=basisobj)
else {
if(is.null(basisobj))
if(is.null(basisobj)) {
basisobj <- create.bspline.basis(argvals)
}
else
if(!inherits(basisobj, 'basisfd'))
#. terminal message
stop("'basisobj' is NOT a functional basis",
" object (class 'basisfd'); class = ",
class(basisobj)[1])
}
}
}
}
} # Last line in code block
a01 <- basisobj$rangeval
arng <- range(argvals)
}
arng <- range(argvals)
rangeval <- basisobj$rangeval
if ((rangeval[1]<=arng[1]) && (arng[2]<=rangeval[2])) {
return(list(argvals=argvals, y=y, basisobj=basisobj))
}
#
yrng <- range(y)
if ((a01[1]<=yrng[1]) && (yrng[2]<=a01[2])) {
if((rangeval[1]<=yrng[1]) && (yrng[2]<=rangeval[2])) {
#. alert message
cat(paste("'argvals' is NOT contained in basisobj$rangeval",
", but 'y' is; swapping 'argvals' and 'y'.\n"))
return(list(argvals=y, y=argvals, basisobj=basisobj))
Expand All @@ -142,10 +172,12 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
stop("Neither 'argvals' nor 'y' are contained in ",
"basisobj$rangeval")
}
} # Last line in code block
}

##. --------------------------------------------------------------------------
## 4. If(length(dimy) < length(dima)) swap argvals and y
## 4. If length(dimy) < length(dima) swap argvals and y and their
## dimensions dimy and dima
## Then stop if a value in dima is not in dimy
##. --------------------------------------------------------------------------

if(length(dimy)<length(dima)) {
Expand All @@ -161,18 +193,20 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
dima <- dimy
dimy <- d.
}

# error message if argvals and y are inconsistent
if(any(dima != dimy[1:length(dima)]))
# terminal message
stop("A dimension of 'argvals' does not match 'y':\n",
" dim(argvals) = ", paste(dima, collapse=" x "),
"; dim(y) = ", paste(dimy, collapse=" x ") )

##. --------------------------------------------------------------------------
## 5. Check compatibility of argvals with basisobj
## 5. check basisobj for having the wrong class, and is so
# proceed as above to find an object with the right class
##. --------------------------------------------------------------------------

{ # First line in code block
if(inherits(basisobj, 'fd'))basisobj <- basisobj$basis
{
if(inherits(basisobj, 'fd')) basisobj <- basisobj$basis
else {
if(inherits(basisobj, 'fdPar'))
basisobj <- basisobj$fd$basis
Expand All @@ -189,20 +223,28 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
basisobj <- create.bspline.basis(argvals)
else
if(!inherits(basisobj, 'basisfd'))
#. error message if basisobj incorrect class
stop("'basisobj' is NOT a functional basis",
" object (class 'basisfd'); class = ",
class(basisobj)[1])
}
}
}
}
} # Last line in code block
a01 <- basisobj$rangeval
rangeval <- basisobj$rangeval
}

##. --------------------------------------------------------------------------
## 6. Check compatibility of argvals with basisobj$rangeval
##. --------------------------------------------------------------------------

a01 <- basisobj$rangeval
arng <- range(argvals)
if((a01[1]<=arng[1]) && (arng[2]<=a01[2])) {
if ((a01[1] <= arng[1]) && (arng[1] <= a01[2])) {
return(list(argvals=argvals, y=y, basisobj=basisobj))
}
#
stop("'argvals' are not contained in basisobj$rangeval")
# error message
stop("There are argvals not contained within basisobj$rangeval")

}

2 changes: 1 addition & 1 deletion man/Data2fd.Rd
View file
Expand Up @@ -267,7 +267,7 @@ par(op)
## Two simple Fourier examples
##
gaitbasis3 <- create.fourier.basis(nbasis=5)
gaitfd3 <- Data2fd(gait, basisobj=gaitbasis3)
gaitfd3 <- Data2fd(seq(0,1,len=20), gait, basisobj=gaitbasis3)
# plotfit.fd(gait, seq(0,1,len=20), gaitfd3)
# set up the fourier basis
daybasis <- create.fourier.basis(c(0, 365), nbasis=65)
Expand Down

0 comments on commit d5e51f4

Please sign in to comment.