|
1 | | -bsplineS <- function (x, breaks, norder=4, nderiv=0) |
2 | | -{ |
3 | | -# This is a wrapper function for the S-PLUS spline.des function. |
4 | | -# The number of spline functions is equal to the number of |
5 | | -# discrete break points, length(BREAKVALUES), plus the order, NORDER, |
6 | | -# minus 2. |
7 | | -# Arguments are as follows: |
8 | | -# X ... array of values at which the spline functions are to |
9 | | -# evaluated |
10 | | -# BREAKS ... a STRICTLY INCREASING sequence of break points or knot |
11 | | -# values. It must contain all the values of X within its |
12 | | -# range. |
13 | | -# NORDER ... order of spline (1 more than degree), so that 1 gives a |
14 | | -# step function, 2 gives triangle functions, |
15 | | -# and 4 gives cubic splines |
16 | | -# NDERIV ... highest order derivative. 0 means only function values |
17 | | -# are returned. |
18 | | -# Return is a matrix with length(X) rows and number of columns equal to |
19 | | -# number of b-splines |
20 | | - |
21 | | -# previously modified 6 January 2020 2012 by Jim Ramsay |
22 | | - |
23 | | - x <- as.vector(x) |
24 | | - n <- length(x) |
25 | | - tol <- 1e-14 |
26 | | - nbreaks <- length(breaks) |
27 | | - if (nbreaks < 2) stop('Number of knots less than 2.') |
28 | | - if (min(diff(breaks)) < 0 ) stop('Knots are not increasing') |
29 | | - |
30 | | - if ( max(x) > max(breaks) + tol || |
31 | | - min(x) < min(breaks) - tol ) |
32 | | - stop('Knots do not span the values of X') |
33 | | - if ( x[n] > breaks[nbreaks]) breaks[nbreaks] <- x[n] |
34 | | - if ( x[1] < breaks[1] ) breaks[1] <- x[1] |
35 | | - |
36 | | - if (norder > 20) stop('NORDER exceeds 20.') |
37 | | - if (norder < 1) stop('NORDER less than 1.') |
38 | | - if (nderiv > 19) stop('NDERIV exceeds 19.') |
39 | | - if (nderiv < 0) stop('NDERIV is negative.') |
40 | | - if (nderiv >= norder) stop ( |
41 | | - 'NDERIV cannot be as large as order of B-spline.') |
42 | | - |
43 | | - knots <- c(rep(breaks[1 ],norder-1), breaks, |
44 | | - rep(breaks[nbreaks],norder-1) ) |
45 | | - derivs <- rep(nderiv,n) |
46 | | - nbasis <- nbreaks + norder - 2 |
47 | | - if (nbasis >= norder) { |
48 | | - if (nbasis > 1) { |
49 | | - basismat <- spline.des(knots, x, norder, derivs)$design |
50 | | - } else { |
51 | | - basismat <- as.matrix(spline.des(knots, x, norder, derivs)$design) |
52 | | - } |
53 | | - if(length(dim(basismat)) == 2){ |
54 | | - return(as.matrix(basismat)) |
55 | | - } |
56 | | - return(basismat) |
57 | | - } else { |
58 | | - stop("NBASIS is less than NORDER.") |
59 | | - } |
60 | | -} |
| 1 | +bsplineS <- function (x, breaks, norder=4, nderiv=0, returnMatrix=FALSE) |
| 2 | +{ |
| 3 | +# This is a wrapper function for the S-PLUS spline.des function. |
| 4 | +# The number of spline functions is equal to the number of |
| 5 | +# discrete break points, length(BREAKVALUES), plus the order, NORDER, |
| 6 | +# minus 2. |
| 7 | +# Arguments are as follows: |
| 8 | +# X ... array of values at which the spline functions are to |
| 9 | +# evaluated |
| 10 | +# BREAKS ... a STRICTLY INCREASING sequence of break points or knot |
| 11 | +# values. It must contain all the values of X within its |
| 12 | +# range. |
| 13 | +# NORDER ... order of spline (1 more than degree), so that 1 gives a |
| 14 | +# step function, 2 gives triangle functions, |
| 15 | +# and 4 gives cubic splines |
| 16 | +# NDERIV ... highest order derivative. 0 means only function values |
| 17 | +# are returned. |
| 18 | +# Return is a matrix with length(X) rows and number of columns equal to |
| 19 | +# number of b-splines |
| 20 | + |
| 21 | +# last modified 6 May 2012 by Spencer Graves |
| 22 | +# previously modified 2 April 2012 by Jim Ramsay |
| 23 | + |
| 24 | + x <- as.vector(x) |
| 25 | + n <- length(x) |
| 26 | + tol <- 1e-14 |
| 27 | + nbreaks <- length(breaks) |
| 28 | + if (nbreaks < 2) stop('Number of knots less than 2.') |
| 29 | + if (min(diff(breaks)) < 0 ) stop('Knots are not increasing') |
| 30 | + |
| 31 | + if ( max(x) > max(breaks) + tol || |
| 32 | + min(x) < min(breaks) - tol ) |
| 33 | + stop('Knots do not span the values of X') |
| 34 | + if ( x[n] > breaks[nbreaks]) breaks[nbreaks] <- x[n] |
| 35 | + if ( x[1] < breaks[1] ) breaks[1] <- x[1] |
| 36 | + |
| 37 | + if (norder > 20) stop('NORDER exceeds 20.') |
| 38 | + if (norder < 1) stop('NORDER less than 1.') |
| 39 | + if (nderiv > 19) stop('NDERIV exceeds 19.') |
| 40 | + if (nderiv < 0) stop('NDERIV is negative.') |
| 41 | + if (nderiv >= norder) stop ( |
| 42 | + 'NDERIV cannot be as large as order of B-spline.') |
| 43 | + |
| 44 | + knots <- c(rep(breaks[1 ],norder-1), breaks, |
| 45 | + rep(breaks[nbreaks],norder-1) ) |
| 46 | + derivs <- rep(nderiv,n) |
| 47 | + nbasis <- nbreaks + norder - 2 |
| 48 | + if (nbasis >= norder) { |
| 49 | + if (nbasis > 1) { |
| 50 | + basismat <- Matrix(spline.des(knots, x, norder, derivs)$design) |
| 51 | + } else { |
| 52 | + basismat <- as.matrix(spline.des(knots, x, norder, derivs)$design) |
| 53 | + } |
| 54 | + if((!returnMatrix) && (length(dim(basismat)) == 2)){ |
| 55 | + return(as.matrix(basismat)) |
| 56 | + } |
| 57 | + return(basismat) |
| 58 | + } else { |
| 59 | + stop("NBASIS is less than NORDER.") |
| 60 | + } |
| 61 | +} |
0 commit comments