Skip to content

Commit d5e51f4

Browse files
James RamsayJames Ramsay
James Ramsay
authored and
James Ramsay
committed
bug report fixed
1 parent daf2214 commit d5e51f4

File tree

3 files changed

+103
-61
lines changed

3 files changed

+103
-61
lines changed

Diff for: ‎DESCRIPTION

+2-2
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Package: fda
2-
Version: 6.1.8
3-
Date: 2024-03-05
2+
Version: 6.1.9
3+
Date: 2024-03-15
44
Title: Functional Data Analysis
55
Authors@R: c(person("James", "Ramsay", role=c("aut","cre"),
66
email="ramsay@psych.mcgill.ca"),

Diff for: ‎R/Data2fd.R

+100-58
Original file line numberDiff line numberDiff line change
@@ -2,138 +2,168 @@ Data2fd <- function(argvals=NULL, y=NULL, basisobj=NULL, nderiv=NULL,
22
lambda=3e-8/diff(as.numeric(range(argvals))),
33
fdnames=NULL, covariates=NULL, method="chol") {
44

5-
# Last modified 1 March 2024
5+
# Last modified 15 March 2024 by Jim
66

7-
#. Tests five situations requiring modification or termination.
7+
#. Data2fd is a simplified version of other smoothing functions that allows
8+
#. neophytes or those in a hurry to smooth data successfully even though
9+
#. one or more of its arguments is deficient in commonly occurring ways.
10+
11+
#. First invoke function argvalSwap() to see if any arguments are
12+
#. illegitimate, and repair them if possible.
13+
14+
#. Five situations requiring modification or termination:
15+
#. 1. if argvals and y should be swapped
16+
# 2. if argvals is now NULL, build argvals and basisobj
17+
# 3. if the dimensions argvals and y as.array match, build basisobj
18+
#. 4. if length(dimy) < length(dima) swap argvals and y and their
19+
# dimensions dimy and dima
20+
#. 5. if basisobj has the wrong class, search other classes for the
21+
# basis object, and change. Otherwise terminate.
822

923
argChk <- argvalsySwap(argvals, y, basisobj)
1024

25+
# check that argvals are numeric
26+
1127
if(!is.numeric(AV <- argChk$argvals)){
12-
if(is.null(AV))
13-
stop('is.null(argChk$argvals); should be numeric')
28+
# terminal message
29+
if(is.null(AV)) stop('is.null(argChk$argvals); should be numeric')
30+
#. otherwise alert message
1431
cat('argChk$argvals is not numeric.\n')
1532
cat('class(argChk$argvals) = ', class(AV), '\n')
16-
}
33+
print(AV)
34+
}
1735

18-
#. Success and smoothing ... S3 object of class fdSmooth is returned
36+
#. S3 object of class fdSmooth is returned by function smooth.basisPar()
1937

20-
smBasis <- smooth.basisPar(argChk$argvals, argChk$y,
38+
fdSmoothobj <- smooth.basisPar(argChk$argvals, argChk$y,
2139
fdobj=basisobj, Lfdobj=nderiv, lambda=lambda,
2240
fdnames=fdnames,
2341
covariates=covariates, method="chol")
24-
return(smBasis$fd)
42+
43+
# return only the fd component
44+
45+
return(fdSmoothobj$fd)
2546

2647
}
2748

2849
# -------------------------------------------------------------------------
2950

30-
## 2020-01-16: Spencer Graves makes argvalsySwap
31-
## An internal function that tests for 6 situations that require modification
32-
## with a warning, or a terminal error message
33-
3451
argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
3552

53+
# Last modified 15 March 2024 by Jim
54+
3655
if (inherits(basisobj, 'basisfd')) rangeval <- basisobj$rangeval
3756

3857
##. --------------------------------------------------------------------------
39-
## Section 1. if(is.null(y)) use argvals for y
58+
## 1. If argument argvals is NULL, swap it with y
4059
##. --------------------------------------------------------------------------
4160

4261
if(is.null(y)){
4362
if(is.null(argvals)) stop("'y' is missing with no default")
4463
# Store argvals as y and alert
4564
cat("'y' is missing, using 'argvals'\n")
46-
y <- argvals
65+
y <- argvals
4766
argvals <- NULL
4867
}
4968

5069
##. --------------------------------------------------------------------------
51-
## Section 2. test for missing argvals, if so construct a sequence
70+
## 2. If argument argvals is now NULL, then:
71+
## if basisobj is null, use default basis object
72+
## else if basisobj is numeric, default basis object
73+
## if length of basis object is > 1 default basis object
74+
## else default basis object with order = numeric value
75+
## else if basisobj is "fd" basisobj = fd$basis
76+
## else if basisobj is "fdPar" basisobj = fdPar$fd$basis
77+
## else stop with message
78+
## set rangevalue to basisobj$rangeval but stop if is NULL
79+
## return with warning all three arguments
5280
##. --------------------------------------------------------------------------
5381

5482
dimy <- dim(as.array(y))
55-
if(is.null(argvals)) {
56-
# the following code block is run if TRUE
57-
{ # beginning of code block
83+
if (is.null(argvals)) {
84+
{
5885
if(is.null(basisobj)){
5986
basisobj <- create.bspline.basis(basisobj)
6087
} else {
6188
if(is.numeric(basisobj)) {
62-
if(length(basisobj)>1){
89+
if(length(basisobj) > 1) {
6390
basisobj <- create.bspline.basis(basisobj)
64-
} else
91+
} else
6592
basisobj <- create.bspline.basis(norder=basisobj)
6693
}
6794
else {
68-
if(inherits(basisobj, 'fd')){
95+
if(inherits(basisobj, 'fd')) {
6996
basisobj <- basisobj$basis
70-
} else
97+
} else
7198
if(inherits(basisobj, 'fdPar'))
7299
basisobj <- basisobj$fd$basis
73100
}
74101
}
75-
} #. end of code block
76-
# This is executed whether or not the previous was
77-
#. locate the range from basisobj
78-
a01 <- basisobj$rangeval
79-
# if range is null, error message and stop
80-
if(is.null(a01))
102+
}
103+
rangeval <- basisobj$rangeval
104+
if(is.null(rangeval))
81105
stop('basisobj does not have a required rangeval component.')
106+
#
82107
n <- dimy[1]
83-
cat(paste("'argvals' is missing; using seq(", a01[1],
84-
", ", a01[2], ", length=", n, ")\n"))
85-
# construct the argval sequence
86-
argvals <- seq(a01[1], a01[2], length=n)
87-
108+
#. alert message
109+
cat(paste("'argvals' is missing; using seq(", rangeval[1],
110+
", ", rangeval[2], ", length=", n, ")\n"))
111+
argvals <- seq(rangeval[1], rangeval[2], length=n)
88112
return(list(argvals=argvals, y=y, basisobj=basisobj))
89-
90113
}
91114

92115
##. --------------------------------------------------------------------------
93-
## 3. swapping y and argvals
116+
## 3. dimy and dima are dimensions of argvals and y as array objects
117+
## If they match, proceed as in step 2 to construct basisobj
118+
## else stop with message
94119
##. --------------------------------------------------------------------------
95120

96-
dima <- dim(as.array(argvals))
97-
{ # First line in code block
98-
if(length(dimy) == length(dima)) {
121+
dima <- dim(as.array(argvals))
122+
{
123+
if(length(dimy) == length(dima)){
99124
if(any(dimy != dima))
125+
#. terminal message
100126
stop("dimensions of 'argvals' and 'y' must be compatible;\n",
101127
" dim(argvals) = ", paste(dima, collapse=' x '),
102128
"; dim(y) = ", paste(dimy, collapse=' x ') )
103129
# Check basisobj
104-
{ # First line in code block
130+
{
105131
if(inherits(basisobj, 'fd')) basisobj <- basisobj$basis
106132
else {
107133
if(inherits(basisobj, 'fdPar'))
108134
basisobj <- basisobj$fd$basis
109135
else {
110-
if(inherits(basisobj, 'array')) {
111-
fd. <- fd(basisobj)
136+
if(inherits(basisobj, 'array')){
137+
fd. <- fd(basisobj)
112138
basisobj <- fd.$basis
113-
} else {
139+
}
140+
else {
114141
if(inherits(basisobj, 'integer'))
115142
basisobj <- create.bspline.basis(argvals, norder=basisobj)
116143
else {
117-
if(is.null(basisobj))
144+
if(is.null(basisobj)) {
118145
basisobj <- create.bspline.basis(argvals)
146+
}
119147
else
120148
if(!inherits(basisobj, 'basisfd'))
149+
#. terminal message
121150
stop("'basisobj' is NOT a functional basis",
122151
" object (class 'basisfd'); class = ",
123152
class(basisobj)[1])
124153
}
125154
}
126155
}
127156
}
128-
} # Last line in code block
129-
a01 <- basisobj$rangeval
130-
arng <- range(argvals)
157+
}
158+
arng <- range(argvals)
159+
rangeval <- basisobj$rangeval
131160
if ((rangeval[1]<=arng[1]) && (arng[2]<=rangeval[2])) {
132161
return(list(argvals=argvals, y=y, basisobj=basisobj))
133162
}
134163
#
135164
yrng <- range(y)
136-
if ((a01[1]<=yrng[1]) && (yrng[2]<=a01[2])) {
165+
if((rangeval[1]<=yrng[1]) && (yrng[2]<=rangeval[2])) {
166+
#. alert message
137167
cat(paste("'argvals' is NOT contained in basisobj$rangeval",
138168
", but 'y' is; swapping 'argvals' and 'y'.\n"))
139169
return(list(argvals=y, y=argvals, basisobj=basisobj))
@@ -142,10 +172,12 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
142172
stop("Neither 'argvals' nor 'y' are contained in ",
143173
"basisobj$rangeval")
144174
}
145-
} # Last line in code block
175+
}
146176

147177
##. --------------------------------------------------------------------------
148-
## 4. If(length(dimy) < length(dima)) swap argvals and y
178+
## 4. If length(dimy) < length(dima) swap argvals and y and their
179+
## dimensions dimy and dima
180+
## Then stop if a value in dima is not in dimy
149181
##. --------------------------------------------------------------------------
150182

151183
if(length(dimy)<length(dima)) {
@@ -161,18 +193,20 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
161193
dima <- dimy
162194
dimy <- d.
163195
}
164-
196+
# error message if argvals and y are inconsistent
165197
if(any(dima != dimy[1:length(dima)]))
198+
# terminal message
166199
stop("A dimension of 'argvals' does not match 'y':\n",
167200
" dim(argvals) = ", paste(dima, collapse=" x "),
168201
"; dim(y) = ", paste(dimy, collapse=" x ") )
169202

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

174-
{ # First line in code block
175-
if(inherits(basisobj, 'fd'))basisobj <- basisobj$basis
208+
{
209+
if(inherits(basisobj, 'fd')) basisobj <- basisobj$basis
176210
else {
177211
if(inherits(basisobj, 'fdPar'))
178212
basisobj <- basisobj$fd$basis
@@ -189,20 +223,28 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
189223
basisobj <- create.bspline.basis(argvals)
190224
else
191225
if(!inherits(basisobj, 'basisfd'))
226+
#. error message if basisobj incorrect class
192227
stop("'basisobj' is NOT a functional basis",
193228
" object (class 'basisfd'); class = ",
194229
class(basisobj)[1])
195230
}
196231
}
197232
}
198233
}
199-
} # Last line in code block
200-
a01 <- basisobj$rangeval
234+
rangeval <- basisobj$rangeval
235+
}
236+
237+
##. --------------------------------------------------------------------------
238+
## 6. Check compatibility of argvals with basisobj$rangeval
239+
##. --------------------------------------------------------------------------
240+
241+
a01 <- basisobj$rangeval
201242
arng <- range(argvals)
202-
if((a01[1]<=arng[1]) && (arng[2]<=a01[2])) {
243+
if ((a01[1] <= arng[1]) && (arng[1] <= a01[2])) {
203244
return(list(argvals=argvals, y=y, basisobj=basisobj))
204245
}
205-
#
206-
stop("'argvals' are not contained in basisobj$rangeval")
246+
# error message
247+
stop("There are argvals not contained within basisobj$rangeval")
248+
207249
}
208250

Diff for: ‎man/Data2fd.Rd

+1-1
Original file line numberDiff line numberDiff line change
@@ -267,7 +267,7 @@ par(op)
267267
## Two simple Fourier examples
268268
##
269269
gaitbasis3 <- create.fourier.basis(nbasis=5)
270-
gaitfd3 <- Data2fd(gait, basisobj=gaitbasis3)
270+
gaitfd3 <- Data2fd(seq(0,1,len=20), gait, basisobj=gaitbasis3)
271271
# plotfit.fd(gait, seq(0,1,len=20), gaitfd3)
272272
# set up the fourier basis
273273
daybasis <- create.fourier.basis(c(0, 365), nbasis=65)

0 commit comments

Comments
 (0)