Skip to content

Commit 5a6795d

Browse files
JamesRamsay5JamesRamsay5
committed
Data2ld R and Rd fixed
1 parent c251256 commit 5a6795d

File tree

3 files changed

+37
-70
lines changed

3 files changed

+37
-70
lines changed

Diff for: ‎DESCRIPTION

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Package: fda
22
Version: 6.1.7
3-
Date: 2024-02-27
3+
Date: 2024-03-01
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

+32-65
Original file line numberDiff line numberDiff line change
@@ -2,38 +2,26 @@ 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 5 February 2024
5+
# Last modified 1 March 2024
66

7-
# Changes proposed by Spencer Graves 2010.12.08 ...
8-
# if(is.null(lambda))
9-
# lambda <- 1e-9*sd(argChk$y)/diff(range(argChk$argvals))
10-
#
11-
# Error in smooth.basis ... argvals is not numeric
12-
# in R CMD check, cannot replicate line by line.
13-
14-
#. Tests six situations requiring modification or termination.
15-
16-
argChk <- argvalsySwap(argvals, y, basisobj)
17-
18-
# another rest with messages
7+
#. Tests five situations requiring modification or termination.
198

209
argChk <- argvalsySwap(argvals, y, basisobj)
2110

2211
if(!is.numeric(AV <- argChk$argvals)){
23-
print(AV)
2412
if(is.null(AV))
2513
stop('is.null(argChk$argvals); should be numeric')
2614
cat('argChk$argvals is not numeric.\n')
2715
cat('class(argChk$argvals) = ', class(AV), '\n')
28-
print(AV)
2916
}
3017

3118
#. Success and smoothing ... S3 object of class fdSmooth is returned
3219

33-
fdSmoothobj <- smooth.basisPar(argChk$argvals, argChk$y,
20+
smBasis <- smooth.basisPar(argChk$argvals, argChk$y,
3421
fdobj=basisobj, Lfdobj=nderiv, lambda=lambda,
3522
fdnames=fdnames,
3623
covariates=covariates, method="chol")
24+
return(smBasis$fd)
3725

3826
}
3927

@@ -48,19 +36,19 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
4836
if (inherits(basisobj, 'basisfd')) rangeval <- basisobj$rangeval
4937

5038
##. --------------------------------------------------------------------------
51-
## 1. if(is.null(y)) use argvals for y
39+
## Section 1. if(is.null(y)) use argvals for y
5240
##. --------------------------------------------------------------------------
5341

5442
if(is.null(y)){
5543
if(is.null(argvals)) stop("'y' is missing with no default")
5644
# Store argvals as y and alert
5745
cat("'y' is missing, using 'argvals'\n")
58-
y <- argvals
46+
y <- argvals
5947
argvals <- NULL
6048
}
6149

6250
##. --------------------------------------------------------------------------
63-
## 2. test for missing argvals, if so construct a sequence
51+
## Section 2. test for missing argvals, if so construct a sequence
6452
##. --------------------------------------------------------------------------
6553

6654
dimy <- dim(as.array(y))
@@ -92,63 +80,60 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
9280
if(is.null(a01))
9381
stop('basisobj does not have a required rangeval component.')
9482
n <- dimy[1]
95-
# construct the argval sequence
96-
argvals <- seq(a01[1], a01[2], length=n)
97-
# warning message about the swap
9883
cat(paste("'argvals' is missing; using seq(", a01[1],
9984
", ", a01[2], ", length=", n, ")\n"))
100-
#. return
85+
# construct the argval sequence
86+
argvals <- seq(a01[1], a01[2], length=n)
87+
10188
return(list(argvals=argvals, y=y, basisobj=basisobj))
89+
10290
}
10391

10492
##. --------------------------------------------------------------------------
10593
## 3. swapping y and argvals
10694
##. --------------------------------------------------------------------------
10795

108-
dima <- dim(as.array(argvals))
109-
{
110-
if(length(dimy) == length(dima)){
96+
dima <- dim(as.array(argvals))
97+
{ # First line in code block
98+
if(length(dimy) == length(dima)) {
11199
if(any(dimy != dima))
112-
#. terminal message
113100
stop("dimensions of 'argvals' and 'y' must be compatible;\n",
114101
" dim(argvals) = ", paste(dima, collapse=' x '),
115102
"; dim(y) = ", paste(dimy, collapse=' x ') )
116103
# Check basisobj
117-
{
104+
{ # First line in code block
118105
if(inherits(basisobj, 'fd')) basisobj <- basisobj$basis
119106
else {
120107
if(inherits(basisobj, 'fdPar'))
121108
basisobj <- basisobj$fd$basis
122109
else {
123-
if(inherits(basisobj, 'array')){
124-
fd. <- fd(basisobj)
110+
if(inherits(basisobj, 'array')) {
111+
fd. <- fd(basisobj)
125112
basisobj <- fd.$basis
126-
}
127-
else {
113+
} else {
128114
if(inherits(basisobj, 'integer'))
129115
basisobj <- create.bspline.basis(argvals, norder=basisobj)
130116
else {
131117
if(is.null(basisobj))
132118
basisobj <- create.bspline.basis(argvals)
133119
else
134120
if(!inherits(basisobj, 'basisfd'))
135-
#. terminal message
136121
stop("'basisobj' is NOT a functional basis",
137122
" object (class 'basisfd'); class = ",
138123
class(basisobj)[1])
139124
}
140125
}
141126
}
142127
}
143-
}
144-
arng <- range(argvals)
128+
} # Last line in code block
129+
a01 <- basisobj$rangeval
130+
arng <- range(argvals)
145131
if ((rangeval[1]<=arng[1]) && (arng[2]<=rangeval[2])) {
146132
return(list(argvals=argvals, y=y, basisobj=basisobj))
147133
}
148134
#
149135
yrng <- range(y)
150-
if((rangeval[1]<=yrng[1]) && (yrng[2]<=rangeval[2])) {
151-
#. alert message
136+
if ((a01[1]<=yrng[1]) && (yrng[2]<=a01[2])) {
152137
cat(paste("'argvals' is NOT contained in basisobj$rangeval",
153138
", but 'y' is; swapping 'argvals' and 'y'.\n"))
154139
return(list(argvals=y, y=argvals, basisobj=basisobj))
@@ -157,7 +142,7 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
157142
stop("Neither 'argvals' nor 'y' are contained in ",
158143
"basisobj$rangeval")
159144
}
160-
}
145+
} # Last line in code block
161146

162147
##. --------------------------------------------------------------------------
163148
## 4. If(length(dimy) < length(dima)) swap argvals and y
@@ -176,9 +161,8 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
176161
dima <- dimy
177162
dimy <- d.
178163
}
179-
# error message if argvals and y are inconsistent
164+
180165
if(any(dima != dimy[1:length(dima)]))
181-
# terminal message
182166
stop("A dimension of 'argvals' does not match 'y':\n",
183167
" dim(argvals) = ", paste(dima, collapse=" x "),
184168
"; dim(y) = ", paste(dimy, collapse=" x ") )
@@ -187,7 +171,7 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
187171
## 5. Check compatibility of argvals with basisobj
188172
##. --------------------------------------------------------------------------
189173

190-
{
174+
{ # First line in code block
191175
if(inherits(basisobj, 'fd'))basisobj <- basisobj$basis
192176
else {
193177
if(inherits(basisobj, 'fdPar'))
@@ -205,37 +189,20 @@ argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL) {
205189
basisobj <- create.bspline.basis(argvals)
206190
else
207191
if(!inherits(basisobj, 'basisfd'))
208-
#. error message if basisobj incorrect class
209192
stop("'basisobj' is NOT a functional basis",
210193
" object (class 'basisfd'); class = ",
211194
class(basisobj)[1])
212195
}
213196
}
214197
}
215198
}
199+
} # Last line in code block
200+
a01 <- basisobj$rangeval
201+
arng <- range(argvals)
202+
if((a01[1]<=arng[1]) && (arng[2]<=a01[2])) {
203+
return(list(argvals=argvals, y=y, basisobj=basisobj))
216204
}
217-
218-
##. --------------------------------------------------------------------------
219-
## 6. Check compatibility of argvals with basisobj$rangeval
220-
##. --------------------------------------------------------------------------
221-
222-
# set up a safety zone for argvals out of range by a tiny amount
223-
delta <- 1e-7*(rangeval[2]-rangeval[1]) # the tiny amount
224-
for (i in 1:length(argvals)) {
225-
argi <- argvals[i]
226-
# print(argi)
227-
if (argi < rangeval[1] && argi >= rangeval[1]-delta) {
228-
argi <- rangeval[1]
229-
}
230-
if (argi > rangeval[2] && argi <= rangeval[2]+delta) {
231-
argi <- rangeval[2]
232-
}
233-
}
234-
if (any(argvals < rangeval[1]) || any(argvals > rangeval[2])) {
235-
# error message
236-
stop("There are argvals not contained within interval basisobj$rangeval")
237-
}
238-
return(list(argvals=argvals, y=y, basisobj=basisobj))
239-
205+
#
206+
stop("'argvals' are not contained in basisobj$rangeval")
240207
}
241208

Diff for: ‎man/Data2fd.Rd

+4-4
Original file line numberDiff line numberDiff line change
@@ -180,7 +180,7 @@ fd1.5 <- Data2fd(y12, basisobj=b1.1, lambda=0.5)
180180
# is an fd smooth object. Calls to functions expecting
181181
# an fd object require attaching $fd to the fdsmooth object
182182
# this is required in lines 268, 311 and 337
183-
eval.fd(seq(0, 1, .2), fd1.5$fd)
183+
eval.fd(seq(0, 1, .2), fd1.5)
184184
##
185185
## step function smoothing
186186
##
@@ -223,7 +223,7 @@ b2.3 <- create.bspline.basis(norder=2, breaks=c(0, .5, 1))
223223
# interpolate the values 0, 2, 1
224224
fd2.3 <- Data2fd(c(0,2,1), basisobj=b2.3, lambda=0)
225225
# display the coefficients
226-
round(fd2.3$fd$coefs, 4)
226+
round(fd2.3$coefs, 4)
227227
# plot the results
228228
op <- par(mfrow=c(2,1))
229229
plot(b2.3, main='bases')
@@ -249,15 +249,15 @@ all.equal(
249249
b3.4 <- create.bspline.basis(norder=3, breaks=c(0, .5, 1))
250250
# fit values c(0,4,2,3) without interpolation
251251
fd3.4 <- Data2fd(c(0,4,2,3), basisobj=b3.4, lambda=0)
252-
round(fd3.4$fd$coefs, 4)
252+
round(fd3.4$coefs, 4)
253253
op <- par(mfrow=c(2,1))
254254
plot(b3.4)
255255
plot(fd3.4)
256256
points(c(0,1/3,2/3,1), c(0,4,2,3))
257257
par(op)
258258
# try smoothing
259259
fd3.4. <- Data2fd(c(0,4,2,3), basisobj=b3.4, lambda=1)
260-
round(fd3.4.$fd$coef, 4)
260+
round(fd3.4.$coef, 4)
261261
op <- par(mfrow=c(2,1))
262262
plot(b3.4)
263263
plot(fd3.4., ylim=c(0,4))

0 commit comments

Comments
 (0)