splines2/0000755000176200001440000000000014121634402012006 5ustar liggesuserssplines2/NAMESPACE0000644000176200001440000000260614121502500013222 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(deriv,bSpline2) S3method(deriv,bernsteinPoly) S3method(deriv,cSpline) S3method(deriv,dbs) S3method(deriv,iSpline) S3method(deriv,ibs) S3method(deriv,mSpline) S3method(deriv,naturalSpline) S3method(knots,bSpline2) S3method(knots,bernsteinPoly) S3method(knots,cSpline) S3method(knots,dbs) S3method(knots,iSpline) S3method(knots,ibs) S3method(knots,mSpline) S3method(knots,naturalSpline) S3method(makepredictcall,bSpline2) S3method(makepredictcall,bernsteinPoly) S3method(makepredictcall,cSpline) S3method(makepredictcall,dbs) S3method(makepredictcall,iSpline) S3method(makepredictcall,ibs) S3method(makepredictcall,mSpline) S3method(makepredictcall,naturalSpline) S3method(predict,bSpline2) S3method(predict,bernsteinPoly) S3method(predict,cSpline) S3method(predict,dbs) S3method(predict,iSpline) S3method(predict,ibs) S3method(predict,mSpline) S3method(predict,naturalSpline) S3method(print,bSpline2) S3method(print,bernsteinPoly) S3method(print,cSpline) S3method(print,dbs) S3method(print,iSpline) S3method(print,ibs) S3method(print,mSpline) S3method(print,naturalSpline) export(bSpline) export(bernsteinPoly) export(cSpline) export(dbs) export(iSpline) export(ibs) export(mSpline) export(naturalSpline) importFrom(Rcpp,sourceCpp) importFrom(stats,deriv) importFrom(stats,knots) importFrom(stats,makepredictcall) importFrom(stats,predict) useDynLib(splines2) splines2/README.md0000644000176200001440000002365414115272534013306 0ustar liggesuserssplines2 ================ [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/splines2)](https://CRAN.R-project.org/package=splines2) [![Total_Downloads](https://cranlogs.r-pkg.org/badges/grand-total/splines2)](https://CRAN.R-project.org/package=splines2) [![Downloads from the RStudio CRAN mirror](https://cranlogs.r-pkg.org/badges/splines2)](https://CRAN.R-project.org/package=splines2) [![Build Status](https://github.com/wenjie2wang/splines2/workflows/R-CMD-check/badge.svg)](https://github.com/wenjie2wang/splines2/actions) [![codecov](https://codecov.io/gh/wenjie2wang/splines2/branch/main/graph/badge.svg)](https://codecov.io/gh/wenjie2wang/splines2) [![JDS](https://img.shields.io/badge/JDS-10.6339%2F21--JDS1020-brightgreen)](https://doi.org/10.6339/21-JDS1020) The R package **splines2** is intended to be a user-friendly *supplement* to the base package **splines**. ## Features The package **splines2** (version 0.4.5.9000) provides functions to construct basis matrices of - B-splines - M-splines - I-splines - convex splines (C-splines) - periodic M-splines - natural cubic splines - generalized Bernstein polynomials - their integrals (except C-splines) and derivatives of given order by closed-form recursive formulas In addition to the R interface, **splines2** provides a C++ header-only library integrated with **Rcpp**, which allows the construction of spline basis functions directly in C++ with the help of **Rcpp** and **RcppArmadillo**. Thus, it can also be treated as one of the **Rcpp\*** packages. A toy example package that uses the C++ interface is available [here](https://github.com/wenjie2wang/example-pkg-Rcpp-splines2). ## Installation of CRAN Version You can install the released version from [CRAN](https://CRAN.R-project.org/package=splines2). ``` r install.packages("splines2") ``` ## Development The latest version of the package is under development at [GitHub](https://github.com/wenjie2wang/splines2). If it is able to pass the automated package checks, one may install it by ``` r if (! require(remotes)) install.packages("remotes") remotes::install_github("wenjie2wang/splines2", upgrade = "never") ``` ## Getting Started The [Online document](https://wwenjie.org/splines2) provides a reference for all functions and contains the following vignettes: - [Demonstration of the common usages in R through examples](https://wwenjie.org/splines2/articles/splines2-intro). - [Introduction to the usage with Rcpp](https://wwenjie.org/splines2/articles/splines2-wi-rcpp) ## Performance Since v0.3.0, the implementation of the main functions has been rewritten in C++ with the help of the **Rcpp** and **RcppArmadillo** packages. The computational performance has thus been boosted and comparable with the function `splines::splineDesign()`. Some quick micro-benchmarks are provided for reference as follows: ``` r library(microbenchmark) library(splines) library(splines2) set.seed(123) x <- runif(1e3) degree <- 3 ord <- degree + 1 internal_knots <- seq.int(0.1, 0.9, 0.1) boundary_knots <- c(0, 1) all_knots <- sort(c(internal_knots, rep(boundary_knots, ord))) ## check equivalency of outputs my_check <- function(values) { all(sapply(values[- 1], function(x) { all.equal(unclass(values[[1]]), x, check.attributes = FALSE) })) } ``` For B-splines, function `splines2::bSpline()` provides equivalent results with `splines::bs()` and `splines::splineDesign()`, and is about 3x faster than `bs()` and 2x faster than `splineDesign()` for this example. ``` r ## B-splines microbenchmark( "splines::bs" = bs(x, knots = internal_knots, degree = degree, intercept = TRUE, Boundary.knots = boundary_knots), "splines::splineDesign" = splineDesign(x, knots = all_knots, ord = ord), "splines2::bSpline" = bSpline( x, knots = internal_knots, degree = degree, intercept = TRUE, Boundary.knots = boundary_knots ), check = my_check, times = 1e3, unit = "relative" ) ``` Unit: relative expr min lq mean median uq max neval cld splines::bs 3.6523 3.5555 3.5506 3.4736 3.5177 1.1974 1000 c splines::splineDesign 2.2324 2.1404 2.1467 2.0619 2.0942 1.0849 1000 b splines2::bSpline 1.0000 1.0000 1.0000 1.0000 1.0000 1.0000 1000 a Similarly, for derivatives of B-splines, `splines2::dbs()` provides equivalent results with `splines::splineDesign()`, and is about 2x faster. ``` r ## Derivatives of B-splines derivs <- 2 microbenchmark( "splines::splineDesign" = splineDesign(x, knots = all_knots, ord = ord, derivs = derivs), "splines2::dbs" = dbs(x, derivs = derivs, knots = internal_knots, degree = degree, intercept = TRUE, Boundary.knots = boundary_knots), check = my_check, times = 1e3, unit = "relative" ) ``` Unit: relative expr min lq mean median uq max neval cld splines::splineDesign 2.678 2.519 2.4873 2.4508 2.5028 1.0712 1000 b splines2::dbs 1.000 1.000 1.0000 1.0000 1.0000 1.0000 1000 a The **splines** package does not contain an implementation for integrals of B-splines. Thus, we performed a comparison with package **ibs** (version `r packageVersion("ibs")`), where the function `ibs::ibs()` was also implemented in **Rcpp**. ``` r ## integrals of B-splines set.seed(123) coef_sp <- rnorm(length(all_knots) - ord) microbenchmark( "ibs::ibs" = ibs::ibs(x, knots = all_knots, ord = ord, coef = coef_sp), "splines2::ibs" = as.numeric( splines2::ibs(x, knots = internal_knots, degree = degree, intercept = TRUE, Boundary.knots = boundary_knots) %*% coef_sp ), check = my_check, times = 1e3, unit = "relative" ) ``` Unit: relative expr min lq mean median uq max neval cld ibs::ibs 9.3175 8.4242 9.3377 9.6631 9.6052 30.53 1000 b splines2::ibs 1.0000 1.0000 1.0000 1.0000 1.0000 1.00 1000 a The function `ibs::ibs()` returns the integrated B-splines instead of the integrals of spline basis functions. Thus, we applied the same coefficients to the basis functions from `splines2::ibs()` for equivalent results, which was still much faster than `ibs::ibs()`. For natural cubic splines (based on B-splines), `splines::ns()` uses the QR decomposition to find the null space of the second derivatives of B-spline basis functions at boundary knots, while `splines2::naturalSpline()` utilizes the closed-form null space derived from the second derivatives of cubic B-splines, which produces nonnegative basis functions (within boundary) and is more computationally efficient. ``` r microbenchmark( "splines::ns" = ns(x, knots = internal_knots, intercept = TRUE, Boundary.knots = boundary_knots), "splines2::naturalSpline" = naturalSpline( x, knots = internal_knots, intercept = TRUE, Boundary.knots = boundary_knots ), times = 1e3, unit = "relative" ) ``` Unit: relative expr min lq mean median uq max neval cld splines::ns 5.2152 4.9659 4.798 4.7187 4.6488 1.335 1000 b splines2::naturalSpline 1.0000 1.0000 1.000 1.0000 1.0000 1.000 1000 a The function `mSpline()` produces periodic spline basis functions (based on M-splines) when `periodic = TRUE` is specified. The `splines::periodicSpline()` returns a periodic interpolation spline (based on B-splines) instead of basis matrix. Thus, we performed a comparison with package **pbs** (version `r packageVersion("pbs")`), where the function `pbs::pbs()` produces a basis matrix of periodic B-spline by using `splines::spline.des()` (a wrapper function of `splines::splineDesign()`). ``` r microbenchmark( "pbs::pbs" = pbs::pbs(x, knots = internal_knots, degree = degree, intercept = TRUE, periodic = TRUE, Boundary.knots = boundary_knots), "splines2::mSpline" = mSpline( x, knots = internal_knots, degree = degree, intercept = TRUE, Boundary.knots = boundary_knots, periodic = TRUE ), times = 1e3, unit = "relative" ) ``` Unit: relative expr min lq mean median uq max neval cld pbs::pbs 3.465 3.2513 3.2501 3.1162 3.1062 3.4498 1000 b splines2::mSpline 1.000 1.0000 1.0000 1.0000 1.0000 1.0000 1000 a
Session Information for Benchmarks ``` r sessionInfo() ``` R version 4.1.0 (2021-05-18) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Arch Linux Matrix products: default BLAS: /usr/lib/libopenblasp-r0.3.17.so LAPACK: /usr/lib/liblapack.so.3.10.0 locale: [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C LC_TIME=en_US.UTF-8 [4] LC_COLLATE=en_US.UTF-8 LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8 [7] LC_PAPER=en_US.UTF-8 LC_NAME=C LC_ADDRESS=C [10] LC_TELEPHONE=C LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C attached base packages: [1] splines stats graphics grDevices utils datasets methods base other attached packages: [1] splines2_0.4.5.9000 microbenchmark_1.4-7 loaded via a namespace (and not attached): [1] Rcpp_1.0.7 mvtnorm_1.1-2 lattice_0.20-44 codetools_0.2-18 ibs_1.4 [6] zoo_1.8-9 digest_0.6.27 MASS_7.3-54 grid_4.1.0 magrittr_2.0.1 [11] evaluate_0.14 rlang_0.4.11 stringi_1.7.3 multcomp_1.4-17 Matrix_1.3-4 [16] sandwich_3.0-1 rmarkdown_2.10 TH.data_1.0-10 tools_4.1.0 stringr_1.4.0 [21] survival_3.2-11 xfun_0.25 yaml_2.2.1 compiler_4.1.0 pbs_1.1 [26] htmltools_0.5.1.1 knitr_1.33
## License [GNU General Public License](https://www.gnu.org/licenses/) (≥ 3) splines2/man/0000755000176200001440000000000014030134441012556 5ustar liggesuserssplines2/man/predict.Rd0000644000176200001440000000427714013353332014514 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.R \name{predict} \alias{predict} \alias{predict.bSpline2} \alias{predict.dbs} \alias{predict.ibs} \alias{predict.mSpline} \alias{predict.iSpline} \alias{predict.cSpline} \alias{predict.bernsteinPoly} \alias{predict.naturalSpline} \title{Evaluate a Spline Basis at specified points} \usage{ \method{predict}{bSpline2}(object, newx, ...) \method{predict}{dbs}(object, newx, ...) \method{predict}{ibs}(object, newx, ...) \method{predict}{mSpline}(object, newx, ...) \method{predict}{iSpline}(object, newx, ...) \method{predict}{cSpline}(object, newx, ...) \method{predict}{bernsteinPoly}(object, newx, ...) \method{predict}{naturalSpline}(object, newx, ...) } \arguments{ \item{object}{Objects of class \code{bSpline2}, \code{ibs}, \code{mSpline}, \code{iSpline}, \code{cSpline}, \code{bernsteinPoly} or \code{naturalSpline} with attributes describing \code{knots}, \code{degree}, etc.} \item{newx}{The \code{x} values at which evaluations are required.} \item{...}{Optional arguments that are not used.} } \value{ An object just like the \code{object} input, except evaluated at the new values of \code{x}. } \description{ This function evaluates a predefined spline basis at a (new) given \code{x}. } \details{ These are methods for the generic function \code{predict} for objects inheriting from class \code{bSpline2}, \code{ibs}, \code{mSpline}, \code{iSpline}, \code{cSpline}, \code{naturalSpline}, or \code{bernsteinPoly}. If \code{newx} is not given, the function returns the input object. } \examples{ library(splines2) x <- seq.int(0, 1, 0.2) knots <- c(0.3, 0.5, 0.6) newX <- seq.int(0.1, 0.9, 0.2) ## for B-splines bsMat <- bSpline(x, knots = knots, degree = 2) predict(bsMat, newX) ## for integral of B-splines ibsMat <- ibs(x, knots = knots, degree = 2) predict(ibsMat, newX) ## for derivative of B-splines dbsMat <- dbs(x, knots = knots, degree = 2) predict(dbsMat, newX) ## for M-spline msMat <- mSpline(x, knots = knots, degree = 2) predict(msMat, newX) ## for I-spline isMat <- iSpline(x, knots = knots, degree = 2) predict(isMat, newX) ## for C-spline csMat <- cSpline(x, knots = knots, degree = 2) predict(csMat, newX) } splines2/man/splines2.Rd0000644000176200001440000000275614106352275014631 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/splines2-package.R \docType{package} \name{splines2} \alias{splines2} \title{splines2: Regression Spline Functions and Classes} \description{ This package provides functions to construct basis matrices of \itemize{ \item B-splines \item M-splines \item I-splines \item convex splines (C-splines) \item periodic M-splines \item natural cubic splines \item generalized Bernstein polynomials \item along with their integrals (except C-splines) and derivatives of given order by closed-form recursive formulas } } \details{ In addition to the R interface, it also provides a C++ header-only library integrated with \pkg{Rcpp}, which allows the construction of spline basis functions directly in C++ with the help of \pkg{Rcpp} and \pkg{RcppArmadillo}. Thus, it can also be treated as one of the \pkg{Rcpp*} packages. A toy example package that uses the C++ interface is available at . The package \pkg{splines2} is intended to be a user-friendly supplement to the base package \pkg{splines}. The trailing number two in the package name means "too" (and by no means refers to the generation two). See Wang and Yan (2021) for details and illustrations of how the package can be applied to shape-restricted regression. } \references{ Wang, W., & Yan, J. (2021). Shape-restricted regression splines with R package \pkg{splines2}. \emph{Journal of Data Science}, 19(3), 498--517. } splines2/man/naturalSpline.Rd0000644000176200001440000001025714014343037015700 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/naturalSpline.R \name{naturalSpline} \alias{naturalSpline} \title{Natural Cubic Spline Basis for Polynomial Splines} \usage{ naturalSpline( x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, derivs = 0L, integral = FALSE, ... ) } \arguments{ \item{x}{The predictor variable. Missing values are allowed and will be returned as they are.} \item{df}{Degree of freedom that equals to the column number of returned matrix. One can specify \code{df} rather than \code{knots}, then the function chooses \code{df - 1 - as.integer(intercept)} internal knots at suitable quantiles of \code{x} ignoring missing values and those \code{x} outside of the boundary. Thus, \code{df} must be greater than or equal to \code{2}. If internal knots are specified via \code{knots}, the specified \code{df} will be ignored.} \item{knots}{The internal breakpoints that define the splines. The default is \code{NULL}, which results in a basis for ordinary polynomial regression. Typical values are the mean or median for one knot, quantiles for more knots.} \item{intercept}{If \code{TRUE}, the complete basis matrix will be returned. Otherwise, the first basis will be excluded from the output.} \item{Boundary.knots}{Boundary points at which to anchor the splines. By default, they are the range of \code{x} excluding \code{NA}. If both \code{knots} and \code{Boundary.knots} are supplied, the basis parameters do not depend on \code{x}. Data can extend beyond \code{Boundary.knots}.} \item{derivs}{A nonnegative integer specifying the order of derivatives of natural splines. The default value is \code{0L} for the spline basis functions.} \item{integral}{A logical value. The default value is \code{FALSE}. If \code{TRUE}, this function will return the integrated natural splines from the left boundary knot.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of \code{length(x)} rows and \code{df} columns if \code{df} is specified or \code{length(knots) + 1 + as.integer(intercept)} columns if \code{knots} are specified instead. Attributes that correspond to the arguments specified are returned for usage of other functions in this package. } \description{ Generates the nonnegative natural cubic spline basis matrix, the corresponding integrals (from the left boundary knot), or derivatives of given order. Each basis is assumed to follow a linear trend for \code{x} outside of boundary. } \details{ It is an implementation of the natural spline basis based on B-spline basis, which utilizes the close-form null space that can be derived from the recursive formula for the second derivatives of B-splines. The constructed spline basis functions are intended to be nonnegative within boundary with second derivatives being zeros at boundary knots. A similar implementation is provided by \code{splines::ns}, which uses QR decomposition to find the null space of the second derivatives of B-spline basis at boundary knots. However, there is no guarantee that the resulting basis functions are nonnegative within boundary. } \examples{ library(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## natural spline basis nsMat0 <- naturalSpline(x, knots = knots, intercept = TRUE) ## integrals nsMat1 <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) ## first derivatives nsMat2 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) ## second derivatives nsMat3 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 2) op <- par(mfrow = c(2, 2), mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, nsMat0, type = "l", ylab = "basis") matplot(x, nsMat1, type = "l", ylab = "integral") matplot(x, nsMat2, type = "l", ylab = "1st derivative") matplot(x, nsMat3, type = "l", ylab = "2nd derivative") par(op) # reset to previous plotting settings ## use the deriv method all.equal(nsMat0, deriv(nsMat1), check.attributes = FALSE) all.equal(nsMat2, deriv(nsMat0)) all.equal(nsMat3, deriv(nsMat2)) all.equal(nsMat3, deriv(nsMat0, 2)) } \seealso{ \code{\link{bSpline}} for B-splines; \code{\link{mSpline}} for M-splines; \code{\link{iSpline}} for I-splines. } splines2/man/deriv.Rd0000644000176200001440000000643714030134441014170 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deriv.R \name{deriv} \alias{deriv} \alias{deriv.bSpline2} \alias{deriv.dbs} \alias{deriv.ibs} \alias{deriv.mSpline} \alias{deriv.iSpline} \alias{deriv.cSpline} \alias{deriv.bernsteinPoly} \alias{deriv.naturalSpline} \title{Derivatives of Spline Basis Functions} \usage{ \method{deriv}{bSpline2}(expr, derivs = 1L, ...) \method{deriv}{dbs}(expr, derivs = 1L, ...) \method{deriv}{ibs}(expr, derivs = 1L, ...) \method{deriv}{mSpline}(expr, derivs = 1L, ...) \method{deriv}{iSpline}(expr, derivs = 1L, ...) \method{deriv}{cSpline}(expr, derivs = 1L, ...) \method{deriv}{bernsteinPoly}(expr, derivs = 1L, ...) \method{deriv}{naturalSpline}(expr, derivs = 1L, ...) } \arguments{ \item{expr}{Objects of class \code{bSpline2}, \code{ibs}, \code{mSpline}, \code{iSpline}, \code{cSpline}, \code{bernsteinPoly} or \code{naturalSpline} with attributes describing \code{knots}, \code{degree}, etc.} \item{derivs}{A positive integer specifying the order of derivatives. By default, it is \code{1L} for the first derivatives.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of the same dimension with the input \code{expr}. } \description{ Returns derivatives of given order for the given spline basis functions. } \details{ At knots, the derivative is defined to be the right derivative except at the right boundary knot. By default, the function returns the first derivatives. For derivatives of order greater than one, nested function calls such as \code{deriv(deriv(expr))} are supported but not recommended. For a better performance, argument \code{derivs} should be specified instead. This function is designed for objects produced by this package. It internally extracts necessary specification about the spline/polynomial basis matrix from its attributes. Therefore, the function will not work if the key attributes are not available after some operations. } \examples{ library(splines2) x <- c(seq.int(0, 1, 0.1), NA) # NA's will be kept. knots <- c(0.3, 0.5, 0.6) ## helper function stopifnot_equivalent <- function(...) { stopifnot(all.equal(..., check.attributes = FALSE)) } ## integal of B-splines and the corresponding B-splines integrated ibsMat <- ibs(x, knots = knots) bsMat <- bSpline(x, knots = knots) ## the first derivative d1Mat <- deriv(ibsMat) stopifnot_equivalent(bsMat, d1Mat) ## the second derivative d2Mat1 <- deriv(bsMat) d2Mat2 <- deriv(ibsMat, derivs = 2L) stopifnot_equivalent(d2Mat1, d2Mat2) ## nested calls are supported d2Mat3 <- deriv(deriv(ibsMat)) stopifnot_equivalent(d2Mat2, d2Mat3) ## C-splines, I-splines, M-splines and the derivatives csMat <- cSpline(x, knots = knots, intercept = TRUE, scale = FALSE) isMat <- iSpline(x, knots = knots, intercept = TRUE) stopifnot_equivalent(isMat, deriv(csMat)) msMat <- mSpline(x, knots = knots, intercept = TRUE) stopifnot_equivalent(msMat, deriv(isMat)) stopifnot_equivalent(msMat, deriv(csMat, 2)) stopifnot_equivalent(msMat, deriv(deriv(csMat))) dmsMat <- mSpline(x, knots = knots, intercept = TRUE, derivs = 1) stopifnot_equivalent(dmsMat, deriv(msMat)) stopifnot_equivalent(dmsMat, deriv(isMat, 2)) stopifnot_equivalent(dmsMat, deriv(deriv(isMat))) stopifnot_equivalent(dmsMat, deriv(csMat, 3)) stopifnot_equivalent(dmsMat, deriv(deriv(deriv(csMat)))) } splines2/man/cSpline.Rd0000644000176200001440000001035014103555677014464 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cSpline.R \name{cSpline} \alias{cSpline} \title{C-Spline Basis for Polynomial Splines} \usage{ cSpline( x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = NULL, derivs = 0L, scale = TRUE, ... ) } \arguments{ \item{x}{The predictor variable. Missing values are allowed and will be returned as they are.} \item{df}{Degree of freedom that equals to the column number of the returned matrix. One can specify \code{df} rather than \code{knots}, then the function chooses \code{df - degree - as.integer(intercept)} internal knots at suitable quantiles of \code{x} ignoring missing values and those \code{x} outside of the boundary. If internal knots are specified via \code{knots}, the specified \code{df} will be ignored.} \item{knots}{The internal breakpoints that define the splines. The default is \code{NULL}, which results in a basis for ordinary polynomial regression. Typical values are the mean or median for one knot, quantiles for more knots.} \item{degree}{The degree of C-spline defined to be the degree of the associated M-spline instead of actual polynomial degree. For example, C-spline basis of degree 2 is defined as the scaled double integral of associated M-spline basis of degree 2.} \item{intercept}{If \code{TRUE} by default, all of the spline basis functions are returned. Notice that when using C-Spline for shape-restricted regression, \code{intercept = TRUE} should be set even when an intercept term is considered additional to the spline basis in the model.} \item{Boundary.knots}{Boundary points at which to anchor the splines. By default, they are the range of \code{x} excluding \code{NA}. If both \code{knots} and \code{Boundary.knots} are supplied, the basis parameters do not depend on \code{x}. Data can extend beyond \code{Boundary.knots}.} \item{derivs}{A nonnegative integer specifying the order of derivatives of C-splines. The default value is \code{0L} for C-spline basis functions.} \item{scale}{A logical value indicating if scaling C-splines is required. If \code{TRUE} by default, each C-spline basis is scaled to have unit height at right boundary knot. The corresponding I-spline and M-spline produced by \code{deriv} methods will be scaled to the same extent.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of \code{length(x)} rows and \code{df} columns if \code{df} is specified or \code{length(knots) + degree + as.integer(intercept)} columns if \code{knots} are specified instead. Attributes that correspond to the arguments specified are returned mainly for other functions in this package. } \description{ Generates the convex regression spline (called C-spline) basis matrix by integrating I-spline basis for a polynomial spline or the corresponding derivatives. } \details{ It is an implementation of the closed-form C-spline basis derived from the recursion formula of I-splines and M-splines. } \examples{ library(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ### when 'scale = TRUE' (by default) csMat <- cSpline(x, knots = knots, degree = 2) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, csMat, type = "l", ylab = "C-spline basis") abline(v = knots, lty = 2, col = "gray") isMat <- deriv(csMat) msMat <- deriv(csMat, derivs = 2) matplot(x, isMat, type = "l", ylab = "scaled I-spline basis") matplot(x, msMat, type = "l", ylab = "scaled M-spline basis") ## reset to previous plotting settings par(op) ### when 'scale = FALSE' csMat <- cSpline(x, knots = knots, degree = 2, scale = FALSE) ## the corresponding I-splines and M-splines (with same arguments) isMat <- iSpline(x, knots = knots, degree = 2) msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) ## or using deriv methods (more efficient) isMat1 <- deriv(csMat) msMat1 <- deriv(csMat, derivs = 2) ## equivalent stopifnot(all.equal(isMat, isMat1, check.attributes = FALSE)) stopifnot(all.equal(msMat, msMat1, check.attributes = FALSE)) } \references{ Meyer, M. C. (2008). Inference using shape-restricted regression splines. \emph{The Annals of Applied Statistics}, 2(3), 1013--1033. } \seealso{ \code{\link{iSpline}} for I-splines; \code{\link{mSpline}} for M-splines. } splines2/man/knots.Rd0000644000176200001440000000336514013354053014216 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/knots.R \name{knots} \alias{knots} \alias{knots.bSpline2} \alias{knots.dbs} \alias{knots.ibs} \alias{knots.mSpline} \alias{knots.iSpline} \alias{knots.cSpline} \alias{knots.bernsteinPoly} \alias{knots.naturalSpline} \title{Extract Knots from the Given Object} \usage{ \method{knots}{bSpline2}(Fn, type = c("internal", "boundary"), ...) \method{knots}{dbs}(Fn, type = c("internal", "boundary"), ...) \method{knots}{ibs}(Fn, type = c("internal", "boundary"), ...) \method{knots}{mSpline}(Fn, type = c("internal", "boundary"), ...) \method{knots}{iSpline}(Fn, type = c("internal", "boundary"), ...) \method{knots}{cSpline}(Fn, type = c("internal", "boundary"), ...) \method{knots}{bernsteinPoly}(Fn, type = c("internal", "boundary"), ...) \method{knots}{naturalSpline}(Fn, type = c("internal", "boundary"), ...) } \arguments{ \item{Fn}{An \code{splines2} object produced by this package.} \item{type}{A character vector of length one indicating the type of knots to return. The available choices are \code{"internal"} for internal knots and \code{"Boundary"} for boundary knots.} \item{...}{Optional arguments that are not used now.} } \value{ A numerical vector. } \description{ Methods for the generic function \code{knots} from the \pkg{stats} package to obtain internal or boundary knots from the objects produced by this package. } \examples{ library(splines2) set.seed(123) x <- rnorm(100) ## B-spline basis bsMat <- bSpline(x, df = 8, degree = 3) ## extract internal knots placed based on the quantile of x (internal_knots <- knots(bsMat)) ## extract boundary knots placed based on the range of x boundary_knots <- knots(bsMat, type = "boundary") all.equal(boundary_knots, range(x)) } splines2/man/ibs.Rd0000644000176200001440000000603714076105150013635 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ibs.R \name{ibs} \alias{ibs} \title{Integrals of B-Splines} \usage{ ibs( x, df = NULL, knots = NULL, degree = 3, intercept = FALSE, Boundary.knots = NULL, ... ) } \arguments{ \item{x}{The predictor variable. Missing values are allowed and will be returned as they are.} \item{df}{Degree of freedom that equals to the column number of the returned matrix. One can specify \code{df} rather than \code{knots}, then the function chooses \code{df - degree - as.integer(intercept)} internal knots at suitable quantiles of \code{x} ignoring missing values and those \code{x} outside of the boundary. If internal knots are specified via \code{knots}, the specified \code{df} will be ignored.} \item{knots}{The internal breakpoints that define the splines. The default is \code{NULL}, which results in a basis for ordinary polynomial regression. Typical values are the mean or median for one knot, quantiles for more knots.} \item{degree}{A nonnegative integer specifying the degree of the piecewise polynomial. The default value is \code{3} for cubic splines. Zero degree is allowed for piecewise constant basis functions.} \item{intercept}{If \code{TRUE}, the complete basis matrix will be returned. Otherwise, the first basis will be excluded from the output.} \item{Boundary.knots}{Boundary points at which to anchor the splines. By default, they are the range of \code{x} excluding \code{NA}. If both \code{knots} and \code{Boundary.knots} are supplied, the basis parameters do not depend on \code{x}. Data can extend beyond \code{Boundary.knots}.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of \code{length(x)} rows and \code{df} columns if \code{df} is specified or \code{length(knots) + degree + as.integer(intercept)} columns if \code{knots} are specified instead. Attributes that correspond to the arguments specified are returned mainly for other functions in this package. } \description{ Generates basis matrix for integrals of B-splines. } \details{ The implementation is based on the closed-form recursion formula. } \examples{ library(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.2, 0.4, 0.7, 0.9) ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) ## get the corresponding B-splines by bSpline() bsMat0 <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) ## or by the deriv() method bsMat <- deriv(ibsMat) stopifnot(all.equal(bsMat0, bsMat, check.attributes = FALSE)) ## plot B-spline basis with their corresponding integrals op <- par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "B-spline basis") abline(v = knots, lty = 2, col = "gray") matplot(x, ibsMat, type = "l", ylab = "Integral of B-spline basis") abline(v = knots, lty = 2, col = "gray") ## reset to previous plotting settings par(op) } \references{ De Boor, Carl. (1978). \emph{A practical guide to splines}. Vol. 27. New York: Springer-Verlag. } \seealso{ \code{\link{bSpline}} for B-splines; \code{\link{dbs}} for derivatives of B-splines; } splines2/man/dbs.Rd0000644000176200001440000000635714076105150013635 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dbs.R \name{dbs} \alias{dbs} \title{Derivatives of B-Splines} \usage{ dbs( x, derivs = 1L, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, ... ) } \arguments{ \item{x}{The predictor variable. Missing values are allowed and will be returned as they are.} \item{derivs}{A positive integer specifying the order of derivative. The default value is \code{1L} for the first derivative.} \item{df}{Degree of freedom that equals to the column number of the returned matrix. One can specify \code{df} rather than \code{knots}, then the function chooses \code{df - degree - as.integer(intercept)} internal knots at suitable quantiles of \code{x} ignoring missing values and those \code{x} outside of the boundary. If internal knots are specified via \code{knots}, the specified \code{df} will be ignored.} \item{knots}{The internal breakpoints that define the splines. The default is \code{NULL}, which results in a basis for ordinary polynomial regression. Typical values are the mean or median for one knot, quantiles for more knots.} \item{degree}{A nonnegative integer specifying the degree of the piecewise polynomial. The default value is \code{3} for cubic splines. Zero degree is allowed for piecewise constant basis functions.} \item{intercept}{If \code{TRUE}, the complete basis matrix will be returned. Otherwise, the first basis will be excluded from the output.} \item{Boundary.knots}{Boundary points at which to anchor the splines. By default, they are the range of \code{x} excluding \code{NA}. If both \code{knots} and \code{Boundary.knots} are supplied, the basis parameters do not depend on \code{x}. Data can extend beyond \code{Boundary.knots}.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of \code{length(x)} rows and \code{df} columns if \code{df} is specified or \code{length(knots) + degree + as.integer(intercept)} columns if \code{knots} are specified instead. Attributes that correspond to the arguments specified are returned mainly for other functions in this package. } \description{ Produces the derivatives of given order of B-splines. } \details{ This function provides a more user-friendly interface and a more consistent handling for \code{NA}'s than \code{splines::splineDesign()} for derivatives of B-splines. The implementation is based on the closed-form recursion formula. At knots, the derivative is defined to be the right derivative except at the right boundary knot. } \examples{ library(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.2, 0.4, 0.7) ## the second derivative of cubic B-splines with three internal knots dMat <- dbs(x, derivs = 2L, knots = knots, intercept = TRUE) ## compare with the results from splineDesign ord <- attr(dMat, "degree") + 1L bKnots <- attr(dMat, "Boundary.knots") aKnots <- c(rep(bKnots[1L], ord), knots, rep(bKnots[2L], ord)) res <- splines::splineDesign(aKnots, x = x, derivs = 2L) stopifnot(all.equal(res, dMat, check.attributes = FALSE)) } \references{ De Boor, Carl. (1978). \emph{A practical guide to splines}. Vol. 27. New York: Springer-Verlag. } \seealso{ \code{\link{bSpline}} for B-splines; \code{\link{ibs}} for integrals of B-splines. } splines2/man/bernsteinPoly.Rd0000644000176200001440000000547614103555677015741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bernsteinPoly.R \name{bernsteinPoly} \alias{bernsteinPoly} \title{Generalized Bernstein Polynomial Basis} \usage{ bernsteinPoly( x, degree = 3, intercept = FALSE, Boundary.knots = NULL, derivs = 0L, integral = FALSE, ... ) } \arguments{ \item{x}{The predictor variable taking values inside of the specified boundary. Missing values are allowed and will be returned as they are.} \item{degree}{A nonnegative integer representing the degree of the polynomials.} \item{intercept}{If \code{TRUE}, the complete basis matrix will be returned. Otherwise, the first basis will be excluded from the output.} \item{Boundary.knots}{Boundary points at which to anchor the Bernstein polynomial basis. The default value is \code{NULL} and the boundary knots is set internally to be \code{range(x, na.rm = TRUE)}.} \item{derivs}{A nonnegative integer specifying the order of derivatives. The default value is \code{0L} for Bernstein polynomial basis functions.} \item{integral}{A logical value. If \code{TRUE}, the integrals of the Bernstein polynomials will be returned. The default value is \code{FALSE}.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of dimension \code{length(x)} by \code{degree + as.integer(intercept)}. } \description{ Returns a generalized Bernstein polynomial basis matrix of given degree over a specified range. } \examples{ library(splines2) x1 <- seq.int(0, 1, 0.01) x2 <- seq.int(- 2, 2, 0.01) ## Bernstein polynomial basis matrix over [0, 1] bMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE) ## generalized Bernstein polynomials basis over [- 2, 2] bMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE) op <- par(mfrow = c(1, 2), mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x1, bMat1, type = "l", ylab = "y") matplot(x2, bMat2, type = "l", ylab = "y") ## the first and second derivative matrix d1Mat1 <- bernsteinPoly(x1, degree = 4, derivs = 1, intercept = TRUE) d2Mat1 <- bernsteinPoly(x1, degree = 4, derivs = 2, intercept = TRUE) d1Mat2 <- bernsteinPoly(x2, degree = 4, derivs = 1, intercept = TRUE) d2Mat2 <- bernsteinPoly(x2, degree = 4, derivs = 2, intercept = TRUE) par(mfrow = c(2, 2)) matplot(x1, d1Mat1, type = "l", ylab = "y") matplot(x2, d1Mat2, type = "l", ylab = "y") matplot(x1, d2Mat1, type = "l", ylab = "y") matplot(x2, d2Mat2, type = "l", ylab = "y") ## reset to previous plotting settings par(op) ## or use the deriv method all.equal(d1Mat1, deriv(bMat1)) all.equal(d2Mat1, deriv(bMat1, 2)) ## the integrals iMat1 <- bernsteinPoly(x1, degree = 4, integral = TRUE, intercept = TRUE) iMat2 <- bernsteinPoly(x2, degree = 4, integral = TRUE, intercept = TRUE) all.equal(deriv(iMat1), bMat1, check.attributes = FALSE) all.equal(deriv(iMat2), bMat2, check.attributes = FALSE) } splines2/man/bSpline.Rd0000644000176200001440000000700314102414367014451 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bSpline.R \name{bSpline} \alias{bSpline} \title{B-Spline Basis for Polynomial Splines} \usage{ bSpline( x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, derivs = 0L, integral = FALSE, ... ) } \arguments{ \item{x}{The predictor variable. Missing values are allowed and will be returned as they are.} \item{df}{Degree of freedom that equals to the column number of the returned matrix. One can specify \code{df} rather than \code{knots}, then the function chooses \code{df - degree - as.integer(intercept)} internal knots at suitable quantiles of \code{x} ignoring missing values and those \code{x} outside of the boundary. If internal knots are specified via \code{knots}, the specified \code{df} will be ignored.} \item{knots}{The internal breakpoints that define the splines. The default is \code{NULL}, which results in a basis for ordinary polynomial regression. Typical values are the mean or median for one knot, quantiles for more knots.} \item{degree}{A nonnegative integer specifying the degree of the piecewise polynomial. The default value is \code{3} for cubic splines. Zero degree is allowed for piecewise constant basis functions.} \item{intercept}{If \code{TRUE}, the complete basis matrix will be returned. Otherwise, the first basis will be excluded from the output.} \item{Boundary.knots}{Boundary points at which to anchor the splines. By default, they are the range of \code{x} excluding \code{NA}. If both \code{knots} and \code{Boundary.knots} are supplied, the basis parameters do not depend on \code{x}. Data can extend beyond \code{Boundary.knots}.} \item{derivs}{A nonnegative integer specifying the order of derivatives of B-splines. The default value is \code{0L} for B-spline basis functions.} \item{integral}{A logical value. If \code{TRUE}, the corresponding integrals of spline basis functions will be returned. The default value is \code{FALSE}.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of \code{length(x)} rows and \code{df} columns if \code{df} is specified or \code{length(knots) + degree + as.integer(intercept)} columns if \code{knots} are specified instead. Attributes that correspond to the arguments specified are returned mainly for other functions in this package. } \description{ Generates the B-spline basis matrix representing the family of piecewise polynomials with the specified interior knots, degree, and boundary knots, evaluated at the values of \code{x}. } \details{ This function extends the \code{bs()} function in the \code{splines} package for B-spline basis by allowing piecewise constant (left-closed and right-open except on the right boundary) spline basis of degree zero. } \examples{ library(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## cubic B-splines bsMat <- bSpline(x, knots = knots, degree = 3, intercept = TRUE) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, bsMat, type = "l", ylab = "Cubic B-splines") abline(v = knots, lty = 2, col = "gray") ## reset to previous plotting settings par(op) ## the first derivaitves d1Mat <- deriv(bsMat) ## the second derivaitves d2Mat <- deriv(bsMat, 2) ## evaluate at new values predict(bsMat, c(0.125, 0.801)) } \references{ De Boor, Carl. (1978). \emph{A practical guide to splines}. Vol. 27. New York: Springer-Verlag. } \seealso{ \code{\link{dbs}} for derivatives of B-splines; \code{\link{ibs}} for integrals of B-splines; } splines2/man/iSpline.Rd0000644000176200001440000000653614103555677014505 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/iSpline.R \name{iSpline} \alias{iSpline} \title{I-Spline Basis for Polynomial Splines} \usage{ iSpline( x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = NULL, derivs = 0L, ... ) } \arguments{ \item{x}{The predictor variable. Missing values are allowed and will be returned as they are.} \item{df}{Degree of freedom that equals to the column number of the returned matrix. One can specify \code{df} rather than \code{knots}, then the function chooses \code{df - degree - as.integer(intercept)} internal knots at suitable quantiles of \code{x} ignoring missing values and those \code{x} outside of the boundary. If internal knots are specified via \code{knots}, the specified \code{df} will be ignored.} \item{knots}{The internal breakpoints that define the splines. The default is \code{NULL}, which results in a basis for ordinary polynomial regression. Typical values are the mean or median for one knot, quantiles for more knots.} \item{degree}{The degree of I-spline defined to be the degree of the associated M-spline instead of actual polynomial degree. For example, I-spline basis of degree 2 is defined as the integral of associated M-spline basis of degree 2.} \item{intercept}{If \code{TRUE} by default, all of the spline basis functions are returned. Notice that when using I-Spline for monotonic regression, \code{intercept = TRUE} should be set even when an intercept term is considered additional to the spline basis functions.} \item{Boundary.knots}{Boundary points at which to anchor the splines. By default, they are the range of \code{x} excluding \code{NA}. If both \code{knots} and \code{Boundary.knots} are supplied, the basis parameters do not depend on \code{x}. Data can extend beyond \code{Boundary.knots}.} \item{derivs}{A nonnegative integer specifying the order of derivatives of I-splines.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of \code{length(x)} rows and \code{df} columns if \code{df} is specified or \code{length(knots) + degree + as.integer(intercept)} columns if \code{knots} are specified instead. Attributes that correspond to the arguments specified are returned mainly for other functions in this package. } \description{ Generates the I-spline (integral of M-spline) basis matrix for a polynomial spline or the corresponding derivatives of given order. } \details{ It is an implementation of the closed-form I-spline basis based on the recursion formula given by Ramsay (1988). } \examples{ library(splines2) ## Example given in the reference paper by Ramsay (1988) x <- seq.int(0, 1, by = 0.01) knots <- c(0.3, 0.5, 0.6) isMat <- iSpline(x, knots = knots, degree = 2) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, isMat, type = "l", ylab = "I-spline basis") abline(v = knots, lty = 2, col = "gray") ## reset to previous plotting settings par(op) ## the derivative of I-splines is M-spline msMat1 <- iSpline(x, knots = knots, degree = 2, derivs = 1) msMat2 <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) stopifnot(all.equal(msMat1, msMat2)) } \references{ Ramsay, J. O. (1988). Monotone regression splines in action. \emph{Statistical Science}, 3(4), 425--441. } \seealso{ \code{\link{mSpline}} for M-splines; \code{\link{cSpline}} for C-splines; } splines2/man/mSpline.Rd0000644000176200001440000001534714102414367014476 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mSpline.R \name{mSpline} \alias{mSpline} \title{M-Spline Basis for Polynomial Splines} \usage{ mSpline( x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, periodic = FALSE, derivs = 0L, integral = FALSE, ... ) } \arguments{ \item{x}{The predictor variable. Missing values are allowed and will be returned as they are.} \item{df}{Degree of freedom that equals to the column number of the returned matrix. One can specify \code{df} rather than \code{knots}. For M-splines, the function chooses \code{df - degree - as.integer(intercept)} internal knots at suitable quantiles of \code{x} ignoring missing values and those \code{x} outside of the boundary. For periodic M-spline (\code{periodic = TRUE}), \code{df - as.integer(intercept)} internal knots will be chosen at suitable quantiles of \code{x} relative to the beginning of the cyclic intervals they belong to (see Examples) and the number of internal knots must be greater or equal to the specified \code{degree - 1}. If internal knots are specified via \code{knots}, the specified \code{df} will be ignored.} \item{knots}{The internal breakpoints that define the splines. The default is \code{NULL}, which results in a basis for ordinary polynomial regression. Typical values are the mean or median for one knot, quantiles for more knots. For periodic splines (\code{periodic = TRUE}), the number of knots must be greater or equal to the specified \code{degree - 1}.} \item{degree}{A nonnegative integer specifying the degree of the piecewise polynomial. The default value is \code{3} for cubic splines. Zero degree is allowed for piecewise constant basis functions.} \item{intercept}{If \code{TRUE}, the complete basis matrix will be returned. Otherwise, the first basis will be excluded from the output.} \item{Boundary.knots}{Boundary points at which to anchor the splines. By default, they are the range of \code{x} excluding \code{NA}. If both \code{knots} and \code{Boundary.knots} are supplied, the basis parameters do not depend on \code{x}. Data can extend beyond \code{Boundary.knots}. For periodic splines (\code{periodic = TRUE}), the specified boundary knots define the cyclic interval.} \item{periodic}{A logical value. If \code{TRUE}, the periodic splines will be returned instead of regular M-splines. The default value is \code{FALSE}.} \item{derivs}{A nonnegative integer specifying the order of derivatives of M-splines. The default value is \code{0L} for M-spline basis functions.} \item{integral}{A logical value. If \code{TRUE}, the corresponding integrals of spline basis functions will be returned. The default value is \code{FALSE}. For periodic splines, the integral of each basis is integrated from the left boundary knot.} \item{...}{Optional arguments that are not used.} } \value{ A numeric matrix of \code{length(x)} rows and \code{df} columns if \code{df} is specified. If \code{knots} are specified instead, the output matrix will consist of \code{length(knots) + degree + as.integer(intercept)} columns if \code{periodic = FALSE}, or \code{length(knots) + as.integer(intercept)} columns if \code{periodic = TRUE}. Attributes that correspond to the arguments specified are returned for usage of other functions in this package. } \description{ Generates the basis matrix of regular M-spline, periodic M-spline, and the corresponding integrals and derivatives. } \details{ This function contains an implementation of the closed-form M-spline basis based on the recursion formula given by Ramsay (1988) or periodic M-spline basis following the procedure producing periodic B-splines given in Piegl and Tiller (1997). For monotone regression, one can use I-splines (see \code{\link{iSpline}}) instead of M-splines. } \examples{ library(splines2) ### example given in the reference paper by Ramsay (1988) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, msMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ## derivatives of M-splines dmsMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE, derivs = 1) ## or using the deriv method dmsMat1 <- deriv(msMat) stopifnot(all.equal(dmsMat, dmsMat1, check.attributes = FALSE)) ### periodic M-splines x <- seq.int(0, 3, 0.01) bknots <- c(0, 1) pMat <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = bknots, periodic = TRUE) ## integrals iMat <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = bknots, periodic = TRUE, integral = TRUE) ## first derivatives by "derivs = 1" dMat1 <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = bknots, periodic = TRUE, derivs = 1) ## first derivatives by using the deriv() method dMat2 <- deriv(pMat) par(mfrow = c(2, 2)) matplot(x, pMat, type = "l", ylab = "Periodic Basis") abline(v = seq.int(0, max(x)), lty = 2, col = "grey") matplot(x, iMat, type = "l", ylab = "Integrals from 0") abline(v = seq.int(0, max(x)), h = seq.int(0, max(x)), lty = 2, col = "grey") matplot(x, dMat1, type = "l", ylab = "1st derivatives by 'derivs=1'") abline(v = seq.int(0, max(x)), lty = 2, col = "grey") matplot(x, dMat2, type = "l", ylab = "1st derivatives by 'deriv()'") abline(v = seq.int(0, max(x)), lty = 2, col = "grey") ## reset to previous plotting settings par(op) ### default placement of internal knots for periodic splines default_knots <- function(x, df, intercept = FALSE, Boundary.knots = range(x, na.rm = TRUE)) { ## get x in the cyclic interval [0, 1) x2 <- (x - Boundary.knots[1]) \%\% (Boundary.knots[2] - Boundary.knots[1]) knots <- quantile(x2, probs = seq(0, 1, length.out = df + 2 - intercept)) unname(knots[- c(1, length(knots))]) } df <- 8 degree <- 3 intercept <- TRUE internal_knots <- default_knots(x, df, intercept) ## 1. specify df spline_basis1 = splines2::mSpline(x, degree = degree, df = df, periodic = TRUE, intercept = intercept) ## 2. specify knots spline_basis2 = splines2::mSpline(x, degree = degree, knots = internal_knots, periodic = TRUE, intercept = intercept) all.equal(internal_knots, knots(spline_basis1)) all.equal(spline_basis1, spline_basis2) } \references{ Ramsay, J. O. (1988). Monotone regression splines in action. \emph{Statistical science}, 3(4), 425--441. Piegl, L., & Tiller, W. (1997). \emph{The NURBS book}. Springer Science \& Business Media. } \seealso{ \code{\link{bSpline}} for B-splines; \code{\link{iSpline}} for I-splines; \code{\link{cSpline}} for C-splines. } splines2/DESCRIPTION0000644000176200001440000000265014121634402013517 0ustar liggesusersPackage: splines2 Title: Regression Spline Functions and Classes Version: 0.4.5 Authors@R: c( person(given = "Wenjie", family = "Wang", email = "wang@wwenjie.org", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-0363-3180")), person(given = "Jun", family = "Yan", role = "aut", comment = c(ORCID = "0000-0003-4401-7296")) ) Description: Constructs basis matrix of B-splines, M-splines, I-splines, convex splines (C-splines), periodic M-splines, natural cubic splines, generalized Bernstein polynomials, and their integrals (except C-splines) and derivatives of given order by close-form recursive formulas. It also contains a C++ head-only library integrated with Rcpp. See Wang and Yan (2021) for details. Imports: Rcpp, stats LinkingTo: Rcpp, RcppArmadillo Suggests: knitr, rmarkdown, tinytest Depends: R (>= 3.2.3) VignetteBuilder: knitr License: GPL (>= 3) URL: https://wwenjie.org/splines2, https://github.com/wenjie2wang/splines2 BugReports: https://github.com/wenjie2wang/splines2/issues Encoding: UTF-8 RoxygenNote: 7.1.1 NeedsCompilation: yes Packaged: 2021-09-19 00:33:10 UTC; wenjie Author: Wenjie Wang [aut, cre] (), Jun Yan [aut] () Maintainer: Wenjie Wang Repository: CRAN Date/Publication: 2021-09-19 13:20:02 UTC splines2/build/0000755000176200001440000000000014121502506013104 5ustar liggesuserssplines2/build/vignette.rds0000644000176200001440000000036214121502506015444 0ustar liggesusersuO] 0i dA|7D*jl _]m4~sAe@44=G6(2Bn= "1.2.2") { ## Set a seed to make the test deterministic set.seed(808) is_at_home <- function() { identical(tolower(Sys.getenv("TT_AT_HOME")), "true") } ## only run the following tests if at home (not at cran) tinytest::test_package("splines2", ncpu = NULL, test_dir = "rcpp-tests", at_home = is_at_home()) ## run anyway tinytest::test_package("splines2", ncpu = NULL, side_effects = TRUE) } splines2/src/0000755000176200001440000000000014121502506012574 5ustar liggesuserssplines2/src/CSpline_export.cpp0000644000176200001440000000461014121502500016231 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #include // [[Rcpp::plugins(cpp11)]] #include // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_cSpline( const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool complete_basis = true ) { splines2::CSpline cs_obj; Rcpp::NumericMatrix out; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; cs_obj = splines2::CSpline(x, spline_df, degree, boundary_knots); } else { // else ignore df cs_obj = splines2::CSpline(x, internal_knots, degree, boundary_knots); } if (derivs > 0) { out = splines2::arma2rmat(cs_obj.derivative(derivs, complete_basis)); } else { out = splines2::arma2rmat(cs_obj.basis(complete_basis)); } // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("degree") = static_cast(cs_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(cs_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(cs_obj.get_boundary_knots()); out.attr("derivs") = static_cast(derivs); out.attr("intercept") = complete_basis; out.attr("scales") = splines2::arma2rvec(cs_obj.get_scales()); return out; } splines2/src/BSpline_export.cpp0000644000176200001440000001316414121502500016234 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #include // [[Rcpp::plugins(cpp11)]] #include // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_bSpline( const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs = 0, const bool integral = false, const bool complete_basis = true ) { Rcpp::NumericMatrix out; splines2::BSpline bs_obj; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; bs_obj = splines2::BSpline(x, spline_df, degree, boundary_knots); } else { // else ignore df bs_obj = splines2::BSpline(x, internal_knots, degree, boundary_knots); } // 1) basis, 2) derivative, or 3) integral if (integral && derivs == 0) { // integrals out = splines2::arma2rmat(bs_obj.integral(complete_basis)); } else if ((! integral && derivs == 0) || (integral && derivs == 1)) { // basis functions out = splines2::arma2rmat(bs_obj.basis(complete_basis)); } else { // derivatives out = splines2::arma2rmat( bs_obj.derivative(derivs - static_cast(integral), complete_basis) ); } // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("degree") = static_cast(bs_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(bs_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(bs_obj.get_boundary_knots()); out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; out.attr("intercept") = complete_basis; return out; } // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_bSpline_derivative( const arma::vec& x, const unsigned int derivs, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const bool complete_basis = true ) { splines2::BSpline bs_obj; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; bs_obj = splines2::BSpline(x, spline_df, degree, boundary_knots); } else { // else ignore df bs_obj = splines2::BSpline(x, internal_knots, degree, boundary_knots); } Rcpp::NumericMatrix out { splines2::arma2rmat(bs_obj.derivative(derivs, complete_basis)) }; // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("derivs") = static_cast(derivs); out.attr("degree") = static_cast(bs_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(bs_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(bs_obj.get_boundary_knots()); out.attr("intercept") = complete_basis; return out; } // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_bSpline_integral( const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const bool complete_basis = true ) { splines2::BSpline bs_obj; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; bs_obj = splines2::BSpline(x, spline_df, degree, boundary_knots); } else { // else ignore df bs_obj = splines2::BSpline(x, internal_knots, degree, boundary_knots); } Rcpp::NumericMatrix out { splines2::arma2rmat(bs_obj.integral(complete_basis)) }; // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("degree") = static_cast(bs_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(bs_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(bs_obj.get_boundary_knots()); out.attr("intercept") = complete_basis; return out; } splines2/src/ISpline_export.cpp0000644000176200001440000000523614121502500016244 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #include // [[Rcpp::plugins(cpp11)]] #include // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_iSpline( const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool integral, const bool complete_basis = true ) { splines2::ISpline is_obj; Rcpp::NumericMatrix out; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; is_obj = splines2::ISpline(x, spline_df, degree, boundary_knots); } else { // else ignore df is_obj = splines2::ISpline(x, internal_knots, degree, boundary_knots); } if (integral && derivs == 0) { // integrals out = splines2::arma2rmat(is_obj.integral(complete_basis)); } else if ((! integral && derivs == 0) || (integral && derivs == 1)) { // basis functions out = splines2::arma2rmat(is_obj.basis(complete_basis)); } else { // derivatives out = splines2::arma2rmat( is_obj.derivative(derivs - static_cast(integral), complete_basis) ); } // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("degree") = static_cast(is_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(is_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(is_obj.get_boundary_knots()); out.attr("derivs") = static_cast(derivs); out.attr("intercept") = complete_basis; return out; } splines2/src/MSpline_export.cpp0000644000176200001440000001163114121502500016244 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #include // [[Rcpp::plugins(cpp11)]] #include // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_mSpline( const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs = 0, const bool integral = false, const bool complete_basis = true ) { Rcpp::NumericMatrix out; splines2::MSpline ms_obj; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; ms_obj = splines2::MSpline(x, spline_df, degree, boundary_knots); } else { // else ignore df ms_obj = splines2::MSpline(x, internal_knots, degree, boundary_knots); } // 1) basis, 2) derivative, or 3) integral if (integral && derivs == 0) { // integrals out = splines2::arma2rmat(ms_obj.integral(complete_basis)); } else if ((! integral && derivs == 0) || (integral && derivs == 1)) { // basis functions out = splines2::arma2rmat(ms_obj.basis(complete_basis)); } else { // derivatives out = splines2::arma2rmat( ms_obj.derivative(derivs - static_cast(integral), complete_basis) ); } // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("degree") = static_cast(ms_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(ms_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(ms_obj.get_boundary_knots()); out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; out.attr("periodic") = false; out.attr("intercept") = complete_basis; return out; } // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_periodic_mSpline( const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs = 0, const bool integral = false, const bool complete_basis = true ) { Rcpp::NumericMatrix out; splines2::PeriodicMSpline ms_obj; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; ms_obj = splines2::PeriodicMSpline( x, spline_df, degree, boundary_knots); } else { // else ignore df ms_obj = splines2::PeriodicMSpline( x, internal_knots, degree, boundary_knots); } // 1) basis, 2) derivative, or 3) integral if (integral && derivs == 0) { // integrals out = splines2::arma2rmat(ms_obj.integral(complete_basis)); } else if ((! integral && derivs == 0) || (integral && derivs == 1)) { // basis functions out = splines2::arma2rmat(ms_obj.basis(complete_basis)); } else { // derivatives out = splines2::arma2rmat( ms_obj.derivative(derivs - static_cast(integral), complete_basis) ); } // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("degree") = static_cast(ms_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(ms_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(ms_obj.get_boundary_knots()); out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; out.attr("periodic") = true; out.attr("intercept") = complete_basis; return out; } splines2/src/Makevars0000644000176200001440000000047313677517626014324 0ustar liggesusers## generated by RcppArmadillo.package.skeleton() CXX_STD = CXX11 PKG_CPPFLAGS = -I../inst/include PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) ## for profiling # PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) -lprofiler splines2/src/BernsteinPoly_export.cpp0000644000176200001440000000410214121502500017465 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #include // [[Rcpp::plugins(cpp11)]] #include // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_bernsteinPoly( const arma::vec& x, const unsigned int degree, const unsigned int derivs, const bool integral, const arma::vec& boundary_knots, const bool complete_basis ) { splines2::BernsteinPoly bp_obj { x, degree, boundary_knots }; Rcpp::NumericMatrix out; if (integral && derivs == 0) { // integrals out = splines2::arma2rmat(bp_obj.integral(complete_basis)); } else if ((! integral && derivs == 0) || (integral && derivs == 1)) { // basis functions out = splines2::arma2rmat(bp_obj.basis(complete_basis)); } else { // derivatives out = splines2::arma2rmat( bp_obj.derivative(derivs - static_cast(integral), complete_basis) ); } // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("degree") = static_cast(bp_obj.get_degree()); out.attr("Boundary.knots") = splines2::arma2rvec( bp_obj.get_boundary_knots() ); out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; out.attr("intercept") = complete_basis; return out; } splines2/src/Makevars.win0000644000176200001440000000024213677517626015112 0ustar liggesusersCXX_STD = CXX11 PKG_CPPFLAGS = -I../inst/include PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) splines2/src/NaturalSpline_export.cpp0000644000176200001440000000524714121502500017464 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #include // [[Rcpp::plugins(cpp11)]] #include // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_naturalSpline( const arma::vec& x, const unsigned int df, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs = 0, const bool integral = false, const bool complete_basis = true ) { splines2::NaturalSpline ns_obj; // if df > 0 and knots are not specified // auto set internal knots based on df if (df > 0 && internal_knots.n_elem == 0) { // compute actual spline degree of freedom const unsigned int wo_intercept { static_cast(! complete_basis) }; unsigned int spline_df { df + wo_intercept }; ns_obj = splines2::NaturalSpline(x, spline_df, boundary_knots); } else { // else ignore df ns_obj = splines2::NaturalSpline(x, internal_knots, boundary_knots); } Rcpp::NumericMatrix out; // 1) basis, 2) derivative, or 3) integral if (integral && derivs == 0) { // integrals out = splines2::arma2rmat(ns_obj.integral(complete_basis)); } else if ((! integral && derivs == 0) || (integral && derivs == 1)) { // basis functions out = splines2::arma2rmat(ns_obj.basis(complete_basis)); } else { // derivatives out = splines2::arma2rmat( ns_obj.derivative(derivs - static_cast(integral), complete_basis) ); } // add attributes out.attr("dimnames") = Rcpp::List::create( R_NilValue, splines2::char_seq_len(out.ncol()) ); out.attr("x") = splines2::arma2rvec(x); out.attr("knots") = splines2::arma2rvec(ns_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(ns_obj.get_boundary_knots()); out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; out.attr("intercept") = complete_basis; return out; } splines2/src/RcppExports.cpp0000644000176200001440000003113414121502500015565 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include #include using namespace Rcpp; #ifdef RCPP_USE_GLOBAL_ROSTREAM Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // rcpp_bSpline Rcpp::NumericMatrix rcpp_bSpline(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool integral, const bool complete_basis); RcppExport SEXP _splines2_rcpp_bSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP derivsSEXP, SEXP integralSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_bSpline(x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_bSpline_derivative Rcpp::NumericMatrix rcpp_bSpline_derivative(const arma::vec& x, const unsigned int derivs, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const bool complete_basis); RcppExport SEXP _splines2_rcpp_bSpline_derivative(SEXP xSEXP, SEXP derivsSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_bSpline_derivative(x, derivs, df, degree, internal_knots, boundary_knots, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_bSpline_integral Rcpp::NumericMatrix rcpp_bSpline_integral(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const bool complete_basis); RcppExport SEXP _splines2_rcpp_bSpline_integral(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_bSpline_integral(x, df, degree, internal_knots, boundary_knots, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_bernsteinPoly Rcpp::NumericMatrix rcpp_bernsteinPoly(const arma::vec& x, const unsigned int degree, const unsigned int derivs, const bool integral, const arma::vec& boundary_knots, const bool complete_basis); RcppExport SEXP _splines2_rcpp_bernsteinPoly(SEXP xSEXP, SEXP degreeSEXP, SEXP derivsSEXP, SEXP integralSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_bernsteinPoly(x, degree, derivs, integral, boundary_knots, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_cSpline Rcpp::NumericMatrix rcpp_cSpline(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool complete_basis); RcppExport SEXP _splines2_rcpp_cSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP derivsSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_cSpline(x, df, degree, internal_knots, boundary_knots, derivs, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_iSpline Rcpp::NumericMatrix rcpp_iSpline(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool integral, const bool complete_basis); RcppExport SEXP _splines2_rcpp_iSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP derivsSEXP, SEXP integralSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_iSpline(x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_mSpline Rcpp::NumericMatrix rcpp_mSpline(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool integral, const bool complete_basis); RcppExport SEXP _splines2_rcpp_mSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP derivsSEXP, SEXP integralSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_mSpline(x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_periodic_mSpline Rcpp::NumericMatrix rcpp_periodic_mSpline(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool integral, const bool complete_basis); RcppExport SEXP _splines2_rcpp_periodic_mSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP derivsSEXP, SEXP integralSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const unsigned int >::type degree(degreeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_periodic_mSpline(x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis)); return rcpp_result_gen; END_RCPP } // rcpp_naturalSpline Rcpp::NumericMatrix rcpp_naturalSpline(const arma::vec& x, const unsigned int df, const arma::vec& internal_knots, const arma::vec& boundary_knots, const unsigned int derivs, const bool integral, const bool complete_basis); RcppExport SEXP _splines2_rcpp_naturalSpline(SEXP xSEXP, SEXP dfSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP derivsSEXP, SEXP integralSEXP, SEXP complete_basisSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< const unsigned int >::type df(dfSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type internal_knots(internal_knotsSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_naturalSpline(x, df, internal_knots, boundary_knots, derivs, integral, complete_basis)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { {"_splines2_rcpp_bSpline", (DL_FUNC) &_splines2_rcpp_bSpline, 8}, {"_splines2_rcpp_bSpline_derivative", (DL_FUNC) &_splines2_rcpp_bSpline_derivative, 7}, {"_splines2_rcpp_bSpline_integral", (DL_FUNC) &_splines2_rcpp_bSpline_integral, 6}, {"_splines2_rcpp_bernsteinPoly", (DL_FUNC) &_splines2_rcpp_bernsteinPoly, 6}, {"_splines2_rcpp_cSpline", (DL_FUNC) &_splines2_rcpp_cSpline, 7}, {"_splines2_rcpp_iSpline", (DL_FUNC) &_splines2_rcpp_iSpline, 8}, {"_splines2_rcpp_mSpline", (DL_FUNC) &_splines2_rcpp_mSpline, 8}, {"_splines2_rcpp_periodic_mSpline", (DL_FUNC) &_splines2_rcpp_periodic_mSpline, 8}, {"_splines2_rcpp_naturalSpline", (DL_FUNC) &_splines2_rcpp_naturalSpline, 7}, {NULL, NULL, 0} }; RcppExport void R_init_splines2(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } splines2/vignettes/0000755000176200001440000000000014121502506014015 5ustar liggesuserssplines2/vignettes/splines2-intro.Rmd0000644000176200001440000003356114103557514017372 0ustar liggesusers--- title: "Introduction to splines2" author: Wenjie Wang date: "`r Sys.Date()`" bibliography: - ../inst/bib/splines2.bib vignette: > %\VignetteIndexEntry{Introduction to splines2} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} output: rmarkdown::html_vignette --- ```{r setup, echo = FALSE} knitr::opts_knit$set(global.par = TRUE) knitr::opts_chunk$set(fig.width = 7, fig.height = 4) ``` ```{r set-par, echo = FALSE} library(graphics) par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) ``` The R package **splines2** is intended to be a comprehensive, efficient supplement to the base package **splines**. It provides functions constructing a variety of regression spline basis functions that are not available from **splines**. Most functions have a very similar user interface with the function `splines::bs()`. To be more specific, it provides functions to construct basis matrices of - B-splines - M-splines - I-splines - C-splines - periodic M-splines - natural cubic splines - generalized Bernstein polynomials along with their integrals (except C-splines) and derivatives of given order by closed-form recursive formulas. Compared to the package **splines**, the package **splines2** allows piecewise constant basis functions for B-splines and provides a more user-friendly interface for their derivatives with consistent handling on `NA`'s. Most of the implementations had been (re)written in C++ with the help of **Rcpp** and **RcppArmadillo** since v0.3.0, which boosted the computational performance. In the remaining of this vignette, we illustrated the basic usage of most functions in the package through examples. See the package manual for the details of function usage. ## B-splines with their integrals and derivatives {#bSpline} Function `bSpline()` provides B-spline basis matrix and allows `degree = 0` for piece-wise constant basis function, which extends the `bs()` function in package **splines** with a better computational performance. One example of linear B-splines with three internal knots is given as follows: ```{r bSpline, fig.cap="B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6."} library(splines2) knots <- c(0.3, 0.5, 0.6) x <- seq(0, 1, 0.01) bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ``` The closed-form recursive formula of B-spline integrals and derivatives given by @boor1978practical is implemented in function `ibs()` and `dbs()`, respectively. Two toy examples are given as follows: ```{r ibs, fig.cap="Piecewise linear B-splines (left) and their integrals (right)."} ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, h = 1, lty = 2, col = "gray") matplot(x, ibsMat, type = "l", ylab = "y") abline(v = knots, h = c(0.15, 0.2, 0.25), lty = 2, col = "gray") ``` ```{r dbs, fig.cap="Cubic B-spline (left) and their first derivative (right)."} bsMat <- bSpline(x, knots = knots, intercept = TRUE) dbsMat <- dbs(x, knots = knots, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") matplot(x, dbsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ``` We may also obtain the derivatives easily by the `deriv()` method as follows: ```{r dbsMat} is_equivalent <- function(a, b) { all.equal(a, b, check.attributes = FALSE) } stopifnot(is_equivalent(dbsMat, deriv(bsMat))) ``` ## M-splines using `mSpline()` {#mSpline} M-splines [@ramsay1988monotone] are considered the normalized version of B-splines with unit integral within boundary knots. An example given by @ramsay1988monotone was a quadratic M-splines with three internal knots placed at 0.3, 0.5, and 0.6. The default boundary knots are the range of `x`, and thus 0 and 1 in this example. ```{r reset-par-mSpline, echo = FALSE} par(mfrow = c(1, 1)) ``` ```{r mSpline, fig.cap = "Quadratic M-spline with three internal knots placed at 0.3, 0.5, and 0.6."} msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, msMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ``` The derivative of the given order of M-splines can be obtained by specifying a positive integer to argument `dervis` of `mSpline()`. Also, for an existing `mSpline` object generated by `mSpline()`, the `deriv()` method can be used conveniently. For example, the first derivative of the M-splines given in the previous example can be obtained equivalently as follows: ```{r mSpline-derivs} dmsMat1 <- mSpline(x, knots = knots, degree = 2, intercept = TRUE, derivs = 1) dmsMat2 <- deriv(msMat) stopifnot(is_equivalent(dmsMat1, dmsMat2)) ``` ### Periodic M-Splines The function `mSpline()` produces periodic splines based on M-spline basis functions when `periodic = TRUE` is specified. The `Boundary.knots` defines the cyclic interval. The construction follows periodic B-splines discussed in @piegl1997nurbs [chapter 12]. ```{r pms-basis, fig.cap = "Cubic periodic M-splines."} x1 <- seq.int(0, 3, 0.01) pmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1)) matplot(x1, pmsMat, type = "l", xlab = "x", ylab = "Periodic Basis") abline(v = seq.int(0, 3), lty = 2, col = "gray") ``` We may still specify the argument `derivs` in `mSpline()` or use the corresponding `deriv()` method to obtain the derivatives when `periodic = TRUE`. ```{r pms-deriv, fig.cap = "The first derivatives of the periodic M-splines."} dpmsMat <- deriv(pmsMat) matplot(x1, dpmsMat, type = "l", xlab = "x", ylab = "The 1st derivatives") abline(v = seq.int(0, 3), lty = 2, col = "gray") ``` Furthermore, we can obtain the integrals of the periodic M-splines by specifying `integral = TRUE`. The integral is integrated from the left boundary knot. ```{r pms-integral, fig.cap = "The integrals of the periodic M-splines."} ipmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE) matplot(x1, ipmsMat, type = "l", xlab = "x", ylab = "Integrals") abline(v = seq.int(0, 3), h = seq.int(0, 3), lty = 2, col = "gray") ``` ## I-splines using `iSpline()` {#iSpline} I-splines [@ramsay1988monotone] are simply the integral of M-splines and thus monotonically nondecreasing with unit maximum value. A monotonically nondecreasing (nonincreasing) function can be fitted by a linear combination of I-spline basis functions with nonnegative (nonpositive) coefficients *plus a constant*, where the coefficient of the constant is unconstrained. The example given by @ramsay1988monotone was the I-splines corresponding to that quadratic M-splines with three internal knots placed at 0.3, 0.5, and 0.6. Notice that the degree of I-splines is defined from the associated M-splines instead of their polynomial degree. ```{r iSpline, fig.cap = "I-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6."} isMat <- iSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, isMat, type = "l", ylab = "y") abline(h = 1, v = knots, lty = 2, col = "gray") ``` The corresponding M-spline basis matrix can be obtained easily as the first derivatives of the I-splines by the `deriv()` method. ```{r msMat} stopifnot(is_equivalent(msMat, deriv(isMat))) ``` We may specify the `derivs = 2` in the `deriv()` method for the second derivatives of the I-splines, which are equivalent to the first derivatives of the corresponding M-splines. ```{r dmsMat} dmsMat3 <- deriv(isMat, 2) stopifnot(is_equivalent(dmsMat1, dmsMat3)) ``` ## C-splines using `cSpline` {#cSpline} Convex splines [@meyer2008inference] called C-splines are scaled integrals of I-splines with unit maximum value at the right boundary knot. @meyer2008inference applied C-splines to shape-restricted regression analysis. The monotone (nondecreasing) property of I-spines ensures the convexity of C-splines. A convex regression function can be estimated using linear combinations of the C-spline basis functions with nonnegative coefficients, plus an unconstrained linear combination of a constant and an identity function $g(x)=x$. If the underlying regression function is both increasing and convex, the coefficient on the identity function is restricted to be nonnegative as well. We may specify the argument `scale = FALSE` in function `cSpline()` to disable the scaling of the integrals of I-splines. Then the actual integrals of the corresponding I-splines will be returned. If `scale = TRUE` (by default), each C-spline basis is scaled to have unit height at the right boundary knot. ```{r cSpline-scaled, fig.cap = "C-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6."} csMat1 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, csMat1, type = "l", ylab = "y") abline(h = 1, v = knots, lty = 2, col = "gray") ``` Similarly, the `deriv()` method can be used to obtain the derivatives. A nested call of `deriv()` is supported for derivatives of order greater than one. However, the argument `derivs` of the `deriv()` method can be specified directly for better computational performance. For example, the first and second derivatives can be obtained by the following equivalent approaches, respectively. ```{r cSpline-not-scaled} csMat2 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE, scale = FALSE) stopifnot(is_equivalent(isMat, deriv(csMat2))) stopifnot(is_equivalent(msMat, deriv(csMat2, 2))) stopifnot(is_equivalent(msMat, deriv(deriv(csMat2)))) ``` ## Generalized Bernstein Polynomials The Bernstein polynomials have also been applied to shape-constrained regression analysis [@wang2012csda]. The $i$-th basis of the generalized Bernstein polynomials of degree $n$ over $[a, b]$ is defined as follows: $$ B_i^n(x)=\frac{1}{(b-a)^n}{n\choose i}(x-a)^i (b-x)^{n-i},~i\in\{0,\ldots,n\}, $$ where $a\le x\le b$. Obviously, it reduces to regular Bernstein polynomials defined over $[0, 1]$ when $a = 0$ and $b = 1$. We may obtain the basis matrix of the generalized using the function `bernsteinPoly()`. For example, the Bernstein polynomials of degree 4 over $[0, 1]$ and is generated as follows: ```{r bp-1, fig.cap = "Bernstein polynomials of degree 4 over [0, 1] (left) and the generalized version over [- 1, 1] (right)."} x1 <- seq.int(0, 1, 0.01) x2 <- seq.int(- 1, 1, 0.01) bpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE) bpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x1, bpMat1, type = "l", ylab = "y") matplot(x2, bpMat2, type = "l", ylab = "y") ``` In addition, we may specify `integral = TRUE` or `derivs = 1` in `bernsteinPoly()` for their integrals or first derivatives, respectively. ```{r bp-2, fig.height=6, fig.cap = "The integrals (upper panel) and the first derivatives (lower panel) of Bernstein polynomials of degree 4."} ibpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, integral = TRUE) ibpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, integral = TRUE) dbpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, derivs = 1) dbpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, derivs = 1) par(mfrow = c(2, 2)) matplot(x1, ibpMat1, type = "l", ylab = "Integrals") matplot(x2, ibpMat2, type = "l", ylab = "y") matplot(x1, dbpMat1, type = "l", ylab = "y") matplot(x2, dbpMat2, type = "l", ylab = "y") ``` Similarly, we may also use the `deriv()` method to get derivatives of an existing `bernsteinPoly` object. ```{r bp-deriv} stopifnot(is_equivalent(dbpMat1, deriv(bpMat1))) stopifnot(is_equivalent(dbpMat2, deriv(bpMat2))) stopifnot(is_equivalent(dbpMat1, deriv(ibpMat1, 2))) stopifnot(is_equivalent(dbpMat2, deriv(ibpMat2, 2))) ``` ## Natural Cubic Splines The function `naturalSpline()` returns nonnegative basis functions (within the boundary) for natural cubic splines by utilizing the closed-form null space derived from the second derivatives of cubic B-splines. While `splines::ns()` uses QR decomposition to find the null space of the second derivatives of B-spline basis at boundary knots with no guarantee that the resulting basis functions are nonnegative within the boundary. When `integral = TRUE`, `naturalSpline()` returns integral of each natural spline basis. ```{r ns-basis, fig.cap = "Nonnegative natural cubic splines (left) and corresponding integrals (right)."} nsMat <- naturalSpline(x, knots = knots, intercept = TRUE) insMat <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) par(mfrow = c(1, 2)) matplot(x, nsMat, type = "l", ylab = "Basis") matplot(x, insMat, type = "l", ylab = "Integrals") stopifnot(is_equivalent(nsMat, deriv(insMat))) ``` Similar to `bernsteinPoly()`, one may specify the argument `derivs` in `naturalSpline()` or use the corresponding `deriv()` method to obtain the derivatives of spline basis functions. ```{r ns-deriv, fig.cap = "The derivatives of natural cubic splines."} d1nsMat <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) d2nsMat <- deriv(nsMat, 2) par(mfrow = c(1, 2)) matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives") matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives") ``` ## Evaluation on New Values by `predict` {#predict} The methods for **splines2** objects dispatched by generic function `predict` will be useful if we want to evaluate the spline object at possibly new $x$ values. For instance, we may evaluate the value of I-splines object in the previous example at 0.275, 0.525, and 0.8, respectively, as follows: ```{r predict} new_x <- c(0.275, 0.525, 0.8) names(new_x) <- paste0("x=", new_x) predict(isMat, new_x) ``` Technically speaking, the methods take all information needed, such as `knots`, `degree`, `intercept`, etc., from attributes of the original objects and call the corresponding function automatically for those new $x$ values. Therefore, the `predict` methods will not be applicable if those attributes are somehow lost after some operations. ## Reference splines2/vignettes/splines2-wi-rcpp.Rmd0000644000176200001440000002176714071743574017634 0ustar liggesusers--- title: "Using splines2 with Rcpp" author: Wenjie Wang date: "`r Sys.Date()`" bibliography: - ../inst/bib/splines2.bib vignette: > %\VignetteIndexEntry{Using splines2 with Rcpp} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} output: rmarkdown::html_vignette --- In this package vignette, we introduce how to use the C++ header-only library that **splines2** contains with the **Rcpp** package [@eddelbuettel2013springer] for constructing spline basis functions. The introduction is intended for package developers who would like to use **splines2** package at C++ level by adding **splines2** to the `LinkingTo` field of package `DESCRIPTION` file. ## Header File and Name Space Different with the procedure-based functions in the R interface, the C++ interface follows the commonly-used object-oriented design in C++ for ease of usage and maintenance. The implementations use the **Armadillo** [@sanderson2016armadillo] library with help of **RcppArmadillo** [@eddelbuettel2014csda] and require C++11. We assume that \proglang{C++11} is enabled for compilation henceforth. We may include the header file named `splines2Armadillo.h` to get the access to all the classes and implementations in the name space `splines2`. ```cpp #include // include header file from splines2 package #include // [[Rcpp::plugins(cpp11)]] ``` To use `Rcpp::sourceCpp()`, one may need to add `[[Rcpp::depends()]]` as follows: ```cpp // [[Rcpp::depends(RcppArmadillo)]] // [[Rcpp::depends(splines2)]] ``` For ease of demonstration, we assume the following *using-directives*: ```cpp using namespace arma using namespace splines2 ``` ## Generalized Bernstein Polynomials The `BernsteinPoly` class is implemented for the generalized Bernstein polynomials. ### Constructors The main non-default constructor is as follows: ```cpp BernsteinPoly(const vec& x, const unsigned int degree, const vec& boundary_knots = vec()); ``` In addition, two explicit constructors are provided for `BernsteinPoly*` and `SplineBase*`, which set `x`, `degree`, and `boundary_knots` from the objects that the pointers point to. ### Function Members The main methods are - `basis()` for basis matrix - `derivative()` for derivatives of basis functions - `integral()` for integrals of basis functions The specific function signatures are as follows: ```cpp mat basis(const bool complete_basis = true); mat derivative(const unsigned int derivs = 1, const bool complete_basis = true); mat integral(const bool complete_basis = true); ``` In addition, we may *set* and *get* the specifications through the following *setter* and *getter* functions, respectively. ```cpp // setter functions BernsteinPoly* set_x(const vec&); BernsteinPoly* set_x(const double); BernsteinPoly* set_degree(const unsigned int); BernsteinPoly* set_order(const unsigned int); BernsteinPoly* set_internal_knots(const vec&); // placeholder, does nothing BernsteinPoly* set_boundary_knots(const vec&); // getter functions vec get_x(); unsigned int get_degree(); unsigned int get_order(); vec get_boundary_knots(); ``` The *setter* function returns a pointer to the current object. ## Classes for Spline Basis Functions A virtual base class named `SplineBase` is implemented to support a variety of classes for spline basis functions including - `BSpline` for B-splines; - `MSpline` for M-splines; - `ISpline` for I-splines; - `CSpline` for C-splines; - `NaturalSpline` for natural cubic splines; - `PeriodicMSpline` for periodic M-splines; - `BernsteinPoly` for Bernstein polynomials. ### Constructors of `BSpline`, `MSpline`, `ISpline`, and `CSpline` The `BSpline`, `MSpline`, `ISpline`, and `CSpline` classes share the same constructors inherited from the `SplineBase` class. There are four constructors in addition to the default constructor. The first non-default constructor is invoked when internal knots are explicitly specified as the second argument. Taking B-splines as an example, the first non-default constructor of a `BSpline` object is ```cpp // 1. specified internal_knots BSpline(const vec& x, const vec& internal_knots, const unsigned int degree = 3, const vec& boundary_knots = vec()); ``` The second non-default constructor is called when an unsigned integer is specified as the second argument, which represents the degree of freedom of the *complete spline basis functions* (different with `df` in the R interface) is specified. Then the number of internal knots is computed as `spline_df - degree - 1` and the placement of internal knots uses quantiles of specified `x` within boundary. ```cpp // 2. specified spline degree of freedom (df) BSpline(const vec& x, const unsigned int spline_df, const unsigned int degree = 3, const vec& boundary_knots = vec()); ``` The third non-default constructor is intended for basis functions with an extended knot sequence, where the multiplicities of the knots can be more than one. ```cpp // 3. specified degree and (extended) knot sequence BSpline(const vec& x, const unsigned int degree, const vec& knot_sequence); ``` The fourth non-default constructor is explicit and takes a pointer to a base class object, which can be useful when we want to create a new object using the same specification (`x`, `degree`, `internal_knots`, and `boundary_knots`) of an existing object (not necessarily a `BSpline` object). ```cpp // 4. create a new object from a base class pointer BSpline(const SplineBase* pSplineBase); ``` This constructor also allows us to easily switch between different types of splines. For example, we create a `BSpline` object `bsp_obj` form an existing `MSpline` object `msp_obj` with the same specification as follows: ```cpp BSpline bsp_obj { &msp_obj }; ``` ### Constructors of `NaturalSpline` The `NaturalSpline` represents the class for natural cubic splines. Thus, its constructors do not allow specification of `degree`. The first non-default constructor is called when internal knots are explicitly specified. ```cpp // 1. specified internal_knots NaturalSpline(const vec& x, const vec& internal_knots, const vec& boundary_knots = vec()); ``` The second non-default constructor is called when an unsigned integer representing the degree of freedom of the *complete spline basis functions* (different with `df` in the R interface) is specified. Then the number of internal knots is computed as `spline_df - 2` and the placement of internal knots uses quantiles of specified `x`. ```cpp // 2. specified spline degree of freedom (df) NaturalSpline(const vec& x, const unsigned int spline_df, const vec& boundary_knots = vec()); ``` The third non-default constructor is explicit and takes a pointer to a base class object. It can be useful when we want to create a new object using the same specification (`x`, `internal_knots`, `boundary_knots`, etc.) of an existing object. ```cpp // 3. create a new object from a base class pointer NaturalSpline(const SplineBase* pSplineBase); ``` ### Constructors of `PeriodicMSpline` The `PeriodicMSpline` class is for constructing the periodic M-splines, which provides the same set of non-default constructors with `BSpline` except the constructor for directly specifying the knot sequence. ### Function Members The main methods are - `basis()` for spline basis matrix - `derivative()` for derivatives of spline basis - `integral()` for integrals of spline basis (except for the `CSpline` class) The specific function signatures are as follows: ```cpp mat basis(const bool complete_basis = true); mat derivative(const unsigned int derivs = 1, const bool complete_basis = true); mat integral(const bool complete_basis = true); ``` Similarly, we may set and get the spline specifications through the following *setter* and *getter* functions, respectively. ```cpp // setter functions SplineBase* set_x(const vec&); SplineBase* set_x(const double); SplineBase* set_internal_knots(const vec&); SplineBase* set_boundary_knots(const vec&); SplineBase* set_knot_sequence(const vec&); SplineBase* set_degree(const unsigned int); SplineBase* set_order(const unsigned int); // getter functions vec get_x(); vec get_internal_knots(); vec get_boundary_knots(); vec get_knot_sequence(); unsigned int get_degree(); unsigned int get_order(); unsigned int get_spline_df(); ``` The *setter* function returns a pointer to the current object so that the specification can be chained for convenience. For example, ```cpp vec x { arma::regspace(0, 0.1, 1) }; // 0, 0.1, ..., 1 BSpline obj { x, 5 }; // df = 5 (and degree = 3, by default) // change degree to 2 and get basis mat basis_mat { obj.set_degree(2)->basis() }; ``` The corresponding first derivatives and integrals of the basis functions can be obtained as follows: ```cpp mat derivative_mat { bs.derivative() }; mat integral_mat { bs.integral() }; ``` Notice that there is no available `integral()` method for `CSpline` and no meaningful `degree` related methods for `NaturalSpline`. ## Reference splines2/R/0000755000176200001440000000000014121502500012200 5ustar liggesuserssplines2/R/ibs.R0000644000176200001440000000572314121502500013107 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' Integrals of B-Splines ##' ##' Generates basis matrix for integrals of B-splines. ##' ##' The implementation is based on the closed-form recursion formula. ##' ##' @inheritParams bSpline ##' ##' @inherit bSpline return ##' ##' @references ##' De Boor, Carl. (1978). \emph{A practical guide to splines}. ##' Vol. 27. New York: Springer-Verlag. ##' ##' @example inst/examples/ex-ibs.R ##' ##' @seealso ##' \code{\link{bSpline}} for B-splines; ##' \code{\link{dbs}} for derivatives of B-splines; ##' ##' @export ibs <- function(x, df = NULL, knots = NULL, degree = 3, intercept = FALSE, Boundary.knots = NULL, ...) { ## check inputs if ((degree <- as.integer(degree)) < 0) stop("The 'degree' must be a nonnegative integer.") if (is.null(df)) { df <- 0L } else { df <- as.integer(df) if (df < 0) { stop("The 'df' must be a nonnegative integer.") } } knots <- null2num0(knots) Boundary.knots <- null2num0(Boundary.knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } ## remove NA's in x xx <- if (nas <- any(nax)) { x[! nax] } else { x } ## call the engine function out <- rcpp_bSpline_integral( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, complete_basis = intercept ) ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (any((xx < b_knots[1L]) | (xx > b_knots[2L]))) { warning(wrapMessages( "Some 'x' values beyond boundary knots", "may cause ill-conditioned basis functions." )) } ## keep NA's as is if (nas) { nmat <- matrix(NA_real_, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency with bs returns name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class class(out) <- c("matrix", "ibs") ## return out } splines2/R/print.R0000644000176200001440000000346514121502500013467 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' @export print.bSpline2 <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ##' @export print.ibs <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ##' @export print.dbs <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ##' @export print.mSpline <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ##' @export print.iSpline <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ##' @export print.cSpline <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ##' @export print.bernsteinPoly <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ##' @export print.naturalSpline <- function(x, ...) { print.default(tidyAttr(x, ...)) invisible(x) } ### internal function ========================================================== ## remove all attributes but dim and dimnames tidyAttr <- function(x, ...) { dimen <- attr(x, "dim") dimenName <- attr(x, "dimnames") attributes(x) <- NULL attr(x, "dim") <- dimen attr(x, "dimnames") <- dimenName x } splines2/R/deriv.R0000644000176200001440000001314114121502500013434 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' Derivatives of Spline Basis Functions ##' ##' Returns derivatives of given order for the given spline basis functions. ##' ##' At knots, the derivative is defined to be the right derivative except at the ##' right boundary knot. By default, the function returns the first derivatives. ##' For derivatives of order greater than one, nested function calls such as ##' \code{deriv(deriv(expr))} are supported but not recommended. For a better ##' performance, argument \code{derivs} should be specified instead. ##' ##' This function is designed for objects produced by this package. It ##' internally extracts necessary specification about the spline/polynomial ##' basis matrix from its attributes. Therefore, the function will not work if ##' the key attributes are not available after some operations. ##' ##' @name deriv ##' ##' @param expr Objects of class \code{bSpline2}, \code{ibs}, \code{mSpline}, ##' \code{iSpline}, \code{cSpline}, \code{bernsteinPoly} or ##' \code{naturalSpline} with attributes describing \code{knots}, ##' \code{degree}, etc. ##' @param derivs A positive integer specifying the order of derivatives. By ##' default, it is \code{1L} for the first derivatives. ##' @param ... Optional arguments that are not used. ##' ##' @return A numeric matrix of the same dimension with the input \code{expr}. ##' ##' @example inst/examples/ex-deriv.R ##' ##' @importFrom stats deriv NULL ##' @rdname deriv ##' @export deriv.bSpline2 <- function(expr, derivs = 1L, ...) { ## checks if key attributes still exist check_attr(expr, c("x", "degree", "knots", "Boundary.knots", "intercept", "derivs", "integral")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(bSpline, attributes(expr)) } ##' @rdname deriv ##' @export deriv.dbs <- function(expr, derivs = 1L, ...) { ## checks if key attributes still exist check_attr(expr, c("x", "degree", "derivs", "knots", "Boundary.knots", "intercept")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(dbs, attributes(expr)) } ##' @rdname deriv ##' @export deriv.ibs <- function(expr, derivs = 1L, ...) { ## quick check on derivs derivs <- as.integer(derivs) if (derivs < 1L) { stop("The 'derivs' has to be a positive integer.") } ## checks if key attributes still exist check_attr(expr, c("x", "degree", "knots", "Boundary.knots", "intercept")) attr(expr, "derivs") <- derivs - 1L do.call(bSpline, attributes(expr)) } ##' @rdname deriv ##' @export deriv.mSpline <- function(expr, derivs = 1L, ...) { ## checks if key attributes still exist check_attr(expr, c("x", "degree", "derivs", "integral", "periodic", "knots", "Boundary.knots", "intercept")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(mSpline, attributes(expr)) } ##' @rdname deriv ##' @export deriv.iSpline <- function(expr, derivs = 1L, ...) { ## quick check on derivs derivs <- as.integer(derivs) if (derivs < 1L) { stop("The 'derivs' has to be a positive integer.") } ## checks if key attributes still exist check_attr(expr, c("x", "degree", "derivs", "knots", "Boundary.knots", "intercept")) attr(expr, "derivs") <- derivs - 1L do.call(mSpline, attributes(expr)) } ##' @rdname deriv ##' @export deriv.cSpline <- function(expr, derivs = 1L, ...) { ## quick check on derivs derivs <- as.integer(derivs) if (derivs < 1L) { stop("The 'derivs' has to be a positive integer.") } ## checks if key attributes still exist check_attr(expr, c("x", "degree", "derivs", "knots", "Boundary.knots", "intercept")) scl <- attr(expr, "scale") if (scl) { ## if scaled attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(cSpline, attributes(expr)) } else { ## if not scaled (then "derivs" must be 0 in cSpline call) derivs <- as.integer(derivs) if (derivs == 1L) { return(do.call(iSpline, attributes(expr))) } if (derivs == 2L) { return(do.call(mSpline, attributes(expr))) } attr(expr, "derivs") <- derivs - 2L do.call(mSpline, attributes(expr)) } } ##' @rdname deriv ##' @export deriv.bernsteinPoly <- function(expr, derivs = 1L, ...) { ## checks if key attributes still exist check_attr(expr, c("x", "degree", "derivs", "integral", "Boundary.knots", "intercept")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(bernsteinPoly, attributes(expr)) } ##' @rdname deriv ##' @export deriv.naturalSpline <- function(expr, derivs = 1L, ...) { ## checks if key attributes still exist check_attr(expr, c("x", "derivs", "integral", "knots", "Boundary.knots", "intercept")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(naturalSpline, attributes(expr)) } splines2/R/makepredictcall.R0000644000176200001440000000566614121502500015464 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ## reference: splines:::makepredictcall ##' @importFrom stats makepredictcall helper_makepredictcall <- function(var, call, fun, key_attr) { fun_symbol <- substitute(fun) fun_name <- as.character(fun_symbol) if (as.character(call)[1L] == fun_name || (is.call(call) && identical(eval(call[[1L]]), eval(fun_symbol)))) { at <- attributes(var)[key_attr] call <- call[1L:2L] call[names(at)] <- at } call } ##' @export makepredictcall.bSpline2 <- function(var, call) { helper_makepredictcall( var, call, fun = bSpline, key_attr = c("degree", "knots", "Boundary.knots", "intercept", "derivs", "integral") ) } ##' @export makepredictcall.naturalSpline <- function(var, call) { helper_makepredictcall( var, call, fun = naturalSpline, key_attr = c("knots", "Boundary.knots", "intercept", "derivs", "integral") ) } ##' @export makepredictcall.dbs <- function(var, call) { helper_makepredictcall( var, call, fun = dbs, key_attr = c("degree", "knots", "Boundary.knots", "intercept", "derivs") ) } ##' @export makepredictcall.ibs <- function(var, call) { helper_makepredictcall( var, call, fun = ibs, key_attr = c("degree", "knots", "Boundary.knots", "intercept") ) } ##' @export makepredictcall.mSpline <- function(var, call) { helper_makepredictcall( var, call, fun = mSpline, key_attr = c("degree", "knots", "Boundary.knots", "intercept", "periodic", "derivs", "integral") ) } ##' @export makepredictcall.iSpline <- function(var, call) { helper_makepredictcall( var, call, fun = iSpline, key_attr = c("degree", "knots", "Boundary.knots", "intercept", "derivs") ) } ##' @export makepredictcall.cSpline <- function(var, call) { helper_makepredictcall( var, call, fun = cSpline, key_attr = c("degree", "knots", "Boundary.knots", "intercept", "derivs", "scale") ) } ##' @export makepredictcall.bernsteinPoly <- function(var, call) { helper_makepredictcall( var, call, fun = bernsteinPoly, key_attr = c("degree", "Boundary.knots", "intercept", "derivs", "integral") ) } splines2/R/bSpline.R0000644000176200001440000001322614121502500013723 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' B-Spline Basis for Polynomial Splines ##' ##' Generates the B-spline basis matrix representing the family of piecewise ##' polynomials with the specified interior knots, degree, and boundary knots, ##' evaluated at the values of \code{x}. ##' ##' This function extends the \code{bs()} function in the \code{splines} package ##' for B-spline basis by allowing piecewise constant (left-closed and ##' right-open except on the right boundary) spline basis of degree zero. ##' ##' @param x The predictor variable. Missing values are allowed and will be ##' returned as they are. ##' @param df Degree of freedom that equals to the column number of the returned ##' matrix. One can specify \code{df} rather than \code{knots}, then the ##' function chooses \code{df - degree - as.integer(intercept)} internal ##' knots at suitable quantiles of \code{x} ignoring missing values and ##' those \code{x} outside of the boundary. If internal knots are specified ##' via \code{knots}, the specified \code{df} will be ignored. ##' @param knots The internal breakpoints that define the splines. The default ##' is \code{NULL}, which results in a basis for ordinary polynomial ##' regression. Typical values are the mean or median for one knot, ##' quantiles for more knots. ##' @param degree A nonnegative integer specifying the degree of the piecewise ##' polynomial. The default value is \code{3} for cubic splines. Zero degree ##' is allowed for piecewise constant basis functions. ##' @param intercept If \code{TRUE}, the complete basis matrix will be returned. ##' Otherwise, the first basis will be excluded from the output. ##' @param Boundary.knots Boundary points at which to anchor the splines. By ##' default, they are the range of \code{x} excluding \code{NA}. If both ##' \code{knots} and \code{Boundary.knots} are supplied, the basis ##' parameters do not depend on \code{x}. Data can extend beyond ##' \code{Boundary.knots}. ##' @param derivs A nonnegative integer specifying the order of derivatives of ##' B-splines. The default value is \code{0L} for B-spline basis functions. ##' @param integral A logical value. If \code{TRUE}, the corresponding ##' integrals of spline basis functions will be returned. The default value ##' is \code{FALSE}. ##' @param ... Optional arguments that are not used. ##' ##' @return A numeric matrix of \code{length(x)} rows and \code{df} columns if ##' \code{df} is specified or \code{length(knots) + degree + ##' as.integer(intercept)} columns if \code{knots} are specified instead. ##' Attributes that correspond to the arguments specified are returned ##' mainly for other functions in this package. ##' ##' @references ##' De Boor, Carl. (1978). \emph{A practical guide to splines}. ##' Vol. 27. New York: Springer-Verlag. ##' ##' @example inst/examples/ex-bSpline.R ##' ##' @seealso ##' \code{\link{dbs}} for derivatives of B-splines; ##' \code{\link{ibs}} for integrals of B-splines; ##' ##' @export bSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, derivs = 0L, integral = FALSE, ...) { ## check inputs if ((derivs <- as.integer(derivs)) < 0) { stop("The 'derivs' must be a nonnegative integer.") } if ((degree <- as.integer(degree)) < 0) stop("The 'degree' must be a nonnegative integer.") if (is.null(df)) { df <- 0L } else { df <- as.integer(df) if (df < 0) { stop("The 'df' must be a nonnegative integer.") } } knots <- null2num0(knots) Boundary.knots <- null2num0(Boundary.knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } ## remove NA's in x xx <- if (nas <- any(nax)) { x[! nax] } else { x } ## call the engine function out <- rcpp_bSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, derivs = derivs, integral = integral, complete_basis = intercept ) ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (any((xx < b_knots[1L]) | (xx > b_knots[2L]))) { warning(wrapMessages( "Some 'x' values beyond boundary knots", "may cause ill-conditioned basis functions." )) } ## keep NA's as is if (nas) { nmat <- matrix(NA_real_, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency with bs returns name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class class(out) <- c("matrix", "bSpline2") ## return out } splines2/R/predict.R0000644000176200001440000001075014121502500013760 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' Evaluate a Spline Basis at specified points ##' ##' This function evaluates a predefined spline basis at a (new) given \code{x}. ##' ##' These are methods for the generic function \code{predict} for objects ##' inheriting from class \code{bSpline2}, \code{ibs}, \code{mSpline}, ##' \code{iSpline}, \code{cSpline}, \code{naturalSpline}, or ##' \code{bernsteinPoly}. If \code{newx} is not given, the function returns the ##' input object. ##' ##' @name predict ##' @param object Objects of class \code{bSpline2}, \code{ibs}, \code{mSpline}, ##' \code{iSpline}, \code{cSpline}, \code{bernsteinPoly} or ##' \code{naturalSpline} with attributes describing \code{knots}, ##' \code{degree}, etc. ##' @param newx The \code{x} values at which evaluations are required. ##' @param ... Optional arguments that are not used. ##' ##' @return ##' An object just like the \code{object} input, except evaluated at ##' the new values of \code{x}. ##' ##' @example inst/examples/ex-predict.R ##' ##' @importFrom stats predict NULL ##' @rdname predict ##' @export predict.bSpline2 <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist check_attr(object, c("x", "degree", "knots", "Boundary.knots", "intercept", "derivs", "integral")) do.call(bSpline, c(list(x = newx), pred_attr(object))) } ##' @rdname predict ##' @export predict.dbs <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist ## checks if key attributes still exist check_attr(object, c("x", "degree", "derivs", "knots", "Boundary.knots", "intercept")) do.call(dbs, c(list(x = newx), pred_attr(object))) } ##' @rdname predict ##' @export predict.ibs <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist check_attr(object, c("x", "degree", "knots", "Boundary.knots", "intercept")) do.call(ibs, c(list(x = newx), pred_attr(object))) } ##' @rdname predict ##' @export predict.mSpline <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist check_attr(object, c("x", "degree", "derivs", "integral", "periodic", "knots", "Boundary.knots", "intercept")) do.call(mSpline, c(list(x = newx), pred_attr(object))) } ##' @rdname predict ##' @export predict.iSpline <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist check_attr(object, c("x", "degree", "derivs", "knots", "Boundary.knots", "intercept")) do.call(iSpline, c(list(x = newx), pred_attr(object))) } ##' @rdname predict ##' @export predict.cSpline <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist check_attr(object, c("x", "degree", "derivs", "scale", "knots", "Boundary.knots", "intercept")) do.call(cSpline, c(list(x = newx), pred_attr(object))) } ##' @rdname predict ##' @export predict.bernsteinPoly <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist check_attr(object, c("x", "degree", "derivs", "integral", "Boundary.knots", "intercept")) do.call(bernsteinPoly, c(list(x = newx), pred_attr(object))) } ##' @rdname predict ##' @export predict.naturalSpline <- function(object, newx, ...) { if (missing(newx)) return(object) ## checks if key attributes still exist check_attr(object, c("x", "derivs", "integral", "knots", "Boundary.knots", "intercept")) do.call(naturalSpline, c(list(x = newx), pred_attr(object))) } splines2/R/splines2-package.R0000644000176200001440000000431414121502500015455 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' splines2: Regression Spline Functions and Classes ##' ##' This package provides functions to construct basis matrices of ##' \itemize{ ##' \item B-splines ##' \item M-splines ##' \item I-splines ##' \item convex splines (C-splines) ##' \item periodic M-splines ##' \item natural cubic splines ##' \item generalized Bernstein polynomials ##' \item along with their integrals (except C-splines) and derivatives ##' of given order by closed-form recursive formulas ##' } ##' ##' In addition to the R interface, it also provides a C++ header-only library ##' integrated with \pkg{Rcpp}, which allows the construction of spline basis ##' functions directly in C++ with the help of \pkg{Rcpp} and ##' \pkg{RcppArmadillo}. Thus, it can also be treated as one of the \pkg{Rcpp*} ##' packages. A toy example package that uses the C++ interface is available at ##' . ##' ##' The package \pkg{splines2} is intended to be a user-friendly supplement to ##' the base package \pkg{splines}. The trailing number two in the package name ##' means "too" (and by no means refers to the generation two). See Wang and ##' Yan (2021) for details and illustrations of how the package can be applied ##' to shape-restricted regression. ##' ##' @references ##' ##' Wang, W., & Yan, J. (2021). Shape-restricted regression splines with R ##' package \pkg{splines2}. \emph{Journal of Data Science}, 19(3), 498--517. ##' ##' @importFrom Rcpp sourceCpp ##' @useDynLib splines2 ##' ##' @docType package ##' @name splines2 NULL splines2/R/bernsteinPoly.R0000644000176200001440000000630114121502500015160 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' Generalized Bernstein Polynomial Basis ##' ##' Returns a generalized Bernstein polynomial basis matrix of given degree over ##' a specified range. ##' ##' @name bernsteinPoly ##' ##' @inheritParams bSpline ##' ##' @param x The predictor variable taking values inside of the specified ##' boundary. Missing values are allowed and will be returned as they are. ##' @param integral A logical value. If \code{TRUE}, the integrals of the ##' Bernstein polynomials will be returned. The default value is ##' \code{FALSE}. ##' @param Boundary.knots Boundary points at which to anchor the Bernstein ##' polynomial basis. The default value is \code{NULL} and the boundary ##' knots is set internally to be \code{range(x, na.rm = TRUE)}. ##' @param degree A nonnegative integer representing the degree of the ##' polynomials. ##' @param derivs A nonnegative integer specifying the order of derivatives. ##' The default value is \code{0L} for Bernstein polynomial basis functions. ##' ##' @return A numeric matrix of dimension \code{length(x)} by \code{degree + ##' as.integer(intercept)}. ##' ##' @example inst/examples/ex-bernsteinPoly.R ##' ##' @export bernsteinPoly <- function(x, degree = 3, intercept = FALSE, Boundary.knots = NULL, derivs = 0L, integral = FALSE, ...) { ## check inputs if ((degree <- as.integer(degree)) < 0) stop("The 'degree' must be a nonnegative integer.") ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } ## remove NA's in x xx <- if (nas <- any(nax)) { x[! nax] } else { x } Boundary.knots <- null2num0(Boundary.knots) ## call the engine function out <- rcpp_bernsteinPoly( x = xx, degree = degree, derivs = derivs, integral = integral, boundary_knots = Boundary.knots, complete_basis = intercept ) ## keep NA's as is if (nas) { nmat <- matrix(NA_real_, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency with bs returns name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class class(out) <- c("matrix", "bernsteinPoly") ## return out } splines2/R/dbs.R0000644000176200001440000000706614121502500013104 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' Derivatives of B-Splines ##' ##' Produces the derivatives of given order of B-splines. ##' ##' This function provides a more user-friendly interface and a more consistent ##' handling for \code{NA}'s than \code{splines::splineDesign()} for derivatives ##' of B-splines. The implementation is based on the closed-form recursion ##' formula. At knots, the derivative is defined to be the right derivative ##' except at the right boundary knot. ##' ##' @inheritParams bSpline ##' ##' @param derivs A positive integer specifying the order of derivative. The ##' default value is \code{1L} for the first derivative. ##' ##' @inherit bSpline return ##' ##' @references ##' De Boor, Carl. (1978). \emph{A practical guide to splines}. ##' Vol. 27. New York: Springer-Verlag. ##' ##' @example inst/examples/ex-dbs.R ##' ##' @seealso ##' \code{\link{bSpline}} for B-splines; ##' \code{\link{ibs}} for integrals of B-splines. ##' ##' @export dbs <- function(x, derivs = 1L, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, ...) { ## check inputs if ((derivs <- as.integer(derivs)) <= 0) { stop("The 'derivs' must be a positive integer.") } if ((degree <- as.integer(degree)) < 0) { stop("The 'degree' must be a nonnegative integer.") } if (is.null(df)) { df <- 0L } else { df <- as.integer(df) if (df < 0) { stop("The 'df' must be a nonnegative integer.") } } knots <- null2num0(knots) Boundary.knots <- null2num0(Boundary.knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } nas <- any(nax) ## remove NA's xx <- if (nas <- any(nax)) { x[! nax] } else { x } ## call the engine function out <- rcpp_bSpline_derivative( x = xx, derivs = derivs, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, complete_basis = intercept ) ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (any((xx < b_knots[1L]) | (xx > b_knots[2L]))) { warning(wrapMessages( "Some 'x' values beyond boundary knots", "may cause ill-conditioned basis functions." )) } ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency with returns from splines::bs name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class class(out) <- c("matrix", "dbs") ## return out } splines2/R/RcppExports.R0000644000176200001440000000460314121502500014617 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 rcpp_bSpline <- function(x, df, degree, internal_knots, boundary_knots, derivs = 0L, integral = FALSE, complete_basis = TRUE) { .Call('_splines2_rcpp_bSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis) } rcpp_bSpline_derivative <- function(x, derivs, df, degree, internal_knots, boundary_knots, complete_basis = TRUE) { .Call('_splines2_rcpp_bSpline_derivative', PACKAGE = 'splines2', x, derivs, df, degree, internal_knots, boundary_knots, complete_basis) } rcpp_bSpline_integral <- function(x, df, degree, internal_knots, boundary_knots, complete_basis = TRUE) { .Call('_splines2_rcpp_bSpline_integral', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, complete_basis) } rcpp_bernsteinPoly <- function(x, degree, derivs, integral, boundary_knots, complete_basis) { .Call('_splines2_rcpp_bernsteinPoly', PACKAGE = 'splines2', x, degree, derivs, integral, boundary_knots, complete_basis) } rcpp_cSpline <- function(x, df, degree, internal_knots, boundary_knots, derivs, complete_basis = TRUE) { .Call('_splines2_rcpp_cSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, derivs, complete_basis) } rcpp_iSpline <- function(x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis = TRUE) { .Call('_splines2_rcpp_iSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis) } rcpp_mSpline <- function(x, df, degree, internal_knots, boundary_knots, derivs = 0L, integral = FALSE, complete_basis = TRUE) { .Call('_splines2_rcpp_mSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis) } rcpp_periodic_mSpline <- function(x, df, degree, internal_knots, boundary_knots, derivs = 0L, integral = FALSE, complete_basis = TRUE) { .Call('_splines2_rcpp_periodic_mSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, derivs, integral, complete_basis) } rcpp_naturalSpline <- function(x, df, internal_knots, boundary_knots, derivs = 0L, integral = FALSE, complete_basis = TRUE) { .Call('_splines2_rcpp_naturalSpline', PACKAGE = 'splines2', x, df, internal_knots, boundary_knots, derivs, integral, complete_basis) } splines2/R/naturalSpline.R0000644000176200001440000001117514121502500015151 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' Natural Cubic Spline Basis for Polynomial Splines ##' ##' Generates the nonnegative natural cubic spline basis matrix, the ##' corresponding integrals (from the left boundary knot), or derivatives of ##' given order. Each basis is assumed to follow a linear trend for \code{x} ##' outside of boundary. ##' ##' It is an implementation of the natural spline basis based on B-spline basis, ##' which utilizes the close-form null space that can be derived from the ##' recursive formula for the second derivatives of B-splines. The constructed ##' spline basis functions are intended to be nonnegative within boundary with ##' second derivatives being zeros at boundary knots. ##' ##' A similar implementation is provided by \code{splines::ns}, which uses QR ##' decomposition to find the null space of the second derivatives of B-spline ##' basis at boundary knots. However, there is no guarantee that the resulting ##' basis functions are nonnegative within boundary. ##' ##' @inheritParams bSpline ##' ##' @param df Degree of freedom that equals to the column number of returned ##' matrix. One can specify \code{df} rather than \code{knots}, then the ##' function chooses \code{df - 1 - as.integer(intercept)} internal knots at ##' suitable quantiles of \code{x} ignoring missing values and those ##' \code{x} outside of the boundary. Thus, \code{df} must be greater than ##' or equal to \code{2}. If internal knots are specified via \code{knots}, ##' the specified \code{df} will be ignored. ##' @param derivs A nonnegative integer specifying the order of derivatives of ##' natural splines. The default value is \code{0L} for the spline basis ##' functions. ##' @param integral A logical value. The default value is \code{FALSE}. If ##' \code{TRUE}, this function will return the integrated natural splines ##' from the left boundary knot. ##' ##' @return A numeric matrix of \code{length(x)} rows and \code{df} ##' columns if \code{df} is specified or \code{length(knots) + 1 + ##' as.integer(intercept)} columns if \code{knots} are specified instead. ##' Attributes that correspond to the arguments specified are returned for ##' usage of other functions in this package. ##' ##' @example inst/examples/ex-naturalSpline.R ##' ##' @seealso ##' \code{\link{bSpline}} for B-splines; ##' \code{\link{mSpline}} for M-splines; ##' \code{\link{iSpline}} for I-splines. ##' ##' @export naturalSpline <- function(x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, derivs = 0L, integral = FALSE, ...) { ## check inputs if ((derivs <- as.integer(derivs)) < 0) { stop("The 'derivs' must be a nonnegative integer.") } if (is.null(df)) { df <- 0L } else { df <- as.integer(df) if (df < 2) { stop("The 'df' must be >= 2.") } } knots <- null2num0(knots) Boundary.knots <- null2num0(Boundary.knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } ## remove NA's in x xx <- if (nas <- any(nax)) { x[! nax] } else { x } ## call the engine function out <- rcpp_naturalSpline( x = xx, df = df, internal_knots = knots, boundary_knots = Boundary.knots, derivs = derivs, integral = integral, complete_basis = intercept ) ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class class(out) <- c("matrix", "naturalSpline") out } splines2/R/misc.R0000644000176200001440000000323014121502500013254 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ### some trivial internal functions ============================================ ## wrap messages and keep proper line length wrapMessages <- function(..., strwrap.args = list()) { x <- paste(...) wrap_x <- do.call(strwrap, c(list(x = x), strwrap.args)) paste(wrap_x, collapse = "\n") } ## convert null to numeric(0) null2num0 <- function(x) { if (is.null(x)) { return(numeric(0)) } x } ## check key attributions check_attr <- function(x, attrs = c("x", "degree", "knots", "Boundary.knots", "intercept")) { idx <- ! attrs %in% names(attributes(x)) if (any(idx)) { stop(wrapMessages( sprintf("Missing attributes: %s.", paste(attrs[idx], collapse = ", ")) ), call. = FALSE) } invisible() } ## return most of the attributes except x and class pred_attr <- function(x, except = c("x", "class", "dimnames")) { out <- attributes(x) out[! names(out) %in% except] } splines2/R/knots.R0000644000176200001440000000404114121502500013460 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' Extract Knots from the Given Object ##' ##' Methods for the generic function \code{knots} from the \pkg{stats} package ##' to obtain internal or boundary knots from the objects produced by this ##' package. ##' ##' @name knots ##' ##' @param Fn An \code{splines2} object produced by this package. ##' @param type A character vector of length one indicating the type of knots to ##' return. The available choices are \code{"internal"} for internal knots ##' and \code{"Boundary"} for boundary knots. ##' @param ... Optional arguments that are not used now. ##' ##' @return A numerical vector. ##' ##' @example inst/examples/ex-knots.R ##' ##' @importFrom stats knots NULL ## the default method knots_ <- function(Fn, type = c("internal", "boundary"), ...) { type <- match.arg(type, choices = c("internal", "boundary")) if (type == "internal") { attr(Fn, "knots") } else { attr(Fn, "Boundary.knots") } } ##' @rdname knots ##' @export knots.bSpline2 <- knots_ ##' @rdname knots ##' @export knots.dbs <- knots_ ##' @rdname knots ##' @export knots.ibs <- knots_ ##' @rdname knots ##' @export knots.mSpline <- knots_ ##' @rdname knots ##' @export knots.iSpline <- knots_ ##' @rdname knots ##' @export knots.cSpline <- knots_ ##' @rdname knots ##' @export knots.bernsteinPoly <- knots_ ##' @rdname knots ##' @export knots.naturalSpline <- knots_ splines2/R/iSpline.R0000644000176200001440000001040514121502500013726 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' I-Spline Basis for Polynomial Splines ##' ##' Generates the I-spline (integral of M-spline) basis matrix for a polynomial ##' spline or the corresponding derivatives of given order. ##' ##' It is an implementation of the closed-form I-spline basis based on the ##' recursion formula given by Ramsay (1988). ##' ##' @inheritParams bSpline ##' ##' @param degree The degree of I-spline defined to be the degree of the ##' associated M-spline instead of actual polynomial degree. For example, ##' I-spline basis of degree 2 is defined as the integral of associated ##' M-spline basis of degree 2. ##' @param intercept If \code{TRUE} by default, all of the spline basis ##' functions are returned. Notice that when using I-Spline for monotonic ##' regression, \code{intercept = TRUE} should be set even when an intercept ##' term is considered additional to the spline basis functions. ##' @param derivs A nonnegative integer specifying the order of derivatives of ##' I-splines. ##' ##' @inherit bSpline return ##' ##' @references ##' Ramsay, J. O. (1988). Monotone regression splines in action. ##' \emph{Statistical Science}, 3(4), 425--441. ##' ##' @example inst/examples/ex-iSpline.R ##' ##' @seealso ##' \code{\link{mSpline}} for M-splines; ##' \code{\link{cSpline}} for C-splines; ##' ##' @export iSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = NULL, derivs = 0L, ...) { ## check inputs if ((derivs <- as.integer(derivs)) < 0) { stop("The 'derivs' must be a nonnegative integer.") } if (derivs > 0) { return(mSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots, derivs = derivs - 1L, ...)) } ## else I-Spline basis if ((degree <- as.integer(degree)) < 0) stop("The 'degree' must be a nonnegative integer.") if (is.null(df)) { df <- 0L } else { df <- as.integer(df) if (df < 0) { stop("The 'df' must be a nonnegative integer.") } } knots <- null2num0(knots) Boundary.knots <- null2num0(Boundary.knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } ## remove NA's in x xx <- if (nas <- any(nax)) { x[! nax] } else { x } ## call the engine function out <- rcpp_iSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, derivs = derivs, integral = FALSE, complete_basis = intercept ) ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (any((xx < b_knots[1L]) | (xx > b_knots[2L]))) { warning(wrapMessages( "Some 'x' values beyond boundary knots", "may cause ill-conditioned basis functions." )) } ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class class(out) <- c("matrix", "iSpline") out } splines2/R/mSpline.R0000644000176200001440000001605214121502500013736 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' M-Spline Basis for Polynomial Splines ##' ##' Generates the basis matrix of regular M-spline, periodic M-spline, and the ##' corresponding integrals and derivatives. ##' ##' This function contains an implementation of the closed-form M-spline basis ##' based on the recursion formula given by Ramsay (1988) or periodic M-spline ##' basis following the procedure producing periodic B-splines given in Piegl ##' and Tiller (1997). For monotone regression, one can use I-splines (see ##' \code{\link{iSpline}}) instead of M-splines. ##' ##' @inheritParams bSpline ##' ##' @param df Degree of freedom that equals to the column number of the returned ##' matrix. One can specify \code{df} rather than \code{knots}. For ##' M-splines, the function chooses \code{df - degree - ##' as.integer(intercept)} internal knots at suitable quantiles of \code{x} ##' ignoring missing values and those \code{x} outside of the boundary. For ##' periodic M-spline (\code{periodic = TRUE}), \code{df - ##' as.integer(intercept)} internal knots will be chosen at suitable ##' quantiles of \code{x} relative to the beginning of the cyclic intervals ##' they belong to (see Examples) and the number of internal knots must be ##' greater or equal to the specified \code{degree - 1}. If internal knots ##' are specified via \code{knots}, the specified \code{df} will be ignored. ##' @param knots The internal breakpoints that define the splines. The default ##' is \code{NULL}, which results in a basis for ordinary polynomial ##' regression. Typical values are the mean or median for one knot, ##' quantiles for more knots. For periodic splines (\code{periodic = ##' TRUE}), the number of knots must be greater or equal to the specified ##' \code{degree - 1}. ##' @param Boundary.knots Boundary points at which to anchor the splines. By ##' default, they are the range of \code{x} excluding \code{NA}. If both ##' \code{knots} and \code{Boundary.knots} are supplied, the basis ##' parameters do not depend on \code{x}. Data can extend beyond ##' \code{Boundary.knots}. For periodic splines (\code{periodic = TRUE}), ##' the specified boundary knots define the cyclic interval. ##' @param periodic A logical value. If \code{TRUE}, the periodic splines will ##' be returned instead of regular M-splines. The default value is ##' \code{FALSE}. ##' @param derivs A nonnegative integer specifying the order of derivatives of ##' M-splines. The default value is \code{0L} for M-spline basis functions. ##' @param integral A logical value. If \code{TRUE}, the corresponding ##' integrals of spline basis functions will be returned. The default value ##' is \code{FALSE}. For periodic splines, the integral of each basis is ##' integrated from the left boundary knot. ##' ##' @return A numeric matrix of \code{length(x)} rows and \code{df} columns if ##' \code{df} is specified. If \code{knots} are specified instead, the ##' output matrix will consist of \code{length(knots) + degree + ##' as.integer(intercept)} columns if \code{periodic = FALSE}, or ##' \code{length(knots) + as.integer(intercept)} columns if \code{periodic = ##' TRUE}. Attributes that correspond to the arguments specified are ##' returned for usage of other functions in this package. ##' ##' @references ##' Ramsay, J. O. (1988). Monotone regression splines in action. ##' \emph{Statistical science}, 3(4), 425--441. ##' ##' Piegl, L., & Tiller, W. (1997). \emph{The NURBS book}. Springer Science \& ##' Business Media. ##' ##' @example inst/examples/ex-mSpline.R ##' ##' @seealso ##' \code{\link{bSpline}} for B-splines; ##' \code{\link{iSpline}} for I-splines; ##' \code{\link{cSpline}} for C-splines. ##' ##' @export mSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, periodic = FALSE, derivs = 0L, integral = FALSE, ...) { ## check inputs if ((derivs <- as.integer(derivs)) < 0) { stop("The 'derivs' must be a nonnegative integer.") } if ((degree <- as.integer(degree)) < 0) stop("The 'degree' must be a nonnegative integer.") if (is.null(df)) { df <- 0L } else { df <- as.integer(df) if (df < 0) { stop("The 'df' must be a nonnegative integer.") } else if (periodic && df < degree) { stop("The 'df' must be >= 'degree' for periodic spline basis.") } } knots <- null2num0(knots) Boundary.knots <- null2num0(Boundary.knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } ## remove NA's in x xx <- if (nas <- any(nax)) { x[! nax] } else { x } ## call the engine function out <- if (periodic) { rcpp_periodic_mSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, derivs = derivs, integral = integral, complete_basis = intercept ) } else { rcpp_mSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, derivs = derivs, integral = integral, complete_basis = intercept ) } ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (! periodic && any((xx < b_knots[1L]) | (xx > b_knots[2L]))) { warning(wrapMessages( "Some 'x' values beyond boundary knots", "may cause ill-conditioned basis functions." )) } ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class class(out) <- c("matrix", "mSpline") out } splines2/R/cSpline.R0000644000176200001440000001313114121502500013717 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2021 ## ## This file is part of the R package splines2. ## ## The R package splines2 is free software: You can redistribute it and/or ## modify it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or any later ## version (at your option). See the GNU General Public License at ## for details. ## ## The R package splines2 is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ## ##' C-Spline Basis for Polynomial Splines ##' ##' Generates the convex regression spline (called C-spline) basis matrix by ##' integrating I-spline basis for a polynomial spline or the corresponding ##' derivatives. ##' ##' It is an implementation of the closed-form C-spline basis derived from the ##' recursion formula of I-splines and M-splines. ##' ##' @inheritParams bSpline ##' ##' @param degree The degree of C-spline defined to be the degree of the ##' associated M-spline instead of actual polynomial degree. For example, ##' C-spline basis of degree 2 is defined as the scaled double integral of ##' associated M-spline basis of degree 2. ##' @param intercept If \code{TRUE} by default, all of the spline basis ##' functions are returned. Notice that when using C-Spline for ##' shape-restricted regression, \code{intercept = TRUE} should be set even ##' when an intercept term is considered additional to the spline basis in ##' the model. ##' @param derivs A nonnegative integer specifying the order of derivatives of ##' C-splines. The default value is \code{0L} for C-spline basis functions. ##' @param scale A logical value indicating if scaling C-splines is required. If ##' \code{TRUE} by default, each C-spline basis is scaled to have unit ##' height at right boundary knot. The corresponding I-spline and M-spline ##' produced by \code{deriv} methods will be scaled to the same extent. ##' ##' @inherit bSpline return ##' ##' @references ##' Meyer, M. C. (2008). Inference using shape-restricted regression splines. ##' \emph{The Annals of Applied Statistics}, 2(3), 1013--1033. ##' ##' @example inst/examples/ex-cSpline.R ##' ##' @seealso ##' \code{\link{iSpline}} for I-splines; ##' \code{\link{mSpline}} for M-splines. ##' ##' @export cSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = NULL, derivs = 0L, scale = TRUE, ...) { ## check inputs if ((derivs <- as.integer(derivs)) < 0) { stop("The 'derivs' must be a nonnegative integer.") } if ((degree <- as.integer(degree)) < 0) stop("The 'degree' must be a nonnegative integer.") if (is.null(df)) { df <- 0L } else { df <- as.integer(df) if (df < 0) { stop("The 'df' must be a nonnegative integer.") } } knots <- null2num0(knots) Boundary.knots <- null2num0(Boundary.knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) { stop("The 'x' cannot be all NA's!") } ## remove NA's in x xx <- if (nas <- any(nax)) { x[! nax] } else { x } out <- if (scale) { rcpp_cSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, derivs = derivs, complete_basis = intercept ) } else { if (derivs == 0) { rcpp_iSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, derivs = 0, integral = TRUE, complete_basis = intercept ) } else { rcpp_iSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, derivs = derivs - 1, integral = FALSE, complete_basis = intercept ) } } ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (any((xx < b_knots[1L]) | (xx > b_knots[2L]))) { warning(wrapMessages( "Some 'x' values beyond boundary knots", "may cause ill-conditioned basis functions." )) } ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), ncol(out)) nmat[! nax, ] <- out saved_attr <- attributes(out) saved_attr$dim[1] <- length(nax) out <- nmat attributes(out) <- saved_attr attr(out, "x") <- x } ## add dimnames for consistency name_x <- names(x) if (! is.null(name_x)) { row.names(out) <- name_x } ## add class if (scale || derivs == 0) { ## add "scale" to attributes for predict(), etc. attr(out, "scale") <- scale class(out) <- c("matrix", "cSpline") } else if (derivs == 1) { class(out) <- c("matrix", "iSpline") } else { class(out) <- c("matrix", "mSpline") } ## return out } splines2/NEWS.md0000644000176200001440000001356214121502457013117 0ustar liggesusers# splines2 0.4.5 ## Minor changes * Improved the computational efficiency of finding the knot intervals for `x` (by replacing the naive binary search implementation with `std::upper_bound` and `std::distance`). # splines2 0.4.4 ## New features * Added the `makepredictcall()` methods for all available spline basis functions to help `model.frame.default()` create the right matrices when predicting from models with terms such as `bSpline()`, etc. Thanks Zheyuan Li for suggesting this feature. * Added arguments `derivs` and `integal` to `bSpline()` for consistency with `mSpline()` and `bernsteinPoly()`, etc. ## Minor changes * Made the internal checking procedure more strict to throw an error if any internal knots are placed at or outside boundary: [issue 5](https://github.com/wenjie2wang/splines2/issues/5). ## Bug fixes * Fixed the `predict()` method for `cSpline` objects when `scale = FALSE`. # splines2 0.4.3 ## New features * Enabled extended knot sequence that allows multiplicity of internal knots for B-splines, M-splines, I-splines, and C-splines in the C++ interface. * Added type conversion to `BernsteinPoly` and `PeriodicMSpline` objects to the C++ interface. ## Minor changes * Added testing examples for constructing spline basis functions via the C++ interface. # splines2 0.4.2 ## New features * Added `knots()` methods to extract internal knots and boundary knots from a given *splines2* object. ## Major changes * Updated the generation of the knot sequence for periodic M-splines following Piegl and Tiller (1997), which relaxed the previous requirement that `length(knots) >= degree` to `length(knots) >= degree - 1`. # splines2 0.4.1 ## New features * Added function `naturalSpline()` providing implementation of nonnegative natural cubic splines. * Added argument `periodic` to function `mSpline()` for periodic M-splines. * Added argument `integral` to function `mSpline()` for integrals of M-splines or periodic M-splines. * Added `deriv()`, `predict()`, and `print()` method for `naturalSpline` class object. ## Minor changes * Updated the `deriv()` method for `mSpline` class object for periodic M-splines. # splines2 0.3.1 ## Minor changes * Modified testing examples for CRAN tests on r-patched-solaris-x86 and r-oldrel-macos-x86_64. # splines2 0.3.0 ## New features * Added function `bernsteinPoly()` providing implementation of generalized Bernstein polynomials. * Added C++ interface that can be easily integrated with **Rcpp**. ## Major changes * Changed most implementations from R to C++ with help of **Rcpp** and **RcppArmadillo** to boost the performance. ## Minor changes * Made piece-wise constant basis functions continuous at right boundary knot for consistency with spline basis matrix of non-zero degrees. * Changed the default value of argument `intercept` in function `iSpline()` and `cSpline()` to `TRUE` for a complete set of spline basis functions in shape-restricted regression. * Removed the corresponding M-spline basis from attributes of outputs from `iSpline()` and `cSpline()`. * Removed the corresponding B-spline basis from attributes of outputs from `bSpline()`. ## Bug fixes * Fixed `deriv.mSpline()` method for third derivatives of scaled C-splines. # splines2 0.2.8 ## Bug fixes * Fixed inconsistency of argument `df` for piecewise constant basis functions when `knots = NULL`. ## Minor changes * Rewrote testing suite for using the **tinytest** package instead of **testthat**. # splines2 0.2.7 ## Minor changes * Updated tests for R development version. # splines2 0.2.6 ## Minor changes * Added checks for any internal knot incorrectly placed outside of the boundary knots and added warnings for users' reference. # splines2 0.2.5 ## Minor changes * Added more tests and increased code coverage. ## Bug fixes * Fixed evaluation of derivatives of M-splines for a single value. Thanks Ina Jazic for reporting the bug and providing possible fix. * Fixed `deriv.cSpline()` method for derivatives of order greater than two when `scale = TRUE`. # splines2 0.2.4 ## New features * Added function `dbs()` generating derivative of given order of B-splines. It is a similar function with `splines::splineDesign()`. However, it provides a more user-friendly interface and more consistent handling on `NA`'s. * Added `deriv()` methods for derivatives of given order of any existing **splines2** object that can be generated currently. ## Major changes * Added argument `derivs` to function `mSpline()` and `iSpline()` for derivatives. * Changed all the classes of object generated for a better dispatching on methods. ## Minor changes * Added tests for all major functions with the help of package **testthat**. ## Bug fixes * Fixed the generation of splines without any internal knot. # splines2 0.2.3 ## Bug fixes * Fixed one-piece constant basis for M-splines. # splines2 0.2.2 ## Bug fixes * Fixed the NA's handling in all the functions constructing spline basis matrix. # splines2 0.2.1 ## New features * Added function `bSpline()` generating B-spline basis allowing zero degree or piecewise constant basis based on function `bs()` in the **splines** package. * Introduced function `bSpline()` to allow M-splines of degree zero. * Added function `cSpline()` constructing convex spline (C-spline) basis. * Added `predict()` methods for `bSpline2` object and `cSpline` object generated by `bSpline()` and `cSpline()`, respectively. * Added `print()` methods for all **splines2** objects developed so far. ## Major changes * Improved the function `iSpline()` to construct I-spline basis directly from B-spline basis instead of M-spline basis. ## Minor changes * Updated all CRAN URL to a canonical form suggested. # splines2 0.1.0 ## New features * The first version of **splines2** providing functions constructing M-spline, I-spline, and integral of B-spline basis. splines2/MD50000644000176200001440000001360214121634402012320 0ustar liggesusers23da1a0f8ecf2d904b3b0c0aaead2bce *DESCRIPTION 4de64c1f0536cc05e1804e61e8cdaff2 *NAMESPACE 323f3254f137051cd9cd0a1cc7ed9521 *NEWS.md 0c3829ddcc5e15aeec8c4ab41f9d3950 *R/RcppExports.R 00a709d64a62fbf3c18e3d607af9ab03 *R/bSpline.R e9479ce0494f18945541f7740b87525c *R/bernsteinPoly.R db5cc1a27267c1dcf933aba85bc8940f *R/cSpline.R 604ae66569e605e59e426c83901562e3 *R/dbs.R 9fdbe46affeff5091927ac5e0f91777e *R/deriv.R bd667c68bc1f3cd0b78b839474858ff9 *R/iSpline.R b3bb67ae67fc865ff02375cb9c8142f1 *R/ibs.R 0c2ad798060686c7a879f1229e3499e2 *R/knots.R 139c6ab6c72b46e12219000a738ceda4 *R/mSpline.R 527ad06ab241b43f126fd0cb02a5079c *R/makepredictcall.R 4c64452fa70160bc80a93714170991b3 *R/misc.R 48c39ccced33df260ce18f2d06cf7715 *R/naturalSpline.R 7ab77716fbdfc98320a74a29bed71e86 *R/predict.R 22ffe0d50b2a76789b95f877b5627585 *R/print.R 89cae8747a2b0f509053408934d958a7 *R/splines2-package.R b11f482831738af05b467253541e832f *README.md 662462e3047d312e74d26acc11c6702c *build/vignette.rds 7ff313fb86924f963b10fc0730c0ee46 *inst/CITATION d0a1c887b7609a0659c758bb71a1fe36 *inst/bib/splines2.bib bc52adac5ba6b64ad7c892492e155647 *inst/doc/splines2-intro.R d144e53b1611e41b112a2aa2f2fabcb9 *inst/doc/splines2-intro.Rmd 21145ec09425b72f811f775214af7027 *inst/doc/splines2-intro.html 4913d389464b55b882b160bc45f13a88 *inst/doc/splines2-wi-rcpp.Rmd 4d76ba4f502751ba9bf0eb1f06405f12 *inst/doc/splines2-wi-rcpp.html e57d0a2781194d86719d22ffe6e88124 *inst/examples/ex-bSpline.R 9f344e6d2f57dd64b9e1a6dc6e5c5235 *inst/examples/ex-bernsteinPoly.R 9a374f9d8254d31c506e696babfe94fe *inst/examples/ex-cSpline.R b8d851ba050bcf9cd641b79f7a5c5ba9 *inst/examples/ex-dbs.R e4a8667814d05d10e8f5508676df2edc *inst/examples/ex-deriv.R e023440443e94bc5e574d3d38a493648 *inst/examples/ex-iSpline.R b8d083460a6374112f071b9b1713a40a *inst/examples/ex-ibs.R 91679c2c786e7fa71d6962f9c56b84ea *inst/examples/ex-knots.R 377edac57884e9c78f33a5472af1642c *inst/examples/ex-mSpline.R 2bed6b8ea5264c0b9ff0245b1a490674 *inst/examples/ex-naturalSpline.R 6f663f2ce0e2e2e07c69751abf51f7fb *inst/examples/ex-predict.R 0d066ffa6e54b6baf21517dc4a93a3b0 *inst/include/splines2Armadillo.h eb2c55602c673bfad591eee34cef3c0e *inst/include/splines2Armadillo/BSpline.h acf0ac4244cb2ab173736ab53ad4e564 *inst/include/splines2Armadillo/BernsteinPoly.h 7f18292622c71c4c095d370f4dfb8ce1 *inst/include/splines2Armadillo/CSpline.h 23af6dd83e4aca771a97cf4fe2145155 *inst/include/splines2Armadillo/ISpline.h 8c5c2cee31bd6217ad5708e45731f369 *inst/include/splines2Armadillo/MSpline.h fff90b5761f2891109a1466b800cebec *inst/include/splines2Armadillo/NaturalSpline.h 2aa9f4cee8c76723bc3b6ffe7cab2d77 *inst/include/splines2Armadillo/PeriodicMSpline.h 5510e7e0403a323104ddf1aa86aa52ef *inst/include/splines2Armadillo/SplineBase.h 660f4aaf0c20bbb9f66a2c4fbda273de *inst/include/splines2Armadillo/common.h 5af11efc571186a0c2b3fa4b6bfeea9d *inst/include/splines2Armadillo/utils.h 1ec75158f73fe49661ec54f7f539dc5c *inst/rcpp-tests/test-BSpline.R 2796e6e43e4f3b69d29332430161c9df *inst/rcpp-tests/test-BSpline.cpp 323382b3972c45bc54f642532e97d755 *inst/rcpp-tests/test-BernsteinPoly.R 0f57ed72e0c2abae970732382c7a4443 *inst/rcpp-tests/test-BernsteinPoly.cpp cf2db89afab808b68bc49f1b496ee804 *inst/rcpp-tests/test-CSpline.R f5c5d2a7abe2e43bdd21159ae0e7175d *inst/rcpp-tests/test-CSpline.cpp 60f4aea0bf65601102d08f52fae3e0ac *inst/rcpp-tests/test-ISpline.R 0f8173d993d0f59a4c04ebef8dbc963b *inst/rcpp-tests/test-ISpline.cpp d1f8c264097d138c4335ed2b4723f697 *inst/rcpp-tests/test-MSpline.R dc6b47e857741e462b8ea228d44c0e22 *inst/rcpp-tests/test-MSpline.cpp b377f59175fb4ba6f094ca6d8bc5610c *inst/rcpp-tests/test-NaturalSpline.R ab7d6bea3edbe4bf2580448b6ac10b7e *inst/rcpp-tests/test-NaturalSpline.cpp f4931ec5f2d6f803cee2758133642e93 *inst/rcpp-tests/test-PeriodicMSpline.R 749401a8c36f3ca3040095aacd144c36 *inst/rcpp-tests/test-PeriodicMSpline.cpp d87155e1516cfa4330cf9940dd7091f0 *inst/tinytest/test-bSpline.R b7e76ebd85143146cefff28bedbc6430 *inst/tinytest/test-bernsteinPoly.R c8e29a29bbec55781ad9dbe208b72c5c *inst/tinytest/test-cSpline.R ae8421bc8d9c604987daeec067f76a53 *inst/tinytest/test-dbs.R 5b1911315475ebfac35ff8d6a2282972 *inst/tinytest/test-deriv.R abee10ab363128f760ae31467bf6c245 *inst/tinytest/test-iSpline.R 92c343cb01fe03e613a3aea015740340 *inst/tinytest/test-ibs.R a94d69e80f513c1643b5f38caf394f08 *inst/tinytest/test-knots.R 47d02977c5e334aa7be8ded14797f2b0 *inst/tinytest/test-mSpline.R 874ae0b4923f9aa5b6f14bea8298236b *inst/tinytest/test-makepredictcall.R 51e51faa1e572e9b48196b1d489b7e4a *inst/tinytest/test-naturalSpline.R f2899667d62ee66db754352bb9b51ab5 *inst/tinytest/test-predict.R 1158260f290e4d803a6ecccb67b0528b *inst/tinytest/test-print.R 012f00f4a21841b8f30237bc559ad3e4 *inst/v0.2.8.R b4a3c2d9b123c24316abc40deb6cc7f4 *man/bSpline.Rd 7d1cd874bb7c61bd77beab05b4ccbfff *man/bernsteinPoly.Rd 5b73c109227bb6b5ed3806ee5afd9a1c *man/cSpline.Rd 9bc39ddfea727f9de0ed653d794c3a0f *man/dbs.Rd 249dd8b4dfadc71c982c2ae3597a0a0f *man/deriv.Rd ef120b815e52416ef8b485ee7511f023 *man/iSpline.Rd 7126de9bf4d6f2c226ba4bd8dce2da24 *man/ibs.Rd 59117ab3600d6fe6b30dd9e065ab8302 *man/knots.Rd 2d0bdbeca81e17aff28eb8a516ccae4f *man/mSpline.Rd 2bd92fd0f33add633c329b3c26d96f8f *man/naturalSpline.Rd 681ddebe35cccf9779fa1d68ded84d1a *man/predict.Rd 12c2b8fe534c622383e6c886953a3380 *man/splines2.Rd ecb5acd1ecb79f084a4406fb7c286441 *src/BSpline_export.cpp b4b225ad31737e09f450860919a0bd04 *src/BernsteinPoly_export.cpp 21ba5312def1876f232c05e7951542ad *src/CSpline_export.cpp 3fa7eb0cd1420702efd726a8b4b5a1d6 *src/ISpline_export.cpp b2dc01181cf2413350b6be29188bc4b0 *src/MSpline_export.cpp 5d1c5d951ea1184e0c58685f65abaa3a *src/Makevars 291180567fdb5e69a1e3e8d671df0540 *src/Makevars.win 1a9fd50b4c2f4d5c1080a6a15f3018ed *src/NaturalSpline_export.cpp bb4fab91a60a6a0213fe57500ad26e00 *src/RcppExports.cpp 455534917cd808306d07b7b863b6e24c *tests/tinytest.R d144e53b1611e41b112a2aa2f2fabcb9 *vignettes/splines2-intro.Rmd 4913d389464b55b882b160bc45f13a88 *vignettes/splines2-wi-rcpp.Rmd splines2/inst/0000755000176200001440000000000014121502506012762 5ustar liggesuserssplines2/inst/examples/0000755000176200001440000000000014030134441014576 5ustar liggesuserssplines2/inst/examples/ex-predict.R0000644000176200001440000000117213677517626017020 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.2) knots <- c(0.3, 0.5, 0.6) newX <- seq.int(0.1, 0.9, 0.2) ## for B-splines bsMat <- bSpline(x, knots = knots, degree = 2) predict(bsMat, newX) ## for integral of B-splines ibsMat <- ibs(x, knots = knots, degree = 2) predict(ibsMat, newX) ## for derivative of B-splines dbsMat <- dbs(x, knots = knots, degree = 2) predict(dbsMat, newX) ## for M-spline msMat <- mSpline(x, knots = knots, degree = 2) predict(msMat, newX) ## for I-spline isMat <- iSpline(x, knots = knots, degree = 2) predict(isMat, newX) ## for C-spline csMat <- cSpline(x, knots = knots, degree = 2) predict(csMat, newX) splines2/inst/examples/ex-dbs.R0000644000176200001440000000076113677517626016141 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.2, 0.4, 0.7) ## the second derivative of cubic B-splines with three internal knots dMat <- dbs(x, derivs = 2L, knots = knots, intercept = TRUE) ## compare with the results from splineDesign ord <- attr(dMat, "degree") + 1L bKnots <- attr(dMat, "Boundary.knots") aKnots <- c(rep(bKnots[1L], ord), knots, rep(bKnots[2L], ord)) res <- splines::splineDesign(aKnots, x = x, derivs = 2L) stopifnot(all.equal(res, dMat, check.attributes = FALSE)) splines2/inst/examples/ex-naturalSpline.R0000644000176200001440000000167013767731223020201 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## natural spline basis nsMat0 <- naturalSpline(x, knots = knots, intercept = TRUE) ## integrals nsMat1 <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) ## first derivatives nsMat2 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) ## second derivatives nsMat3 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 2) op <- par(mfrow = c(2, 2), mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, nsMat0, type = "l", ylab = "basis") matplot(x, nsMat1, type = "l", ylab = "integral") matplot(x, nsMat2, type = "l", ylab = "1st derivative") matplot(x, nsMat3, type = "l", ylab = "2nd derivative") par(op) # reset to previous plotting settings ## use the deriv method all.equal(nsMat0, deriv(nsMat1), check.attributes = FALSE) all.equal(nsMat2, deriv(nsMat0)) all.equal(nsMat3, deriv(nsMat2)) all.equal(nsMat3, deriv(nsMat0, 2)) splines2/inst/examples/ex-bernsteinPoly.R0000644000176200001440000000257413766423270020220 0ustar liggesuserslibrary(splines2) x1 <- seq.int(0, 1, 0.01) x2 <- seq.int(- 2, 2, 0.01) ## Bernstein polynomial basis matrix over [0, 1] bMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE) ## generalized Bernstein polynomials basis over [- 2, 2] bMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE) op <- par(mfrow = c(1, 2), mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x1, bMat1, type = "l", ylab = "y") matplot(x2, bMat2, type = "l", ylab = "y") ## the first and second derivative matrix d1Mat1 <- bernsteinPoly(x1, degree = 4, derivs = 1, intercept = TRUE) d2Mat1 <- bernsteinPoly(x1, degree = 4, derivs = 2, intercept = TRUE) d1Mat2 <- bernsteinPoly(x2, degree = 4, derivs = 1, intercept = TRUE) d2Mat2 <- bernsteinPoly(x2, degree = 4, derivs = 2, intercept = TRUE) par(mfrow = c(2, 2)) matplot(x1, d1Mat1, type = "l", ylab = "y") matplot(x2, d1Mat2, type = "l", ylab = "y") matplot(x1, d2Mat1, type = "l", ylab = "y") matplot(x2, d2Mat2, type = "l", ylab = "y") ## reset to previous plotting settings par(op) ## or use the deriv method all.equal(d1Mat1, deriv(bMat1)) all.equal(d2Mat1, deriv(bMat1, 2)) ## the integrals iMat1 <- bernsteinPoly(x1, degree = 4, integral = TRUE, intercept = TRUE) iMat2 <- bernsteinPoly(x2, degree = 4, integral = TRUE, intercept = TRUE) all.equal(deriv(iMat1), bMat1, check.attributes = FALSE) all.equal(deriv(iMat2), bMat2, check.attributes = FALSE) splines2/inst/examples/ex-knots.R0000644000176200001440000000053214013353001016465 0ustar liggesuserslibrary(splines2) set.seed(123) x <- rnorm(100) ## B-spline basis bsMat <- bSpline(x, df = 8, degree = 3) ## extract internal knots placed based on the quantile of x (internal_knots <- knots(bsMat)) ## extract boundary knots placed based on the range of x boundary_knots <- knots(bsMat, type = "boundary") all.equal(boundary_knots, range(x)) splines2/inst/examples/ex-deriv.R0000644000176200001440000000253614030134441016452 0ustar liggesuserslibrary(splines2) x <- c(seq.int(0, 1, 0.1), NA) # NA's will be kept. knots <- c(0.3, 0.5, 0.6) ## helper function stopifnot_equivalent <- function(...) { stopifnot(all.equal(..., check.attributes = FALSE)) } ## integal of B-splines and the corresponding B-splines integrated ibsMat <- ibs(x, knots = knots) bsMat <- bSpline(x, knots = knots) ## the first derivative d1Mat <- deriv(ibsMat) stopifnot_equivalent(bsMat, d1Mat) ## the second derivative d2Mat1 <- deriv(bsMat) d2Mat2 <- deriv(ibsMat, derivs = 2L) stopifnot_equivalent(d2Mat1, d2Mat2) ## nested calls are supported d2Mat3 <- deriv(deriv(ibsMat)) stopifnot_equivalent(d2Mat2, d2Mat3) ## C-splines, I-splines, M-splines and the derivatives csMat <- cSpline(x, knots = knots, intercept = TRUE, scale = FALSE) isMat <- iSpline(x, knots = knots, intercept = TRUE) stopifnot_equivalent(isMat, deriv(csMat)) msMat <- mSpline(x, knots = knots, intercept = TRUE) stopifnot_equivalent(msMat, deriv(isMat)) stopifnot_equivalent(msMat, deriv(csMat, 2)) stopifnot_equivalent(msMat, deriv(deriv(csMat))) dmsMat <- mSpline(x, knots = knots, intercept = TRUE, derivs = 1) stopifnot_equivalent(dmsMat, deriv(msMat)) stopifnot_equivalent(dmsMat, deriv(isMat, 2)) stopifnot_equivalent(dmsMat, deriv(deriv(isMat))) stopifnot_equivalent(dmsMat, deriv(csMat, 3)) stopifnot_equivalent(dmsMat, deriv(deriv(deriv(csMat)))) splines2/inst/examples/ex-iSpline.R0000644000176200001440000000112013767720106016747 0ustar liggesuserslibrary(splines2) ## Example given in the reference paper by Ramsay (1988) x <- seq.int(0, 1, by = 0.01) knots <- c(0.3, 0.5, 0.6) isMat <- iSpline(x, knots = knots, degree = 2) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, isMat, type = "l", ylab = "I-spline basis") abline(v = knots, lty = 2, col = "gray") ## reset to previous plotting settings par(op) ## the derivative of I-splines is M-spline msMat1 <- iSpline(x, knots = knots, degree = 2, derivs = 1) msMat2 <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) stopifnot(all.equal(msMat1, msMat2)) splines2/inst/examples/ex-cSpline.R0000644000176200001440000000203213766423475016754 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ### when 'scale = TRUE' (by default) csMat <- cSpline(x, knots = knots, degree = 2) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, csMat, type = "l", ylab = "C-spline basis") abline(v = knots, lty = 2, col = "gray") isMat <- deriv(csMat) msMat <- deriv(csMat, derivs = 2) matplot(x, isMat, type = "l", ylab = "scaled I-spline basis") matplot(x, msMat, type = "l", ylab = "scaled M-spline basis") ## reset to previous plotting settings par(op) ### when 'scale = FALSE' csMat <- cSpline(x, knots = knots, degree = 2, scale = FALSE) ## the corresponding I-splines and M-splines (with same arguments) isMat <- iSpline(x, knots = knots, degree = 2) msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) ## or using deriv methods (more efficient) isMat1 <- deriv(csMat) msMat1 <- deriv(csMat, derivs = 2) ## equivalent stopifnot(all.equal(isMat, isMat1, check.attributes = FALSE)) stopifnot(all.equal(msMat, msMat1, check.attributes = FALSE)) splines2/inst/examples/ex-ibs.R0000644000176200001440000000130014014343543016111 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.2, 0.4, 0.7, 0.9) ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) ## get the corresponding B-splines by bSpline() bsMat0 <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) ## or by the deriv() method bsMat <- deriv(ibsMat) stopifnot(all.equal(bsMat0, bsMat, check.attributes = FALSE)) ## plot B-spline basis with their corresponding integrals op <- par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "B-spline basis") abline(v = knots, lty = 2, col = "gray") matplot(x, ibsMat, type = "l", ylab = "Integral of B-spline basis") abline(v = knots, lty = 2, col = "gray") ## reset to previous plotting settings par(op) splines2/inst/examples/ex-mSpline.R0000644000176200001440000000513514076105344016760 0ustar liggesuserslibrary(splines2) ### example given in the reference paper by Ramsay (1988) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, msMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ## derivatives of M-splines dmsMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE, derivs = 1) ## or using the deriv method dmsMat1 <- deriv(msMat) stopifnot(all.equal(dmsMat, dmsMat1, check.attributes = FALSE)) ### periodic M-splines x <- seq.int(0, 3, 0.01) bknots <- c(0, 1) pMat <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = bknots, periodic = TRUE) ## integrals iMat <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = bknots, periodic = TRUE, integral = TRUE) ## first derivatives by "derivs = 1" dMat1 <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = bknots, periodic = TRUE, derivs = 1) ## first derivatives by using the deriv() method dMat2 <- deriv(pMat) par(mfrow = c(2, 2)) matplot(x, pMat, type = "l", ylab = "Periodic Basis") abline(v = seq.int(0, max(x)), lty = 2, col = "grey") matplot(x, iMat, type = "l", ylab = "Integrals from 0") abline(v = seq.int(0, max(x)), h = seq.int(0, max(x)), lty = 2, col = "grey") matplot(x, dMat1, type = "l", ylab = "1st derivatives by 'derivs=1'") abline(v = seq.int(0, max(x)), lty = 2, col = "grey") matplot(x, dMat2, type = "l", ylab = "1st derivatives by 'deriv()'") abline(v = seq.int(0, max(x)), lty = 2, col = "grey") ## reset to previous plotting settings par(op) ### default placement of internal knots for periodic splines default_knots <- function(x, df, intercept = FALSE, Boundary.knots = range(x, na.rm = TRUE)) { ## get x in the cyclic interval [0, 1) x2 <- (x - Boundary.knots[1]) %% (Boundary.knots[2] - Boundary.knots[1]) knots <- quantile(x2, probs = seq(0, 1, length.out = df + 2 - intercept)) unname(knots[- c(1, length(knots))]) } df <- 8 degree <- 3 intercept <- TRUE internal_knots <- default_knots(x, df, intercept) ## 1. specify df spline_basis1 = splines2::mSpline(x, degree = degree, df = df, periodic = TRUE, intercept = intercept) ## 2. specify knots spline_basis2 = splines2::mSpline(x, degree = degree, knots = internal_knots, periodic = TRUE, intercept = intercept) all.equal(internal_knots, knots(spline_basis1)) all.equal(spline_basis1, spline_basis2) splines2/inst/examples/ex-bSpline.R0000644000176200001440000000101114014343374016731 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## cubic B-splines bsMat <- bSpline(x, knots = knots, degree = 3, intercept = TRUE) op <- par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) matplot(x, bsMat, type = "l", ylab = "Cubic B-splines") abline(v = knots, lty = 2, col = "gray") ## reset to previous plotting settings par(op) ## the first derivaitves d1Mat <- deriv(bsMat) ## the second derivaitves d2Mat <- deriv(bsMat, 2) ## evaluate at new values predict(bsMat, c(0.125, 0.801)) splines2/inst/v0.2.8.R0000644000176200001440000012616613700155063013760 0ustar liggesusers##' B-Spline Basis for Polynomial Splines ##' ##' This function generates the B-spline basis matrix for a polynomial spline. ##' ##' It is an augmented function of \code{\link[splines]{bs}} in package ##' \code{splines} for B-spline basis that allows piecewise constant (close on ##' the left, open on the right) spline basis with zero degree. When the ##' argument \code{degree} is greater than zero, it internally calls ##' \code{\link[splines]{bs}} and generates a basis matrix for representing the ##' family of piecewise polynomials with the specified interior knots and ##' degree, evaluated at the values of \code{x}. The function has the same ##' arguments with \code{\link[splines]{bs}} for ease usage. ##' ##' @usage ##' bSpline(x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, ##' Boundary.knots = range(x, na.rm = TRUE), ...) ##' ##' @param x The predictor variable. Missing values are allowed and will be ##' returned as they were. ##' @param df Degrees of freedom. One can specify \code{df} rather than ##' \code{knots}, then the function chooses "df - degree" (minus one if ##' there is an intercept) knots at suitable quantiles of \code{x} (which ##' will ignore missing values). The default, \code{NULL}, corresponds to ##' no inner knots, i.e., "degree - intercept". If \code{knots} was ##' specified, \code{df} specified will be ignored. ##' @param knots The internal breakpoints that define the spline. The default ##' is \code{NULL}, which results in a basis for ordinary polynomial ##' regression. Typical values are the mean or median for one knot, ##' quantiles for more knots. See also \code{Boundary.knots}. ##' @param degree Non-negative integer degree of the piecewise polynomial. The ##' default value is 3 for cubic splines. Zero degree is allowed for this ##' function, which is the only difference compared with ##' \code{\link[splines]{bs}} in package \code{splines}. ##' @param intercept If \code{TRUE}, an intercept is included in the basis; ##' Default is \code{FALSE}. ##' @param Boundary.knots Boundary points at which to anchor the B-spline basis. ##' By default, they are the range of the non-\code{NA} data. If both ##' \code{knots} and \code{Boundary.knots} are supplied, the basis ##' parameters do not depend on \code{x}. Data can extend beyond ##' \code{Boundary.knots}. ##' @param ... Optional arguments for future usage. ##' ##' @return A matrix of dimension \code{length(x)} by ##' \code{df = degree + length(knots)} (plus one if intercept is included). ##' Attributes that correspond to the arguments specified are returned ##' for usage of other functions in this package. ##' @examples ##' library(splines2) ##' x <- seq.int(0, 1, 0.01) ##' knots <- c(0.3, 0.5, 0.6) ##' bsMat <- bSpline(x, knots = knots, degree = 0, intercept = TRUE) ##' ##' library(graphics) ##' matplot(x, bsMat, type = "l", ylab = "Piecewise constant B-spline bases") ##' abline(v = knots, lty = 2, col = "gray") ##' @seealso ##' \code{\link{predict.bSpline2}} for evaluation at given (new) values; ##' \code{\link{dbs}}, \code{\link{deriv.bSpline2}} for derivatives; ##' \code{\link{ibs}} for integral of B-splines; ##' \code{\link{mSpline}} for M-splines; ##' \code{\link{iSpline}} for I-splines; ##' \code{\link{cSpline}} for C-splines. ##' @importFrom splines bs ##' @importFrom stats stepfun ##' @export bSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = range(x, na.rm = TRUE), ...) { ## check and reformat 'degree' if ((degree <- as.integer(degree)) < 0) stop("'degree' must be a nonnegative integer.") ## sort and remove possible NA's in internal knots if exist if (length(knots)) knots <- sort.int(knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) stop("The 'x' cannot be all NA's!") ## call splines::bs for non-zero degree if (degree > 0) { out <- splines::bs(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots) ## add "x" to attributes attr(out, "x") <- x ## throw out warning if any internal knot outside boundary.knots knots <- attr(out, "knots") Boundary.knots <- attr(out, "Boundary.knots") ## any internal knots placed outside of boundary knots? outside_knots <- (knots <= Boundary.knots[1L]) | (knots >= Boundary.knots[2L]) if (any(outside_knots)) warning(wrapMessages( "Some internal knots were not placed", "inside of boundary knots,", "which may cause \nill-conditioned bases!" )) ## update classes class(out) <- c("matrix", "bSpline2") return(out) } ## else degree is zero ## remove NA's in x xx <- if (nas <- any(nax)) x[! nax] else x ## check whether any of x is outside of the boundary knots outside_x <- rep(FALSE, length(xx)) if (! missing(Boundary.knots)) { if (! is.numeric(Boundary.knots) || anyNA(Boundary.knots)) stop(wrapMessages( "The 'Boundary.knots' has to be", "numeric vector of length 2", "with no missing value." )) if (length(Boundary.knots) > 2) { warning(wrapMessages( "Only the first two values", "in the 'Boundary.knots' were used." )) Boundary.knots <- Boundary.knots[seq_len(2L)] } Boundary.knots <- sort.int(Boundary.knots) outside_x <- (xx < Boundary.knots[1L]) | (xx > Boundary.knots[2L]) } if (any(outside_x)) warning(wrapMessages( "Some 'x' values beyond boundary knots", "may cause ill-conditioned bases!" )) ## prepare inputs for piecewise constant bases inputs <- pieceConst(x = xx[! outside_x], df = df, knots = knots, Boundary.knots = Boundary.knots, intercept = intercept) knots <- inputs$knots ## potentially, df is a bad name since df is also a function in stats df <- inputs$df ## piecewise constant basis augKnots <- c(Boundary.knots[1L], knots, Boundary.knots[2L] + 10 * .Machine$double.eps) bsMat <- sapply(seq_len(df), function (i) { foo <- stats::stepfun(augKnots[i: (i + 1L)], c(0L, 1L, 0L)) foo(xx) }) ## close on the right boundary knot for the last constant piece? ## if (any(rightX <- xx == Boundary.knots[2L])) ## bsMat[rightX, df] <- 1 ## make sure bsMat is a matrix if (! is.matrix(bsMat)) bsMat <- matrix(bsMat, nrow = length(xx)) ## include intercept or not if (! intercept) { bsMat <- bsMat[, - 1L, drop = FALSE] } ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), ncol(bsMat)) nmat[! nax, ] <- bsMat bsMat <- nmat } ## add dimnames for consistency with bs returns row.names(bsMat) <- names(x) colnames(bsMat) <- as.character(seq_len(df - as.integer(! intercept))) ## on attributes tmp <- list(degree = degree, knots = if (is.null(knots)) numeric(0L) else knots, Boundary.knots = Boundary.knots, intercept = intercept, x = x) attributes(bsMat) <- c(attributes(bsMat), tmp) class(bsMat) <- c("matrix", "bSpline2") bsMat } ### internal function ========================================================== ##' @importFrom stats quantile pieceConst <- function (x, df, knots, Boundary.knots, intercept) { ind <- (is.null(df) + 1L) * is.null(knots) + 1L ## ind == 1: knots is not NULL; ## df0 = df = length(knots) + 1L ## ind == 2: df is not NULL, while knots is NULL; ## df := function input ## number of knots = df - as.integer(intercept) from `splines::bs` ## df0 := DF of spline bases from splines definition ## = length(knots) + 1L ## = df - as.integer(intercept) + 1L ## ind == 3: both df and knots are NULL; one-piece constant ## number of knots = 0, df0 = 1 int_intercept <- as.integer(intercept) df0 <- switch(ind, length(knots) + 1L, { int_df <- as.integer(df) if (int_df < 1L) stop("The spepcified `df` must be positive!", call. = FALSE) int_df - int_intercept + 1L }, { if (! intercept) stop(wrapMessages( "The 'intercept' has to be 'TRUE'", "for one-piece const basis." ), call. = FALSE) 1L }) if (ind > 1L) { tknots <- df0 + 1L quans <- seq.int(from = 0, to = 1, length.out = tknots)[- c(1L, tknots)] knots <- as.numeric(stats::quantile(x, quans)) } else { ## any internal knots placed outside of boundary knots? outside_knots <- (knots <= Boundary.knots[1L]) | (knots >= Boundary.knots[2L]) ## remove internal knots placed outside of boundary knots if (any(outside_knots)) { knots <- knots[! outside_knots] df0 <- df0 - sum(outside_knots) warning(wrapMessages( "Only internal knots placed inside of", "the boundary knots were considered." ), call. = FALSE) } if (! is.null(df) && df != df0) warning(wrapMessages( "The 'df' specified was not appropriate.", sprintf("Used 'df = %d' instead.", df0) ), call. = FALSE) } list(df = df0, knots = knots) } ##' C-Spline Basis for Polynomial Splines ##' ##' This function generates the convex regression spline (called C-spline) basis ##' matrix by integrating I-spline basis for a polynomial spline. ##' ##' It is an implementation of the close form C-spline basis derived from ##' the recursion formula of I-spline and M-spline. Internally, it calls ##' \code{\link{iSpline}} and generates a basis matrix for representing the ##' family of piecewise polynomials and their corresponding integrals with the ##' specified interior knots and degree, evaluated at the values of \code{x}. ##' ##' @usage ##' cSpline(x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, ##' Boundary.knots = range(x, na.rm = TRUE), scale = TRUE, ...) ##' ##' @param x The predictor variable. Missing values are allowed and will be ##' returned as they were. ##' @param df Degrees of freedom. One can specify \code{df} rather than ##' \code{knots}, then the function chooses "df - degree" (minus one if ##' there is an intercept) knots at suitable quantiles of \code{x} (which ##' will ignore missing values). The default, \code{NULL}, corresponds to ##' no inner knots, i.e., "degree - intercept". ##' @param knots The internal breakpoints that define the spline. The default ##' is \code{NULL}, which results in a basis for ordinary polynomial ##' regression. Typical values are the mean or median for one knot, ##' quantiles for more knots. See also \code{Boundary.knots}. ##' @param degree Non-negative integer degree of the piecewise polynomial. The ##' default value is 3 for cubic splines. ##' @param intercept If \code{TRUE} by default, all spline bases are included. ##' Notice that when using C-Spline for shape-restricted regression, ##' \code{intercept = TRUE} should be set even when an intercept term is ##' considered additional to the spline bases in the model. ##' @param Boundary.knots Boundary points at which to anchor the C-spline basis. ##' By default, they are the range of the non-\code{NA} data. If both ##' \code{knots} and \code{Boundary.knots} are supplied, the basis ##' parameters do not depend on \code{x}. Data can extend beyond ##' \code{Boundary.knots}. ##' @param scale Logical value (\code{TRUE} by default) indicating whether ##' scaling on C-spline basis is required. If TRUE, C-spline basis is scaled ##' to have unit height at right boundary knot; the corresponding I-spline ##' and M-spline basis matrices shipped in attributes are also scaled to the ##' same extent. ##' @param ... Optional arguments for future usage. ##' ##' @return A matrix of dimension \code{length(x)} by ##' \code{df = degree + length(knots)} (plus on if intercept is included). ##' The attributes that correspond to the arguments specified are returned ##' for the usage of other functions in this package. ##' @references ##' Meyer, M. C. (2008). Inference using shape-restricted regression splines. ##' \emph{The Annals of Applied Statistics}, 1013--1033. Chicago ##' @examples ##' library(splines2) ##' x <- seq.int(0, 1, 0.01) ##' knots <- c(0.3, 0.5, 0.6) ##' ##' ### when 'scale = TRUE' (by default) ##' csMat <- cSpline(x, knots = knots, degree = 2) ##' ##' library(graphics) ##' matplot(x, csMat, type = "l", ylab = "C-spline basis") ##' abline(v = knots, lty = 2, col = "gray") ##' isMat <- deriv(csMat) ##' msMat <- deriv(csMat, derivs = 2) ##' matplot(x, isMat, type = "l", ylab = "scaled I-spline basis") ##' matplot(x, msMat, type = "l", ylab = "scaled M-spline basis") ##' ##' ### when 'scale = FALSE' ##' csMat <- cSpline(x, knots = knots, degree = 2, scale = FALSE) ##' ## the corresponding I-splines and M-splines (with same arguments) ##' isMat <- iSpline(x, knots = knots, degree = 2) ##' msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) ##' ## or using deriv methods (more efficient) ##' isMat1 <- deriv(csMat) ##' msMat1 <- deriv(csMat, derivs = 2) ##' ## equivalent ##' stopifnot(all.equal(isMat, isMat1, check.attributes = FALSE)) ##' stopifnot(all.equal(msMat, msMat1, check.attributes = FALSE)) ##' @seealso ##' \code{\link{predict.cSpline}} for evaluation at given (new) values; ##' \code{\link{deriv.cSpline}} for derivatives; ##' \code{\link{iSpline}} for I-splines; ##' \code{\link{mSpline}} for M-splines. ##' @importFrom stats stepfun ##' @export cSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = range(x, na.rm = TRUE), scale = TRUE, ...) { ## I-spline basis for inputs isOut <- iSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots) ## update input degree <- attr(isOut, "degree") knots <- attr(isOut, "knots") bKnots <- attr(isOut, "Boundary.knots") ord <- 1L + degree nKnots <- length(knots) df <- nKnots + ord ## take care of possible NA's in `x` for the following calculation nax <- is.na(x) if ((nas <- any(nax))) x <- x[! nax] nX <- length(x) ## define knot sequence aKnots <- sort(c(rep(bKnots, ord + 1L), knots)) ## generate I-spline basis with (degree + 1) augX <- c(x, bKnots[2L]) isOut1 <- iSpline(x = augX, knots = knots, degree = ord, intercept = FALSE, Boundary.knots = bKnots) ## function determining j from x j <- if (length(knots)) { foo <- stats::stepfun(x = knots, y = seq.int(ord, df)) as.integer(foo(augX)) } else { rep.int(ord, nX + 1L) } numer1 <- diff(aKnots, lag = ord + 1L)[- 1L] ## if there is at least one internal knot if (nKnots) { ## calculate C-spline basis at each internal knot t_j isOutKnots <- iSpline(knots, knots = knots, degree = ord, intercept = FALSE, Boundary.knots = bKnots) matKnots <- rep(numer1, each = nKnots) * isOutKnots / (ord + 1) augKnots <- seq_len(nKnots) + ord diffKnots <- diff(knots) csKnots <- lapply(seq_len(nKnots), function(i, idx) { ji <- augKnots[i] a <- matKnots[i, ] js <- seq_len(ji) a[- js] <- 0 a[js] <- rev(cumsum(rev(a[js]))) a[idx < ji - ord] <- diffKnots[ji - ord - 1L] a }, idx = seq_len(df)) csKnots <- do.call(rbind, csKnots) idxMat <- lower.tri(csKnots, diag = TRUE) linList <- lapply(seq_len(nKnots), function(ind) { cumsum(csKnots[idxMat[, ind], ind]) }) csKnots[idxMat] <- do.call(c, linList) } else { csKnots <- matrix(0, 1L, df) } ## calculate C-spline basis at each x matX <- rep(numer1, each = nX + 1) * isOut1 / (ord + 1) csOut <- lapply(seq_len(nX + 1L), function(i, idx) { ji <- j[i] xx <- augX[i] a <- matX[i, ] js <- seq_len(ji) a[- js] <- 0 a[js] <- rev(cumsum(rev(a[js]))) a[idx < ji - ord] <- xx - knots[ji - ord] + csKnots[ji - ord, idx < ji - ord] a }, idx = seq_len(df)) csOut <- do.call(rbind, csOut) if (! intercept) csOut <- csOut[, - 1L, drop = FALSE] scl <- unname(csOut[nX + 1L, ]) csOut <- csOut[- (nX + 1L), ] ## mSpline basis matrix msMat <- attr(isOut, "msMat") ## keep NA's as is for csOut if (nas) { nmat <- matrix(NA, length(nax), ncol(csOut)) nmat[! nax, ] <- csOut csOut <- nmat } ## scale C-spline, I-spline, and M-spline basis if (scale) { vec <- rep(1 / scl, each = length(nax)) csOut <- vec * csOut isOut <- vec * isOut msMat <- vec * msMat attr(isOut, "scale") <- attr(msMat, "scale") <- scale attr(isOut, "scales") <- attr(msMat, "scales") <- scl } ## output attr(isOut, "msMat") <- NULL attributes(csOut) <- c(attributes(isOut), list(isMat = isOut, msMat = msMat, scale = scale, scales = scl)) attr(csOut, "derivs") <- NULL class(csOut) <- c("matrix", "cSpline") csOut } ##' Derivative of B-Spline Basis for Polynomial Splines ##' ##' This function produces the derivative of given order of B-splines. It is an ##' implementation of the close form derivative of B-spline basis based on ##' recursion relation. At knots, the derivative is defined to be the right ##' derivative. ##' ##' The function is similar with \code{\link[splines]{splineDesign}}. However, ##' it provides a more user-friendly interface, a more considerate \code{NA}'s ##' handling. Internally, it calls \code{\link{bSpline}} and generates a basis ##' matrix for representing the family of piecewise polynomials and their ##' corresponding derivative with the specified interior knots and degree, ##' evaluated at the values of \code{x}. The function \code{splineDesign} in ##' \code{splines} package can also be used to calculate derivative of ##' B-splines. ##' ##' @usage ##' dbs(x, derivs = 1L, df = NULL, knots = NULL, degree = 3L, ##' intercept = FALSE, Boundary.knots = range(x, na.rm = TRUE), ...) ##' ##' @param x The predictor variable. Missing values are allowed and will be ##' kept and returned as they were. ##' @param derivs A positive integer specifying the order of derivative. By ##' default, it is \code{1L} for the first derivative. ##' @param df Degrees of freedom of the B-spline basis to be differentiated. ##' One can specify \code{df} rather than \code{knots}, then the function ##' chooses "df - degree" (minus one if there is an intercept) knots at ##' suitable quantiles of \code{x} (which will ignore missing values). The ##' default, \code{NULL}, corresponds to no inner knots, i.e., ##' "degree - intercept". ##' @param knots The internal breakpoints that define the B-spline basis to be ##' differentiated. The default is \code{NULL}, which results in a basis ##' for ordinary polynomial regression. Typical values are the mean or ##' median for one knot, quantiles for more knots. See also ##' \code{Boundary.knots}. ##' @param degree Non-negative integer degree of the piecewise polynomial to be ##' differentiated. The default value is 3 for the integral of cubic ##' B-splines. ##' @param intercept If \code{TRUE}, an intercept is included in the basis; ##' Default is \code{FALSE}. ##' @param Boundary.knots Boundary points at which to anchor the B-spline basis ##' to be differentiated. By default, they are the range of the ##' non-\code{NA} data. If both \code{knots} and \code{Boundary.knots} are ##' supplied, the basis parameters do not depend on \code{x}. ##' @param ... Optional arguments for future usage. ##' ##' @return A matrix of dimension \code{length(x)} by ##' \code{df = degree + length(knots)} (plus on if intercept is included). ##' Attributes that correspond to the arguments specified are returned ##' for usage of other functions in this package. ##' @references ##' De Boor, Carl. (1978). \emph{A practical guide to splines}. ##' Vol. 27. New York: Springer-Verlag. ##' @examples ##' library(splines2) ##' x <- seq.int(0, 1, 0.01) ##' knots <- c(0.2, 0.4, 0.7) ##' ## the second derivative of cubic B-splines with three internal knots ##' dMat <- dbs(x, derivs = 2L, knots = knots, intercept = TRUE) ##' ##' ## compare with the results from splineDesign ##' ord <- attr(dMat, "degree") + 1L ##' bKnots <- attr(dMat, "Boundary.knots") ##' aKnots <- c(rep(bKnots[1L], ord), knots, rep(bKnots[2L], ord)) ##' res <- splines::splineDesign(aKnots, x = x, derivs = 2L) ##' stopifnot(all.equal(res, dMat, check.attributes = FALSE)) ##' @seealso ##' \code{\link{predict.dbs}} for evaluation at given (new) values; ##' \code{\link{deriv.dbs}} for derivative method; ##' \code{\link{bSpline}} for B-splines; ##' \code{\link{ibs}} for integral of B-splines. ##' @importFrom stats quantile ##' @export dbs <- function(x, derivs = 1L, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = range(x, na.rm = TRUE), ...) { ## check order of derivative derivs <- as.integer(derivs) if (derivs < 1L) stop("'derivs' has to be a positive integer.") ## check and reformat 'degree' if ((degree <- as.integer(degree)) < 0) stop("'degree' must be a nonnegative integer.") ## sort and remove possible NA's in internal knots if exist if (length(knots)) knots <- sort.int(knots) ## take care of possible NA's in `x` nax <- is.na(x) if (all(nax)) stop("'x' cannot be all NA's!") nas <- any(nax) ## remove NA's xx <- if (nas) x[! nax] else x ## check Boundary.knots specified by users outside <- rep(FALSE, length(xx)) if (! missing(Boundary.knots)) { Boundary.knots <- sort(Boundary.knots[seq_len(2)]) outside <- (xx < Boundary.knots[1L]) | (xx > Boundary.knots[2L]) } ## determine knots from df if missing inter <- as.integer(intercept) if (! is.null(df)) { df0 <- length(knots) + degree + inter if (tmp <- (df < df0)) warning(sprintf("'df' was too small; have used %d", df0)) df <- ifelse(tmp, df0, df) nKnots <- df - degree - inter if (is.null(knots) && nKnots > 0) { quans <- seq.int(from = 0, to = 1, length.out = nKnots + 2L)[- c(1L, nKnots + 2L)] knots <- stats::quantile(xx[! outside], quans) } } ## update degree of freedom from inputs df0 <- length(knots) + degree + 1L df <- df0 - 1L + inter ## attribute knots for output knotsAttr <- if (is.null(knots)) numeric(0L) else knots ## for derivs > degree if (derivs > degree) { ## df == 0, i.e., no basis returned if (! df) warning("Degree of freedom is zero.") dMat <- matrix(0, nrow = length(x), ncol = df) if (nas) dMat[nax, ] <- NA tmp <- list(degree = degree, knots = knotsAttr, Boundary.knots = Boundary.knots, intercept = intercept, x = x, derivs = derivs) attributes(dMat) <- c(attributes(dMat), tmp) class(dMat) <- c("matrix", "dbs") return(dMat) } ## B-spline bases dMat <- bSpline(xx, knots = knots, degree = degree - derivs, intercept = TRUE, Boundary.knots = Boundary.knots, ...) ## derivative matrix for (iter in seq_len(derivs)) { ## define knot sequence according to the bases being differentiated ord <- degree - derivs + iter + 1L aKnots <- sort(c(rep(Boundary.knots, ord), knots)) denom <- diff(aKnots, lag = ord - 1L) facVec <- ifelse(denom > 0, (ord - 1L) / denom, 0) dMat0 <- cbind(0, dMat, 0) dMat <- sapply(seq_len(df0 - derivs + iter), function(a) { idx <- a : (a + 1L) tmpMat <- dMat0[, idx, drop = FALSE] facVec[idx[1L]] * tmpMat[, 1L, drop = FALSE] - facVec[idx[2L]] * tmpMat[, 2L, drop = FALSE] }) ## recover dimension after sapply if (! is.matrix(dMat)) dMat <- matrix(dMat, nrow = 1L) } ## take care of intercept if (! intercept) dMat <- dMat[, - 1L, drop = FALSE] ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), df) nmat[! nax, ] <- dMat dMat <- nmat } ## add dimnames for consistency with returns from splines::bs row.names(dMat) <- names(x) colnames(dMat) <- as.character(seq_len(df)) ## on attributes tmp <- list(degree = degree, knots = knotsAttr, Boundary.knots = Boundary.knots, intercept = intercept, x = x, derivs = derivs) attributes(dMat) <- c(attributes(dMat), tmp) class(dMat) <- c("matrix", "dbs") ## return dMat } ##' Integral of B-Spline Basis for Polynomial Splines ##' ##' This function generates the integral of B-spline basis matrix ##' for a polynomial spline. The arguments are exactly the same with function ##' \code{\link[splines]{bs}} in package \code{splines}. ##' ##' It is an implementation of the close form integral of B-spline basis based ##' on recursion relation. Internally, it calls \code{\link{bSpline}} and ##' generates a basis matrix for representing the family of piecewise ##' polynomials and their corresponding integrals with the specified interior ##' knots and degree, evaluated at the values of \code{x}. ##' ##' @usage ##' ibs(x, df = NULL, knots = NULL, degree = 3, intercept = FALSE, ##' Boundary.knots = range(x, na.rm = TRUE), ...) ##' ##' @param x The predictor variable. Missing values are allowed and will be ##' returned as they were. ##' @param df Degrees of freedom of the B-spline basis to be integrated. One ##' can specify \code{df} rather than \code{knots}, then the function ##' chooses "df - degree" (minus one if there is an intercept) knots at ##' suitable quantiles of \code{x} (which will ignore missing values). The ##' default, \code{NULL}, corresponds to no inner knots, i.e., ##' "degree - intercept". ##' @param knots The internal breakpoints that define the B-spline basis to be ##' integrated. The default is \code{NULL}, which results in a basis for ##' ordinary polynomial regression. Typical values are the mean or median ##' for one knot, quantiles for more knots. See also \code{Boundary.knots}. ##' @param degree Non-negative integer degree of the piecewise polynomial to be ##' integrated. The default value is 3 for the integral of cubic B-splines. ##' @param intercept If \code{TRUE}, an intercept is included in the basis; ##' Default is \code{FALSE}. ##' @param Boundary.knots Boundary points at which to anchor the B-spline basis ##' to be integrated. By default, they are the range of the non-\code{NA} ##' data. If both \code{knots} and \code{Boundary.knots} are supplied, the ##' basis parameters do not depend on \code{x}. Data can extend beyond ##' \code{Boundary.knots}. ##' @param ... Optional arguments for future usage. ##' ##' @return A matrix of dimension \code{length(x)} by ##' \code{df = degree + length(knots)} (plus on if intercept is included). ##' Attributes that correspond to the arguments specified are returned ##' for usage of other functions in this package. ##' @references ##' De Boor, Carl. (1978). \emph{A practical guide to splines}. ##' Vol. 27. New York: Springer-Verlag. ##' @examples ##' library(splines2) ##' x <- seq.int(0, 1, 0.01) ##' knots <- c(0.2, 0.4, 0.7, 0.9) ##' ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) ##' ##' ## the B-spline bases integrated by function bSpline (same arguments) ##' bsMat0 <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) ##' ## or by function deriv (recommended) that directly extracts the existing ##' ## result from the attribute of ibsMat and thus is much more efficient. ##' bsMat <- deriv(ibsMat) ##' stopifnot(all.equal(bsMat0, bsMat, check.attributes = FALSE)) # equivalent ##' ##' ## plot B-spline basis with their corresponding integrals ##' library(graphics) ##' par(mfrow = c(1, 2)) ##' matplot(x, bsMat, type = "l", ylab = "B-spline basis") ##' abline(v = knots, lty = 2, col = "gray") ##' matplot(x, ibsMat, type = "l", ylab = "Integral of B-spline basis") ##' abline(v = knots, lty = 2, col = "gray") ##' par(mfrow = c(1, 1)) ##' @seealso ##' \code{\link{predict.ibs}} for evaluation at given (new) values; ##' \code{\link{deriv.ibs}} for derivative method. ##' \code{\link{bSpline}} for B-splines; ##' \code{\link{dbs}} for derivatives of B-splines; ##' @export ibs <- function(x, df = NULL, knots = NULL, degree = 3, intercept = FALSE, Boundary.knots = range(x, na.rm = TRUE), ...) { ## B-spline basis for inputs bsOut <- bSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots) ## update input degree <- attr(bsOut, "degree") knots <- attr(bsOut, "knots") bKnots <- attr(bsOut, "Boundary.knots") ord <- 1L + degree ## define knot sequence aKnots <- sort(c(rep(bKnots, ord), knots)) ## generate B-spline basis with (degree + 1) bsOut1 <- bSpline(x = x, knots = knots, degree = ord, intercept = FALSE, Boundary.knots = bKnots) numer1 <- diff(aKnots, lag = ord) if (! intercept) { bsOut1 <- bsOut1[, - 1L, drop = FALSE] numer1 <- numer1[- 1L] } numer2 <- apply(bsOut1, 1, function(a) rev(cumsum(rev(a)))) ibsOut <- t(numer1 * numer2) / ord ## output attributes(ibsOut) <- c(attributes(bsOut), list(bsMat = bsOut, x = x)) class(ibsOut) <- c("matrix", "ibs") ibsOut } ##' I-Spline Basis for Polynomial Splines or its derivatives ##' ##' This function generates the I-spline (integral of M-spline) basis matrix for ##' a polynomial spline or its derivatives of given order.. ##' ##' It is an implementation of the close form I-spline basis based on the ##' recursion formula of B-spline basis. Internally, it calls ##' \code{\link{mSpline}} and \code{\link{bSpline}}, and generates a basis ##' matrix for representing the family of piecewise polynomials and their ##' corresponding integrals with the specified interior knots and degree, ##' evaluated at the values of \code{x}. ##' ##' @usage ##' iSpline(x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, ##' Boundary.knots = range(x, na.rm = TRUE), derivs = 0L, ...) ##' ##' @param x The predictor variable. Missing values are allowed and will be ##' returned as they were. ##' @param df Degrees of freedom. One can specify \code{df} rather than ##' \code{knots}, then the function chooses "df - degree" (minus one if ##' there is an intercept) knots at suitable quantiles of \code{x} (which ##' will ignore missing values). The default, \code{NULL}, corresponds to ##' no inner knots, i.e., "degree - intercept". ##' @param knots The internal breakpoints that define the spline. The default ##' is \code{NULL}, which results in a basis for ordinary polynomial ##' regression. Typical values are the mean or median for one knot, ##' quantiles for more knots. See also \code{Boundary.knots}. ##' @param degree Non-negative integer degree of the piecewise polynomial. The ##' default value is 3 for cubic splines. Note that the degree of I-spline ##' is defined to be the degree of the associated M-spline instead of actual ##' polynomial degree. In other words, I-spline basis of degree 2 is defined ##' as the integral of associated M-spline basis of degree 2. ##' @param intercept If \code{TRUE} by default, all spline bases are included. ##' Notice that when using I-Spline for monotonic regression, ##' \code{intercept = TRUE} should be set even when an intercept term is ##' considered additional to the spline bases in the model. ##' @param Boundary.knots Boundary points at which to anchor the I-spline basis. ##' By default, they are the range of the non-\code{NA} data. If both ##' \code{knots} and \code{Boundary.knots} are supplied, the basis ##' parameters do not depend on \code{x}. Data can extend beyond ##' \code{Boundary.knots}. ##' @param derivs A non-negative integer specifying the order of derivatives of ##' I-splines. ##' @param ... Optional arguments for future usage. ##' ##' @return A matrix of dimension \code{length(x)} by ##' \code{df = degree + length(knots)} (plus on if intercept is included). ##' Attributes that correspond to the arguments specified are returned ##' for usage of other functions in this package. ##' @references ##' Ramsay, J. O. (1988). Monotone regression splines in action. ##' \emph{Statistical science}, 3(4), 425--441. ##' @examples ##' ## Example given in the reference paper by Ramsay (1988) ##' library(splines2) ##' x <- seq.int(0, 1, by = 0.01) ##' knots <- c(0.3, 0.5, 0.6) ##' isMat <- iSpline(x, knots = knots, degree = 2) ##' ##' library(graphics) ##' matplot(x, isMat, type = "l", ylab = "I-spline basis") ##' abline(v = knots, lty = 2, col = "gray") ##' ##' ## the derivative of I-splines is M-spline ##' msMat1 <- iSpline(x, knots = knots, degree = 2, derivs = 1) ##' msMat2 <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) ##' stopifnot(all.equal(msMat1, msMat2)) ##' @seealso ##' \code{\link{predict.iSpline}} for evaluation at given (new) values; ##' \code{\link{deriv.iSpline}} for derivative method; ##' \code{\link{mSpline}} for M-splines; ##' \code{\link{cSpline}} for C-splines; ##' @importFrom stats stepfun ##' @export iSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = range(x, na.rm = TRUE), derivs = 0L, ...) { ## check order of derivative if (! missing(derivs)) { derivs <- as.integer(derivs) if (derivs < 0L) stop("'derivs' has to be a non-negative integer.") } ## M-spline basis for outputs in attributes msOut <- mSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots, derivs = 0L, ...) ## update input degree <- attr(msOut, "degree") knots <- attr(msOut, "knots") bKnots <- attr(msOut, "Boundary.knots") ord <- 1L + degree nKnots <- length(knots) df <- nKnots + ord ## default, for derivs == 0L, return I-splines if (! derivs) { ## define knot sequence ## aKnots <- sort(c(rep(bKnots, ord + 1L), knots)) ## take care of possible NA's in `x` for the following calculation nax <- is.na(x) if (nas <- any(nax)) x <- x[! nax] ## function determining j from x j <- if (nKnots) { foo <- stats::stepfun(x = knots, y = seq.int(ord, df)) as.integer(foo(x)) } else { rep.int(ord, length(x)) } ## calculate I-spline basis at non-NA x's ## directly based on B-spline bsOut1 <- bSpline(x = x, knots = knots, degree = ord, intercept = FALSE, Boundary.knots = bKnots) isOut <- lapply(seq_along(j), function(i, idx) { a <- bsOut1[i, ] js <- seq_len(j[i]) a[- js] <- 0 a[js] <- rev(cumsum(rev(a[js]))) a[idx < j[i] - ord] <- 1 # <=> a[idx < j[i] - degree] <- 1 a }, idx = seq_len(df)) isOut <- do.call(rbind, isOut) ## Or based on M-spline ## generate M-spline basis with (degree + 1) ## msOut1 <- mSpline(x = x, knots = knots, degree = ord, ## intercept = FALSE, Boundary.knots = bKnots) ## df <- length(knots) + ord ## numer1 <- diff(aKnots, lag = ord + 1)[- 1L] ## msMat <- rep(numer1, each = length(x)) * msOut1 / (ord + 1) ## msAugMat <- cbind(j, msMat) ## isOut <- t(apply(msAugMat, 1, function(b, idx = seq_len(df)) { ## j <- b[1L] ## a <- b[- 1L] ## js <- seq_len(j) ## a[- js] <- 0 ## a[js] <- rev(cumsum(rev(a[js]))) ## a[idx < j - ord] <- 1 # <=> a[idx < j - degree] <- 1 ## a ## })) ## intercept if (! intercept) isOut <- isOut[, - 1L, drop = FALSE] ## keep NA's as is if (nas) { nmat <- matrix(NA, length(nax), ncol(isOut)) nmat[! nax, ] <- isOut isOut <- nmat } } else { ## for derivatives >= 1L out <- mSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots, derivs = derivs - 1L, ...) return(out) } ## output attributes(isOut) <- c(attributes(msOut), list(msMat = msOut)) class(isOut) <- c("matrix", "iSpline") isOut } ### some trivial internal functions ============================================ ## wrap messages and keep proper line length wrapMessages <- function(..., strwrap.args = list()) { x <- paste(...) wrap_x <- do.call(strwrap, c(list(x = x), strwrap.args)) paste(wrap_x, collapse = "\n") } ## is x a numeric matrix (optionally of nRow rows and nCol columns) isNumMatrix <- function(x, nRow = NULL, nCol = NULL, ...) { out <- is.numeric(x) && is.matrix(x) if (out) { nDim <- dim(x) if (! is.null(nRow)) out <- out && nDim[1L] == nRow if (! is.null(nCol)) out <- out && nDim[2L] == nCol } out } ##' M-Spline Basis for Polynomial Splines and its Derivatives ##' ##' This function generates the basis matrix of the regression spline called ##' M-spline or its derivatives of given order. For monotone regression, ##' \code{\link{iSpline}} should be used. ##' ##' It is an implementation of the close form M-spline basis based on ##' relationship between M-spline basis and B-spline basis. In fact, M-spline ##' basis is a rescaled version of B-spline basis. Internally, it calls function ##' \code{\link{bSpline}} and generates a basis matrix for representing the ##' family of piecewise polynomials with the specified interior knots and ##' degree, evaluated at the values of \code{x}. ##' ##' @usage ##' mSpline(x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, ##' Boundary.knots = range(x, na.rm = TRUE), derivs = 0L, ...) ##' ##' @param x The predictor variable. Missing values are allowed and will be ##' returned as they were. ##' @param df Degrees of freedom. One can specify \code{df} rather than ##' \code{knots}, then the function chooses "df - degree" (minus one if ##' there is an intercept) knots at suitable quantiles of \code{x} (which ##' will ignore missing values). The default, \code{NULL}, corresponds to ##' no inner knots, i.e., "degree - intercept". ##' @param knots The internal breakpoints that define the spline. The default ##' is \code{NULL}, which results in a basis for ordinary polynomial ##' regression. Typical values are the mean or median for one knot, ##' quantiles for more knots. See also \code{Boundary.knots}. ##' @param degree Non-negative integer degree of the piecewise polynomial. The ##' default value is 3 for cubic splines. Zero degree is allowed for ##' piecewise constant basis. ##' @param intercept If \code{TRUE}, all bases will be returned. The default ##' value is \code{FALSE}. ##' @param Boundary.knots Boundary points at which to anchor the M-spline basis. ##' By default, they are the range of the non-\code{NA} data. If both ##' \code{knots} and \code{Boundary.knots} are supplied, the basis ##' parameters do not depend on \code{x}. Data can extend beyond ##' \code{Boundary.knots}. ##' @param derivs A non-negative integer specifying the order of derivatives of ##' M-splines. The default value is \code{0L} for M-spline bases. ##' @param ... Optional arguments for future usage. ##' ##' @return A matrix of dimension \code{length(x)} by ##' \code{df = degree + length(knots)} (plus one if intercept is included). ##' Attributes that correspond to the arguments specified are returned ##' for usage of other functions in this package. ##' @references ##' Ramsay, J. O. (1988). Monotone regression splines in action. ##' \emph{Statistical science}, 3(4), 425--441. ##' @examples ##' ## Example given in the reference paper by Ramsay (1988) ##' library(splines2) ##' x <- seq.int(0, 1, 0.01) ##' knots <- c(0.3, 0.5, 0.6) ##' msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) ##' ##' library(graphics) ##' matplot(x, msMat, type = "l", ylab = "M-spline basis") ##' abline(v = knots, lty = 2, col = "gray") ##' ##' ## derivatives of M-splines ##' dmsMat <- mSpline(x, knots = knots, degree = 2, ##' intercept = TRUE, derivs = 1) ##' ## or using the 'deriv' method ##' dmsMat1 <- deriv(msMat) ##' stopifnot(all.equal(dmsMat, dmsMat1, check.attributes = FALSE)) ##' @seealso ##' \code{\link{predict.mSpline}} for evaluation at given (new) values; ##' \code{\link{deriv.mSpline}} for derivative method; ##' \code{\link{bSpline}} for B-splines; ##' \code{\link{iSpline}} for I-splines; ##' \code{\link{cSpline}} for C-splines. ##' @export mSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = range(x, na.rm = TRUE), derivs = 0L, ...) { ## check order of derivative if (! missing(derivs)) { derivs <- as.integer(derivs) if (derivs < 0L) stop("'derivs' has to be a non-negative integer.") } bsOut <- if (derivs) { dbs(x = x, derivs = derivs, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots, ...) } else { bSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots, ...) } ## update input ord <- attr(bsOut, "degree") + 1L knots <- attr(bsOut, "knots") bKnots <- attr(bsOut, "Boundary.knots") ## define knot sequence aKnots <- sort(c(rep(bKnots, ord), knots)) ## transformation from B-splines to M-splines denom <- diff(aKnots, lag = ord) transCoef <- ifelse(denom > 0, ord / denom, 0) if (! intercept) transCoef <- transCoef[- 1L] msOut <- rep(transCoef, each = length(x)) * bsOut attr(msOut, "derivs") <- derivs class(msOut) <- c("matrix", "mSpline") msOut } splines2/inst/doc/0000755000176200001440000000000014121502506013527 5ustar liggesuserssplines2/inst/doc/splines2-wi-rcpp.html0000644000176200001440000011304414121502506017536 0ustar liggesusers Using splines2 with Rcpp

Using splines2 with Rcpp

Wenjie Wang

2021-09-18

In this package vignette, we introduce how to use the C++ header-only library that splines2 contains with the Rcpp package (Eddelbuettel 2013) for constructing spline basis functions. The introduction is intended for package developers who would like to use splines2 package at C++ level by adding splines2 to the LinkingTo field of package DESCRIPTION file.

Header File and Name Space

Different with the procedure-based functions in the R interface, the C++ interface follows the commonly-used object-oriented design in C++ for ease of usage and maintenance. The implementations use the Armadillo (Sanderson 2016) library with help of RcppArmadillo (Eddelbuettel and Sanderson 2014) and require C++11. We assume that is enabled for compilation henceforth. We may include the header file named splines2Armadillo.h to get the access to all the classes and implementations in the name space splines2.

#include <RcppArmadillo.h>
// include header file from splines2 package
#include <splines2Armadillo.h>
// [[Rcpp::plugins(cpp11)]]

To use Rcpp::sourceCpp(), one may need to add [[Rcpp::depends()]] as follows:

// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::depends(splines2)]]

For ease of demonstration, we assume the following using-directives:

using namespace arma
using namespace splines2

Generalized Bernstein Polynomials

The BernsteinPoly class is implemented for the generalized Bernstein polynomials.

Constructors

The main non-default constructor is as follows:

BernsteinPoly(const vec& x,
              const unsigned int degree,
              const vec& boundary_knots = vec());

In addition, two explicit constructors are provided for BernsteinPoly* and SplineBase*, which set x, degree, and boundary_knots from the objects that the pointers point to.

Function Members

The main methods are

  • basis() for basis matrix
  • derivative() for derivatives of basis functions
  • integral() for integrals of basis functions

The specific function signatures are as follows:

mat basis(const bool complete_basis = true);
mat derivative(const unsigned int derivs = 1,
               const bool complete_basis = true);
mat integral(const bool complete_basis = true);

In addition, we may set and get the specifications through the following setter and getter functions, respectively.

// setter functions
BernsteinPoly* set_x(const vec&);
BernsteinPoly* set_x(const double);
BernsteinPoly* set_degree(const unsigned int);
BernsteinPoly* set_order(const unsigned int);
BernsteinPoly* set_internal_knots(const vec&); // placeholder, does nothing
BernsteinPoly* set_boundary_knots(const vec&);

// getter functions
vec get_x();
unsigned int get_degree();
unsigned int get_order();
vec get_boundary_knots();

The setter function returns a pointer to the current object.

Classes for Spline Basis Functions

A virtual base class named SplineBase is implemented to support a variety of classes for spline basis functions including

  • BSpline for B-splines;
  • MSpline for M-splines;
  • ISpline for I-splines;
  • CSpline for C-splines;
  • NaturalSpline for natural cubic splines;
  • PeriodicMSpline for periodic M-splines;
  • BernsteinPoly for Bernstein polynomials.

Constructors of BSpline, MSpline, ISpline, and CSpline

The BSpline, MSpline, ISpline, and CSpline classes share the same constructors inherited from the SplineBase class. There are four constructors in addition to the default constructor.

The first non-default constructor is invoked when internal knots are explicitly specified as the second argument. Taking B-splines as an example, the first non-default constructor of a BSpline object is

// 1. specified internal_knots
BSpline(const vec& x,
        const vec& internal_knots,
        const unsigned int degree = 3,
        const vec& boundary_knots = vec());

The second non-default constructor is called when an unsigned integer is specified as the second argument, which represents the degree of freedom of the complete spline basis functions (different with df in the R interface) is specified. Then the number of internal knots is computed as spline_df - degree - 1 and the placement of internal knots uses quantiles of specified x within boundary.

// 2. specified spline degree of freedom (df)
BSpline(const vec& x,
        const unsigned int spline_df,
        const unsigned int degree = 3,
        const vec& boundary_knots = vec());

The third non-default constructor is intended for basis functions with an extended knot sequence, where the multiplicities of the knots can be more than one.

// 3. specified degree and (extended) knot sequence
BSpline(const vec& x,
        const unsigned int degree,
        const vec& knot_sequence);

The fourth non-default constructor is explicit and takes a pointer to a base class object, which can be useful when we want to create a new object using the same specification (x, degree, internal_knots, and boundary_knots) of an existing object (not necessarily a BSpline object).

// 4. create a new object from a base class pointer
BSpline(const SplineBase* pSplineBase);

This constructor also allows us to easily switch between different types of splines. For example, we create a BSpline object bsp_obj form an existing MSpline object msp_obj with the same specification as follows:

BSpline bsp_obj { &msp_obj };

Constructors of NaturalSpline

The NaturalSpline represents the class for natural cubic splines. Thus, its constructors do not allow specification of degree. The first non-default constructor is called when internal knots are explicitly specified.

// 1. specified internal_knots
NaturalSpline(const vec& x,
              const vec& internal_knots,
              const vec& boundary_knots = vec());

The second non-default constructor is called when an unsigned integer representing the degree of freedom of the complete spline basis functions (different with df in the R interface) is specified. Then the number of internal knots is computed as spline_df - 2 and the placement of internal knots uses quantiles of specified x.

// 2. specified spline degree of freedom (df)
NaturalSpline(const vec& x,
              const unsigned int spline_df,
              const vec& boundary_knots = vec());

The third non-default constructor is explicit and takes a pointer to a base class object. It can be useful when we want to create a new object using the same specification (x, internal_knots, boundary_knots, etc.) of an existing object.

// 3. create a new object from a base class pointer
NaturalSpline(const SplineBase* pSplineBase);

Constructors of PeriodicMSpline

The PeriodicMSpline class is for constructing the periodic M-splines, which provides the same set of non-default constructors with BSpline except the constructor for directly specifying the knot sequence.

Function Members

The main methods are

  • basis() for spline basis matrix
  • derivative() for derivatives of spline basis
  • integral() for integrals of spline basis (except for the CSpline class)

The specific function signatures are as follows:

mat basis(const bool complete_basis = true);
mat derivative(const unsigned int derivs = 1,
               const bool complete_basis = true);
mat integral(const bool complete_basis = true);

Similarly, we may set and get the spline specifications through the following setter and getter functions, respectively.

// setter functions
SplineBase* set_x(const vec&);
SplineBase* set_x(const double);
SplineBase* set_internal_knots(const vec&);
SplineBase* set_boundary_knots(const vec&);
SplineBase* set_knot_sequence(const vec&);
SplineBase* set_degree(const unsigned int);
SplineBase* set_order(const unsigned int);

// getter functions
vec get_x();
vec get_internal_knots();
vec get_boundary_knots();
vec get_knot_sequence();
unsigned int get_degree();
unsigned int get_order();
unsigned int get_spline_df();

The setter function returns a pointer to the current object so that the specification can be chained for convenience. For example,

vec x { arma::regspace(0, 0.1, 1) }; // 0, 0.1, ..., 1
BSpline obj { x, 5 };                // df = 5 (and degree = 3, by default)
// change degree to 2 and get basis
mat basis_mat { obj.set_degree(2)->basis() };

The corresponding first derivatives and integrals of the basis functions can be obtained as follows:

mat derivative_mat { bs.derivative() };
mat integral_mat { bs.integral() };

Notice that there is no available integral() method for CSpline and no meaningful degree related methods for NaturalSpline.

Reference

Eddelbuettel, Dirk. 2013. Seamless R and C++ Integration with Rcpp. Springer.
Eddelbuettel, Dirk, and Conrad Sanderson. 2014. RcppArmadillo: Accelerating R with High-Performance C++ Linear Algebra.” Computational Statistics and Data Analysis 71: 1054–63. http://dx.doi.org/10.1016/j.csda.2013.02.005.
Sanderson, Conrad. 2016. Armadillo: An Open Source C++ Linear Algebra Library for Fast Prototyping and Computationally Intensive Experiments.” Journal of Open Source Software 1: 26.
splines2/inst/doc/splines2-intro.Rmd0000644000176200001440000003356114103557514017104 0ustar liggesusers--- title: "Introduction to splines2" author: Wenjie Wang date: "`r Sys.Date()`" bibliography: - ../inst/bib/splines2.bib vignette: > %\VignetteIndexEntry{Introduction to splines2} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} output: rmarkdown::html_vignette --- ```{r setup, echo = FALSE} knitr::opts_knit$set(global.par = TRUE) knitr::opts_chunk$set(fig.width = 7, fig.height = 4) ``` ```{r set-par, echo = FALSE} library(graphics) par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) ``` The R package **splines2** is intended to be a comprehensive, efficient supplement to the base package **splines**. It provides functions constructing a variety of regression spline basis functions that are not available from **splines**. Most functions have a very similar user interface with the function `splines::bs()`. To be more specific, it provides functions to construct basis matrices of - B-splines - M-splines - I-splines - C-splines - periodic M-splines - natural cubic splines - generalized Bernstein polynomials along with their integrals (except C-splines) and derivatives of given order by closed-form recursive formulas. Compared to the package **splines**, the package **splines2** allows piecewise constant basis functions for B-splines and provides a more user-friendly interface for their derivatives with consistent handling on `NA`'s. Most of the implementations had been (re)written in C++ with the help of **Rcpp** and **RcppArmadillo** since v0.3.0, which boosted the computational performance. In the remaining of this vignette, we illustrated the basic usage of most functions in the package through examples. See the package manual for the details of function usage. ## B-splines with their integrals and derivatives {#bSpline} Function `bSpline()` provides B-spline basis matrix and allows `degree = 0` for piece-wise constant basis function, which extends the `bs()` function in package **splines** with a better computational performance. One example of linear B-splines with three internal knots is given as follows: ```{r bSpline, fig.cap="B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6."} library(splines2) knots <- c(0.3, 0.5, 0.6) x <- seq(0, 1, 0.01) bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ``` The closed-form recursive formula of B-spline integrals and derivatives given by @boor1978practical is implemented in function `ibs()` and `dbs()`, respectively. Two toy examples are given as follows: ```{r ibs, fig.cap="Piecewise linear B-splines (left) and their integrals (right)."} ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, h = 1, lty = 2, col = "gray") matplot(x, ibsMat, type = "l", ylab = "y") abline(v = knots, h = c(0.15, 0.2, 0.25), lty = 2, col = "gray") ``` ```{r dbs, fig.cap="Cubic B-spline (left) and their first derivative (right)."} bsMat <- bSpline(x, knots = knots, intercept = TRUE) dbsMat <- dbs(x, knots = knots, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") matplot(x, dbsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ``` We may also obtain the derivatives easily by the `deriv()` method as follows: ```{r dbsMat} is_equivalent <- function(a, b) { all.equal(a, b, check.attributes = FALSE) } stopifnot(is_equivalent(dbsMat, deriv(bsMat))) ``` ## M-splines using `mSpline()` {#mSpline} M-splines [@ramsay1988monotone] are considered the normalized version of B-splines with unit integral within boundary knots. An example given by @ramsay1988monotone was a quadratic M-splines with three internal knots placed at 0.3, 0.5, and 0.6. The default boundary knots are the range of `x`, and thus 0 and 1 in this example. ```{r reset-par-mSpline, echo = FALSE} par(mfrow = c(1, 1)) ``` ```{r mSpline, fig.cap = "Quadratic M-spline with three internal knots placed at 0.3, 0.5, and 0.6."} msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, msMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ``` The derivative of the given order of M-splines can be obtained by specifying a positive integer to argument `dervis` of `mSpline()`. Also, for an existing `mSpline` object generated by `mSpline()`, the `deriv()` method can be used conveniently. For example, the first derivative of the M-splines given in the previous example can be obtained equivalently as follows: ```{r mSpline-derivs} dmsMat1 <- mSpline(x, knots = knots, degree = 2, intercept = TRUE, derivs = 1) dmsMat2 <- deriv(msMat) stopifnot(is_equivalent(dmsMat1, dmsMat2)) ``` ### Periodic M-Splines The function `mSpline()` produces periodic splines based on M-spline basis functions when `periodic = TRUE` is specified. The `Boundary.knots` defines the cyclic interval. The construction follows periodic B-splines discussed in @piegl1997nurbs [chapter 12]. ```{r pms-basis, fig.cap = "Cubic periodic M-splines."} x1 <- seq.int(0, 3, 0.01) pmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1)) matplot(x1, pmsMat, type = "l", xlab = "x", ylab = "Periodic Basis") abline(v = seq.int(0, 3), lty = 2, col = "gray") ``` We may still specify the argument `derivs` in `mSpline()` or use the corresponding `deriv()` method to obtain the derivatives when `periodic = TRUE`. ```{r pms-deriv, fig.cap = "The first derivatives of the periodic M-splines."} dpmsMat <- deriv(pmsMat) matplot(x1, dpmsMat, type = "l", xlab = "x", ylab = "The 1st derivatives") abline(v = seq.int(0, 3), lty = 2, col = "gray") ``` Furthermore, we can obtain the integrals of the periodic M-splines by specifying `integral = TRUE`. The integral is integrated from the left boundary knot. ```{r pms-integral, fig.cap = "The integrals of the periodic M-splines."} ipmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE) matplot(x1, ipmsMat, type = "l", xlab = "x", ylab = "Integrals") abline(v = seq.int(0, 3), h = seq.int(0, 3), lty = 2, col = "gray") ``` ## I-splines using `iSpline()` {#iSpline} I-splines [@ramsay1988monotone] are simply the integral of M-splines and thus monotonically nondecreasing with unit maximum value. A monotonically nondecreasing (nonincreasing) function can be fitted by a linear combination of I-spline basis functions with nonnegative (nonpositive) coefficients *plus a constant*, where the coefficient of the constant is unconstrained. The example given by @ramsay1988monotone was the I-splines corresponding to that quadratic M-splines with three internal knots placed at 0.3, 0.5, and 0.6. Notice that the degree of I-splines is defined from the associated M-splines instead of their polynomial degree. ```{r iSpline, fig.cap = "I-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6."} isMat <- iSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, isMat, type = "l", ylab = "y") abline(h = 1, v = knots, lty = 2, col = "gray") ``` The corresponding M-spline basis matrix can be obtained easily as the first derivatives of the I-splines by the `deriv()` method. ```{r msMat} stopifnot(is_equivalent(msMat, deriv(isMat))) ``` We may specify the `derivs = 2` in the `deriv()` method for the second derivatives of the I-splines, which are equivalent to the first derivatives of the corresponding M-splines. ```{r dmsMat} dmsMat3 <- deriv(isMat, 2) stopifnot(is_equivalent(dmsMat1, dmsMat3)) ``` ## C-splines using `cSpline` {#cSpline} Convex splines [@meyer2008inference] called C-splines are scaled integrals of I-splines with unit maximum value at the right boundary knot. @meyer2008inference applied C-splines to shape-restricted regression analysis. The monotone (nondecreasing) property of I-spines ensures the convexity of C-splines. A convex regression function can be estimated using linear combinations of the C-spline basis functions with nonnegative coefficients, plus an unconstrained linear combination of a constant and an identity function $g(x)=x$. If the underlying regression function is both increasing and convex, the coefficient on the identity function is restricted to be nonnegative as well. We may specify the argument `scale = FALSE` in function `cSpline()` to disable the scaling of the integrals of I-splines. Then the actual integrals of the corresponding I-splines will be returned. If `scale = TRUE` (by default), each C-spline basis is scaled to have unit height at the right boundary knot. ```{r cSpline-scaled, fig.cap = "C-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6."} csMat1 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, csMat1, type = "l", ylab = "y") abline(h = 1, v = knots, lty = 2, col = "gray") ``` Similarly, the `deriv()` method can be used to obtain the derivatives. A nested call of `deriv()` is supported for derivatives of order greater than one. However, the argument `derivs` of the `deriv()` method can be specified directly for better computational performance. For example, the first and second derivatives can be obtained by the following equivalent approaches, respectively. ```{r cSpline-not-scaled} csMat2 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE, scale = FALSE) stopifnot(is_equivalent(isMat, deriv(csMat2))) stopifnot(is_equivalent(msMat, deriv(csMat2, 2))) stopifnot(is_equivalent(msMat, deriv(deriv(csMat2)))) ``` ## Generalized Bernstein Polynomials The Bernstein polynomials have also been applied to shape-constrained regression analysis [@wang2012csda]. The $i$-th basis of the generalized Bernstein polynomials of degree $n$ over $[a, b]$ is defined as follows: $$ B_i^n(x)=\frac{1}{(b-a)^n}{n\choose i}(x-a)^i (b-x)^{n-i},~i\in\{0,\ldots,n\}, $$ where $a\le x\le b$. Obviously, it reduces to regular Bernstein polynomials defined over $[0, 1]$ when $a = 0$ and $b = 1$. We may obtain the basis matrix of the generalized using the function `bernsteinPoly()`. For example, the Bernstein polynomials of degree 4 over $[0, 1]$ and is generated as follows: ```{r bp-1, fig.cap = "Bernstein polynomials of degree 4 over [0, 1] (left) and the generalized version over [- 1, 1] (right)."} x1 <- seq.int(0, 1, 0.01) x2 <- seq.int(- 1, 1, 0.01) bpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE) bpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x1, bpMat1, type = "l", ylab = "y") matplot(x2, bpMat2, type = "l", ylab = "y") ``` In addition, we may specify `integral = TRUE` or `derivs = 1` in `bernsteinPoly()` for their integrals or first derivatives, respectively. ```{r bp-2, fig.height=6, fig.cap = "The integrals (upper panel) and the first derivatives (lower panel) of Bernstein polynomials of degree 4."} ibpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, integral = TRUE) ibpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, integral = TRUE) dbpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, derivs = 1) dbpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, derivs = 1) par(mfrow = c(2, 2)) matplot(x1, ibpMat1, type = "l", ylab = "Integrals") matplot(x2, ibpMat2, type = "l", ylab = "y") matplot(x1, dbpMat1, type = "l", ylab = "y") matplot(x2, dbpMat2, type = "l", ylab = "y") ``` Similarly, we may also use the `deriv()` method to get derivatives of an existing `bernsteinPoly` object. ```{r bp-deriv} stopifnot(is_equivalent(dbpMat1, deriv(bpMat1))) stopifnot(is_equivalent(dbpMat2, deriv(bpMat2))) stopifnot(is_equivalent(dbpMat1, deriv(ibpMat1, 2))) stopifnot(is_equivalent(dbpMat2, deriv(ibpMat2, 2))) ``` ## Natural Cubic Splines The function `naturalSpline()` returns nonnegative basis functions (within the boundary) for natural cubic splines by utilizing the closed-form null space derived from the second derivatives of cubic B-splines. While `splines::ns()` uses QR decomposition to find the null space of the second derivatives of B-spline basis at boundary knots with no guarantee that the resulting basis functions are nonnegative within the boundary. When `integral = TRUE`, `naturalSpline()` returns integral of each natural spline basis. ```{r ns-basis, fig.cap = "Nonnegative natural cubic splines (left) and corresponding integrals (right)."} nsMat <- naturalSpline(x, knots = knots, intercept = TRUE) insMat <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) par(mfrow = c(1, 2)) matplot(x, nsMat, type = "l", ylab = "Basis") matplot(x, insMat, type = "l", ylab = "Integrals") stopifnot(is_equivalent(nsMat, deriv(insMat))) ``` Similar to `bernsteinPoly()`, one may specify the argument `derivs` in `naturalSpline()` or use the corresponding `deriv()` method to obtain the derivatives of spline basis functions. ```{r ns-deriv, fig.cap = "The derivatives of natural cubic splines."} d1nsMat <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) d2nsMat <- deriv(nsMat, 2) par(mfrow = c(1, 2)) matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives") matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives") ``` ## Evaluation on New Values by `predict` {#predict} The methods for **splines2** objects dispatched by generic function `predict` will be useful if we want to evaluate the spline object at possibly new $x$ values. For instance, we may evaluate the value of I-splines object in the previous example at 0.275, 0.525, and 0.8, respectively, as follows: ```{r predict} new_x <- c(0.275, 0.525, 0.8) names(new_x) <- paste0("x=", new_x) predict(isMat, new_x) ``` Technically speaking, the methods take all information needed, such as `knots`, `degree`, `intercept`, etc., from attributes of the original objects and call the corresponding function automatically for those new $x$ values. Therefore, the `predict` methods will not be applicable if those attributes are somehow lost after some operations. ## Reference splines2/inst/doc/splines2-wi-rcpp.Rmd0000644000176200001440000002176714071743574017346 0ustar liggesusers--- title: "Using splines2 with Rcpp" author: Wenjie Wang date: "`r Sys.Date()`" bibliography: - ../inst/bib/splines2.bib vignette: > %\VignetteIndexEntry{Using splines2 with Rcpp} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} output: rmarkdown::html_vignette --- In this package vignette, we introduce how to use the C++ header-only library that **splines2** contains with the **Rcpp** package [@eddelbuettel2013springer] for constructing spline basis functions. The introduction is intended for package developers who would like to use **splines2** package at C++ level by adding **splines2** to the `LinkingTo` field of package `DESCRIPTION` file. ## Header File and Name Space Different with the procedure-based functions in the R interface, the C++ interface follows the commonly-used object-oriented design in C++ for ease of usage and maintenance. The implementations use the **Armadillo** [@sanderson2016armadillo] library with help of **RcppArmadillo** [@eddelbuettel2014csda] and require C++11. We assume that \proglang{C++11} is enabled for compilation henceforth. We may include the header file named `splines2Armadillo.h` to get the access to all the classes and implementations in the name space `splines2`. ```cpp #include // include header file from splines2 package #include // [[Rcpp::plugins(cpp11)]] ``` To use `Rcpp::sourceCpp()`, one may need to add `[[Rcpp::depends()]]` as follows: ```cpp // [[Rcpp::depends(RcppArmadillo)]] // [[Rcpp::depends(splines2)]] ``` For ease of demonstration, we assume the following *using-directives*: ```cpp using namespace arma using namespace splines2 ``` ## Generalized Bernstein Polynomials The `BernsteinPoly` class is implemented for the generalized Bernstein polynomials. ### Constructors The main non-default constructor is as follows: ```cpp BernsteinPoly(const vec& x, const unsigned int degree, const vec& boundary_knots = vec()); ``` In addition, two explicit constructors are provided for `BernsteinPoly*` and `SplineBase*`, which set `x`, `degree`, and `boundary_knots` from the objects that the pointers point to. ### Function Members The main methods are - `basis()` for basis matrix - `derivative()` for derivatives of basis functions - `integral()` for integrals of basis functions The specific function signatures are as follows: ```cpp mat basis(const bool complete_basis = true); mat derivative(const unsigned int derivs = 1, const bool complete_basis = true); mat integral(const bool complete_basis = true); ``` In addition, we may *set* and *get* the specifications through the following *setter* and *getter* functions, respectively. ```cpp // setter functions BernsteinPoly* set_x(const vec&); BernsteinPoly* set_x(const double); BernsteinPoly* set_degree(const unsigned int); BernsteinPoly* set_order(const unsigned int); BernsteinPoly* set_internal_knots(const vec&); // placeholder, does nothing BernsteinPoly* set_boundary_knots(const vec&); // getter functions vec get_x(); unsigned int get_degree(); unsigned int get_order(); vec get_boundary_knots(); ``` The *setter* function returns a pointer to the current object. ## Classes for Spline Basis Functions A virtual base class named `SplineBase` is implemented to support a variety of classes for spline basis functions including - `BSpline` for B-splines; - `MSpline` for M-splines; - `ISpline` for I-splines; - `CSpline` for C-splines; - `NaturalSpline` for natural cubic splines; - `PeriodicMSpline` for periodic M-splines; - `BernsteinPoly` for Bernstein polynomials. ### Constructors of `BSpline`, `MSpline`, `ISpline`, and `CSpline` The `BSpline`, `MSpline`, `ISpline`, and `CSpline` classes share the same constructors inherited from the `SplineBase` class. There are four constructors in addition to the default constructor. The first non-default constructor is invoked when internal knots are explicitly specified as the second argument. Taking B-splines as an example, the first non-default constructor of a `BSpline` object is ```cpp // 1. specified internal_knots BSpline(const vec& x, const vec& internal_knots, const unsigned int degree = 3, const vec& boundary_knots = vec()); ``` The second non-default constructor is called when an unsigned integer is specified as the second argument, which represents the degree of freedom of the *complete spline basis functions* (different with `df` in the R interface) is specified. Then the number of internal knots is computed as `spline_df - degree - 1` and the placement of internal knots uses quantiles of specified `x` within boundary. ```cpp // 2. specified spline degree of freedom (df) BSpline(const vec& x, const unsigned int spline_df, const unsigned int degree = 3, const vec& boundary_knots = vec()); ``` The third non-default constructor is intended for basis functions with an extended knot sequence, where the multiplicities of the knots can be more than one. ```cpp // 3. specified degree and (extended) knot sequence BSpline(const vec& x, const unsigned int degree, const vec& knot_sequence); ``` The fourth non-default constructor is explicit and takes a pointer to a base class object, which can be useful when we want to create a new object using the same specification (`x`, `degree`, `internal_knots`, and `boundary_knots`) of an existing object (not necessarily a `BSpline` object). ```cpp // 4. create a new object from a base class pointer BSpline(const SplineBase* pSplineBase); ``` This constructor also allows us to easily switch between different types of splines. For example, we create a `BSpline` object `bsp_obj` form an existing `MSpline` object `msp_obj` with the same specification as follows: ```cpp BSpline bsp_obj { &msp_obj }; ``` ### Constructors of `NaturalSpline` The `NaturalSpline` represents the class for natural cubic splines. Thus, its constructors do not allow specification of `degree`. The first non-default constructor is called when internal knots are explicitly specified. ```cpp // 1. specified internal_knots NaturalSpline(const vec& x, const vec& internal_knots, const vec& boundary_knots = vec()); ``` The second non-default constructor is called when an unsigned integer representing the degree of freedom of the *complete spline basis functions* (different with `df` in the R interface) is specified. Then the number of internal knots is computed as `spline_df - 2` and the placement of internal knots uses quantiles of specified `x`. ```cpp // 2. specified spline degree of freedom (df) NaturalSpline(const vec& x, const unsigned int spline_df, const vec& boundary_knots = vec()); ``` The third non-default constructor is explicit and takes a pointer to a base class object. It can be useful when we want to create a new object using the same specification (`x`, `internal_knots`, `boundary_knots`, etc.) of an existing object. ```cpp // 3. create a new object from a base class pointer NaturalSpline(const SplineBase* pSplineBase); ``` ### Constructors of `PeriodicMSpline` The `PeriodicMSpline` class is for constructing the periodic M-splines, which provides the same set of non-default constructors with `BSpline` except the constructor for directly specifying the knot sequence. ### Function Members The main methods are - `basis()` for spline basis matrix - `derivative()` for derivatives of spline basis - `integral()` for integrals of spline basis (except for the `CSpline` class) The specific function signatures are as follows: ```cpp mat basis(const bool complete_basis = true); mat derivative(const unsigned int derivs = 1, const bool complete_basis = true); mat integral(const bool complete_basis = true); ``` Similarly, we may set and get the spline specifications through the following *setter* and *getter* functions, respectively. ```cpp // setter functions SplineBase* set_x(const vec&); SplineBase* set_x(const double); SplineBase* set_internal_knots(const vec&); SplineBase* set_boundary_knots(const vec&); SplineBase* set_knot_sequence(const vec&); SplineBase* set_degree(const unsigned int); SplineBase* set_order(const unsigned int); // getter functions vec get_x(); vec get_internal_knots(); vec get_boundary_knots(); vec get_knot_sequence(); unsigned int get_degree(); unsigned int get_order(); unsigned int get_spline_df(); ``` The *setter* function returns a pointer to the current object so that the specification can be chained for convenience. For example, ```cpp vec x { arma::regspace(0, 0.1, 1) }; // 0, 0.1, ..., 1 BSpline obj { x, 5 }; // df = 5 (and degree = 3, by default) // change degree to 2 and get basis mat basis_mat { obj.set_degree(2)->basis() }; ``` The corresponding first derivatives and integrals of the basis functions can be obtained as follows: ```cpp mat derivative_mat { bs.derivative() }; mat integral_mat { bs.integral() }; ``` Notice that there is no available `integral()` method for `CSpline` and no meaningful `degree` related methods for `NaturalSpline`. ## Reference splines2/inst/doc/splines2-intro.html0000644000176200001440000310363314121502505017315 0ustar liggesusers Introduction to splines2

Introduction to splines2

Wenjie Wang

2021-09-18

The R package splines2 is intended to be a comprehensive, efficient supplement to the base package splines. It provides functions constructing a variety of regression spline basis functions that are not available from splines. Most functions have a very similar user interface with the function splines::bs(). To be more specific, it provides functions to construct basis matrices of

  • B-splines
  • M-splines
  • I-splines
  • C-splines
  • periodic M-splines
  • natural cubic splines
  • generalized Bernstein polynomials

along with their integrals (except C-splines) and derivatives of given order by closed-form recursive formulas.

Compared to the package splines, the package splines2 allows piecewise constant basis functions for B-splines and provides a more user-friendly interface for their derivatives with consistent handling on NA’s. Most of the implementations had been (re)written in C++ with the help of Rcpp and RcppArmadillo since v0.3.0, which boosted the computational performance.

In the remaining of this vignette, we illustrated the basic usage of most functions in the package through examples. See the package manual for the details of function usage.

B-splines with their integrals and derivatives

Function bSpline() provides B-spline basis matrix and allows degree = 0 for piece-wise constant basis function, which extends the bs() function in package splines with a better computational performance. One example of linear B-splines with three internal knots is given as follows:

library(splines2)
knots <- c(0.3, 0.5, 0.6)
x <- seq(0, 1, 0.01)
bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE)
matplot(x, bsMat, type = "l", ylab = "y")
abline(v = knots, lty = 2, col = "gray")

B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6.

The closed-form recursive formula of B-spline integrals and derivatives given by De Boor (1978) is implemented in function ibs() and dbs(), respectively. Two toy examples are given as follows:

ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE)
par(mfrow = c(1, 2))
matplot(x, bsMat, type = "l", ylab = "y")
abline(v = knots, h = 1, lty = 2, col = "gray")
matplot(x, ibsMat, type = "l", ylab = "y")
abline(v = knots, h = c(0.15, 0.2, 0.25), lty = 2, col = "gray")

Piecewise linear B-splines (left) and their integrals (right).

bsMat <- bSpline(x, knots = knots, intercept = TRUE)
dbsMat <- dbs(x, knots = knots, intercept = TRUE)
par(mfrow = c(1, 2))
matplot(x, bsMat, type = "l", ylab = "y")
abline(v = knots, lty = 2, col = "gray")
matplot(x, dbsMat, type = "l", ylab = "y")
abline(v = knots, lty = 2, col = "gray")

Cubic B-spline (left) and their first derivative (right).

We may also obtain the derivatives easily by the deriv() method as follows:

is_equivalent <- function(a, b) {
    all.equal(a, b, check.attributes = FALSE)
}
stopifnot(is_equivalent(dbsMat, deriv(bsMat)))

M-splines using mSpline()

M-splines (Ramsay 1988) are considered the normalized version of B-splines with unit integral within boundary knots. An example given by Ramsay (1988) was a quadratic M-splines with three internal knots placed at 0.3, 0.5, and 0.6. The default boundary knots are the range of x, and thus 0 and 1 in this example.

msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE)
matplot(x, msMat, type = "l", ylab = "y")
abline(v = knots, lty = 2, col = "gray")

Quadratic M-spline with three internal knots placed at 0.3, 0.5, and 0.6.

The derivative of the given order of M-splines can be obtained by specifying a positive integer to argument dervis of mSpline(). Also, for an existing mSpline object generated by mSpline(), the deriv() method can be used conveniently. For example, the first derivative of the M-splines given in the previous example can be obtained equivalently as follows:

dmsMat1 <- mSpline(x, knots = knots, degree = 2, intercept = TRUE, derivs = 1)
dmsMat2 <- deriv(msMat)
stopifnot(is_equivalent(dmsMat1, dmsMat2))

Periodic M-Splines

The function mSpline() produces periodic splines based on M-spline basis functions when periodic = TRUE is specified. The Boundary.knots defines the cyclic interval. The construction follows periodic B-splines discussed in Piegl and Tiller (1997, chap. 12).

x1 <- seq.int(0, 3, 0.01)
pmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE,
                  periodic = TRUE, Boundary.knots = c(0, 1))
matplot(x1, pmsMat, type = "l", xlab = "x", ylab = "Periodic Basis")
abline(v = seq.int(0, 3), lty = 2, col = "gray")

Cubic periodic M-splines.

We may still specify the argument derivs in mSpline() or use the corresponding deriv() method to obtain the derivatives when periodic = TRUE.

dpmsMat <- deriv(pmsMat)
matplot(x1, dpmsMat, type = "l", xlab = "x", ylab = "The 1st derivatives")
abline(v = seq.int(0, 3), lty = 2, col = "gray")

The first derivatives of the periodic M-splines.

Furthermore, we can obtain the integrals of the periodic M-splines by specifying integral = TRUE. The integral is integrated from the left boundary knot.

ipmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE,
                   periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE)
matplot(x1, ipmsMat, type = "l", xlab = "x", ylab = "Integrals")
abline(v = seq.int(0, 3), h = seq.int(0, 3), lty = 2, col = "gray")

The integrals of the periodic M-splines.

I-splines using iSpline()

I-splines (Ramsay 1988) are simply the integral of M-splines and thus monotonically nondecreasing with unit maximum value. A monotonically nondecreasing (nonincreasing) function can be fitted by a linear combination of I-spline basis functions with nonnegative (nonpositive) coefficients plus a constant, where the coefficient of the constant is unconstrained.

The example given by Ramsay (1988) was the I-splines corresponding to that quadratic M-splines with three internal knots placed at 0.3, 0.5, and 0.6. Notice that the degree of I-splines is defined from the associated M-splines instead of their polynomial degree.

isMat <- iSpline(x, knots = knots, degree = 2, intercept = TRUE)
matplot(x, isMat, type = "l", ylab = "y")
abline(h = 1, v = knots, lty = 2, col = "gray")

I-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6.

The corresponding M-spline basis matrix can be obtained easily as the first derivatives of the I-splines by the deriv() method.

stopifnot(is_equivalent(msMat, deriv(isMat)))

We may specify the derivs = 2 in the deriv() method for the second derivatives of the I-splines, which are equivalent to the first derivatives of the corresponding M-splines.

dmsMat3 <- deriv(isMat, 2)
stopifnot(is_equivalent(dmsMat1, dmsMat3))

C-splines using cSpline

Convex splines (Meyer 2008) called C-splines are scaled integrals of I-splines with unit maximum value at the right boundary knot. Meyer (2008) applied C-splines to shape-restricted regression analysis. The monotone (nondecreasing) property of I-spines ensures the convexity of C-splines. A convex regression function can be estimated using linear combinations of the C-spline basis functions with nonnegative coefficients, plus an unconstrained linear combination of a constant and an identity function \(g(x)=x\). If the underlying regression function is both increasing and convex, the coefficient on the identity function is restricted to be nonnegative as well.

We may specify the argument scale = FALSE in function cSpline() to disable the scaling of the integrals of I-splines. Then the actual integrals of the corresponding I-splines will be returned. If scale = TRUE (by default), each C-spline basis is scaled to have unit height at the right boundary knot.

csMat1 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE)
matplot(x, csMat1, type = "l", ylab = "y")
abline(h = 1, v = knots, lty = 2, col = "gray")

C-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6.

Similarly, the deriv() method can be used to obtain the derivatives. A nested call of deriv() is supported for derivatives of order greater than one. However, the argument derivs of the deriv() method can be specified directly for better computational performance. For example, the first and second derivatives can be obtained by the following equivalent approaches, respectively.

csMat2 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE, scale = FALSE)
stopifnot(is_equivalent(isMat, deriv(csMat2)))
stopifnot(is_equivalent(msMat, deriv(csMat2, 2)))
stopifnot(is_equivalent(msMat, deriv(deriv(csMat2))))

Generalized Bernstein Polynomials

The Bernstein polynomials have also been applied to shape-constrained regression analysis (Wang and Ghosh 2012). The \(i\)-th basis of the generalized Bernstein polynomials of degree \(n\) over \([a, b]\) is defined as follows: \[ B_i^n(x)=\frac{1}{(b-a)^n}{n\choose i}(x-a)^i (b-x)^{n-i},~i\in\{0,\ldots,n\}, \] where \(a\le x\le b\). Obviously, it reduces to regular Bernstein polynomials defined over \([0, 1]\) when \(a = 0\) and \(b = 1\).

We may obtain the basis matrix of the generalized using the function bernsteinPoly(). For example, the Bernstein polynomials of degree 4 over \([0, 1]\) and is generated as follows:

x1 <- seq.int(0, 1, 0.01)
x2 <- seq.int(- 1, 1, 0.01)
bpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE)
bpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE)
par(mfrow = c(1, 2))
matplot(x1, bpMat1, type = "l", ylab = "y")
matplot(x2, bpMat2, type = "l", ylab = "y")

Bernstein polynomials of degree 4 over [0, 1] (left) and the generalized version over [- 1, 1] (right).

In addition, we may specify integral = TRUE or derivs = 1 in bernsteinPoly() for their integrals or first derivatives, respectively.

ibpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, integral = TRUE)
ibpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, integral = TRUE)
dbpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, derivs = 1)
dbpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, derivs = 1)
par(mfrow = c(2, 2))
matplot(x1, ibpMat1, type = "l", ylab = "Integrals")
matplot(x2, ibpMat2, type = "l", ylab = "y")
matplot(x1, dbpMat1, type = "l", ylab = "y")
matplot(x2, dbpMat2, type = "l", ylab = "y")

The integrals (upper panel) and the first derivatives (lower panel) of Bernstein polynomials of degree 4.

Similarly, we may also use the deriv() method to get derivatives of an existing bernsteinPoly object.

stopifnot(is_equivalent(dbpMat1, deriv(bpMat1)))
stopifnot(is_equivalent(dbpMat2, deriv(bpMat2)))
stopifnot(is_equivalent(dbpMat1, deriv(ibpMat1, 2)))
stopifnot(is_equivalent(dbpMat2, deriv(ibpMat2, 2)))

Natural Cubic Splines

The function naturalSpline() returns nonnegative basis functions (within the boundary) for natural cubic splines by utilizing the closed-form null space derived from the second derivatives of cubic B-splines. While splines::ns() uses QR decomposition to find the null space of the second derivatives of B-spline basis at boundary knots with no guarantee that the resulting basis functions are nonnegative within the boundary. When integral = TRUE, naturalSpline() returns integral of each natural spline basis.

nsMat <- naturalSpline(x, knots = knots, intercept = TRUE)
insMat <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE)
par(mfrow = c(1, 2))
matplot(x, nsMat, type = "l", ylab = "Basis")
matplot(x, insMat, type = "l", ylab = "Integrals")

Nonnegative natural cubic splines (left) and corresponding integrals (right).

stopifnot(is_equivalent(nsMat, deriv(insMat)))

Similar to bernsteinPoly(), one may specify the argument derivs in naturalSpline() or use the corresponding deriv() method to obtain the derivatives of spline basis functions.

d1nsMat <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1)
d2nsMat <- deriv(nsMat, 2)
par(mfrow = c(1, 2))
matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives")
matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives")

The derivatives of natural cubic splines.

Evaluation on New Values by predict

The methods for splines2 objects dispatched by generic function predict will be useful if we want to evaluate the spline object at possibly new \(x\) values. For instance, we may evaluate the value of I-splines object in the previous example at 0.275, 0.525, and 0.8, respectively, as follows:

new_x <- c(0.275, 0.525, 0.8)
names(new_x) <- paste0("x=", new_x)
predict(isMat, new_x)
##                 1         2         3         4        5     6
## x=0.275 0.9994213 0.7730556 0.2310764 0.0000000 0.000000 0.000
## x=0.525 1.0000000 1.0000000 0.9765625 0.2696429 0.000625 0.000
## x=0.8   1.0000000 1.0000000 1.0000000 0.9428571 0.580000 0.125

Technically speaking, the methods take all information needed, such as knots, degree, intercept, etc., from attributes of the original objects and call the corresponding function automatically for those new \(x\) values. Therefore, the predict methods will not be applicable if those attributes are somehow lost after some operations.

Reference

De Boor, Carl. 1978. A Practical Guide to Splines. Vol. 27. New York: springer-verlag. https://doi.org/10.1002/zamm.19800600129.
Meyer, Mary C. 2008. “Inference Using Shape-Restricted Regression Splines.” The Annals of Applied Statistics 2 (3): 1013–33. https://doi.org/10.1214/08-aoas167.
Piegl, Les, and Wayne Tiller. 1997. The NURBS Book. 2nd ed. Springer Science & Business Media.
Ramsay, James O. 1988. “Monotone Regression Splines in Action.” Statistical Science 3 (4): 425–41. https://doi.org/10.1214/ss/1177012761.
Wang, Jiangdian, and Sujit K. Ghosh. 2012. “Shape Restricted Nonparametric Regression with Bernstein Polynomials.” Computational Statistics & Data Analysis 56 (9): 2729–41.
splines2/inst/doc/splines2-intro.R0000644000176200001440000001462114121502505016545 0ustar liggesusers## ----setup, echo = FALSE------------------------------------------------------ knitr::opts_knit$set(global.par = TRUE) knitr::opts_chunk$set(fig.width = 7, fig.height = 4) ## ----set-par, echo = FALSE---------------------------------------------------- library(graphics) par(mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) ## ----bSpline, fig.cap="B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6."---- library(splines2) knots <- c(0.3, 0.5, 0.6) x <- seq(0, 1, 0.01) bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ## ----ibs, fig.cap="Piecewise linear B-splines (left) and their integrals (right)."---- ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, h = 1, lty = 2, col = "gray") matplot(x, ibsMat, type = "l", ylab = "y") abline(v = knots, h = c(0.15, 0.2, 0.25), lty = 2, col = "gray") ## ----dbs, fig.cap="Cubic B-spline (left) and their first derivative (right)."---- bsMat <- bSpline(x, knots = knots, intercept = TRUE) dbsMat <- dbs(x, knots = knots, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x, bsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") matplot(x, dbsMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ## ----dbsMat------------------------------------------------------------------- is_equivalent <- function(a, b) { all.equal(a, b, check.attributes = FALSE) } stopifnot(is_equivalent(dbsMat, deriv(bsMat))) ## ----reset-par-mSpline, echo = FALSE------------------------------------------ par(mfrow = c(1, 1)) ## ----mSpline, fig.cap = "Quadratic M-spline with three internal knots placed at 0.3, 0.5, and 0.6."---- msMat <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, msMat, type = "l", ylab = "y") abline(v = knots, lty = 2, col = "gray") ## ----mSpline-derivs----------------------------------------------------------- dmsMat1 <- mSpline(x, knots = knots, degree = 2, intercept = TRUE, derivs = 1) dmsMat2 <- deriv(msMat) stopifnot(is_equivalent(dmsMat1, dmsMat2)) ## ----pms-basis, fig.cap = "Cubic periodic M-splines."------------------------- x1 <- seq.int(0, 3, 0.01) pmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1)) matplot(x1, pmsMat, type = "l", xlab = "x", ylab = "Periodic Basis") abline(v = seq.int(0, 3), lty = 2, col = "gray") ## ----pms-deriv, fig.cap = "The first derivatives of the periodic M-splines."---- dpmsMat <- deriv(pmsMat) matplot(x1, dpmsMat, type = "l", xlab = "x", ylab = "The 1st derivatives") abline(v = seq.int(0, 3), lty = 2, col = "gray") ## ----pms-integral, fig.cap = "The integrals of the periodic M-splines."------- ipmsMat <- mSpline(x1, knots = knots, degree = 3, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE) matplot(x1, ipmsMat, type = "l", xlab = "x", ylab = "Integrals") abline(v = seq.int(0, 3), h = seq.int(0, 3), lty = 2, col = "gray") ## ----iSpline, fig.cap = "I-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6."---- isMat <- iSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, isMat, type = "l", ylab = "y") abline(h = 1, v = knots, lty = 2, col = "gray") ## ----msMat-------------------------------------------------------------------- stopifnot(is_equivalent(msMat, deriv(isMat))) ## ----dmsMat------------------------------------------------------------------- dmsMat3 <- deriv(isMat, 2) stopifnot(is_equivalent(dmsMat1, dmsMat3)) ## ----cSpline-scaled, fig.cap = "C-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6."---- csMat1 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE) matplot(x, csMat1, type = "l", ylab = "y") abline(h = 1, v = knots, lty = 2, col = "gray") ## ----cSpline-not-scaled------------------------------------------------------- csMat2 <- cSpline(x, knots = knots, degree = 2, intercept = TRUE, scale = FALSE) stopifnot(is_equivalent(isMat, deriv(csMat2))) stopifnot(is_equivalent(msMat, deriv(csMat2, 2))) stopifnot(is_equivalent(msMat, deriv(deriv(csMat2)))) ## ----bp-1, fig.cap = "Bernstein polynomials of degree 4 over [0, 1] (left) and the generalized version over [- 1, 1] (right)."---- x1 <- seq.int(0, 1, 0.01) x2 <- seq.int(- 1, 1, 0.01) bpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE) bpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE) par(mfrow = c(1, 2)) matplot(x1, bpMat1, type = "l", ylab = "y") matplot(x2, bpMat2, type = "l", ylab = "y") ## ----bp-2, fig.height=6, fig.cap = "The integrals (upper panel) and the first derivatives (lower panel) of Bernstein polynomials of degree 4."---- ibpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, integral = TRUE) ibpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, integral = TRUE) dbpMat1 <- bernsteinPoly(x1, degree = 4, intercept = TRUE, derivs = 1) dbpMat2 <- bernsteinPoly(x2, degree = 4, intercept = TRUE, derivs = 1) par(mfrow = c(2, 2)) matplot(x1, ibpMat1, type = "l", ylab = "Integrals") matplot(x2, ibpMat2, type = "l", ylab = "y") matplot(x1, dbpMat1, type = "l", ylab = "y") matplot(x2, dbpMat2, type = "l", ylab = "y") ## ----bp-deriv----------------------------------------------------------------- stopifnot(is_equivalent(dbpMat1, deriv(bpMat1))) stopifnot(is_equivalent(dbpMat2, deriv(bpMat2))) stopifnot(is_equivalent(dbpMat1, deriv(ibpMat1, 2))) stopifnot(is_equivalent(dbpMat2, deriv(ibpMat2, 2))) ## ----ns-basis, fig.cap = "Nonnegative natural cubic splines (left) and corresponding integrals (right)."---- nsMat <- naturalSpline(x, knots = knots, intercept = TRUE) insMat <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) par(mfrow = c(1, 2)) matplot(x, nsMat, type = "l", ylab = "Basis") matplot(x, insMat, type = "l", ylab = "Integrals") stopifnot(is_equivalent(nsMat, deriv(insMat))) ## ----ns-deriv, fig.cap = "The derivatives of natural cubic splines."---------- d1nsMat <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) d2nsMat <- deriv(nsMat, 2) par(mfrow = c(1, 2)) matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives") matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives") ## ----predict------------------------------------------------------------------ new_x <- c(0.275, 0.525, 0.8) names(new_x) <- paste0("x=", new_x) predict(isMat, new_x) splines2/inst/include/0000755000176200001440000000000014121502506014405 5ustar liggesuserssplines2/inst/include/splines2Armadillo.h0000644000176200001440000000202614121502500020134 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_ARMADILLO_H #define SPLINES2_ARMADILLO_H #include "splines2Armadillo/BSpline.h" #include "splines2Armadillo/MSpline.h" #include "splines2Armadillo/ISpline.h" #include "splines2Armadillo/CSpline.h" #include "splines2Armadillo/BernsteinPoly.h" #include "splines2Armadillo/NaturalSpline.h" #include "splines2Armadillo/PeriodicMSpline.h" #endif splines2/inst/include/splines2Armadillo/0000755000176200001440000000000014121634402017772 5ustar liggesuserssplines2/inst/include/splines2Armadillo/BernsteinPoly.h0000644000176200001440000002351314121502500022735 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_BERNSTEINPOLY_H #define SPLINES2_BERNSTEINPOLY_H #include #include "common.h" #include "SplineBase.h" #include "utils.h" namespace splines2 { // define class for generalized Bernstein polynomials over [a, b] class BernsteinPoly { protected: unsigned int degree_ = 3; unsigned int order_ = 4; rvec boundary_knots_; // [a, b] double range_size_ = 1; // b - a rvec x_; // check x inline void check_x(const rvec& x) { if (x.has_nan()) { throw std::range_error("x cannot contain NA."); } if (boundary_knots_.n_elem == 2) { for (size_t i {0}; i < x.n_elem; ++i) { if (x(i) < boundary_knots_(0) || x(i) > boundary_knots_(1)) { throw std::range_error( "The 'x' must be inside of boundary." ); } } } x_ = x; } // check boundary inline void check_boundary(const rvec& boundary_knots) { if (boundary_knots.has_nan()) { throw std::range_error("Boundary knots cannot contain NA."); } double left { boundary_knots(0) }; double right { boundary_knots(1) }; if (left >= right) { throw std::range_error( "The left boundary must be less than the right boundary." ); } boundary_knots_ = arma::zeros(2); boundary_knots_(0) = left; boundary_knots_(1) = right; range_size_ = right - left; } inline void autoset_x_and_boundary(const rvec& x) { if (x.n_elem == 0) { return; } else if (x.has_nan()) { throw std::range_error("x cannot contain NA."); } boundary_knots_ = arma::zeros(2); boundary_knots_(0) = arma::min(x); boundary_knots_(1) = arma::max(x); range_size_ = boundary_knots_(1) - boundary_knots_(0); x_ = x; } public: BernsteinPoly() {} virtual ~BernsteinPoly() {} explicit BernsteinPoly(const BernsteinPoly* pBernsteinPoly) { x_ = pBernsteinPoly->x_; degree_ = pBernsteinPoly->degree_; order_ = degree_ + 1; if (pBernsteinPoly->boundary_knots_.n_elem == 0) { autoset_x_and_boundary(x_); } else { check_boundary(pBernsteinPoly->boundary_knots_); } } explicit BernsteinPoly(const SplineBase* pSplineBase) { x_ = pSplineBase->get_x(); degree_ = pSplineBase->get_degree(); order_ = degree_ + 1; rvec bound_knots { pSplineBase->get_boundary_knots() }; if (bound_knots.n_elem == 0) { autoset_x_and_boundary(x_); } else { check_boundary(bound_knots); } } // explicit conversion template explicit operator T() const { T obj; obj.set_x(x_)-> set_degree(degree_)-> set_boundary_knots(boundary_knots_); return obj; } // given boundary_knots for consistency with SplineBase BernsteinPoly(const rvec& x, const unsigned int degree, const rvec& boundary_knots = rvec()) : degree_ { degree }, order_ { degree + 1 } { if (boundary_knots.n_elem == 0) { autoset_x_and_boundary(x); } else if (boundary_knots.n_elem != 2) { throw std::range_error("Need two distinct boundary knots."); } else { check_boundary(boundary_knots); check_x(x); } } // setter functions inline BernsteinPoly* set_x(const rvec& x) { check_x(x); return this; } inline BernsteinPoly* set_x(const double x) { check_x(num2vec(x)); return this; } inline BernsteinPoly* set_degree(const unsigned int degree) { degree_ = degree; order_ = degree + 1; return this; } inline BernsteinPoly* set_order(const unsigned int order) { if (order > 0) { set_degree(order - 1); } else { throw std::range_error("The 'order' must be at least 1."); } return this; } // placeholder for conversion inline BernsteinPoly* set_internal_knots(const rvec& internal_knots) { if (internal_knots.n_elem > 0) { // do nothing } return this; } inline BernsteinPoly* set_boundary_knots(const rvec& boundary_knots) { check_boundary(boundary_knots); check_x(x_); return this; } // getter functions inline rvec get_x() const { return x_; } inline unsigned int get_degree() const { return degree_; } inline unsigned int get_order() const { return order_; } inline rvec get_boundary_knots() const { return boundary_knots_; } // construct polynomial basis by recursive formula inline rmat basis(const bool complete_basis = true) { // define output matrix rmat b_mat { arma::ones(x_.n_elem, order_) }; // only do if degree >= 1 for (unsigned int k {1}; k <= degree_; ++k) { for (size_t i {0}; i < x_.n_elem; ++i) { double saved { 0 }; for (size_t j {0}; j < k; ++j) { double term { b_mat(i, j) / range_size_ }; b_mat(i, j) = saved + (boundary_knots_(1) - x_(i)) * term; saved = (x_(i) - boundary_knots_(0)) * term; } b_mat(i, k) = saved; } } if (complete_basis) { return b_mat; } // else return mat_wo_col1(b_mat); } // derivatives inline rmat derivative(const unsigned int derivs = 1, const bool complete_basis = true) { if (derivs == 0) { throw std::range_error( "'derivs' has to be a positive integer." ); } // early exit if derivs is large enough if (degree_ < derivs) { if (complete_basis) { return arma::zeros(x_.n_elem, order_); } if (order_ == 1) { throw std::range_error("No column left in the matrix."); } return arma::zeros(x_.n_elem, order_ - 1); } BernsteinPoly bp_obj2 { this }; // get basis matrix for (degree - derivs) bp_obj2.set_degree(degree_ - derivs); rmat d_mat { bp_obj2.basis(true) }; // add zero columns d_mat = add_zero_cols(d_mat, order_ - d_mat.n_cols); // derivatives by recursive formula for (unsigned int k {1}; k <= derivs; ++k) { const unsigned int k_offset { derivs - k }; const size_t numer { degree_ - k_offset }; const double numer2 { numer / range_size_ }; for (size_t i {0}; i < x_.n_elem; ++i) { double saved { 0 }; for (size_t j {0}; j < numer; ++j) { double term { numer2 * d_mat(i, j) }; d_mat(i, j) = saved - term; saved = term; } d_mat(i, numer) = saved; } } // remove the first column if needed if (complete_basis) { return d_mat; } // else return mat_wo_col1(d_mat); } // integrals inline rmat integral(const bool complete_basis = true) { BernsteinPoly bp_obj2 { this }; // get basis matrix for (degree + 1) with intercept bp_obj2.set_degree(order_); rmat i_mat { bp_obj2.basis(false) }; // integral by recursive formula const double fac { range_size_ / order_ }; for (unsigned int i {0}; i < x_.n_elem; ++i) { arma::rowvec tmp { i_mat.row(i) * fac }; i_mat.row(i) = rev_cum_sum(tmp) ; } // remove the first column if needed if (complete_basis) { return i_mat; } return mat_wo_col1(i_mat); } }; } // splines2 #endif /* SPLINES2_BERNSTEINPOLY_H */ splines2/inst/include/splines2Armadillo/SplineBase.h0000644000176200001440000004052314121502500022165 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINE2_SPLINE_BASE_H #define SPLINE2_SPLINE_BASE_H #include #include #include "common.h" #include "utils.h" namespace splines2 { // define base class for some regression splines class SplineBase { protected: // setter and getter rvec x_ = rvec(); rvec internal_knots_ = rvec(); rvec boundary_knots_ = rvec(); unsigned int degree_ = 3; unsigned int order_ = 4; // degree of freedom of complete spline basis // notice that this argument is different with the df in splines::bs() unsigned int spline_df_ = 4; // knot sequence rvec knot_sequence_ = rvec(); bool has_internal_multiplicity_ = false; bool is_knot_sequence_latest_ = false; bool is_extended_knot_sequence_ = false; // for extended knot sequence // [min(knot_sequence), max(knot_sequence)] rvec surrogate_internal_knots_; rvec surrogate_boundary_knots_; // index of x relative to internal knots uvec x_index_ = uvec(); bool is_x_index_latest_ = false; // pre-process some inputs // check knots, and do assignment inline virtual void simplify_knots( const rvec& internal_knots = rvec(), const rvec& boundary_knots = rvec() ) { // for unspecified boundary knots // 1. do generation if no boundary knots have been set // 2. or skip checks if a set of boundary knots have been set if (boundary_knots.n_elem == 0) { if (boundary_knots_.n_elem != 2 && x_.n_elem > 0) { // set boundary knots to be min(x) and max(x) double left { arma::min(x_) }; double right { arma::max(x_) }; // check if boundary knots are different if (left == right) { throw std::range_error( "Cannot set boundary knots from x." ); } boundary_knots_ = arma::zeros(2); boundary_knots_(0) = left; boundary_knots_(1) = right; } } else { // check before assigment if (boundary_knots.has_nan()) { throw std::range_error("Boundary knots cannot contain NA."); } // specified boundary knots rvec uni_boundary_knots { arma::unique(boundary_knots) }; if (uni_boundary_knots.n_elem != 2) { throw std::range_error( "Need two distinct boundary knots."); } boundary_knots_ = uni_boundary_knots; } if (internal_knots.has_nan()) { throw std::range_error("Internal knots cannot contain NA."); } // for non-empty internal knots if (internal_knots.n_elem > 0) { // check internal knots are inside boundary knots rvec sorted_internal_knots { arma::sort(internal_knots) }; double min_int_knots { sorted_internal_knots(0) }; double max_int_knots { sorted_internal_knots(sorted_internal_knots.n_elem - 1) }; if (boundary_knots_.n_elem == 2 && (boundary_knots_[0] >= min_int_knots || boundary_knots_[1] <= max_int_knots)) { throw std::range_error( "Internal knots must be set inside boundary." ); } // check multiplicity rvec tmp { arma::join_vert(sorted_internal_knots, boundary_knots_) }; has_internal_multiplicity_ = any_duplicated(tmp); internal_knots_ = sorted_internal_knots; } else { has_internal_multiplicity_ = false; internal_knots_ = rvec(); } } // compute spline df inline virtual void update_spline_df() { spline_df_ = internal_knots_.n_elem + order_; } // get simple knot sequence inline virtual rvec get_simple_knot_sequence( const rvec& internal_knots, const rvec& boundary_knots, const unsigned int order ) { rvec out { arma::zeros(internal_knots.n_elem + 2 * order) }; rvec::iterator it { out.begin() }, it_end { out.end() - 1 }; rvec::const_iterator ii { internal_knots.begin() }; for (size_t i {0}; i < order; ++i, ++it, --it_end) { *it = boundary_knots(0); *it_end = boundary_knots(1); } for (++it_end; it != it_end; ++it, ++ii) { *it = *ii; } return out; } // set simple knot sequence inline virtual void update_simple_knot_sequence() { if (is_knot_sequence_latest_ && knot_sequence_.n_elem > 0) { return; } knot_sequence_ = get_simple_knot_sequence( internal_knots_, boundary_knots_, order_ ); is_knot_sequence_latest_ = true; } // set extended knot sequence inline virtual void set_extended_knot_sequence( const rvec& knot_sequence ) { // check the length of specified knot sequence if (knot_sequence.n_elem < 2 * order_) { throw std::range_error( "The length of specified knot sequence is too small." ); } unsigned int n_internal_knots { knot_sequence.n_elem - 2 * order_ }; // sort knot sequence knot_sequence_ = arma::sort(knot_sequence); // get boundary knots boundary_knots_ = arma::zeros(2); boundary_knots_(0) = knot_sequence_(degree_); boundary_knots_(1) = knot_sequence_(knot_sequence_.n_elem - order_); if (isAlmostEqual(boundary_knots_(0), boundary_knots_(1))) { throw std::range_error( "The specified knot sequence has the same boundary knots." ); } // get internal knots if (n_internal_knots > 0) { internal_knots_ = knot_sequence_.subvec( order_, order_ + n_internal_knots - 1); // check multiplicity rvec tmp { arma::join_vert(internal_knots_, boundary_knots_) }; has_internal_multiplicity_ = any_duplicated(tmp); } else { internal_knots_ = rvec(); has_internal_multiplicity_ = false; } // set surrogate knots surrogate_boundary_knots_ = arma::zeros(2); surrogate_boundary_knots_(0) = knot_sequence_(0); surrogate_boundary_knots_(1) = knot_sequence_(knot_sequence_.n_elem - 1); surrogate_internal_knots_ = knot_sequence_.subvec(1, knot_sequence_.n_elem - 2); // check if it is actually a simple knot sequence is_extended_knot_sequence_ = ! ( isAlmostEqual(boundary_knots_(0), surrogate_boundary_knots_(0)) && isAlmostEqual(boundary_knots_(1), surrogate_boundary_knots_(1)) ); // set flags to prevent knot sequence from being updated is_knot_sequence_latest_ = true; } inline virtual void update_knot_sequence() { if (is_knot_sequence_latest_ && knot_sequence_.n_elem > 0) { return; } if (is_extended_knot_sequence_) { set_extended_knot_sequence(knot_sequence_); } else { update_simple_knot_sequence(); } } // allow x outside of boundary // let degree 0 basis take 1 outside boundary // the way to generate knot index for each x // avoids denominator = 0 inline virtual void update_x_index() { if (is_x_index_latest_ && x_index_.n_elem > 0) { return; } x_index_ = arma::zeros(x_.n_elem); arma::uvec::iterator xi { x_index_.begin() }; arma::vec::iterator it { x_.begin() }, pos, ie { x_.end() }, knots_begin { internal_knots_.begin() }, knots_end { internal_knots_.end() }; for (; it != ie; ++it, ++xi) { pos = std::upper_bound(knots_begin, knots_end, *it); *xi = std::distance(knots_begin, pos); } is_x_index_latest_ = true; } // check if simple knot sequence inline virtual void stopifnot_simple_knot_sequence() const { if (has_internal_multiplicity_ || is_extended_knot_sequence_) { throw std::range_error( "Expected a simple knot sequence." ); } } public: // the default constructor SplineBase() {} virtual ~SplineBase() {} // explicit constructor explicit SplineBase(const SplineBase* pSplineBase) : x_ { pSplineBase->x_ }, internal_knots_ { pSplineBase->internal_knots_ }, boundary_knots_ { pSplineBase->boundary_knots_ }, degree_ { pSplineBase->degree_ }, knot_sequence_ { pSplineBase->knot_sequence_ }, has_internal_multiplicity_ { pSplineBase->is_knot_sequence_latest_ }, is_knot_sequence_latest_ { pSplineBase->is_knot_sequence_latest_ }, is_extended_knot_sequence_ { pSplineBase->is_extended_knot_sequence_ }, surrogate_internal_knots_ { pSplineBase->surrogate_internal_knots_ }, surrogate_boundary_knots_ { pSplineBase->surrogate_boundary_knots_ }, x_index_ { pSplineBase->x_index_ }, is_x_index_latest_ { pSplineBase->is_x_index_latest_ } { order_ = degree_ + 1; } // constructor with specificied internal_knots SplineBase(const rvec& x, const rvec& internal_knots, const unsigned int degree = 3, const rvec& boundary_knots = rvec()) : x_ { x }, degree_ { degree } { simplify_knots(internal_knots, boundary_knots); order_ = degree_ + 1; } // constructor with specified df SplineBase(const rvec& x, const unsigned int spline_df, const unsigned int degree = 3, const rvec& boundary_knots = rvec()) : x_ { x }, degree_ { degree } { order_ = degree_ + 1; if (spline_df < order_) { throw std::range_error("The specified df was too small."); } spline_df_ = spline_df; // determine internal knots by spline_df and x unsigned int n_internal_knots { spline_df_ - order_ }; if (n_internal_knots == 0) { simplify_knots(rvec(), boundary_knots); } else { rvec prob_vec { arma::linspace(0, 1, n_internal_knots + 2) }; prob_vec = prob_vec.subvec(1, n_internal_knots); simplify_knots(rvec(), boundary_knots); // get quantiles of x within boundary only rvec x_inside { get_inside_x(x, boundary_knots_) }; rvec internal_knots { arma_quantile(x_inside, prob_vec) }; simplify_knots(internal_knots); } } // constructor for a given knot sequence SplineBase(const rvec& x, const unsigned int degree, const rvec& knot_sequence) { x_ = x; degree_ = degree; order_ = degree_ + 1; set_extended_knot_sequence(knot_sequence); } // function members // "setter" functions inline virtual SplineBase* set_x(const rvec& x) { x_ = x; is_x_index_latest_ = false; return this; } inline virtual SplineBase* set_x(const double x) { x_ = num2vec(x); is_x_index_latest_ = false; return this; } inline virtual SplineBase* set_internal_knots( const rvec& internal_knots ) { if (! is_approx_equal(internal_knots_, internal_knots)) { simplify_knots(internal_knots); update_spline_df(); is_knot_sequence_latest_ = false; is_x_index_latest_ = false; } return this; } inline virtual SplineBase* set_boundary_knots( const rvec& boundary_knots ) { if (! is_approx_equal(boundary_knots_, boundary_knots)) { simplify_knots(internal_knots_, boundary_knots); is_knot_sequence_latest_ = false; is_x_index_latest_ = false; } return this; } inline virtual SplineBase* set_knot_sequence( const rvec& knot_sequence ) { if (! is_approx_equal(knot_sequence_, knot_sequence)) { set_extended_knot_sequence(knot_sequence); } return this; } inline virtual SplineBase* set_degree( const unsigned int degree ) { if (degree_ != degree) { degree_ = degree; order_ = degree + 1; update_spline_df(); if (is_extended_knot_sequence_) { set_extended_knot_sequence(knot_sequence_); } else { is_knot_sequence_latest_ = false; } } return this; } inline virtual SplineBase* set_order(const unsigned int order) { if (order > 0) { set_degree(order - 1); } else { throw std::range_error("The 'order' must be at least 1."); } return this; } // "getter" functions inline rvec get_x() const { return x_; } inline rvec get_internal_knots() const { return internal_knots_; } inline rvec get_boundary_knots() const { return boundary_knots_; } inline rvec get_knot_sequence() { update_knot_sequence(); return knot_sequence_; } inline unsigned int get_degree() const { return degree_; } inline unsigned int get_order() const { return order_; } inline unsigned int get_spline_df() { update_spline_df(); return spline_df_; } // define pure virtual functions inline virtual rmat basis( const bool complete_basis = true ) = 0; inline virtual rmat derivative( const unsigned int derivs = 1, const bool complete_basis = true ) = 0; inline virtual rmat integral( const bool complete_basis = true ) = 0; }; } #endif splines2/inst/include/splines2Armadillo/ISpline.h0000644000176200001440000000730214121502500021501 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_ISPLINE_H #define SPLINES2_ISPLINE_H #include #include "common.h" #include "utils.h" #include "SplineBase.h" #include "BSpline.h" #include "MSpline.h" namespace splines2 { // define a class for M-splines class ISpline : public SplineBase { protected: inline rmat get_integral_simple() { BSpline bsp_obj { this }; bsp_obj.set_degree(degree_ + 1); rmat i_mat { bsp_obj.integral(false) }; update_x_index(); // for each row of i_mat for (size_t i {0}; i < x_.n_elem; ++i) { size_t k2 { x_index_(i) + degree_ }; arma::rowvec numer { i_mat(i, arma::span(0, k2)) }; numer = rev_cum_sum(numer); for (size_t j {0}; j < i_mat.n_cols; ++j) { if (j > k2) { i_mat(i, j) = 0.0; } else { i_mat(i, j) = numer(j); } } } return i_mat; } inline rmat get_integral_extended() { ISpline isp_obj { x_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat out { isp_obj.get_integral_simple() }; // remove first and last #degree basis functions return out.cols(degree_, out.n_cols - order_); } public: // inherits constructors using SplineBase::SplineBase; // function members //! Compute I-spline basis //! //! @param complete_basis A `bool` value indicating whether to return a //! complete spline basis //! //! @return arma::mat inline rmat basis(const bool complete_basis = true) override { MSpline msp_obj { this }; rmat out { msp_obj.integral(true) }; if (complete_basis) { return out; } return mat_wo_col1(out); } inline rmat derivative(const unsigned int derivs = 1, const bool complete_basis = true) override { if (derivs == 0) { throw std::range_error( "'derivs' has to be a positive integer."); } MSpline msp_obj { this }; if (derivs == 1) { return msp_obj.basis(complete_basis); } return msp_obj.derivative(derivs - 1, complete_basis); } inline rmat integral(const bool complete_basis = true) override { rmat i_mat; if (is_extended_knot_sequence_) { i_mat = get_integral_extended(); } else { i_mat = get_integral_simple(); } // remove the first column if needed if (complete_basis) { return i_mat; } return mat_wo_col1(i_mat); } }; } // splines2 #endif /* SPLINES2_ISPLINE_H */ splines2/inst/include/splines2Armadillo/utils.h0000644000176200001440000001471214121502500021301 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_UTILS_H #define SPLINES2_UTILS_H #include // std::max, std::set_union, etc. #include // std::pow and std::sqrt, etc. #include #include #include #include #include #include #include // #include #include namespace splines2 { // compare double-precision numbers for almost equality inline bool isAlmostEqual(double A, double B = 0.0) { const double MaxRelDiff { std::numeric_limits::epsilon() }; // compute the difference. double diff = std::abs(A - B); A = std::abs(A); B = std::abs(B); // Find the largest double largest = (B > A) ? B : A; if (diff <= largest * MaxRelDiff) { return true; } return false; } template inline bool is_approx_equal(const T& A, const T& B) { const double MaxRelDiff { std::numeric_limits::epsilon() }; return arma::approx_equal(A, B, "reldiff", MaxRelDiff); } template // function checking if there exists any duplicates inline bool any_duplicated(const T& x) { std::unordered_set seen; bool res {false}; for (size_t i {0}; i < x.n_rows; ++i) { res = ! seen.insert(x(i)).second; if (res) break; } return res; } // cumulative sum in possibly reverse order> template inline T rev_cum_sum(const T& x) { const unsigned long int n_x {x.n_elem}; T res { arma::zeros(n_x) }; double tmp {0.0}; for (size_t i {1}; i <= n_x; ++i) { tmp += x[n_x - i]; res[n_x - i] = tmp; } return res; } template inline T get_inside_x(const T& x, const arma::vec& boundary_knots) { std::vector res; for (size_t i {0}; i < x.n_elem; ++i) { if (x(i) >= boundary_knots(0) && x(i) <= boundary_knots(1)) { res.push_back(x(i)); } } return T(res); } // quantile function // reference: Hyndman and Fan (1996) inline arma::vec arma_quantile(const arma::vec& x, const arma::vec& probs, const unsigned int type = 7) { double alpha { 0 }, beta { 0 }; switch(type) { case 4: beta = 1.0; break; case 5: alpha = beta = 0.5; break; case 6: break; default: case 7: alpha = beta = 1.0; break; case 8: alpha = beta = 1.0 / 3; break; case 9: alpha = beta = 3.0 / 8; break; } const long n { static_cast(x.n_elem) }; arma::vec inc_x { arma::sort(x) }; arma::vec res { arma::zeros(probs.n_elem) }; double fuzz { std::numeric_limits::epsilon() }; for (size_t i {0}; i < probs.n_elem; ++i) { // n * p + m double nppm { alpha + probs(i) * (n + 1 - alpha - beta) }; double j { std::floor(nppm + fuzz) }; double h { nppm - j }; long lj { static_cast(j) }; if (lj == 0) { res(i) = x.min(); continue; } if (lj >= n) { res(i) = x.max(); continue; } res(i) = (1 - h) * inc_x(lj - 1) + h * inc_x(lj); } return res; } // inline handy functions inline arma::vec mat2vec(const arma::mat& x) { return arma::conv_to::from(x); } inline arma::rowvec mat2rowvec(const arma::mat& x) { return arma::conv_to::from(x); } inline arma::vec num2vec(const double x) { arma::vec out { arma::zeros(1) }; out(0) = x; return out; } // convert arma vector type to Rcpp vector type template inline Rcpp::NumericVector arma2rvec(const T& x) { return Rcpp::NumericVector(x.begin(), x.end()); } // convert Rcpp::NumericVector to arma::colvec template inline arma::vec rvec2arma(const T& x) { return arma::vec(x.begin(), x.size(), false); } // convert arma matrix type to Rcpp matrix type inline Rcpp::NumericMatrix arma2rmat(const arma::mat& x) { return Rcpp::NumericMatrix(x.n_rows, x.n_cols, x.begin()); } // convert Rcpp matrix to arma matrix // cannot add const to x inline arma::mat rmat2arma(Rcpp::NumericMatrix& x) { return arma::mat(x.begin(), x.nrow(), x.ncol(), false); } // function to remove the first column of a matrix template inline T mat_wo_col1(const T& x) { const arma::uword x_ncol { x.n_cols }; if (x_ncol > 1) { return x.tail_cols(x_ncol - 1); } // else throw std::range_error("No column left in the matrix."); return T(); } // function to add zero columns to the end of a matrix inline arma::mat add_zero_cols(const arma::mat& x, const unsigned int n_cols = 1) { // create zero matrix arma::mat mat2 { arma::zeros(x.n_rows, n_cols) }; return arma::join_rows(x, mat2); } // create a character vector ("1", ...) of a given length inline Rcpp::CharacterVector char_seq_len(const unsigned int n) { Rcpp::CharacterVector out { n }; for (size_t i {0}; i < n; ++i) { out[i] = std::to_string(i + 1); } return out; } } #endif splines2/inst/include/splines2Armadillo/MSpline.h0000644000176200001440000002471214121502500021511 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_MSPLINE_H #define SPLINES2_MSPLINE_H #include #include "common.h" #include "utils.h" #include "SplineBase.h" namespace splines2 { // define a class for M-splines class MSpline : public SplineBase { protected: inline rmat get_basis_simple() { update_spline_df(); update_x_index(); update_knot_sequence(); // define output matrix rmat b_mat { arma::zeros(x_.n_elem, spline_df_) }; // generate basis of degree 0 for (size_t i {0}; i < x_.n_elem; ++i) { unsigned int j { x_index_(i) }; double denom { knot_sequence_(j + order_) - knot_sequence_(j + degree_) }; b_mat(i, j) = 1 / denom; } // main loop for (unsigned int k {1}; k <= degree_; ++k) { double dk { static_cast(k) }; double dk1 { (1.0 + 1.0 / dk) }; const unsigned int k_offset { degree_ - k }; // use the Cox-de Boor recursive formula for (size_t i {0}; i < x_.n_elem; ++i) { double saved { 0 }; // for each x, at most "order" columns are not zero // basis(x) is not zero from t_ii to t_{ii+k+1} // where ii is index of x in terms of basis for (size_t j {0}; j < k; ++j) { size_t j_index { x_index_(i) + j }; size_t i1 { j_index + k_offset }; size_t i2 { j_index + order_ }; double den { knot_sequence_(i2) - knot_sequence_(i1) }; double term { dk1 * b_mat(i, j_index) }; b_mat(i, j_index) = saved + (knot_sequence_(i2) - x_(i)) * term / den; double den2 { knot_sequence_(i2 + 1) - knot_sequence_(i1 + 1) }; saved = (x_(i) - knot_sequence_(i1 + 1)) * term / den2; } b_mat(i, x_index_(i) + k) = saved; } } return b_mat; } inline rmat get_basis_extended() { MSpline msp_obj { x_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat out { msp_obj.get_basis_simple() }; // remove first and last #degree basis functions return out.cols(degree_, out.n_cols - order_); } inline rmat get_derivative_simple( const unsigned int derivs = 1 ) { MSpline msp_obj { this }; msp_obj.set_degree(degree_ - derivs); // get basis matrix for (degree - derivs) rmat d_mat { msp_obj.get_basis_simple() }; // make sure knot sequence and x index are latest update_knot_sequence(); update_x_index(); // add zero columns update_spline_df(); // if (spline_df_ <= d_mat.n_cols) { // throw std::range_error("FIXME: get_derivative_simple()"); // } d_mat = add_zero_cols(d_mat, spline_df_ - d_mat.n_cols); // main loop for (unsigned int k {1}; k <= derivs; ++k) { const unsigned int k_offset { derivs - k }; const size_t numer { degree_ - k_offset }; for (size_t i {0}; i < x_.n_elem; ++i) { double saved { 0 }; for (size_t j {0}; j < numer; ++j) { size_t j_index { x_index_(i) + j }; size_t i1 { j_index + k_offset }; size_t i2 { j_index + order_ }; double den { knot_sequence_(i2) - knot_sequence_(i1) }; double term { (numer + 1) * d_mat(i, j_index) }; d_mat(i, j_index) = saved - term / den; double den2 { knot_sequence_(i2 + 1) - knot_sequence_(i1 + 1) }; saved = term / den2; } d_mat(i, x_index_(i) + numer) = saved; } } return d_mat; } inline rmat get_derivative_extended( const unsigned int derivs = 1 ) { MSpline msp_obj { x_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat out { msp_obj.get_derivative_simple(derivs) }; // remove first and last #degree basis functions return out.cols(degree_, out.n_cols - order_); } inline rmat get_integral_simple() { // create a copy of this object MSpline msp_obj { this }; // get basis matrix for (degree - derivs) msp_obj.set_degree(degree_ + 1); rmat i_mat { msp_obj.basis(false) }; rvec knot_sequence_ord { msp_obj.get_knot_sequence() }; // throw warning if any x is less than left-most boundary // if (arma::any(x_ < msp_obj.knot_sequence_(0))) { // Rcpp::Rcout << "Warning: Found x < the leftmost knot, " // << msp_obj.knot_sequence_(0) // << ". " // << "The basis integrals were not well-defined." // << std::endl; // } // make sure x index is latest update_x_index(); // compute t_{(i+1)+(k+1)+1} - t_{i+1} of s_{k} // which equals t_{(i+1)+(k+1)+2} - t_{(i+1)+1} of s_{k+1} arma::rowvec numer1 { arma::zeros(i_mat.n_cols) }; for (size_t j { 0 }; j < numer1.n_elem; ++j) { numer1(j) = knot_sequence_ord(j + order_ + 2) - knot_sequence_ord(j + 1); } // for each row of i_mat for (size_t i {0}; i < x_.n_elem; ++i) { size_t k1 { x_index_(i) }, k2 { k1 + degree_ }; arma::rowvec numer2 { i_mat(i, arma::span(k1, k2)) }; arma::rowvec numer { numer1.cols(k1, k2) % numer2 }; numer = rev_cum_sum(numer); for (size_t j {0}; j < i_mat.n_cols; ++j) { if (j > k2) { i_mat(i, j) = 0.0; } else if (j >= k1) { i_mat(i, j) = numer(j - k1) / (order_ + 1); } else { i_mat(i, j) = 1.0; } } } return i_mat; } inline rmat get_integral_extended() { MSpline msp_obj { x_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat out { msp_obj.get_integral_simple() }; // remove first and last #degree basis functions return out.cols(degree_, out.n_cols - order_); } public: // inherits constructors using SplineBase::SplineBase; // function members //! Compute M-spline basis //! //! @param complete_basis A `bool` value indicating whether to return a //! complete spline basis //! //! @return arma::mat inline rmat basis(const bool complete_basis = true) override { rmat b_mat; if (is_extended_knot_sequence_) { b_mat = get_basis_extended(); } else { b_mat = get_basis_simple(); } // about to return if (complete_basis) { return b_mat; } // else return mat_wo_col1(b_mat); } // derivatives of M-splines inline rmat derivative( const unsigned int derivs = 1, const bool complete_basis = true ) override { if (derivs == 0) { throw std::range_error( "'derivs' has to be a positive integer."); } // early exit if derivs is large enough update_spline_df(); if (degree_ < derivs) { if (complete_basis) { return arma::zeros(x_.n_elem, spline_df_); } if (spline_df_ == 1) { throw std::range_error("No column left in the matrix."); } return arma::zeros(x_.n_elem, spline_df_ - 1); } rmat d_mat; if (is_extended_knot_sequence_) { d_mat = get_derivative_extended(derivs); } else { d_mat = get_derivative_simple(derivs); } // remove the first column if needed if (complete_basis) { return d_mat; } // else return mat_wo_col1(d_mat); } // integral of M-splines (I-splines) inline rmat integral(const bool complete_basis = true) override { rmat i_mat; if (is_extended_knot_sequence_) { i_mat = get_integral_extended(); } else { i_mat = get_integral_simple(); } // remove the first column if needed if (complete_basis) { return i_mat; } return mat_wo_col1(i_mat); } }; } // splines2 #endif /* SPLINES2_MSPLINE_H */ splines2/inst/include/splines2Armadillo/BSpline.h0000644000176200001440000002351314121502500021474 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_BSPLINE_H #define SPLINES2_BSPLINE_H #include #include "common.h" #include "utils.h" #include "SplineBase.h" namespace splines2 { // define a class for B-splines class BSpline : public SplineBase { protected: inline rmat get_basis_simple() { update_spline_df(); update_x_index(); // define output matrix rmat b_mat { arma::zeros(x_.n_elem, spline_df_) }; // generate basis of degree 0 for (size_t i {0}; i < x_.n_elem; ++i) { b_mat(i, x_index_(i)) = 1; } // only need knot sequence for degree > 0 unless extended if (degree_ > 0) { update_knot_sequence(); } for (unsigned int k {1}; k <= degree_; ++k) { const unsigned int k_offset { degree_ - k }; // use the Cox-de Boor recursive formula for (size_t i {0}; i < x_.n_elem; ++i) { double saved { 0.0 }; // for each x, at most "order" columns are not zero // basis_j(x) is not zero from t_j to t_{j+k+1} // where j is index of x in terms of basis // knot sequence: t0, t1, t2, ... for (size_t j {0}; j < k; ++j) { size_t j_index { x_index_(i) + j }; size_t i1 { j_index + k_offset + 1 }; size_t i2 { j_index + order_ }; double den { knot_sequence_(i2) - knot_sequence_(i1) }; // if (isAlmostEqual(den)) { // if (j != 0 || knot_sequence_(i2) - x_(i) != 0) { // b_mat(i, j_index) = saved; // } // saved = 0.0; // } else { // no need to check for distinct internal knots double term { b_mat(i, j_index) / den }; b_mat(i, j_index) = saved + (knot_sequence_(i2) - x_(i)) * term; saved = (x_(i) - knot_sequence_(i1)) * term; // } } b_mat(i, x_index_(i) + k) = saved; } } return b_mat; } inline rmat get_basis_extended() { BSpline bsp_obj { x_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat out { bsp_obj.get_basis_simple() }; // remove first and last #degree basis functions return out.cols(degree_, out.n_cols - order_); } inline rmat get_derivative_simple( const unsigned int derivs = 1 ) { // create a copy of this object BSpline bsp_obj { this }; bsp_obj.set_degree(degree_ - derivs); // get basis matrix for (degree - derivs) rmat d_mat { bsp_obj.get_basis_simple() }; // make sure knot sequence and x index are latest update_knot_sequence(); update_x_index(); // add zero columns update_spline_df(); // if (spline_df_ <= d_mat.n_cols) { // throw std::range_error("FIXME: get_derivative_simple()"); // } d_mat = add_zero_cols(d_mat, spline_df_ - d_mat.n_cols); for (unsigned int k {1}; k <= derivs; ++k) { const unsigned int k_offset { derivs - k }; const size_t numer { degree_ - k_offset }; for (size_t i {0}; i < x_.n_elem; ++i) { double saved { 0 }; for (size_t j {0}; j < numer; ++j) { size_t j_index { x_index_(i) + j }; size_t i1 { j_index + k_offset + 1 }; size_t i2 { j_index + order_ }; double den { knot_sequence_(i2) - knot_sequence_(i1) }; double term { numer * d_mat(i, j_index) / den }; d_mat(i, j_index) = saved - term; saved = term; } d_mat(i, x_index_(i) + numer) = saved; } } return d_mat; } inline rmat get_derivative_extended( const unsigned int derivs = 1 ) { BSpline bsp_obj { x_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat out { bsp_obj.get_derivative_simple(derivs) }; // remove first and last #degree basis functions return out.cols(degree_, out.n_cols - order_); } inline rmat get_integral_simple() { // create a copy of this object BSpline bsp_obj { this }; bsp_obj.set_degree(degree_ + 1); rmat i_mat { bsp_obj.basis(false) }; rvec knot_sequence_ord { bsp_obj.get_knot_sequence() }; // make sure x index are latest update_x_index(); // compute t_{(i+1)+k+1} - t_{i+1} of s_{k} // which is t_{(i+1)+(k+1)+1} - t_{(i+1)+1} of s_{k+1} arma::rowvec numer1 { arma::zeros(i_mat.n_cols) }; for (size_t j { 0 }; j < numer1.n_elem; ++j) { numer1(j) = knot_sequence_ord(j + order_ + 1) - knot_sequence_ord(j + 1); } // for each row of i_mat for (size_t i {0}; i < x_.n_elem; ++i) { size_t k1 { x_index_(i) }, k2 { k1 + degree_ }; arma::rowvec numer2 { i_mat(i, arma::span(k1, k2)) }; numer2 = rev_cum_sum(numer2); for (size_t j {0}; j < i_mat.n_cols; ++j) { if (j > k2) { i_mat(i, j) = 0; } else if (j >= k1) { i_mat(i, j) = numer2(j - k1) * numer1(j) / order_; } else { i_mat(i, j) = numer1(j) / order_; } } } return i_mat; } inline rmat get_integral_extended() { BSpline bsp_obj { x_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat out { bsp_obj.get_integral_simple() }; // remove first and last #degree basis functions return out.cols(degree_, out.n_cols - order_); } public: // inherits constructors using SplineBase::SplineBase; // function members //! Compute B-spline basis functions //! //! @param complete_basis A `bool` value indicating whether to return a //! complete spline basis //! //! @return arma::mat inline rmat basis(const bool complete_basis = true) override { rmat b_mat; if (is_extended_knot_sequence_) { b_mat = get_basis_extended(); } else { b_mat = get_basis_simple(); } // about to return if (complete_basis) { return b_mat; } // else return mat_wo_col1(b_mat); } // derivatives of B-splines inline rmat derivative( const unsigned int derivs = 1, const bool complete_basis = true ) override { if (derivs == 0) { throw std::range_error( "'derivs' has to be a positive integer."); } // early exit if derivs is large enough update_spline_df(); if (degree_ < derivs) { if (complete_basis) { return arma::zeros(x_.n_elem, spline_df_); } if (spline_df_ == 1) { throw std::range_error("No column left in the matrix."); } return arma::zeros(x_.n_elem, spline_df_ - 1); } rmat d_mat; if (is_extended_knot_sequence_) { d_mat = get_derivative_extended(derivs); } else { d_mat = get_derivative_simple(derivs); } // remove the first column if needed if (complete_basis) { return d_mat; } // else return mat_wo_col1(d_mat); } // integral of B-splines inline rmat integral(const bool complete_basis = true) override { rmat i_mat; if (is_extended_knot_sequence_) { i_mat = get_integral_extended(); } else { i_mat = get_integral_simple(); } // remove the first column if needed if (complete_basis) { return i_mat; } return mat_wo_col1(i_mat); } }; } #endif splines2/inst/include/splines2Armadillo/CSpline.h0000644000176200001440000000706414121502500021500 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_CSPLINE_H #define SPLINES2_CSPLINE_H #include #include "common.h" #include "utils.h" #include "SplineBase.h" #include "MSpline.h" #include "ISpline.h" namespace splines2 { // define a class for M-splines class CSpline : public SplineBase { private: // hide pure virtual function for integral here inline rmat integral(const bool complete_basis = true) override { if (complete_basis) { // do nothing } return rmat(); } protected: arma::rowvec scales_; // compute scales inline void compute_scales() { ISpline isp_obj { this }; scales_ = mat2rowvec( isp_obj.set_x(boundary_knots_(1))->integral(true) ); } inline rmat apply_scales(const rmat& x) { return x.each_row() / scales_; } public: // inherits constructors using SplineBase::SplineBase; // additional function members inline arma::rowvec get_scales() { return scales_; } //! Compute I-spline basis //! //! @param complete_basis A `bool` value indicating whether to return a //! complete spline basis //! //! @return arma::mat inline rmat basis(const bool complete_basis = true) override { ISpline isp_obj { this }; rmat out { isp_obj.integral(true) }; // compute the scale on the right boundary knot scales_ = mat2rowvec( isp_obj.set_x(boundary_knots_(1))->integral(true) ); // rescale each column out.each_row() /= scales_; if (complete_basis) { return out; } return mat_wo_col1(out); } inline rmat derivative(const unsigned int derivs = 1, const bool complete_basis = true) override { if (derivs == 0) { throw std::range_error( "'derivs' has to be a positive integer." ); } // compute scales compute_scales(); if (derivs == 1) { // I-spline ISpline isp_obj { this }; return apply_scales( isp_obj.basis(complete_basis) ); } // else derivs >= 2 MSpline msp_obj { this }; if (derivs == 2) { return apply_scales( msp_obj.basis(complete_basis) ); } // else derivs >= 3 return apply_scales( msp_obj.derivative(derivs - 2, complete_basis) ); } }; } // spline2 #endif /* SPLINES2_CSPLINE_H */ splines2/inst/include/splines2Armadillo/NaturalSpline.h0000644000176200001440000003430314121502500022720 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_NATURALSPLINE_H #define SPLINES2_NATURALSPLINE_H #include #include "common.h" #include "utils.h" #include "SplineBase.h" #include "BSpline.h" namespace splines2 { // define a class for Natural splines class NaturalSpline : public SplineBase { protected: rmat null_colvecs_; // indices of x placed outside of boundary (left/right) bool is_x_outside_latest_ = false; uvec x_outside_left_; uvec x_outside_right_; using SplineBase::SplineBase; // get null space vector for the second derivatives // of B-spline basis on boundary knotsn // the results depend on knot sequence only inline void set_null_colvecs(bool standardize = true) { null_colvecs_ = arma::zeros(spline_df_ + 2, spline_df_); size_t n_knots { internal_knots_.n_elem }; if (n_knots == 0) { // without any internal knot null_colvecs_(0, 0) = 3.0; null_colvecs_(1, 0) = 2.0; null_colvecs_(2, 0) = 1.0; null_colvecs_(1, 1) = 1.0; null_colvecs_(2, 1) = 2.0; null_colvecs_(3, 1) = 3.0; } else if (n_knots == 1) { // with only one internal knot null_colvecs_(0, 0) = 1.0 + (internal_knots_(0) - boundary_knots_(0)) / (boundary_knots_(1) - boundary_knots_(0)); null_colvecs_(1, 0) = 1.0; null_colvecs_(1, 1) = 1.0 / (1.0 / (internal_knots_(0) - boundary_knots_(0)) + 1.0); null_colvecs_(2, 1) = 1.0; null_colvecs_(3, 1) = 1.0 / (1.0 / (boundary_knots_(1) - internal_knots_(0)) + 1.0); null_colvecs_(3, 2) = 1.0; null_colvecs_(4, 2) = 1.0 + (boundary_knots_(1) - internal_knots_(0)) / (boundary_knots_(1) - boundary_knots_(0)); } else { // with at least two internal knots for (size_t i {0}; i < 3; ++i) { null_colvecs_(i, 0) = 1.0; null_colvecs_(spline_df_ - i + 1, 1) = 1.0; } null_colvecs_(1, 2) = 1.0; null_colvecs_(2, 2) = 1.0 + (internal_knots_(1) - boundary_knots_(0)) / (internal_knots_(0) - boundary_knots_(0)); null_colvecs_(spline_df_ - 1, 3) = 1.0 + (boundary_knots_(1) - internal_knots_(n_knots - 2)) / (boundary_knots_(1) - internal_knots_(n_knots - 1)); null_colvecs_(spline_df_, 3) = 1.0; if (spline_df_ > 4) { for (size_t j {3}; j < spline_df_ - 1; ++j) { null_colvecs_(j, j + 1) = 1.0; } } } // standardize coefficient for each column if (standardize) { size_t ncol_out { null_colvecs_.n_cols }; for (size_t j {0}; j < ncol_out; ++j) { null_colvecs_.col(j) /= arma::sum(null_colvecs_.col(j)); } } } // update x index for outside inline void update_x_outside() { if (! is_x_outside_latest_) { x_outside_left_ = arma::find(x_ < boundary_knots_(0)); x_outside_right_ = arma::find(x_ > boundary_knots_(1)); is_x_outside_latest_ = true; } } // compute spline df inline void update_spline_df() override { spline_df_ = internal_knots_.n_elem + 2; } public: // the default constructor NaturalSpline() {} // explicit constructor explicit NaturalSpline(const SplineBase* pSplineBase) : SplineBase(pSplineBase) { stopifnot_simple_knot_sequence(); degree_ = 3; order_ = 4; update_spline_df(); this->set_null_colvecs(); update_x_outside(); } // constructor with specificied internal_knots NaturalSpline(const rvec& x, const rvec& internal_knots, const rvec& boundary_knots = rvec()) { x_ = x; degree_ = 3; order_ = 4; simplify_knots(internal_knots, boundary_knots); update_spline_df(); update_x_outside(); } // constructor with specified df NaturalSpline(const rvec& x, const unsigned int spline_df, const rvec& boundary_knots = rvec()) { x_ = x; degree_ = 3; order_ = 4; if (spline_df < 2) { // df has to be at least 2 (order - 2) throw std::range_error("The specified df was too small."); } spline_df_ = spline_df; // determine internal knots by spline_df and x unsigned int n_internal_knots { spline_df_ - 2 }; if (n_internal_knots == 0) { simplify_knots(rvec(), boundary_knots); } else { rvec prob_vec { arma::linspace(0, 1, n_internal_knots + 2) }; prob_vec = prob_vec.subvec(1, n_internal_knots); simplify_knots(rvec(), boundary_knots); // get quantiles of x within boundary only rvec x_inside { get_inside_x(x, boundary_knots_) }; rvec internal_knots { arma_quantile(x_inside, prob_vec) }; simplify_knots(internal_knots); } update_x_outside(); } // function members //! Compute Natural-spline basis based on B-spline //! //! @param complete_basis A `bool` value indicating whether to return a //! complete spline basis //! //! @return arma::mat inline rmat basis(const bool complete_basis = true) override { stopifnot_simple_knot_sequence(); this->set_null_colvecs(); BSpline bs_obj { this }; rmat bsMat { bs_obj.basis(true) }; // precess x outside of boundary update_x_outside(); if (x_outside_left_.n_elem > 0 || x_outside_right_.n_elem > 0) { BSpline bs_tmp; bs_tmp.set_degree(3); bs_tmp.set_internal_knots(internal_knots_); bs_tmp.set_boundary_knots(boundary_knots_); if (x_outside_left_.n_elem > 0) { bs_tmp.set_x(boundary_knots_(0)); rmat tt1 { bs_tmp.basis(true) }; rmat tt2 { bs_tmp.derivative(true) }; for (size_t k {0}; k < x_outside_left_.n_elem; ++k) { size_t idx { x_outside_left_(k) }; bsMat.row(idx) = tt1 + tt2 * (x_(idx) - boundary_knots_(0)); } } if (x_outside_right_.n_elem > 0) { bs_tmp.set_x(boundary_knots_(1)); rmat tt1 { bs_tmp.basis(true) }; rmat tt2 { bs_tmp.derivative(true) }; for (size_t k {0}; k < x_outside_right_.n_elem; ++k) { size_t idx { x_outside_right_(k) }; bsMat.row(idx) = tt1 + tt2 * (x_(idx) - boundary_knots_(1)); } } } // apply null space bsMat *= null_colvecs_; if (complete_basis) { return bsMat; } // else return mat_wo_col1(bsMat); } inline rmat derivative(const unsigned int derivs = 1, const bool complete_basis = true) override { stopifnot_simple_knot_sequence(); this->set_null_colvecs(); BSpline bs_obj { this }; rmat bsMat { bs_obj.derivative(derivs, true) }; // precess x outside of boundary update_x_outside(); if (x_outside_left_.n_elem > 0 || x_outside_right_.n_elem > 0) { if (derivs > 1) { arma::rowvec zero_row { arma::zeros(bsMat.n_cols) }; if (x_outside_left_.n_elem > 0) { for (size_t k {0}; k < x_outside_left_.n_elem; ++k) { size_t idx { x_outside_left_(k) }; bsMat.row(idx) = zero_row; } } if (x_outside_right_.n_elem > 0) { for (size_t k {0}; k < x_outside_right_.n_elem; ++k) { size_t idx { x_outside_right_(k) }; bsMat.row(idx) = zero_row; } } } else { // derivs = 1 BSpline bs_tmp; bs_tmp.set_degree(3); bs_tmp.set_internal_knots(internal_knots_); bs_tmp.set_boundary_knots(boundary_knots_); if (x_outside_left_.n_elem > 0) { bs_tmp.set_x(boundary_knots_(0)); rmat tt2 { bs_tmp.derivative(true) }; for (size_t k {0}; k < x_outside_left_.n_elem; ++k) { size_t idx { x_outside_left_(k) }; bsMat.row(idx) = tt2; } } if (x_outside_right_.n_elem > 0) { bs_tmp.set_x(boundary_knots_(1)); rmat tt2 { bs_tmp.derivative(true) }; for (size_t k {0}; k < x_outside_right_.n_elem; ++k) { size_t idx { x_outside_right_(k) }; bsMat.row(idx) = tt2; } } } } // apply null space rmat out { bsMat * null_colvecs_ }; if (complete_basis) { return out; } // else return mat_wo_col1(out); } inline rmat integral(const bool complete_basis = true) override { stopifnot_simple_knot_sequence(); this->set_null_colvecs(); BSpline bs_obj { this }; rmat bsMat { bs_obj.integral(true) }; // precess x outside of boundary update_x_outside(); if (x_outside_left_.n_elem > 0 || x_outside_right_.n_elem > 0) { // integrate from left boundary if (x_outside_left_.n_elem > 0) { arma::rowvec zero_row { arma::zeros(bsMat.n_cols) }; for (size_t k {0}; k < x_outside_left_.n_elem; ++k) { size_t idx { x_outside_left_(k) }; bsMat.row(idx) = zero_row; } } if (x_outside_right_.n_elem > 0) { BSpline bs_tmp; bs_tmp.set_degree(3); bs_tmp.set_internal_knots(internal_knots_); bs_tmp.set_boundary_knots(boundary_knots_); bs_tmp.set_x(boundary_knots_(1)); arma::rowvec right_row { bs_obj.set_x(boundary_knots_(1))->integral(true).row(0) }; rmat tt1 { bs_tmp.basis(true) }; rmat tt2 { bs_tmp.derivative(true) }; for (size_t k {0}; k < x_outside_right_.n_elem; ++k) { size_t idx { x_outside_right_(k) }; double tmp { x_(idx) - boundary_knots_(1) }; bsMat.row(idx) = right_row + tt1 * tmp + 0.5 * tt2 * tmp * tmp; } } } // apply null space rmat out { bsMat * null_colvecs_ }; if (complete_basis) { return out; } // else return mat_wo_col1(out); } // re-define some "setter" functions inline NaturalSpline* set_x(const rvec& x) override { x_ = x; is_x_index_latest_ = false; is_x_outside_latest_ = false; return this; } inline NaturalSpline* set_x(const double x) override { x_ = num2vec(x); is_x_index_latest_ = false; is_x_outside_latest_ = false; return this; } inline NaturalSpline* set_boundary_knots( const rvec& boundary_knots ) override { simplify_knots(internal_knots_, boundary_knots); is_knot_sequence_latest_ = false; is_x_index_latest_ = false; is_x_outside_latest_ = false; return this; } // placeholders inline NaturalSpline* set_degree(const unsigned int degree) override { if (degree) { // do nothing } return this; } inline NaturalSpline* set_order(const unsigned int order) override { if (order) { // do nothing } return this; } }; } // splines2 #endif /* SPLINES2_NATURALSPLINE_H */ splines2/inst/include/splines2Armadillo/common.h0000644000176200001440000000166714121502500021436 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_COMMON_H #define SPLINES2_COMMON_H #include namespace splines2 { typedef arma::vec rvec; typedef arma::mat rmat; typedef arma::ivec ivec; typedef arma::uvec uvec; } // splines2 #endif /* SPLINES2_COMMON_H */ splines2/inst/include/splines2Armadillo/PeriodicMSpline.h0000644000176200001440000002603014121502500023163 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2021 // // This file is part of the R package splines2. // // The R package splines2 is free software: You can redistribute it and/or // modify it under the terms of the GNU General Public License as published by // the Free Software Foundation, either version 3 of the License, or any later // version (at your option). See the GNU General Public License at // for details. // // The R package splines2 is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // #ifndef SPLINES2_PERIODICMSPLINE_H #define SPLINES2_PERIODICMSPLINE_H #include #include "common.h" #include "utils.h" #include "SplineBase.h" #include "MSpline.h" namespace splines2 { // define a class for nonnegative periodic spline basis over [a, b] // with unit integral over [a, b] based on M-splines class PeriodicMSpline : public SplineBase { protected: double range_size_; // b - a rvec x_in_range_; // x in range rvec x_num_shift_; // x_ = x_in_range + x_num_shift * range_size bool is_x_in_range_latest_ = false; // compute range size given boundary knots inline void update_range_size() { range_size_ = boundary_knots_(1) - boundary_knots_(0); } // compute spline df inline void update_spline_df() override { spline_df_ = internal_knots_.n_elem + 1; } // extend knot sequence for periodic splines // reference: // - Farin, G., & Hansford, D. (2000). The essentials of CAGD. // - Schumaker, L. (2007). Spline functions: Basic theory. // - splines::splineDesign() when outer.ok = TRUE // - Piegl, L., & Tiller, W. (1997). The NURBS book. Springer inline void extend_knot_sequence() { // number of internal knots must >= degree if (internal_knots_.n_elem + 1 < degree_) { throw std::range_error( "The number of unique internal knots must be >= degree - 1." ); } // extend to distinct knot sequence first rvec res { arma::zeros(internal_knots_.n_elem + 2 * order_) }; // place the internal knots for (size_t i {0}; i < internal_knots_.n_elem; ++i) { res(degree_ + 1 + i) = internal_knots_(i); } // place the boundary knots res(degree_) = boundary_knots_(0); res(res.n_elem - 1 - degree_) = boundary_knots_(1); // first and last "degree-size" knots size_t n_ { degree_ + internal_knots_.n_elem }; for (size_t i {0}; i < degree_; ++i) { res(degree_ - i - 1) = res(degree_ - i) - (res(n_ - i + 1) - res(n_ - i)); res(n_ + i + 2) = res(n_ + i + 1) + (res(degree_ + i + 1) - res(degree_ + i)); } surrogate_boundary_knots_ = arma::zeros(2); surrogate_boundary_knots_(0) = res(0); surrogate_boundary_knots_(1) = res(res.n_elem - 1); surrogate_internal_knots_ = res.subvec(1, res.n_elem - 2); // add multiplicities to "boundary" knots knot_sequence_ = arma::zeros(res.n_elem + 2 * degree_); for (size_t i {0}; i < knot_sequence_.n_elem; ++i) { if (i < order_) { knot_sequence_(i) = surrogate_boundary_knots_(0); } else if (i < knot_sequence_.n_elem - order_) { knot_sequence_(i) = surrogate_internal_knots_(i - order_); } else { knot_sequence_(i) = surrogate_boundary_knots_(1); } } } inline void update_knot_sequence() override { if (! is_knot_sequence_latest_ || knot_sequence_.n_elem == 0) { extend_knot_sequence(); is_knot_sequence_latest_ = true; } } inline void set_x_in_range() { if (is_x_in_range_latest_) { return; } update_range_size(); x_num_shift_ = arma::floor((x_ - boundary_knots_(0)) / range_size_); x_in_range_ = x_ - range_size_ * x_num_shift_; } inline rmat clamp_basis(const rmat& b_mat) { rmat out { b_mat.head_cols(degree_) + b_mat.tail_cols(degree_) }; if (internal_knots_.n_elem + 1 > degree_) { rmat out1 { b_mat.cols(degree_, internal_knots_.n_elem) }; out = arma::join_rows(out1, out); } return out; } public: PeriodicMSpline() {} explicit PeriodicMSpline(const SplineBase* pSplineBase) : SplineBase(pSplineBase) { stopifnot_simple_knot_sequence(); update_spline_df(); } // explicit conversion template explicit operator T() const { T obj; obj.set_x(x_)-> set_degree(degree_)-> set_internal_knots(internal_knots_)-> set_boundary_knots(boundary_knots_); return obj; } // given boundary_knots for consistency with SplineBase PeriodicMSpline(const rvec& x, const rvec& internal_knots, const unsigned int degree = 3, const rvec& boundary_knots = rvec()) { x_ = x; degree_ = degree; simplify_knots(internal_knots, boundary_knots); if (internal_knots_.n_elem + 1 < degree_) { throw std::range_error( "The number of unique internal knots must be >= degree - 1." ); } order_ = degree_ + 1; update_spline_df(); } PeriodicMSpline(const rvec& x, const unsigned int spline_df, const unsigned int degree = 3, const rvec& boundary_knots = rvec()) { x_ = x; degree_ = degree; // spline_df = number(internal_knot) + 1 >= degree if (spline_df < degree) { throw std::range_error( "The specified 'df' must be > 'degree'."); } spline_df_ = spline_df; order_ = degree_ + 1; // determine internal knots by spline_df and x unsigned int n_internal_knots { spline_df_ - 1 }; rvec prob_vec { arma::linspace(0, 1, n_internal_knots + 2) }; prob_vec = prob_vec.subvec(1, n_internal_knots); simplify_knots(rvec(), boundary_knots); // get quantiles of x in range set_x_in_range(); rvec internal_knots { arma_quantile(x_in_range_, prob_vec) }; simplify_knots(internal_knots); } //! Compute periodic spline basis based on M-spline basis //! //! @param complete_basis A `bool` value indicating whether to return a //! complete spline basis //! //! @return arma::mat inline rmat basis(const bool complete_basis = true) override { stopifnot_simple_knot_sequence(); update_knot_sequence(); set_x_in_range(); // create a MSpline object for the extended knot sequence MSpline ms_obj { x_in_range_, degree_, knot_sequence_ }; rmat b_mat { ms_obj.basis(true) }; // remove first and last #degree basis functions b_mat = b_mat.cols(degree_, b_mat.n_cols - order_); b_mat = clamp_basis(b_mat); // post-processing if (complete_basis) { return b_mat; } // else return mat_wo_col1(b_mat); } inline rmat derivative( const unsigned int derivs = 1, const bool complete_basis = true ) override { stopifnot_simple_knot_sequence(); if (derivs == 0) { throw std::range_error( "'derivs' has to be a positive integer."); } // early exit if derivs is large enough if (degree_ < derivs) { unsigned int old_df { spline_df_ }; if (complete_basis) { return arma::zeros(x_.n_elem, old_df); } if (old_df == 1) { throw std::range_error("No column left in the matrix."); } return arma::zeros(x_.n_elem, old_df - 1); } // else do the generation update_knot_sequence(); set_x_in_range(); // create a MSpline object for the extended knot sequence MSpline ms_obj { x_in_range_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat b_mat { ms_obj.derivative(derivs, true) }; // remove first and last #degree basis functions b_mat = b_mat.cols(degree_, b_mat.n_cols - order_); // post-processing b_mat = clamp_basis(b_mat); if (complete_basis) { return b_mat; } // else return mat_wo_col1(b_mat); } inline rmat integral( const bool complete_basis = true ) override { stopifnot_simple_knot_sequence(); update_knot_sequence(); set_x_in_range(); // create a MSpline object for the extended knot sequence MSpline ms_obj { x_in_range_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat b_mat { ms_obj.integral(true) }; // remove first and last #degree basis functions b_mat = b_mat.cols(degree_, b_mat.n_cols - order_); // get initial values at the left boundary knot rmat v0 { ms_obj.set_x(boundary_knots_(0))->integral(true) }; // remove first and last #degree basis functions v0 = v0.cols(degree_, v0.n_cols - order_); // clear initial values for (size_t i {0}; i < v0.n_cols; ++i) { b_mat.col(i) -= v0(0, i); } // post-processing b_mat = clamp_basis(b_mat); // get cumulative sum of integral from left boundary knot for (size_t j {0}; j < b_mat.n_cols; ++j) { b_mat.col(j) = (b_mat.col(j) + x_num_shift_) % (x_num_shift_ >= 0); } // return if (complete_basis) { return b_mat; } // else return mat_wo_col1(b_mat); } }; } // splines2 #endif /* SPLINES2_PERIODICMSPLINE_H */ splines2/inst/CITATION0000644000176200001440000000140714121502500014113 0ustar liggesuserscitHeader("To cite splines2 in publications use:") bibentry( key = "splines2-package", bibtype = "Manual", title = "{splines2}: {R}egression Spline Functions and Classes", author = c( as.person("Wenjie Wang"), as.person("Jun Yan") ), year = "2021", url = "https://CRAN.R-project.org/package=splines2", note = "{R} package version 0.4.5" ) bibentry( key = "splines2-paper", bibtype = "Article", title = "Shape-Restricted Regression Splines with {R} Package {splines2}", author = c( as.person("Wenjie Wang"), as.person("Jun Yan") ), journal = "Journal of Data Science", year = "2021", volume = "19", number = "3", pages = "498--517", doi = "10.6339/21-JDS1020" ) splines2/inst/tinytest/0000755000176200001440000000000014103551015014644 5ustar liggesuserssplines2/inst/tinytest/test-predict.R0000644000176200001440000000232314102405203017372 0ustar liggesusersx <- c(seq.int(0, 10, 0.5), NA) bsMat <- bSpline(x) ibsMat <- ibs(x) dbsMat <- dbs(x) msMat <- mSpline(x) isMat <- iSpline(x) csMat1 <- cSpline(x) csMat2 <- cSpline(x, scale = FALSE) bpMat <- bernsteinPoly(x) nsMat <- naturalSpline(x, df = 3) ## with newx expect_equivalent(predict(bsMat, 1), bsMat[3L, , drop = FALSE]) expect_equivalent(predict(ibsMat, 1), ibsMat[3L, , drop = FALSE]) expect_equivalent(predict(dbsMat, 1), dbsMat[3L, , drop = FALSE]) expect_equivalent(predict(msMat, 1), msMat[3L, , drop = FALSE]) expect_equivalent(predict(isMat, 1), isMat[3L, , drop = FALSE]) expect_equivalent(predict(csMat1, 1), csMat1[3L, , drop = FALSE]) expect_equivalent(predict(csMat2, 1), csMat2[3L, , drop = FALSE]) expect_equivalent(predict(bpMat, 1), bpMat[3L, , drop = FALSE]) expect_equivalent(predict(nsMat, 1), nsMat[3L, , drop = FALSE]) ## without newx expect_equivalent(predict(bsMat), bsMat) expect_equivalent(predict(ibsMat), ibsMat) expect_equivalent(predict(dbsMat), dbsMat) expect_equivalent(predict(msMat), msMat) expect_equivalent(predict(isMat), isMat) expect_equivalent(predict(csMat1), csMat1) expect_equivalent(predict(csMat2), csMat2) expect_equivalent(predict(bpMat), bpMat) expect_equivalent(predict(nsMat), nsMat) splines2/inst/tinytest/test-makepredictcall.R0000644000176200001440000000454314102405053021075 0ustar liggesusers## helper function get_predvars <- function(mod, key_attr) { out <- as.list(attr(terms(mod$model), "predvars")[[3]])[key_attr] if (anyNA(names(out))) stop("Found not matched key attribute.") } get_attr <- function(x, key_attr) { out <- attributes(x)[key_attr] if (anyNA(names(out))) stop("Found not matched key attribute.") } ## simulated data n <- 1e2 x <- rnorm(n) y <- x + rnorm(n, sd = 0.1) new_x <- runif(2 * n, min(x), max(x)) ## bSpline() mod <- lm(y ~ bSpline(x, df = 6)) key_attr <- c("degree", "knots", "Boundary.knots", "intercept") expect_equal( get_attr(bSpline(x, df = 6), key_attr), get_predvars(mod, key_attr) ) new_mat <- predict(bSpline(x, df = 6), new_x) pred1 <- predict(mod, data.frame(x = new_x)) pred2 <- coef(mod)[1L] + as.numeric(new_mat %*% coef(mod)[- 1L]) expect_equivalent(pred1, pred2) ## naturalSpline() mod <- lm(y ~ naturalSpline(x, df = 6)) key_attr <- c("knots", "Boundary.knots", "intercept") expect_equal( get_attr(naturalSpline(x, df = 6), key_attr), get_predvars(mod, key_attr) ) ## mSpline() mod <- lm(y ~ mSpline(x, df = 6)) key_attr <- c("degree", "knots", "Boundary.knots", "intercept", "periodic", "derivs", "integral") expect_equal( get_attr(mSpline(x, df = 6), key_attr), get_predvars(mod, key_attr) ) ## iSpline() mod <- lm(y ~ iSpline(x, df = 6)) key_attr <- c("degree", "knots", "Boundary.knots", "intercept", "derivs") expect_equal( get_attr(iSpline(x, df = 6), key_attr), get_predvars(mod, key_attr) ) ## cSpline() mod <- lm(y ~ cSpline(x, df = 6)) key_attr <- c("degree", "knots", "Boundary.knots", "intercept", "scale", "derivs") expect_equal( get_attr(cSpline(x, df = 6), key_attr), get_predvars(mod, key_attr) ) ## dbs() mod <- lm(y ~ dbs(x, df = 6)) key_attr <- c("degree", "knots", "Boundary.knots", "intercept", "derivs") expect_equal( get_attr(dbs(x, df = 6), key_attr), get_predvars(mod, key_attr) ) ## ibs() mod <- lm(y ~ ibs(x, df = 6)) key_attr <- c("degree", "knots", "Boundary.knots", "intercept") expect_equal( get_attr(ibs(x, df = 6), key_attr), get_predvars(mod, key_attr) ) ## bernsteinPoly() mod <- lm(y ~ bernsteinPoly(x, df = 6)) key_attr <- c("degree", "Boundary.knots", "intercept", "derivs", "integral") expect_equal( get_attr(bernsteinPoly(x, df = 6), key_attr), get_predvars(mod, key_attr) ) splines2/inst/tinytest/test-knots.R0000644000176200001440000000311314013361556017111 0ustar liggesusersx <- rnorm(100) ## internal knots no_first_last <- function(x) { unname(x[seq.int(2, length(x) - 1)]) } df0 <- 10 degree0 <- 3 inter_knots1 <- no_first_last( quantile(x, seq.int(0, 1, length.out = df0 - degree0 + 2)) ) inter_knots2 <- no_first_last( quantile(x, seq.int(0, 1, length.out = df0 - degree0 + 2 - 1)) ) inter_knots3 <- no_first_last( quantile(x, seq.int(0, 1, length.out = df0 - 1 + 2)) ) ## boundary knots boundary_knots <- range(x) ## basis matrices bsMat <- bSpline(x, df = df0) ibsMat <- ibs(x, df = df0) dbsMat <- dbs(x, df = df0) msMat <- mSpline(x, df = df0) isMat <- iSpline(x, df = df0) csMat <- cSpline(x, df = df0) bpMat <- bernsteinPoly(x, df = df0) nsMat <- naturalSpline(x, df = df0) ## internal knots expect_equivalent(knots(bsMat), inter_knots1) expect_equivalent(knots(ibsMat), inter_knots1) expect_equivalent(knots(dbsMat), inter_knots1) expect_equivalent(knots(msMat), inter_knots1) expect_equivalent(knots(isMat), inter_knots2) expect_equivalent(knots(csMat), inter_knots2) expect_equivalent(knots(bpMat), NULL) expect_equivalent(knots(nsMat), inter_knots3) ## boundary knots expect_equivalent(knots(bsMat, "boundary"), boundary_knots) expect_equivalent(knots(ibsMat, "boundary"), boundary_knots) expect_equivalent(knots(dbsMat, "boundary"), boundary_knots) expect_equivalent(knots(msMat, "boundary"), boundary_knots) expect_equivalent(knots(isMat, "boundary"), boundary_knots) expect_equivalent(knots(csMat, "boundary"), boundary_knots) expect_equivalent(knots(bpMat, "boundary"), boundary_knots) expect_equivalent(knots(nsMat, "boundary"), boundary_knots) splines2/inst/tinytest/test-print.R0000644000176200001440000000101613770276453017121 0ustar liggesusersx <- c(NA, seq.int(0, 10, 0.5), NA) bsMat <- bSpline(x) ibsMat <- ibs(x) dbsMat <- dbs(x) msMat <- mSpline(x) isMat <- iSpline(x) csMat <- cSpline(x) bnMat <- bernsteinPoly(x) nsMat <- naturalSpline(x, df = 3) expect_equivalent(print(bsMat), bsMat) expect_equivalent(print(ibsMat), ibsMat) expect_equivalent(print(dbsMat), dbsMat) expect_equivalent(print(msMat), msMat) expect_equivalent(print(isMat), isMat) expect_equivalent(print(csMat), csMat) expect_equivalent(print(bnMat), bnMat) expect_equivalent(print(nsMat), nsMat) splines2/inst/tinytest/test-mSpline.R0000644000176200001440000004215614076104177017377 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first x <- c(NA, seq.int(0, 0.5, 0.1), NA, seq.int(0.6, 1, 0.1), NA) knots <- c(0.25, 0.5, 0.75) x2 <- c(- 1, 2, x) b_knots <- c(0, 1) ## default cubic splines without internal knots expect_equivalent(mSpline(x), v2$mSpline(x)) ## cubic splines with specified df expect_equivalent(mSpline(x, df = 5), v2$mSpline(x, df = 5)) ## cubic splines with specified internal knots expect_equivalent(mSpline(x, knots = knots), v2$mSpline(x, knots = knots)) ## qudractic splines without internal knots expect_equivalent(mSpline(x, degree = 2L), v2$mSpline(x, degree = 2L)) ## complete basis with intercept expect_equivalent(mSpline(x, intercept = TRUE), v2$mSpline(x, intercept = TRUE)) ## specified knots expect_equivalent(mSpline(x, knots = knots, intercept = TRUE), v2$mSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_equivalent(mSpline(x, df = 6, intercept = TRUE), v2$mSpline(x, df = 6, intercept = TRUE)) ## for testing splines with degree zero msMat0a <- mSpline(x, degree = 0, intercept = TRUE) msMat0b <- mSpline(x, knots = knots, degree = 1) msMat0b2 <- mSpline(x, knots = knots, degree = 1, derivs = 1, integral = TRUE) isMat0a <- mSpline(x, knots = knots, degree = 1, integral = TRUE) msMat0c <- mSpline(x, knots = knots, degree = 1, intercept = TRUE) msMat0d <- mSpline(x, knots = knots, degree = 2) msMat0e <- mSpline(x, knots = knots, degree = 2, intercept = TRUE) msMat0f <- mSpline(0.1, knots = knots, degree = 2, intercept = TRUE, Boundary.knots = c(0, 1), derivs = 1) msMat0g <- mSpline(x, df = 6, degree = 2, intercept = TRUE, Boundary.knots = c(0, 1), derivs = 2) msMat0h <- mSpline(0.1, knots = knots, degree = 2, Boundary.knots = c(0, 1), derivs = 3) expect_true(isNumMatrix(msMat0a, 14L, 1L)) expect_equal(sum(is.na(msMat0b)), 12L) # keep NA's as is expect_equivalent(msMat0b, msMat0b2) expect_equivalent(deriv(isMat0a), msMat0b2) expect_true(isNumMatrix(msMat0b, 14L, 4L)) expect_true(isNumMatrix(msMat0c, 14L, 5L)) expect_true(isNumMatrix(msMat0d, 14L, 5L)) expect_true(isNumMatrix(msMat0e, 14L, 6L)) expect_true(isNumMatrix(msMat0f, 1L, 6L)) expect_true(isNumMatrix(msMat0g, 14L, 6L)) expect_true(isNumMatrix(msMat0h, 1L, 5L)) expect_error(mSpline(x, degree = 0)) expect_warning(mSpline(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1)), "beyond boundary knots") ## intercept = FALSE msMat0f <- mSpline(0.1, knots = knots, degree = 2, Boundary.knots = c(0, 1), derivs = 1) msMat0g <- mSpline(x, df = 6, degree = 2, Boundary.knots = c(0, 1), derivs = 2) expect_true(isNumMatrix(msMat0f, 1, length(knots) + 2)) expect_true(isNumMatrix(msMat0g, length(x), 6)) ## true closed-form formula given the all knots and degree ## transformation of constant basis x3 <- seq.int(0, 7, 0.1) m0_1 <- function(x) as.numeric(x < 1) m0_2 <- function(x) as.numeric(x >= 1 & x < 3) * 0.5 m0_3 <- function(x) as.numeric(x >= 3 & x <= 7) * 0.25 expect_equivalent(mSpline(x3, knots = c(1, 3), degree = 0L, intercept = TRUE), cbind(m0_1(x3), m0_2(x3), m0_3(x3))) ## transformation of linear basis x4 <- seq.int(0, 3, 0.1) ind01 <- function(x) as.numeric(x >= 0 & x < 1) ind12 <- function(x) as.numeric(x >= 1 & x < 2) ind23 <- function(x) as.numeric(x >= 2 & x <= 3) m0_1 <- function(x) ind01(x) * (2 - 2 * x) m0_2 <- function(x) ind01(x) * x + ind12(x) * (2 - x) m0_3 <- function(x) ind12(x) * (x - 1) + ind23(x) * (3 - x) m0_4 <- function(x) ind23(x) * (2 * x - 4) expect_equivalent(mSpline(x4, knots = c(1, 2), degree = 1L, intercept = TRUE), cbind(m0_1(x4), m0_2(x4), m0_3(x4), m0_4(x4))) ## x outside of boundary suppressWarnings({ expect_equivalent( mSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$mSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_equivalent( mSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots), v2$mSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots) ) }) ## keep names of x names(x) <- sample(LETTERS, length(x), replace = TRUE) expect_equal(rownames(bSpline(x)), names(x)) ### 2. check designed features with expectation ## NA is only allowed in x ## error if all of x are NA's expect_error(mSpline(c(NA_real_, NA_real_), degree = 0)) expect_error(mSpline(c(NA, NA), df = 5)) ## error if degree has NA or negative expect_error(mSpline(x, degree = - 1)) expect_error(mSpline(x, degree = NA)) ## error if df has NA or negative expect_error(mSpline(x, df = - 1)) expect_error(mSpline(x, df = NA)) ## error if knots has NA expect_error(mSpline(x, knots = c(0.1, 0.5, NA))) expect_error(mSpline(x, Boundary.knots = c(0.1, 0.5, NA))) ## error if boundary knots are inappropriate expect_error(mSpline(x, Boundary.knots = 0.1)) expect_error(mSpline(x, Boundary.knots = c(0.1, 0.1))) expect_error(mSpline(x, Boundary.knots = c(0.1, 0.5, 1))) ## error if empty matrix expect_true(isNumMatrix(mSpline(x, degree = 0, intercept = TRUE), length(x), 1)) expect_error(mSpline(x, degree = 0)) expect_error(mSpline(x, degree = 0, derivs = 1)) ## error if any internal knot is placed outside boundary expect_error(mSpline(x, knots = c(- 0.1, 0.5), degree = 0)) ## warning if any x outside of boundary expect_warning(mSpline(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1))) expect_warning(mSpline(c(x, 10), knots = knots, degree = 3, Boundary.knots = c(0, 1))) ### 3. periodic M-splines ## 3.1. with specified df x <- c(seq.int(0, 3, 0.01), NA, seq.int(3, 4, 0.1), NA) b_knots <- c(0, 1) is_in <- function(x, a = 0, b = 1) { x >= a & x <= b } ## without specified boundary knots tmp <- mSpline(x, df = 8, degree = 2, periodic = TRUE) expect_equal(attr(tmp, "Boundary.knots"), range(x, na.rm = TRUE)) expect_equal(length(attr(tmp, "knots")), 8) ## intercept = TRUE ## basis res0 <- mSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE) tmp <- mSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1, integral = TRUE) expect_equal(res0[1, ], res0[nrow(res0) - 1, ]) expect_true(isNumMatrix(res0, length(x), 6)) expect_equivalent(matrix(predict(res0, 0.25), nrow = 4, ncol = ncol(res0), byrow = TRUE), predict(res0, 0.25 + 1:4)) expect_true(all(is_in(attr(res0, "knots"), 0, 1))) expect_equivalent(res0, tmp) ## first derivatives res1 <- mSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1) expect_equal(res1[1, ], res1[nrow(res1) - 1, ]) expect_true(isNumMatrix(res1, length(x), 6)) expect_true(all(is_in(attr(res1, "knots"), 0, 1))) expect_equivalent(deriv(res0), res1) expect_equivalent(deriv(tmp), res1) expect_equivalent(matrix(predict(res1, 0.25), nrow = 4, ncol = ncol(res1), byrow = TRUE), predict(res1, 0.25 + 1:4)) ## second derivatives res2 <- mSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 2) expect_equal(res2[1, ], res2[nrow(res2) - 1, ]) expect_true(isNumMatrix(res2, length(x), 6)) expect_true(all(is_in(attr(res2, "knots"), 0, 1))) expect_equivalent(deriv(res1), res2) expect_equivalent(deriv(res0, 2), res2) expect_equivalent(deriv(tmp, 2), res2) expect_equivalent(matrix(predict(res2, 0.25), nrow = 4, ncol = ncol(res2), byrow = TRUE), predict(res2, 0.25 + 1:4)) ## third derivatives res3 <- mSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 3) expect_equal(res3[1, ], res3[nrow(res3) - 1, ]) expect_true(isNumMatrix(res3, length(x), 6)) expect_true(all(is_in(attr(res3, "knots"), 0, 1))) expect_equivalent(deriv(res2), res3) expect_equivalent(deriv(res1, 2), res3) expect_equivalent(deriv(res0, 3), res3) expect_equivalent(deriv(tmp, 3), res3) expect_equivalent(matrix(predict(res3, 0.25), nrow = 4, ncol = ncol(res3), byrow = TRUE), predict(res3, 0.25 + 1:4)) ## fourth derivatives res4 <- mSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 4) expect_equal(res4[1, ], res4[nrow(res4) - 1, ]) expect_true(isNumMatrix(res4, length(x), 6)) expect_equivalent(res4[1, , drop = FALSE], matrix(0, ncol = ncol(res4), nrow = 1)) ## integrals res3 <- mSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, integral = TRUE) expect_true(isNumMatrix(res3, length(x), 6)) expect_true(all(is_in(attr(res3, "knots"), 0, 1))) expect_equivalent(deriv(res3), res0) expect_equivalent(deriv(res3), tmp) expect_equivalent(deriv(res3, 2), res1) expect_equivalent(deriv(res3, 3), res2) expect_equivalent(matrix(predict(res3, 0.25), byrow = TRUE, nrow = 4, ncol = ncol(res3)) + seq_len(4), predict(res3, 0.25 + 1:4)) ## intercept = FALSE ## basis res0 <- mSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE) tmp <- mSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1, integral = TRUE) expect_equal(res0[1, ], res0[nrow(res0) - 1, ]) expect_equivalent(matrix(predict(res0, 0.25), nrow = 4, ncol = ncol(res0), byrow = TRUE), predict(res0, 0.25 + 1:4)) expect_equivalent(res0, tmp) expect_true(isNumMatrix(res0, length(x), 6)) expect_true(all(is_in(attr(res0, "knots"), 0, 1))) ## first derivatives res1 <- mSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1) expect_equal(res1[1, ], res1[nrow(res1) - 1, ]) expect_true(isNumMatrix(res1, length(x), 6)) expect_true(all(is_in(attr(res1, "knots"), 0, 1))) expect_equivalent(deriv(res0), res1) expect_equivalent(deriv(tmp), res1) expect_equivalent(matrix(predict(res1, 0.25), nrow = 4, ncol = ncol(res1), byrow = TRUE), predict(res1, 0.25 + 1:4)) ## second derivatives res2 <- mSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 2) expect_equal(res2[1, ], res2[nrow(res2) - 1, ]) expect_true(isNumMatrix(res2, length(x), 6)) expect_true(all(is_in(attr(res2, "knots"), 0, 1))) expect_equivalent(deriv(res1), res2) expect_equivalent(deriv(res0, 2), res2) expect_equivalent(deriv(tmp, 2), res2) expect_equivalent(matrix(predict(res2, 0.25), nrow = 4, ncol = ncol(res2), byrow = TRUE), predict(res2, 0.25 + 1:4)) ## third derivatives res3 <- mSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 3) expect_equal(res3[1, ], res3[nrow(res3) - 1, ]) expect_true(isNumMatrix(res3, length(x), 6)) expect_true(all(is_in(attr(res3, "knots"), 0, 1))) expect_equivalent(deriv(res2), res3) expect_equivalent(deriv(res1, 2), res3) expect_equivalent(deriv(res0, 3), res3) expect_equivalent(deriv(tmp, 3), res3) expect_equivalent(matrix(predict(res3, 0.25), nrow = 4, ncol = ncol(res3), byrow = TRUE), predict(res3, 0.25 + 1:4)) ## fourth derivatives res4 <- mSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 4) expect_equal(res4[1, ], res4[nrow(res4) - 1, ]) expect_true(isNumMatrix(res4, length(x), 6)) expect_equivalent(res4[1, , drop = FALSE], matrix(0, ncol = ncol(res4), nrow = 1)) ## integrals res3 <- mSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, integral = TRUE) expect_true(isNumMatrix(res3, length(x), 6)) expect_true(all(is_in(attr(res3, "knots"), 0, 1))) expect_equivalent(deriv(res3), res0) expect_equivalent(deriv(res3), tmp) expect_equivalent(deriv(res3, 2), res1) expect_equivalent(deriv(res3, 3), res2) expect_equivalent(matrix(predict(res3, 0.25), byrow = TRUE, nrow = 4, ncol = ncol(res3)) + seq_len(4), predict(res3, 0.25 + 1:4)) ## 3.2. with specified knots x <- c(seq.int(0, 3, 0.01), NA, seq.int(3, 4, 0.1), NA) knots <- c(0.3, 0.6, 0.8) b_knots <- c(0, 1) ## intercept = TRUE ## basis res0 <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE) tmp <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1, integral = TRUE) expect_equal(res0[1, ], res0[nrow(res0) - 1, ]) expect_equivalent(res0, tmp) expect_true(isNumMatrix(res0, length(x), length(knots) + 1L)) expect_equivalent(matrix(predict(res0, 0.25), nrow = 4, ncol = ncol(res0), byrow = TRUE), predict(res0, 0.25 + 1:4)) ## first derivatives res1 <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1) expect_equal(res1[1, ], res1[nrow(res1) - 1, ]) expect_true(isNumMatrix(res1, length(x), length(knots) + 1L)) expect_equivalent(deriv(res0), res1) expect_equivalent(deriv(tmp), res1) expect_equivalent(matrix(predict(res1, 0.25), nrow = 4, ncol = ncol(res1), byrow = TRUE), predict(res1, 0.25 + 1:4)) ## second derivatives res2 <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, derivs = 2) expect_equal(res2[1, ], res2[nrow(res2) - 1, ]) expect_true(isNumMatrix(res2, length(x), length(knots) + 1L)) expect_equivalent(deriv(res1), res2) expect_equivalent(deriv(res0, 2), res2) expect_equivalent(deriv(tmp, 2), res2) expect_equivalent(matrix(predict(res2, 0.25), nrow = 4, ncol = ncol(res2), byrow = TRUE), predict(res2, 0.25 + 1:4)) ## integrals res3 <- mSpline(x, knots = knots, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE, integral = TRUE) expect_true(isNumMatrix(res3, length(x), length(knots) + 1L)) expect_equivalent(deriv(res3), res0) expect_equivalent(deriv(res3), tmp) expect_equivalent(deriv(res3, 2), res1) expect_equivalent(deriv(res3, 3), res2) expect_equivalent(matrix(predict(res3, 0.25), byrow = TRUE, nrow = 4, ncol = ncol(res3)) + seq_len(4), predict(res3, 0.25 + 1:4)) ## intercept = FALSE knots <- c(0.2, 0.5, 0.6, 0.75) ## basis res0 <- mSpline(x, knots = knots, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE) tmp <- mSpline(x, knots = knots, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1, integral = TRUE) expect_true(isNumMatrix(res0, length(x), length(knots))) expect_equivalent(res0, tmp) expect_equivalent(matrix(predict(res0, 0.25), nrow = 4, ncol = ncol(res0), byrow = TRUE), predict(res0, 0.25 + 1:4)) ## first derivatives res1 <- mSpline(x, knots = knots, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 1) expect_equal(res1[1, ], res1[nrow(res1) - 1, ]) expect_true(isNumMatrix(res1, length(x), length(knots))) expect_equivalent(deriv(res0), res1) expect_equivalent(deriv(tmp), res1) expect_equivalent(matrix(predict(res1, 0.25), nrow = 4, ncol = ncol(res1), byrow = TRUE), predict(res1, 0.25 + 1:4)) ## second derivatives res2 <- mSpline(x, knots = knots, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, derivs = 2) expect_equal(res2[1, ], res2[nrow(res2) - 1, ]) expect_true(isNumMatrix(res2, length(x), length(knots))) expect_equivalent(deriv(res1), res2) expect_equivalent(deriv(res0, 2), res2) expect_equivalent(deriv(tmp, 2), res2) expect_equivalent(matrix(predict(res2, 0.25), nrow = 4, ncol = ncol(res2), byrow = TRUE), predict(res2, 0.25 + 1:4)) ## integrals res3 <- mSpline(x, knots = knots, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE, integral = TRUE) expect_true(isNumMatrix(res3, length(x), length(knots))) expect_equivalent(deriv(res3), res0) expect_equivalent(deriv(res3), tmp) expect_equivalent(deriv(res3, 2), res1) expect_equivalent(deriv(res3, 3), res2) expect_equivalent(matrix(predict(res3, 0.25), byrow = TRUE, nrow = 4, ncol = ncol(res3)) + seq_len(4), predict(res3, 0.25 + 1:4)) ### 4. catch errors and warnings for periodic splines expect_error(mSpline(x, df = 2, periodic = TRUE)) expect_error(mSpline(x, df = 1, degree = 2, periodic = TRUE)) splines2/inst/tinytest/test-ibs.R0000644000176200001440000001364514030134441016531 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first ## without internal knots x <- seq.int(0, 1, 0.1) ## degree = 0 expect_equivalent(matrix(x), ibs(x, degree = 0, intercept = TRUE)) ## degree = 1 b1 <- function(x) x - x ^ 2 / 2 b2 <- function(x) x ^ 2 / 2 i1mat <- cbind(b1(x), b2(x)) expect_equivalent(matrix(b2(x)), ibs(x, degree = 1)) expect_equivalent(i1mat, ibs(x, degree = 1, intercept = TRUE)) ## degree = 2 b1 <- function(x) x ^ 3 / 3 - x ^ 2 + x b2 <- function(x) - 2 * x ^ 3 / 3 + x ^ 2 b3 <- function(x) x ^ 3 / 3 i2mat <- cbind(b1(x), b2(x), b3(x)) expect_equivalent(cbind(b2(x), b3(x)), ibs(x, degree = 2)) expect_equivalent(i2mat, ibs(x, degree = 2, intercept = TRUE)) ## degree = 3 b1 <- function(x) - (1 - x) ^ 4 / 4 + 1 / 4 b2 <- function(x) 3 / 4 * x ^ 4 - 2 * x ^ 3 + 3 / 2 * x ^ 2 b3 <- function(x) x ^ 3 - 3 / 4 * x ^ 4 b4 <- function(x) x ^ 4 / 4 i3mat <- cbind(b1(x), b2(x), b3(x), b4(x)) expect_equivalent(cbind(b2(x), b3(x), b4(x)), ibs(x, degree = 3)) expect_equivalent(i3mat, ibs(x, degree = 3, intercept = TRUE)) ## with two internal knots x <- seq.int(0, 4, 0.1) knots <- c(1, 3) ind01 <- function(x) as.numeric(x >= 0 & x < 1) ind13 <- function(x) as.numeric(x >= 1 & x < 3) ind34 <- function(x) as.numeric(x >= 3 & x <= 4) ## degree = 0 b1 <- function(x) ind01(x) * x + ind13(x) + ind34(x) b2 <- function(x) ind13(x) * (x - 1) + 2 * ind34(x) b3 <- function(x) ind34(x) * (x - 3) expect_equivalent(cbind(b2(x), b3(x)), ibs(x, knots = knots, degree = 0)) expect_equivalent(cbind(b1(x), b2(x), b3(x)), ibs(x, knots = knots, degree = 0, intercept = TRUE)) ## degree = 1 b1 <- function(x) ind01(x) * (x - x ^ 2 / 2) + (ind13(x) + ind34(x)) / 2 b2 <- function(x) { ind01(x) * x ^ 2 / 2 + ind13(x) * (1.5 * x - 0.25 * x ^ 2 - 3 / 4) + ind34(x) * 1.5 } b3 <- function(x) { ind13(x) * (x ^ 2 / 4 - x / 2 + 1 / 4) + ind34(x) * (- x ^ 2 / 2 + 4 * x - 6.5) } b4 <- function(x) ind34(x) * (x ^ 2 / 2 - 3 * x + 4.5) expect_equivalent(cbind(b2(x), b3(x), b4(x)), ibs(x, knots = knots, degree = 1)) expect_equivalent(cbind(b1(x), b2(x), b3(x), b4(x)), ibs(x, knots = knots, degree = 1, intercept = TRUE)) ## compare with v0.2.8 x <- c(NA, seq.int(0, 0.5, 0.1), NA, seq.int(0.6, 1, 0.1), NA) knots <- c(0.25, 0.5, 0.75) x2 <- c(- 1, 2, x) b_knots <- c(0, 1) ## default cubic splines without internal knots expect_equivalent(ibs(x), v2$ibs(x)) ## cubic splines with specified df expect_equivalent(ibs(x, df = 5), v2$ibs(x, df = 5)) ## cubic splines with specified internal knots expect_equivalent(ibs(x, knots = knots), v2$ibs(x, knots = knots)) ## qudractic splines without internal knots expect_equivalent(ibs(x, degree = 2L), v2$ibs(x, degree = 2L)) ## complete basis with intercept expect_equivalent(ibs(x, intercept = TRUE), v2$ibs(x, intercept = TRUE)) ## specified knots expect_equivalent(ibs(x, knots = knots, intercept = TRUE), v2$ibs(x, knots = knots, intercept = TRUE)) ## specified df expect_equivalent(ibs(x, df = 6, intercept = TRUE), v2$ibs(x, df = 6, intercept = TRUE)) ## degree zero expect_equivalent(ibs(x, df = 5, degree = 0), v2$ibs(x, df = 5, degree = 0)) expect_equivalent(ibs(x, df = 5, degree = 0, intercept = TRUE), v2$ibs(x, df = 5, degree = 0, intercept = TRUE)) bsMat0a <- ibs(x, degree = 0, intercept = TRUE) bsMat0b <- ibs(x, df = 5, degree = 0) bsMat0c <- ibs(x, df = 5, degree = 0, intercept = TRUE) bsMat0d <- ibs(x, knots = knots, degree = 0) bsMat0e <- ibs(x, knots = knots, degree = 0, intercept = TRUE) expect_true(isNumMatrix(bsMat0a, 14L, 1L)) expect_equal(sum(is.na(bsMat0b)), 15L) # keep NA's as is expect_true(isNumMatrix(bsMat0b, 14L, 5L)) expect_true(isNumMatrix(bsMat0c, 14L, 5L)) expect_true(isNumMatrix(bsMat0d, 14L, 3L)) expect_true(isNumMatrix(bsMat0e, 14L, 4L)) expect_true(isNumMatrix( ibs(x, df = 10, knots = knots, degree = 0L), 14L, 3L)) expect_true(isNumMatrix( ibs(x, df = 10, knots = knots, degree = 0, intercept = TRUE), 14L, 4L)) ## x outside of boundary suppressWarnings({ expect_equivalent( ibs(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$ibs(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_equivalent( ibs(x2, knots = knots, degree = 3, Boundary.knots = b_knots), v2$ibs(x2, knots = knots, degree = 3, Boundary.knots = b_knots) ) }) ## keep names of x names(x) <- sample(LETTERS, length(x), replace = TRUE) expect_equal(rownames(ibs(x)), names(x)) ### 2. check designed features with expectation ## NA is only allowed in x ## error if all of x are NA's expect_error(ibs(c(NA_real_, NA_real_), degree = 0)) expect_error(ibs(c(NA, NA), df = 5)) ## error if degree has NA or negative expect_error(ibs(x, degree = - 1)) expect_error(ibs(x, degree = NA)) ## error if df has NA or negative expect_error(ibs(x, df = - 1)) expect_error(ibs(x, df = NA)) ## error if knots has NA expect_error(ibs(x, knots = c(0.1, 0.5, NA))) expect_error(ibs(x, Boundary.knots = c(0.1, 0.5, NA))) ## error if boundary knots are inappropriate expect_error(ibs(x, Boundary.knots = 0.1)) expect_error(ibs(x, Boundary.knots = c(0.1, 0.1))) expect_error(ibs(x, Boundary.knots = c(0.1, 0.5, 1))) ## error if empty matrix expect_true(isNumMatrix(ibs(x, degree = 0, intercept = TRUE), length(x), 1)) expect_error(ibs(x, degree = 0)) ## error if any internal knot is placed outside boundary expect_error(ibs(x, knots = c(- 0.1, 0.5), degree = 0)) ## warning if any x outside of boundary expect_warning(ibs(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1))) expect_warning(ibs(c(x, 10), knots = knots, degree = 3, Boundary.knots = c(0, 1))) splines2/inst/tinytest/test-naturalSpline.R0000644000176200001440000001022313773516170020602 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first x <- seq.int(0, 1, 0.1) knots <- c(0.3, 0.5, 0.6) b_knots <- c(0, 1) ## without internal knots nsMat0a <- naturalSpline(x, df = 2, intercept = TRUE) nsMat0b <- naturalSpline(x, intercept = TRUE) ## integrals nsMat1 <- naturalSpline(x, intercept = FALSE, integral = TRUE) ## first derivatives nsMat2 <- naturalSpline(x, intercept = FALSE, derivs = 1) ## second derivatives nsMat3 <- naturalSpline(x, intercept = FALSE, derivs = 2) ## check matrix size expect_true(isNumMatrix(nsMat0a, length(x), 2L)) expect_true(isNumMatrix(nsMat0b, length(x), 2L)) expect_true(isNumMatrix(nsMat1, length(x), 1L)) expect_true(isNumMatrix(nsMat2, length(x), 1L)) expect_true(isNumMatrix(nsMat3, length(x), 1L)) ## natural spline basis nsMat0 <- naturalSpline(x, knots = knots, intercept = TRUE) ## integrals nsMat1 <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) ## first derivatives nsMat2 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) ## second derivatives nsMat3 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 2) ## check matrix size expect_true(isNumMatrix(nsMat0, length(x), length(knots) + 2L)) expect_true(isNumMatrix(nsMat1, length(x), length(knots) + 2L)) expect_true(isNumMatrix(nsMat2, length(x), length(knots) + 2L)) expect_true(isNumMatrix(nsMat3, length(x), length(knots) + 2L)) ## specify df directly instead of knots for (j in seq.int(2, 10)) { expect_true(isNumMatrix( naturalSpline(x, df = j), length(x), j )) } ## use the deriv method expect_equivalent(nsMat0, deriv(nsMat1)) expect_equivalent(nsMat2, deriv(nsMat0)) expect_equivalent(nsMat3, deriv(nsMat2)) expect_equivalent(nsMat3, deriv(nsMat0, 2)) ## check second derivatives at boundary knots expect_true(all(abs(predict(nsMat3, 0)) < 1e-12)) expect_true(all(abs(predict(nsMat3, 1)) < 1e-12)) ## keep names of x names(x) <- sample(LETTERS, length(x), replace = TRUE) expect_equal(rownames(naturalSpline(x, df = 3)), names(x)) ## for x outside of boundary xx <- seq.int(- 1, 2, 0.05) knots <- c(0.3, 0.4, 0.6, 0.8) b_knots <- c(0, 1) nsMat <- naturalSpline(xx, knots = knots, intercept = TRUE, Boundary.knots = b_knots) d1Mat <- naturalSpline(xx, knots = knots, intercept = TRUE, Boundary.knots = b_knots, derivs = 1) d2Mat <- naturalSpline(xx, knots = knots, intercept = TRUE, Boundary.knots = b_knots, derivs = 2) iMat <- naturalSpline(xx, knots = knots, intercept = TRUE, Boundary.knots = b_knots, integral = TRUE) expect_equal(nsMat[1:5, ] - nsMat[2:6, ], nsMat[2:6, ] - nsMat[3:7, ]) expect_equal(nsMat[seq.int(length(xx) - 10, length(xx) - 5), ] - nsMat[seq.int(length(xx) - 9, length(xx) - 4), ], nsMat[seq.int(length(xx) - 9, length(xx) - 4), ] - nsMat[seq.int(length(xx) - 8, length(xx) - 3), ]) expect_equal(d1Mat[1:5, ], d1Mat[2:6, ]) expect_equal(d1Mat[seq.int(length(xx) - 10, length(xx) - 5), ], d1Mat[seq.int(length(xx) - 9, length(xx) - 4), ]) expect_equivalent(d2Mat[1:5, ], matrix(0, ncol = ncol(d2Mat), nrow = 5)) expect_equivalent(tail(d2Mat, 5), matrix(0, ncol = ncol(d2Mat), nrow = 5)) expect_equivalent(iMat[1:5, ], matrix(0, ncol = ncol(iMat), nrow = 5)) expect_equal(iMat[seq.int(length(xx) - 10, length(xx) - 5), 2] - iMat[seq.int(length(xx) - 9, length(xx) - 4), 2], iMat[seq.int(length(xx) - 9, length(xx) - 4), 2] - iMat[seq.int(length(xx) - 8, length(xx) - 3), 2]) expect_true(all( iMat[seq.int(length(xx) - 10, length(xx) - 5), 4] - iMat[seq.int(length(xx) - 9, length(xx) - 4), 4] < iMat[seq.int(length(xx) - 9, length(xx) - 4), 4] - iMat[seq.int(length(xx) - 8, length(xx) - 3), 4] )) ### 2. checking inputs x <- c(NA, seq.int(0, 0.5, 0.1), NA, seq.int(0.6, 1, 0.1), NA) knots <- c(0.25, 0.5, 0.8) x2 <- c(- 1, 2, x) b_knots <- c(0, 1) ## expect errors expect_error(naturalSpline(x2, df = 5, derivs = - 1)) expect_error(naturalSpline(x2, df = 1)) expect_error(naturalSpline(rep(NA, 10), df = 2)) splines2/inst/tinytest/test-iSpline.R0000644000176200001440000001102614030134441017346 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first x <- c(NA, seq.int(0, 0.5, 0.1), NA, seq.int(0.6, 1, 0.1), NA) knots <- c(0.25, 0.5, 0.75) x2 <- c(- 1, 2, x) b_knots <- c(0, 1) ## default cubic splines without internal knots expect_equivalent(iSpline(x), v2$iSpline(x)) ## cubic splines with specified df expect_equivalent(iSpline(x, df = 5), v2$iSpline(x, df = 5)) ## cubic splines with specified internal knots expect_equivalent(iSpline(x, knots = knots), v2$iSpline(x, knots = knots)) ## qudractic splines without internal knots expect_equivalent(iSpline(x, degree = 2L), v2$iSpline(x, degree = 2L)) ## complete basis with intercept expect_equivalent(iSpline(x, intercept = TRUE), v2$iSpline(x, intercept = TRUE)) ## specified knots expect_equivalent(iSpline(x, knots = knots, intercept = TRUE), v2$iSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_equivalent(iSpline(x, df = 6, intercept = TRUE), v2$iSpline(x, df = 6, intercept = TRUE)) ## degree zero expect_equivalent(iSpline(x, df = 5, degree = 0), v2$iSpline(x, df = 5, degree = 0)) expect_equivalent(iSpline(x, df = 5, degree = 0, intercept = TRUE), v2$iSpline(x, df = 5, degree = 0, intercept = TRUE)) bsMat0a <- iSpline(x, degree = 0, intercept = TRUE) bsMat0b <- iSpline(x, df = 5, degree = 0, intercept = FALSE) bsMat0c <- iSpline(x, df = 5, degree = 0, intercept = TRUE) bsMat0d <- iSpline(x, knots = knots, degree = 0, intercept = FALSE) bsMat0e <- iSpline(x, knots = knots, degree = 0, intercept = TRUE) expect_true(isNumMatrix(bsMat0a, 14L, 1L)) expect_equal(sum(is.na(bsMat0b)), 15L) # keep NA's as is expect_true(isNumMatrix(bsMat0b, 14L, 5L)) expect_true(isNumMatrix(bsMat0c, 14L, 5L)) expect_true(isNumMatrix(bsMat0d, 14L, 3L)) expect_true(isNumMatrix(bsMat0e, 14L, 4L)) expect_true(isNumMatrix( iSpline(x, df = 10, knots = knots, degree = 0L, intercept = FALSE), 14L, 3L)) expect_true(isNumMatrix( iSpline(x, df = 10, knots = knots, degree = 0, intercept = TRUE), 14L, 4L)) ## x outside of boundary suppressWarnings({ expect_equivalent( iSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$iSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_equivalent( iSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots), v2$iSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots) ) }) ## keep names of x names(x) <- sample(LETTERS, length(x), replace = TRUE) expect_equal(rownames(iSpline(x)), names(x)) ## equivalency with M-splines expect_equivalent( iSpline(x, df = 5, derivs = 1), mSpline(x, df = 5, intercept = TRUE) ) expect_equivalent( iSpline(x, knots = knots, degree = 2, derivs = 2), mSpline(x, knots = knots, degree = 2, derivs = 1, intercept = TRUE) ) expect_equivalent( iSpline(x, knots = knots, degree = 2, derivs = 3), mSpline(x, knots = knots, degree = 2, derivs = 2, intercept = TRUE) ) ### 2. check designed features with expectation ## NA is only allowed in x ## error if all of x are NA's expect_error(iSpline(c(NA_real_, NA_real_), degree = 0)) expect_error(iSpline(c(NA, NA), df = 5)) ## error if degree has NA or negative expect_error(iSpline(x, degree = - 1)) expect_error(iSpline(x, degree = NA)) ## error if df has NA or negative expect_error(iSpline(x, df = - 1)) expect_error(iSpline(x, df = NA)) ## error if knots has NA expect_error(iSpline(x, knots = c(0.1, 0.5, NA))) expect_error(iSpline(x, Boundary.knots = c(0.1, 0.5, NA))) ## error if boundary knots are inappropriate expect_error(iSpline(x, Boundary.knots = 0.1)) expect_error(iSpline(x, Boundary.knots = c(0.1, 0.1))) expect_error(iSpline(x, Boundary.knots = c(0.1, 0.5, 1))) ## error if empty matrix expect_true(isNumMatrix(iSpline(x, degree = 0, intercept = TRUE), length(x), 1)) expect_error(iSpline(x, degree = 0, intercept = FALSE)) ## error if any internal knot is placed outside boundary expect_error(iSpline(x, knots = c(- 0.1, 0.5), degree = 0)) ## warning if any x outside of boundary expect_warning(iSpline(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1))) expect_warning(iSpline(c(x, 10), knots = knots, degree = 3, Boundary.knots = c(0, 1))) ## error for negative derivs expect_error(iSpline(x, derivs = - 1)) splines2/inst/tinytest/test-deriv.R0000644000176200001440000001305414102414527017065 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first x <- c(seq.int(0, 1, 0.1), NA) knots <- c(0.3, 0.5, 0.6) ## test deriv methods for B-splines related ibsMat <- ibs(x, knots = knots, intercept = TRUE) bsMat <- bSpline(x, knots = knots, intercept = TRUE) dbsMat <- dbs(x, knots = knots, intercept = TRUE) dbsMatNested <- deriv(deriv(ibsMat)) d2bsMat <- dbs(x, derivs = 2, knots = knots, intercept = TRUE) d3bsMat <- dbs(x, derivs = 3, knots = knots, intercept = TRUE) d4bsMat <- dbs(x, derivs = 4, knots = knots, intercept = TRUE) ## first derivative of ibs == bs expect_equivalent(bsMat, tmp <- deriv(ibsMat)) ## second derivative of ibs == dbs expect_equivalent(dbsMat, deriv(bsMat)) expect_equivalent(dbsMat, deriv(ibsMat, 2)) expect_equivalent(dbsMat, tmp <- deriv(tmp)) ## third derivative of ibs == d2bs expect_equivalent(d2bsMat, deriv(dbsMat)) expect_equivalent(d2bsMat, deriv(bsMat, 2)) expect_equivalent(d2bsMat, deriv(ibsMat, 3)) expect_equivalent(d2bsMat, tmp <- deriv(tmp)) ## forth derivative of ibs == d3bs expect_equivalent(d3bsMat, deriv(d2bsMat)) expect_equivalent(d3bsMat, deriv(dbsMat, 2)) expect_equivalent(d3bsMat, deriv(bsMat, 3)) expect_equivalent(d3bsMat, deriv(ibsMat, 4)) expect_equivalent(d3bsMat, tmp <- deriv(tmp)) ## fifth derivative of ibs == d4bs expect_equivalent(d4bsMat, deriv(d3bsMat)) expect_equivalent(d4bsMat, deriv(d2bsMat, 2)) expect_equivalent(d4bsMat, deriv(dbsMat, 3)) expect_equivalent(d4bsMat, deriv(bsMat, 4)) expect_equivalent(d4bsMat, deriv(ibsMat, 5)) expect_equivalent(d4bsMat, deriv(tmp)) ## test deriv methods for M-splines related ## if scale == FALSE csMat <- cSpline(x, knots = knots, scale = FALSE, intercept = TRUE) isMat <- iSpline(x, knots = knots, intercept = TRUE) msMat <- mSpline(x, knots = knots, intercept = TRUE) ms1Mat <- mSpline(x, knots = knots, derivs = 1, intercept = TRUE) ms2Mat <- mSpline(x, knots = knots, derivs = 2, intercept = TRUE) ms3Mat <- mSpline(x, knots = knots, derivs = 3, intercept = TRUE) ms4Mat <- mSpline(x, knots = knots, derivs = 4, intercept = TRUE) ## first derivative of csMat == isMat expect_equivalent(isMat, tmp <- deriv(csMat)) ## second derivative of csMat == msMat expect_equivalent(msMat, deriv(isMat)) expect_equivalent(msMat, deriv(csMat, 2)) expect_equivalent(msMat, tmp <- deriv(tmp)) ## third derivative of csMat == ms1Mat expect_equivalent(ms1Mat, deriv(msMat)) expect_equivalent(ms1Mat, deriv(isMat, 2)) expect_equivalent(ms1Mat, deriv(csMat, 3)) expect_equivalent(ms1Mat, tmp <- deriv(tmp)) ## forth derivative of csMat == ms2Mat expect_equivalent(ms2Mat, deriv(ms1Mat)) expect_equivalent(ms2Mat, deriv(msMat, 2)) expect_equivalent(ms2Mat, deriv(isMat, 3)) expect_equivalent(ms2Mat, deriv(csMat, 4)) expect_equivalent(ms2Mat, tmp <- deriv(tmp)) ## fifth derivative of csMat == ms3Mat expect_equivalent(ms3Mat, deriv(ms2Mat)) expect_equivalent(ms3Mat, deriv(ms1Mat, 2)) expect_equivalent(ms3Mat, deriv(msMat, 3)) expect_equivalent(ms3Mat, deriv(isMat, 4)) expect_equivalent(ms3Mat, deriv(csMat, 5)) expect_equivalent(ms3Mat, tmp <- deriv(tmp)) ## sixth derivative of csMat == ms4Mat expect_equivalent(ms4Mat, deriv(ms3Mat)) expect_equivalent(ms4Mat, deriv(ms2Mat, 2)) expect_equivalent(ms4Mat, deriv(ms1Mat, 3)) expect_equivalent(ms4Mat, deriv(msMat, 4)) expect_equivalent(ms4Mat, deriv(isMat, 5)) expect_equivalent(ms4Mat, deriv(csMat, 6)) expect_equivalent(ms4Mat, tmp <- deriv(tmp)) ## if scale == TRUE csMat <- cSpline(x, knots = knots, degree = 4, scale = TRUE, intercept = TRUE) expect_true(isNumMatrix(deriv(csMat), length(x), 8L)) expect_equivalent(deriv(csMat, 2), deriv(deriv(csMat))) expect_equivalent(deriv(csMat, 3), deriv(deriv(csMat, 2))) expect_equivalent(deriv(csMat, 3), deriv(deriv(csMat), 2)) expect_equivalent(deriv(csMat, 3), deriv(deriv(deriv(csMat)))) expect_equivalent(deriv(csMat, 4), deriv(deriv(deriv(deriv(csMat))))) ## test the method for bernstein polynomials bpMat <- bernsteinPoly(x, degree = 3, intercept = TRUE) dbpMat <- bernsteinPoly(x, degree = 3, derivs = 1, intercept = TRUE) d2bpMat <- bernsteinPoly(x, degree = 3, derivs = 2, intercept = TRUE) d3bpMat <- bernsteinPoly(x, degree = 3, derivs = 3, intercept = TRUE) d4bpMat <- bernsteinPoly(x, degree = 3, derivs = 4, intercept = TRUE) expect_equivalent(deriv(bpMat), dbpMat) expect_equivalent(deriv(bpMat, 2), d2bpMat) expect_equivalent(deriv(deriv(bpMat)), d2bpMat) expect_equivalent(deriv(bpMat, 3), d3bpMat) expect_equivalent(deriv(deriv(bpMat, 2)), d3bpMat) expect_equivalent(deriv(deriv(bpMat), 2), d3bpMat) expect_equivalent(deriv(deriv(deriv(bpMat))), d3bpMat) expect_equivalent(deriv(bpMat, 4), d4bpMat) expect_equivalent(deriv(deriv(bpMat, 3)), d4bpMat) expect_equivalent(deriv(deriv(bpMat), 3), d4bpMat) expect_equivalent(deriv(deriv(bpMat, 2), 2), d4bpMat) expect_equivalent(deriv(deriv(bpMat, 3)), d4bpMat) expect_equivalent(deriv(deriv(deriv(deriv(bpMat)))), d4bpMat) ### 2. check designed features with expectation expect_error(deriv(ibsMat, 0)) ## expect_error(deriv(bsMat, 0)) ## expect_error(deriv(csMat, 0)) expect_error(deriv(isMat, 0)) ## expect_error(deriv(msMat, 0)) ## expect_error(deriv(dbsMat, 0)) expect_error(deriv(ibsMat, - 1)) expect_error(deriv(bsMat, - 1)) expect_error(deriv(csMat, - 1)) expect_error(deriv(isMat, - 1)) expect_error(deriv(msMat, - 1)) expect_error(deriv(dbsMat, - 1)) meta_obj <- matrix(1:10, nrow = 10, ncol = 5) class(meta_obj) <- c("matrix", "bSpline") expect_error(deriv(meta_obj)) ## check attributes attr(bsMat, "degree") <- NULL expect_error(deriv(bsMat), "degree") splines2/inst/tinytest/test-cSpline.R0000644000176200001440000001315714030134441017347 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first x <- c(NA, seq.int(0, 0.5, 0.1), NA, seq.int(0.6, 1, 0.1), NA) knots <- c(0.25, 0.5, 0.75) x2 <- c(- 1, 2, x) b_knots <- c(0, 1) ## default cubic splines without internal knots expect_equivalent(cSpline(x), v2$cSpline(x)) ## cubic splines with specified df expect_equivalent(cSpline(x, df = 5), v2$cSpline(x, df = 5)) ## cubic splines with specified internal knots expect_equivalent(cSpline(x, knots = knots), v2$cSpline(x, knots = knots)) ## qudractic splines without internal knots expect_equivalent(cSpline(x, degree = 2L), v2$cSpline(x, degree = 2L)) ## complete basis with intercept expect_equivalent(cSpline(x, intercept = TRUE), v2$cSpline(x, intercept = TRUE)) ## specified knots expect_equivalent(cSpline(x, knots = knots, intercept = TRUE), v2$cSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_equivalent(cSpline(x, df = 6, intercept = TRUE), v2$cSpline(x, df = 6, intercept = TRUE)) ## degree zero expect_equivalent(cSpline(x, df = 5, degree = 0), v2$cSpline(x, df = 5, degree = 0)) expect_equivalent(cSpline(x, df = 5, degree = 0, intercept = TRUE), v2$cSpline(x, df = 5, degree = 0, intercept = TRUE)) bsMat0a <- cSpline(x, degree = 0, intercept = TRUE) bsMat0b <- cSpline(x, df = 5, degree = 0, intercept = FALSE) bsMat0c <- cSpline(x, df = 5, degree = 0, intercept = TRUE) bsMat0d <- cSpline(x, knots = knots, degree = 0, intercept = FALSE) bsMat0e <- cSpline(x, knots = knots, degree = 0, intercept = TRUE) expect_true(isNumMatrix(bsMat0a, 14L, 1L)) expect_equal(sum(is.na(bsMat0b)), 15L) # keep NA's as is expect_true(isNumMatrix(bsMat0b, 14L, 5L)) expect_true(isNumMatrix(bsMat0c, 14L, 5L)) expect_true(isNumMatrix(bsMat0d, 14L, 3L)) expect_true(isNumMatrix(bsMat0e, 14L, 4L)) expect_true(isNumMatrix( cSpline(x, df = 10, knots = knots, degree = 0L, intercept = FALSE), 14L, 3L)) expect_true(isNumMatrix( cSpline(x, df = 10, knots = knots, degree = 0, intercept = TRUE), 14L, 4L)) ## x outside of boundary suppressWarnings({ expect_equivalent( cSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$cSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_equivalent( cSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots), v2$cSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots) ) }) ## keep names of x names(x) <- sample(LETTERS, length(x), replace = TRUE) expect_equal(rownames(cSpline(x)), names(x)) ## equivalency with I-splines expect_equivalent( cSpline(x, df = 5, derivs = 1, scale = FALSE, intercept = TRUE), iSpline(x, df = 5, intercept = TRUE) ) expect_equivalent( cSpline(x, knots = knots, derivs = 1, scale = FALSE, intercept = TRUE), iSpline(x, knots = knots, intercept = TRUE) ) expect_equivalent( cSpline(x, df = 6, degree = 2, derivs = 2, intercept = TRUE, scale = FALSE), iSpline(x, df = 6, degree = 2, derivs = 1, intercept = TRUE) ) expect_equivalent( cSpline(x, knots = knots, degree = 2, derivs = 2, intercept = TRUE, scale = FALSE), iSpline(x, knots = knots, degree = 2, derivs = 1, intercept = TRUE) ) expect_equivalent( cSpline(x, df = 6, degree = 2, derivs = 3, intercept = TRUE, scale = FALSE), iSpline(x, df = 6, degree = 2, derivs = 2, intercept = TRUE) ) expect_equivalent( cSpline(x, knots = knots, degree = 2, derivs = 3, intercept = TRUE, scale = FALSE), iSpline(x, knots = knots, degree = 2, derivs = 2, intercept = TRUE) ) expect_equivalent( cSpline(x, df = 6, degree = 2, derivs = 4, intercept = TRUE, scale = FALSE), iSpline(x, df = 6, degree = 2, derivs = 3, intercept = TRUE) ) expect_equivalent( cSpline(x, knots = knots, degree = 2, derivs = 4, intercept = TRUE, scale = FALSE), iSpline(x, knots = knots, degree = 2, derivs = 3, intercept = TRUE) ) ### 2. check designed features with expectation ## NA is only allowed in x ## error if all of x are NA's expect_error(cSpline(c(NA_real_, NA_real_), degree = 0)) expect_error(cSpline(c(NA, NA), df = 5)) ## error if degree has NA or negative expect_error(cSpline(x, degree = - 1)) expect_error(cSpline(x, degree = NA)) ## error if df has NA or negative expect_error(cSpline(x, df = - 1)) expect_error(cSpline(x, df = NA)) ## error if knots has NA expect_error(cSpline(x, knots = c(0.1, 0.5, NA))) expect_error(cSpline(x, Boundary.knots = c(0.1, 0.5, NA))) ## error if boundary knots are inappropriate expect_error(cSpline(x, Boundary.knots = 0.1)) expect_error(cSpline(x, Boundary.knots = c(0.1, 0.1))) expect_error(cSpline(x, Boundary.knots = c(0.1, 0.5, 1))) ## error if empty matrix expect_true(isNumMatrix(cSpline(x, degree = 0, intercept = TRUE), length(x), 1)) expect_error(cSpline(x, degree = 0, intercept = FALSE)) ## error if any internal knot is placed outside boundary expect_error(cSpline(x, knots = c(- 0.1, 0.5), degree = 0)) ## warning if any x outside of boundary expect_warning(cSpline(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1))) expect_warning(cSpline(c(x, 10), knots = knots, degree = 3, Boundary.knots = c(0, 1))) ## error if negative derivs expect_error(cSpline(x, df = 5, degree = 3, derivs = - 1)) splines2/inst/tinytest/test-dbs.R0000644000176200001440000001425514030134441016522 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first ## compare with splines::splineDesign x <- seq.int(0, 1, 0.05) ord <- 4 aKnots <- c(rep(0, ord), rep(1, ord)) expect_equivalent(dbs(x, derivs = 1, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 1)) expect_equivalent(dbs(x, derivs = 2, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 2)) ## except at right boundary knots expect_equivalent( dbs(x, derivs = 3, intercept = TRUE)[- length(x), ], splines::splineDesign(aKnots, derivs = 3, x = x)[- length(x), ] ) knots <- c(0.2, 0.4, 0.7) aKnots <- c(rep(0, ord), na.omit(knots), rep(1, ord)) expect_equivalent(dbs(x, derivs = 1, knots = knots, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 1)) expect_equivalent(dbs(x, derivs = 2, knots = knots, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 2)) expect_equivalent( dbs(x, derivs = 3, knots = knots, intercept = TRUE)[- length(x), ], splines::splineDesign(aKnots, x = x, derivs = 3)[- length(x), ] ) knots <- c(0.3, 0.6) ord <- 5 aKnots <- c(rep(0, ord), na.omit(knots), rep(1, ord)) expect_equivalent(dbs(x, 1, knots = knots, degree = 4, intercept = TRUE), splines::splineDesign(aKnots, x, ord, derivs = 1)) expect_equivalent(dbs(x, 2, knots = knots, degree = 4, intercept = TRUE), splines::splineDesign(aKnots, x, ord, derivs = 2)) expect_equivalent(dbs(x, 3, knots = knots, degree = 4, intercept = TRUE), splines::splineDesign(aKnots, x, ord, derivs = 3)) expect_equivalent( dbs(x, 4, knots = knots, degree = 4, intercept = TRUE)[- length(x), ], splines::splineDesign(aKnots, x, ord, derivs = 4)[- length(x), ] ) expect_error(dbs(x, 1, df = 1, intercept = TRUE)) expect_error(dbs(x, 1, df = 2, intercept = TRUE)) expect_error(dbs(x, 1, df = 3, intercept = TRUE)) expect_error(dbs(x, 2, df = 3, intercept = TRUE)) expect_true( isNumMatrix(dbs(x, 1, df = 1, degree = 0, intercept = TRUE), 21L, 1L) ) expect_true(isNumMatrix(dbs(x, 1, df = 4), 21L, 4L)) expect_true(isNumMatrix(dbs(x, 1, df = 4, intercept = TRUE), 21L, 4L)) expect_true(isNumMatrix(dbs(x, 1, df = 5), 21L, 5L)) expect_true(isNumMatrix(dbs(x, 1, df = 5, intercept = TRUE), 21L, 5L)) expect_true(isNumMatrix(dbs(x, 1, df = 5, degree = 0), 21L, 5L)) expect_true( isNumMatrix(dbs(x, 1, df = 5, degree = 0, intercept = TRUE), 21L, 5L) ) ## compare with v0.2.8 x <- c(NA, seq.int(0, 0.5, 0.1), NA, seq.int(0.6, 1, 0.1), NA) knots <- c(0.25, 0.5, 0.75) x2 <- c(- 1, 2, x) b_knots <- c(0, 1) ## default cubic splines without internal knots expect_equivalent(dbs(x), v2$dbs(x)) ## cubic splines with specified df expect_equivalent(dbs(x, df = 5), v2$dbs(x, df = 5)) ## cubic splines with specified internal knots expect_equivalent(dbs(x, knots = knots), v2$dbs(x, knots = knots)) ## qudractic splines without internal knots expect_equivalent(dbs(x, degree = 2L), v2$dbs(x, degree = 2L)) ## complete basis with intercept expect_equivalent(dbs(x, intercept = TRUE), v2$dbs(x, intercept = TRUE)) ## specified knots expect_equivalent(dbs(x, knots = knots, intercept = TRUE), v2$dbs(x, knots = knots, intercept = TRUE)) ## specified df expect_equivalent(dbs(x, df = 6, intercept = TRUE), v2$dbs(x, df = 6, intercept = TRUE)) ## degree zero expect_equivalent(dbs(x, df = 5, degree = 0), v2$dbs(x, df = 5, degree = 0)) expect_equivalent(dbs(x, df = 5, degree = 0, intercept = TRUE), v2$dbs(x, df = 5, degree = 0, intercept = TRUE)) bsMat0a <- dbs(x, degree = 0, intercept = TRUE) bsMat0b <- dbs(x, df = 5, degree = 0) bsMat0c <- dbs(x, df = 5, degree = 0, intercept = TRUE) bsMat0d <- dbs(x, knots = knots, degree = 0) bsMat0e <- dbs(x, knots = knots, degree = 0, intercept = TRUE) expect_true(isNumMatrix(bsMat0a, 14L, 1L)) expect_equal(sum(is.na(bsMat0b)), 15L) # keep NA's as is expect_true(isNumMatrix(bsMat0b, 14L, 5L)) expect_true(isNumMatrix(bsMat0c, 14L, 5L)) expect_true(isNumMatrix(bsMat0d, 14L, 3L)) expect_true(isNumMatrix(bsMat0e, 14L, 4L)) expect_true(isNumMatrix( dbs(x, df = 10, knots = knots, degree = 0L), 14L, 3L)) expect_true(isNumMatrix( dbs(x, df = 10, knots = knots, degree = 0, intercept = TRUE), 14L, 4L)) ## x outside of boundary suppressWarnings({ expect_equivalent( dbs(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$dbs(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_equivalent( dbs(x2, knots = knots, degree = 3, Boundary.knots = b_knots), v2$dbs(x2, knots = knots, degree = 3, Boundary.knots = b_knots) ) }) ## keep names of x names(x) <- sample(LETTERS, length(x), replace = TRUE) expect_equal(rownames(dbs(x)), names(x)) ### 2. check designed features with expectation ## NA is only allowed in x ## error if all of x are NA's expect_error(dbs(c(NA_real_, NA_real_), degree = 0)) expect_error(dbs(c(NA, NA), df = 5)) ## error if degree has NA or negative expect_error(dbs(x, degree = - 1)) expect_error(dbs(x, degree = NA)) ## error if df has NA or negative expect_error(dbs(x, df = - 1)) expect_error(dbs(x, df = NA)) ## error if knots has NA expect_error(dbs(x, knots = c(0.1, 0.5, NA))) expect_error(dbs(x, Boundary.knots = c(0.1, 0.5, NA))) ## error if boundary knots are inappropriate expect_error(dbs(x, Boundary.knots = 0.1)) expect_error(dbs(x, Boundary.knots = c(0.1, 0.1))) expect_error(dbs(x, Boundary.knots = c(0.1, 0.5, 1))) ## error if empty matrix expect_true(isNumMatrix(dbs(x, degree = 0, intercept = TRUE), length(x), 1)) expect_error(dbs(x, degree = 0)) ## error if any internal knot is placed outside boundary expect_error(dbs(x, knots = c(- 0.1, 0.5), degree = 0)) ## warning if any x outside of boundary expect_warning(dbs(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1))) expect_warning(dbs(c(x, 10), knots = knots, degree = 3, Boundary.knots = c(0, 1))) splines2/inst/tinytest/test-bSpline.R0000644000176200001440000001132214102414757017351 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first x <- c(NA, seq.int(0, 0.5, 0.1), NA, seq.int(0.6, 1, 0.1), NA) knots <- c(0.25, 0.5, 0.75) x2 <- c(- 1, 2, x) b_knots <- c(0, 1) ## default cubic splines without internal knots expect_equivalent(bSpline(x), v2$bSpline(x)) expect_equivalent(bSpline(x, derivs = 1), dbs(x)) expect_equivalent(bSpline(x, derivs = 2), dbs(x, derivs = 2)) expect_equivalent(bSpline(x, integral = TRUE), ibs(x)) expect_equivalent(bSpline(x), bSpline(x, derivs = 1, integral = TRUE)) ## cubic splines with specified df expect_equivalent(bSpline(x, df = 5), v2$bSpline(x, df = 5)) ## cubic splines with specified internal knots expect_equivalent(bSpline(x, knots = knots), v2$bSpline(x, knots = knots)) ## qudractic splines without internal knots expect_equivalent(bSpline(x, degree = 2L), v2$bSpline(x, degree = 2L)) ## complete basis with intercept expect_equivalent(bSpline(x, intercept = TRUE), v2$bSpline(x, intercept = TRUE)) ## specified knots expect_equivalent(bSpline(x, knots = knots, intercept = TRUE), v2$bSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_equivalent(bSpline(x, df = 6, intercept = TRUE), v2$bSpline(x, df = 6, intercept = TRUE)) ## degree zero knots2 <- seq.int(0.2, 0.8, 0.2) expect_equivalent(bSpline(x, knots = knots2, degree = 0), v2$bSpline(x, knots = knots2, degree = 0)) expect_equivalent(bSpline(x, knots = knots2, degree = 0, intercept = TRUE), v2$bSpline(x, knots = knots2, degree = 0, intercept = TRUE)) bsMat0a <- bSpline(x, degree = 0, intercept = TRUE) bsMat0b <- bSpline(x, df = 5, degree = 0) bsMat0c <- bSpline(x, df = 5, degree = 0, intercept = TRUE) bsMat0d <- bSpline(x, knots = knots, degree = 0) bsMat0e <- bSpline(x, knots = knots, degree = 0, intercept = TRUE) expect_true(isNumMatrix(bsMat0a, 14L, 1L)) expect_equal(sum(is.na(bsMat0b)), 15L) # keep NA's as is expect_true(isNumMatrix(bsMat0b, 14L, 5L)) expect_true(isNumMatrix(bsMat0c, 14L, 5L)) expect_true(isNumMatrix(bsMat0d, 14L, 3L)) expect_true(isNumMatrix(bsMat0e, 14L, 4L)) expect_true(isNumMatrix( bSpline(x, df = 10, knots = knots, degree = 0L), 14L, 3L)) expect_true(isNumMatrix( bSpline(x, df = 10, knots = knots, degree = 0, intercept = TRUE), 14L, 4L)) ## true closed-form formula given the all knots and degree ## test with two internal knots x3 <- seq.int(0, 5, 0.1) b0_1 <- function(x) as.numeric(x >= 0 & x < 1) b0_2 <- function(x) as.numeric(x >= 1 & x < 3) b0_3 <- function(x) as.numeric(x >= 3 & x <= 5) expect_equivalent(bSpline(x3, knots = c(1, 3), degree = 0L, intercept = TRUE), cbind(b0_1(x3), b0_2(x3), b0_3(x3))) ## x outside of boundary suppressWarnings({ expect_equivalent( bSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$bSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_equivalent( bSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots), v2$bSpline(x2, knots = knots, degree = 3, Boundary.knots = b_knots) ) }) ## keep names of x names(x) <- sample(LETTERS, length(x), replace = TRUE) expect_equal(rownames(bSpline(x)), names(x)) ### 2. check designed features with expectation ## NA is only allowed in x ## error if all of x are NA's expect_error(bSpline(c(NA_real_, NA_real_), degree = 0)) expect_error(bSpline(c(NA, NA), df = 5)) ## error if degree has NA or negative expect_error(bSpline(x, degree = - 1)) expect_error(bSpline(x, degree = NA)) ## error if df has NA or negative expect_error(bSpline(x, df = - 1)) expect_error(bSpline(x, df = NA)) ## error if knots has NA expect_error(bSpline(x, knots = c(0.1, 0.5, NA))) expect_error(bSpline(x, Boundary.knots = c(0.1, 0.5, NA))) ## error if boundary knots are inappropriate expect_error(bSpline(x, Boundary.knots = 0.1)) expect_error(bSpline(x, Boundary.knots = c(0.1, 0.1))) expect_error(bSpline(x, Boundary.knots = c(0.1, 0.5, 1))) ## error if empty matrix expect_true(isNumMatrix(bSpline(x, degree = 0, intercept = TRUE), length(x), 1)) expect_error(bSpline(x, degree = 0)) ## error if any internal knot is placed outside boundary expect_error(bSpline(x, knots = c(- 0.1, 0.5), degree = 0)) expect_error(bSpline(x, knots = c(range(x), 0.5), degree = 0)) ## warning if any x outside of boundary expect_warning(bSpline(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1))) expect_warning(bSpline(c(x, 10), knots = knots, degree = 3, Boundary.knots = c(0, 1))) splines2/inst/tinytest/test-bernsteinPoly.R0000644000176200001440000001350213770207041020610 0ustar liggesusers### 1. test correctness first x <- seq.int(0, 1, 0.1) ## degree 0: basis res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE) expect_equivalent(matrix(1, nrow = length(x)), res0) res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE, derivs = 1, integral = TRUE) expect_equivalent(matrix(1, nrow = length(x)), res0) ## degree 0: derivative res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE, derivs = 1) expect_equivalent(matrix(0, nrow = length(x)), res0) ## degree 0: integral res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE, integral = TRUE) expect_equivalent(matrix(x, nrow = length(x)), res0) ## degree 1: basis bp1 <- function(x) { cbind(1 - x, x) } res1 <- bernsteinPoly(x, degree = 1, intercept = TRUE) expect_equivalent(bp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, derivs = 1, integral = TRUE) expect_equivalent(bp1(x)[, -1L, drop = FALSE], res1) ## degree 1: first derivative dbp1 <- function(x) { matrix(c(- 1, 1), nrow = length(x), ncol = 2, byrow = TRUE) } res1 <- bernsteinPoly(x, degree = 1, intercept = TRUE, derivs = 1) expect_equivalent(dbp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, derivs = 2, integral = TRUE) expect_equivalent(dbp1(x)[, - 1L, drop = FALSE], res1) ## degree 1: second derivative ddbp1 <- function(x) { matrix(0, nrow = length(x), ncol = 2) } res1 <- bernsteinPoly(x, degree = 1, intercept = TRUE, derivs = 2) expect_equivalent(ddbp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, derivs = 3, integral = TRUE) expect_equivalent(ddbp1(x)[, - 1L, drop = FALSE], res1) ## degree 1: integral ibp1 <- function(x) { cbind(x - 0.5 * x ^ 2, 0.5 * x ^ 2) } res1 <- bernsteinPoly(x, degree = 1, intercept = TRUE, integral = TRUE) expect_equivalent(ibp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, integral = TRUE) expect_equivalent(ibp1(x)[, - 1L, drop = FALSE], res1) ## degree 2: basis bp2 <- function(x) { cbind((1 - x) ^ 2, 2 * x * (1 - x), x ^ 2) } res2 <- bernsteinPoly(x, degree = 2, intercept = TRUE) expect_equivalent(bp2(x), res2) ## degree 2: first derivative dbp2 <- function(x) { cbind(- 2 * (1 - x), 2 * (1 - 2 * x), 2 * x) } res2 <- bernsteinPoly(x, degree = 2, intercept = TRUE, derivs = 1) expect_equivalent(dbp2(x), res2) res2 <- bernsteinPoly(x, degree = 2, intercept = TRUE, derivs = 2, integral = TRUE) expect_equivalent(dbp2(x), res2) ## degree 2: second derivative ddbp2 <- function(x) { matrix(c(2, - 4, 2), nrow = length(x), ncol = 3, byrow = TRUE) } res2 <- bernsteinPoly(x, degree = 2, intercept = TRUE, derivs = 2, integral = FALSE) expect_equivalent(ddbp2(x), res2) ## degree 2: integral ibp2 <- function(x) { cbind(1 / 3 - (1 - x) ^ 3 / 3, x ^ 2 - 2 / 3 * x ^ 3, 1 / 3 * x ^ 3) } res2 <- bernsteinPoly(x, degree = 2, intercept = TRUE, integral = TRUE) expect_equivalent(ibp2(x), res2) ## degree 3: basis bp3 <- function(x) { cbind((1 - x) ^ 3, 3 * x * (1 - x) ^ 2, 3 * (1 - x) * x ^ 2, x ^ 3) } res3 <- bernsteinPoly(x, degree = 3, intercept = TRUE) expect_equivalent(bp3(x), res3) ## degree 3: first derivative dbp3 <- function(x) { cbind(- 3 * (1 - x) ^ 2, 3 * ((1 - x) ^ 2 - 2 * x * (1 - x)), 3 * (- x ^ 2 + (1 - x) * 2 * x), 3 * x ^ 2) } res3 <- bernsteinPoly(x, degree = 3, intercept = TRUE, derivs = 1) expect_equivalent(dbp3(x), res3) res3 <- bernsteinPoly(x, degree = 3, intercept = TRUE, derivs = 2, integral = TRUE) expect_equivalent(dbp3(x), res3) ## degree 3: second derivative ddbp3 <- function(x) { cbind(6 * (1 - x), 3 * (6 * x - 4), 3 * (- 6 * x + 2), 6 * x) } res3 <- bernsteinPoly(x, degree = 3, intercept = TRUE, derivs = 2) expect_equivalent(ddbp3(x), res3) ## degree 3: integral ibp3 <- function(x) { cbind(1 / 4 - (1 - x) ^ 4 / 4, 3 / 2 * x ^ 2 - 2 * x ^ 3 + 3 / 4 * x ^ 4, x ^ 3 - 3 / 4 * x ^ 4, x ^ 4 / 4) } res3 <- bernsteinPoly(x, degree = 3, intercept = TRUE, integral = TRUE) expect_equivalent(ibp3(x), res3) ## for given boundary knots a <- - 1.23 b <- 2.68 get_x <- function(x, a, b) { (x - a) / (b - a) } xx <- seq.int(a, b, by = 0.01) ## basis res0 <- bp3(get_x(xx, a, b)) res1 <- bernsteinPoly(xx, degree = 3, intercept = TRUE, Boundary.knots = c(a, b)) expect_equivalent(res0, res1) ## first derivatives res0 <- dbp3(get_x(xx, a, b)) / (b - a) res1 <- bernsteinPoly(xx, degree = 3, intercept = TRUE, Boundary.knots = c(a, b), derivs = 1) expect_equivalent(res0, res1) ## second derivatives res0 <- ddbp3(get_x(xx, a, b)) / (b - a) ^ 2 res1 <- bernsteinPoly(xx, degree = 3, intercept = TRUE, Boundary.knots = c(a, b), derivs = 2) expect_equivalent(res0, res1) ## integral res0 <- ibp3(get_x(xx, a, b)) * (b - a) res1 <- bernsteinPoly(xx, degree = 3, intercept = TRUE, Boundary.knots = c(a, b), integral = TRUE) expect_equivalent(res0, res1) ## for named x named_x <- seq.int(- 1, 1, 0.1) names(named_x) <- paste("x =", sprintf("%.1f", named_x)) res3 <- bernsteinPoly(named_x, degree = 5) expect_equal(row.names(res3), names(named_x)) ### 2. edge cases ## NA is only allowed in x ## error if all of x are NA's expect_error(bernsteinPoly(c(NA_real_, NA_real_), degree = 0)) expect_error(bernsteinPoly(c(NA, NA), degree = 5)) ## error if degree has NA or negative expect_error(bernsteinPoly(x, degree = - 1)) expect_error(bernsteinPoly(x, degree = NA)) ## error if empty matrix expect_error(bernsteinPoly(x, degree = 0)) ## error if x is outside of boundary expect_error(bernsteinPoly(c(- 1, x, 1, 1.1), degree = 2, Boundary.knots = c(0, 1))) ## error if the specified boundary knots is inappropriate expect_error(bernsteinPoly(c(- 1, x, 1, 1.1), degree = 2, Boundary.knots = 0)) splines2/inst/rcpp-tests/0000755000176200001440000000000014103551015015065 5ustar liggesuserssplines2/inst/rcpp-tests/test-PeriodicMSpline.cpp0000644000176200001440000001167314030754302021607 0ustar liggesusers#include // [[Rcpp::plugins(cpp11)]] // [[Rcpp::depends(RcppArmadillo)]] #include "../include/splines2Armadillo.h" // helper function inline Rcpp::List return_list(splines2::PeriodicMSpline obj) { return Rcpp::List::create( Rcpp::Named("basis") = obj.basis(), Rcpp::Named("integral") = obj.integral(), Rcpp::Named("d1") = obj.derivative(), Rcpp::Named("d2") = obj.derivative(2), Rcpp::Named("d3") = obj.derivative(3), Rcpp::Named("degree") = obj.get_degree(), Rcpp::Named("internal_knots") = splines2::arma2rvec( obj.get_internal_knots()), Rcpp::Named("boundary_knots") = splines2::arma2rvec( obj.get_boundary_knots()) ); } // default constructor and setter methods // [[Rcpp::export]] Rcpp::List rcpp_pmspline00(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj; // setter methods obj.set_x(x)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline01(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj; // setter methods obj.set_x(x)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline02(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj; // setter methods obj.set_internal_knots(iknots)-> set_x(x)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline03(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_x(x)-> set_internal_knots(iknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline04(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj; // setter methods obj.set_degree(degree)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline05(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_x(x); return return_list(obj); } // non-default constructor 1 // [[Rcpp::export]] Rcpp::List rcpp_pmspline1(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj { x, iknots, degree, bknots }; return return_list(obj); } // non-default constructor 2 // [[Rcpp::export]] Rcpp::List rcpp_pmspline2(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj { x, df, degree, bknots }; return return_list(obj); } // non-default constructor 4 // [[Rcpp::export]] Rcpp::List rcpp_pmspline4(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj0; obj0.set_x(x)-> set_internal_knots(iknots)-> set_degree(degree)-> set_boundary_knots(bknots); splines2::PeriodicMSpline obj { &obj0 }; return return_list(obj); } // conversion from BernsteinPoly // [[Rcpp::export]] Rcpp::List rcpp_pmspline5(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj0 { x, degree, bknots }; splines2::PeriodicMSpline obj { static_cast(obj0) }; obj.set_internal_knots(iknots); return return_list(obj); } splines2/inst/rcpp-tests/test-ISpline.cpp0000644000176200001440000001274614030754332020131 0ustar liggesusers#include // [[Rcpp::plugins(cpp11)]] // [[Rcpp::depends(RcppArmadillo)]] #include "../include/splines2Armadillo.h" // helper function inline Rcpp::List return_list(splines2::ISpline obj) { return Rcpp::List::create( Rcpp::Named("basis") = obj.basis(), Rcpp::Named("integral") = obj.integral(), Rcpp::Named("d1") = obj.derivative(), Rcpp::Named("d2") = obj.derivative(2), Rcpp::Named("d3") = obj.derivative(3), Rcpp::Named("degree") = obj.get_degree(), Rcpp::Named("internal_knots") = splines2::arma2rvec( obj.get_internal_knots()), Rcpp::Named("boundary_knots") = splines2::arma2rvec( obj.get_boundary_knots()) ); } // default constructor and setter methods // [[Rcpp::export]] Rcpp::List rcpp_ispline00(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj; // setter methods obj.set_x(x)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_ispline01(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj; // setter methods obj.set_x(x)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_ispline02(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj; // setter methods obj.set_internal_knots(iknots)-> set_x(x)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_ispline03(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_x(x)-> set_internal_knots(iknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_ispline04(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj; // setter methods obj.set_degree(degree)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_ispline05(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_x(x); return return_list(obj); } // non-default constructor 1 // [[Rcpp::export]] Rcpp::List rcpp_ispline1(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj { x, iknots, degree, bknots }; return return_list(obj); } // non-default constructor 2 // [[Rcpp::export]] Rcpp::List rcpp_ispline2(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj { x, df, degree, bknots }; return return_list(obj); } // non-default constructor 3 // [[Rcpp::export]] Rcpp::List rcpp_ispline3(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::ISpline obj { x, degree, knot_seq }; return return_list(obj); } // non-default constructor 4 // [[Rcpp::export]] Rcpp::List rcpp_ispline4(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::ISpline obj0; obj0.set_x(x)-> set_internal_knots(iknots)-> set_degree(degree)-> set_boundary_knots(bknots); splines2::ISpline obj { &obj0 }; return return_list(obj); } // conversion from BernsteinPoly // [[Rcpp::export]] Rcpp::List rcpp_ispline5(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj0 { x, degree, bknots }; splines2::ISpline obj { static_cast(obj0) }; obj.set_internal_knots(iknots); return return_list(obj); } // conversion from PeriodicMSpline // [[Rcpp::export]] Rcpp::List rcpp_ispline6(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj0 { x, iknots, degree, bknots }; splines2::ISpline obj { static_cast(obj0) }; return return_list(obj); } splines2/inst/rcpp-tests/test-MSpline.R0000644000176200001440000000504314030137475017547 0ustar liggesusersRcpp::sourceCpp("test-MSpline.cpp") x <- seq.int(0, 10, 0.02) inter_knots <- c(2.4, 3.5, 5.2, 8) bound_knots <- c(- 1, 12) degree <- 4 foo <- function(...) { mat <- mSpline(..., intercept = TRUE) imat <- mSpline(..., intercept = TRUE, integral = TRUE) d1mat <- deriv(mat) d2mat <- deriv(d1mat) d3mat <- deriv(d2mat) list(basis = mat, integral = imat, d1 = d1mat, d2 = d2mat, d3 = d3mat, degree = attr(mat, "degree"), internal_knots = knots(mat), boundary_knots = attr(mat, "Boundary.knots")) } res <- foo(x = x, knots = inter_knots, degree = degree, Boundary.knots = bound_knots) ## default constructors with setter methods res00 <- rcpp_mspline00(x, inter_knots, degree, bound_knots) expect_equivalent(res, res00) res01 <- rcpp_mspline01(x, inter_knots, degree, bound_knots) expect_equivalent(res, res01) res02 <- rcpp_mspline02(x, inter_knots, degree, bound_knots) expect_equivalent(res, res02) res03 <- rcpp_mspline03(x, inter_knots, degree, bound_knots) expect_equivalent(res, res03) res04 <- rcpp_mspline04(x, inter_knots, degree, bound_knots) expect_equivalent(res, res04) res05 <- rcpp_mspline05(x, inter_knots, degree, bound_knots) expect_equivalent(res, res05) ## non-default constructor 1 res1 <- rcpp_mspline1(x, inter_knots, degree, bound_knots) expect_equivalent(res, res1) ## non-default constructor 2 res2 <- rcpp_mspline2(x, 10, degree, bound_knots) res20 <- foo(x = x, degree = degree, df = 10, Boundary.knots = bound_knots) expect_equivalent(res20, res2) ## non-default constructor 3: simple knot sequence knot_seq <- sort(c(rep(bound_knots, each = degree + 1), inter_knots)) res31 <- rcpp_mspline3(x, degree, knot_seq) expect_equivalent(res, res31) ## non-default constructor 3: extended knot sequence knot_seq <- sort(c(seq.int(0, 10, 1), 1, rep(4, 2), rep(7, 2))) res32 <- rcpp_mspline3(x, degree, knot_seq) expect_equivalent( lapply(res32, function(a) { tmp <- dim(a) if (is.null(tmp)) { tmp <- length(a) } tmp }), { tmp <- c(length(x), length(knot_seq) - degree - 1) c(rep(list(tmp), 5), 1, length(knot_seq) - 2 * (degree + 1), 2) } ) ## non-default constructor 4 res4 <- rcpp_mspline4(x, inter_knots, degree, bound_knots) expect_equivalent(res, res4) ## conversion from BernsteinPoly res5 <- rcpp_mspline5(x, inter_knots, degree, bound_knots) expect_equivalent(res, res5) ## conversion from PeriodicMSpline res6 <- rcpp_mspline6(x, inter_knots, degree, bound_knots) expect_equivalent(res, res6) splines2/inst/rcpp-tests/test-MSpline.cpp0000644000176200001440000001274614030754340020134 0ustar liggesusers#include // [[Rcpp::plugins(cpp11)]] // [[Rcpp::depends(RcppArmadillo)]] #include "../include/splines2Armadillo.h" // helper function inline Rcpp::List return_list(splines2::MSpline obj) { return Rcpp::List::create( Rcpp::Named("basis") = obj.basis(), Rcpp::Named("integral") = obj.integral(), Rcpp::Named("d1") = obj.derivative(), Rcpp::Named("d2") = obj.derivative(2), Rcpp::Named("d3") = obj.derivative(3), Rcpp::Named("degree") = obj.get_degree(), Rcpp::Named("internal_knots") = splines2::arma2rvec( obj.get_internal_knots()), Rcpp::Named("boundary_knots") = splines2::arma2rvec( obj.get_boundary_knots()) ); } // default constructor and setter methods // [[Rcpp::export]] Rcpp::List rcpp_mspline00(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj; // setter methods obj.set_x(x)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_mspline01(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj; // setter methods obj.set_x(x)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_mspline02(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj; // setter methods obj.set_internal_knots(iknots)-> set_x(x)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_mspline03(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_x(x)-> set_internal_knots(iknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_mspline04(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj; // setter methods obj.set_degree(degree)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_mspline05(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_x(x); return return_list(obj); } // non-default constructor 1 // [[Rcpp::export]] Rcpp::List rcpp_mspline1(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj { x, iknots, degree, bknots }; return return_list(obj); } // non-default constructor 2 // [[Rcpp::export]] Rcpp::List rcpp_mspline2(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj { x, df, degree, bknots }; return return_list(obj); } // non-default constructor 3 // [[Rcpp::export]] Rcpp::List rcpp_mspline3(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::MSpline obj { x, degree, knot_seq }; return return_list(obj); } // non-default constructor 4 // [[Rcpp::export]] Rcpp::List rcpp_mspline4(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj0; obj0.set_x(x)-> set_internal_knots(iknots)-> set_degree(degree)-> set_boundary_knots(bknots); splines2::MSpline obj { &obj0 }; return return_list(obj); } // conversion from BernsteinPoly // [[Rcpp::export]] Rcpp::List rcpp_mspline5(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj0 { x, degree, bknots }; splines2::MSpline obj { static_cast(obj0) }; obj.set_internal_knots(iknots); return return_list(obj); } // conversion from PeriodicMSpline // [[Rcpp::export]] Rcpp::List rcpp_mspline6(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj0 { x, iknots, degree, bknots }; splines2::MSpline obj { static_cast(obj0) }; return return_list(obj); } splines2/inst/rcpp-tests/test-NaturalSpline.R0000644000176200001440000000340614030151531020747 0ustar liggesusersRcpp::sourceCpp("test-NaturalSpline.cpp") x <- seq.int(0, 10, 0.02) inter_knots <- c(2.4, 3.5, 5.2, 8) bound_knots <- c(- 1, 12) foo <- function(...) { mat <- naturalSpline(..., intercept = TRUE) imat <- naturalSpline(..., intercept = TRUE, integral = TRUE) d1mat <- deriv(mat) d2mat <- deriv(d1mat) d3mat <- deriv(d2mat) list(basis = mat, integral = imat, d1 = d1mat, d2 = d2mat, d3 = d3mat, degree = 3, internal_knots = knots(mat), boundary_knots = attr(mat, "Boundary.knots")) } res <- foo(x = x, knots = inter_knots, Boundary.knots = bound_knots) ## default constructors with setter methods res00 <- rcpp_nspline00(x, inter_knots, bound_knots) expect_equivalent(res, res00) res01 <- rcpp_nspline01(x, inter_knots, bound_knots) expect_equivalent(res, res01) res02 <- rcpp_nspline02(x, inter_knots, bound_knots) expect_equivalent(res, res02) res03 <- rcpp_nspline03(x, inter_knots, bound_knots) expect_equivalent(res, res03) res04 <- rcpp_nspline04(x, inter_knots, bound_knots) expect_equivalent(res, res04) res05 <- rcpp_nspline05(x, inter_knots, bound_knots) expect_equivalent(res, res05) ## non-default constructor 1 res1 <- rcpp_nspline1(x, inter_knots, bound_knots) expect_equivalent(res, res1) ## non-default constructor 2 res2 <- rcpp_nspline2(x, 10, bound_knots) res20 <- foo(x = x, df = 10, Boundary.knots = bound_knots) expect_equivalent(res20, res2) ## non-default constructor 4 res4 <- rcpp_nspline4(x, inter_knots, bound_knots) expect_equivalent(res, res4) ## conversion from BernsteinPoly res5 <- rcpp_nspline5(x, inter_knots, degree = 4, bound_knots) expect_equivalent(res, res5) ## conversion from PeriodicNspline res6 <- rcpp_nspline6(x, inter_knots, degree = 5, bound_knots) expect_equivalent(res, res6) splines2/inst/rcpp-tests/test-BSpline.cpp0000644000176200001440000001274614037710171020122 0ustar liggesusers#include // [[Rcpp::plugins(cpp11)]] // [[Rcpp::depends(RcppArmadillo)]] #include "../include/splines2Armadillo.h" // helper function inline Rcpp::List return_list(splines2::BSpline obj) { return Rcpp::List::create( Rcpp::Named("basis") = obj.basis(), Rcpp::Named("integral") = obj.integral(), Rcpp::Named("d1") = obj.derivative(), Rcpp::Named("d2") = obj.derivative(2), Rcpp::Named("d3") = obj.derivative(3), Rcpp::Named("degree") = obj.get_degree(), Rcpp::Named("internal_knots") = splines2::arma2rvec( obj.get_internal_knots()), Rcpp::Named("boundary_knots") = splines2::arma2rvec( obj.get_boundary_knots()) ); } // default constructor and setter methods // [[Rcpp::export]] Rcpp::List rcpp_bspline00(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj; // setter methods obj.set_x(x)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bspline01(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj; // setter methods obj.set_x(x)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bspline02(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj; // setter methods obj.set_internal_knots(iknots)-> set_x(x)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bspline03(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_x(x)-> set_internal_knots(iknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bspline04(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj; // setter methods obj.set_degree(degree)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bspline05(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_x(x); return return_list(obj); } // non-default constructor 1 // [[Rcpp::export]] Rcpp::List rcpp_bspline1(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj { x, iknots, degree, bknots }; return return_list(obj); } // non-default constructor 2 // [[Rcpp::export]] Rcpp::List rcpp_bspline2(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& bknots) { splines2::BSpline obj { x, df, degree, bknots }; return return_list(obj); } // non-default constructor 3 // [[Rcpp::export]] Rcpp::List rcpp_bspline3(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::BSpline obj { x, degree, knot_seq }; return return_list(obj); } // non-default constructor 4 // [[Rcpp::export]] Rcpp::List rcpp_bspline4(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj0; obj0.set_x(x)-> set_internal_knots(iknots)-> set_degree(degree)-> set_boundary_knots(bknots); splines2::BSpline obj { &obj0 }; return return_list(obj); } // conversion from BernsteinPoly // [[Rcpp::export]] Rcpp::List rcpp_bspline5(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj0 { x, degree, bknots }; splines2::BSpline obj { static_cast(obj0) }; obj.set_internal_knots(iknots); return return_list(obj); } // conversion from PeriodicMSpline // [[Rcpp::export]] Rcpp::List rcpp_bspline6(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj0 { x, iknots, degree, bknots }; splines2::BSpline obj { static_cast(obj0) }; return return_list(obj); } splines2/inst/rcpp-tests/test-BernsteinPoly.cpp0000644000176200001440000000732314030756577021373 0ustar liggesusers#include // [[Rcpp::plugins(cpp11)]] // [[Rcpp::depends(RcppArmadillo)]] #include "../include/splines2Armadillo.h" // helper function inline Rcpp::List return_list(splines2::BernsteinPoly obj) { return Rcpp::List::create( Rcpp::Named("basis") = obj.basis(), Rcpp::Named("integral") = obj.integral(), Rcpp::Named("d1") = obj.derivative(), Rcpp::Named("d2") = obj.derivative(2), Rcpp::Named("d3") = obj.derivative(3), Rcpp::Named("degree") = obj.get_degree(), Rcpp::Named("boundary_knots") = splines2::arma2rvec( obj.get_boundary_knots()) ); } // default constructor and setter methods // [[Rcpp::export]] Rcpp::List rcpp_bp00(const arma::vec& x, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj; // setter methods obj.set_x(x)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bp01(const arma::vec& x, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj; // setter methods obj.set_x(x)-> set_degree(degree)-> set_boundary_knots(bknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bp02(const arma::vec& x, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj; // setter methods obj.set_degree(degree)-> set_x(x)-> set_boundary_knots(bknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bp03(const arma::vec& x, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bp04(const arma::vec& x, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj; // setter methods obj.set_boundary_knots(bknots)-> set_degree(degree)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_bp05(const arma::vec& x, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj; // setter methods obj.set_boundary_knots(bknots)-> set_x(x)-> set_degree(degree); return return_list(obj); } // non-default constructor 1 // [[Rcpp::export]] Rcpp::List rcpp_bp1(const arma::vec& x, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj { x, degree, bknots }; return return_list(obj); } // non-default constructor 4 // [[Rcpp::export]] Rcpp::List rcpp_bp4(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::MSpline obj0; obj0.set_x(x)-> set_degree(degree)-> set_internal_knots(iknots)-> set_boundary_knots(bknots); splines2::BernsteinPoly obj { &obj0 }; return return_list(obj); } // conversion from PeriodicMSpline // [[Rcpp::export]] Rcpp::List rcpp_bp6(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj0 { x, iknots, degree, bknots }; splines2::BernsteinPoly obj { static_cast(obj0) }; return return_list(obj); } splines2/inst/rcpp-tests/test-CSpline.R0000644000176200001440000000471514030145566017542 0ustar liggesusersRcpp::sourceCpp("test-CSpline.cpp") x <- seq.int(0, 10, 0.02) inter_knots <- c(2.4, 3.5, 5.2, 8) bound_knots <- c(- 1, 12) degree <- 4 foo <- function(...) { mat <- cSpline(..., intercept = TRUE) d1mat <- deriv(mat) d2mat <- deriv(d1mat) d3mat <- deriv(d2mat) list(basis = mat, d1 = d1mat, d2 = d2mat, d3 = d3mat, degree = attr(mat, "degree"), internal_knots = knots(mat), boundary_knots = attr(mat, "Boundary.knots")) } res <- foo(x = x, knots = inter_knots, degree = degree, Boundary.knots = bound_knots) ## default constructors with setter methods res00 <- rcpp_cspline00(x, inter_knots, degree, bound_knots) expect_equivalent(res, res00) res01 <- rcpp_cspline01(x, inter_knots, degree, bound_knots) expect_equivalent(res, res01) res02 <- rcpp_cspline02(x, inter_knots, degree, bound_knots) expect_equivalent(res, res02) res03 <- rcpp_cspline03(x, inter_knots, degree, bound_knots) expect_equivalent(res, res03) res04 <- rcpp_cspline04(x, inter_knots, degree, bound_knots) expect_equivalent(res, res04) res05 <- rcpp_cspline05(x, inter_knots, degree, bound_knots) expect_equivalent(res, res05) ## non-default constructor 1 res1 <- rcpp_cspline1(x, inter_knots, degree, bound_knots) expect_equivalent(res, res1) ## non-default constructor 2 res2 <- rcpp_cspline2(x, 10, degree, bound_knots) res20 <- foo(x = x, degree = degree, df = 10, Boundary.knots = bound_knots) expect_equivalent(res20, res2) ## non-default constructor 3: simple knot sequence knot_seq <- sort(c(rep(bound_knots, each = degree + 1), inter_knots)) res31 <- rcpp_cspline3(x, degree, knot_seq) expect_equivalent(res, res31) ## non-default constructor 3: extended knot sequence knot_seq <- sort(c(seq.int(0, 10, 1), 1, rep(4, 2), rep(7, 2))) res32 <- rcpp_cspline3(x, degree, knot_seq) expect_equivalent( lapply(res32, function(a) { tmp <- dim(a) if (is.null(tmp)) { tmp <- length(a) } tmp }), { tmp <- c(length(x), length(knot_seq) - degree - 1) c(rep(list(tmp), 4), 1, length(knot_seq) - 2 * (degree + 1), 2) } ) ## non-default constructor 4 res4 <- rcpp_cspline4(x, inter_knots, degree, bound_knots) expect_equivalent(res, res4) ## conversion from BernsteinPoly res5 <- rcpp_cspline5(x, inter_knots, degree, bound_knots) expect_equivalent(res, res5) ## conversion from PeriodicCspline res6 <- rcpp_cspline6(x, inter_knots, degree, bound_knots) expect_equivalent(res, res6) splines2/inst/rcpp-tests/test-ISpline.R0000644000176200001440000000504114030144113017524 0ustar liggesusersRcpp::sourceCpp("test-ISpline.cpp") x <- seq.int(0, 10, 0.02) inter_knots <- c(2.4, 3.5, 5.2, 8) bound_knots <- c(- 1, 12) degree <- 4 foo <- function(...) { mat <- iSpline(..., intercept = TRUE) imat <- cSpline(..., intercept = TRUE, scale = FALSE) d1mat <- deriv(mat) d2mat <- deriv(d1mat) d3mat <- deriv(d2mat) list(basis = mat, integral = imat, d1 = d1mat, d2 = d2mat, d3 = d3mat, degree = attr(mat, "degree"), internal_knots = knots(mat), boundary_knots = attr(mat, "Boundary.knots")) } res <- foo(x = x, knots = inter_knots, degree = degree, Boundary.knots = bound_knots) ## default constructors with setter methods res00 <- rcpp_ispline00(x, inter_knots, degree, bound_knots) expect_equivalent(res, res00) res01 <- rcpp_ispline01(x, inter_knots, degree, bound_knots) expect_equivalent(res, res01) res02 <- rcpp_ispline02(x, inter_knots, degree, bound_knots) expect_equivalent(res, res02) res03 <- rcpp_ispline03(x, inter_knots, degree, bound_knots) expect_equivalent(res, res03) res04 <- rcpp_ispline04(x, inter_knots, degree, bound_knots) expect_equivalent(res, res04) res05 <- rcpp_ispline05(x, inter_knots, degree, bound_knots) expect_equivalent(res, res05) ## non-default constructor 1 res1 <- rcpp_ispline1(x, inter_knots, degree, bound_knots) expect_equivalent(res, res1) ## non-default constructor 2 res2 <- rcpp_ispline2(x, 10, degree, bound_knots) res20 <- foo(x = x, degree = degree, df = 10, Boundary.knots = bound_knots) expect_equivalent(res20, res2) ## non-default constructor 3: simple knot sequence knot_seq <- sort(c(rep(bound_knots, each = degree + 1), inter_knots)) res31 <- rcpp_ispline3(x, degree, knot_seq) expect_equivalent(res, res31) ## non-default constructor 3: extended knot sequence knot_seq <- sort(c(seq.int(0, 10, 1), 1, rep(4, 2), rep(7, 2))) res32 <- rcpp_ispline3(x, degree, knot_seq) expect_equivalent( lapply(res32, function(a) { tmp <- dim(a) if (is.null(tmp)) { tmp <- length(a) } tmp }), { tmp <- c(length(x), length(knot_seq) - degree - 1) c(rep(list(tmp), 5), 1, length(knot_seq) - 2 * (degree + 1), 2) } ) ## non-default constructor 4 res4 <- rcpp_ispline4(x, inter_knots, degree, bound_knots) expect_equivalent(res, res4) ## conversion from BernsteinPoly res5 <- rcpp_ispline5(x, inter_knots, degree, bound_knots) expect_equivalent(res, res5) ## conversion from PeriodicIspline res6 <- rcpp_ispline6(x, inter_knots, degree, bound_knots) expect_equivalent(res, res6) splines2/inst/rcpp-tests/test-PeriodicMSpline.R0000644000176200001440000000350414030755557021235 0ustar liggesusersRcpp::sourceCpp("test-PeriodicMSpline.cpp") x <- seq.int(0, 10, 0.02) inter_knots <- c(2.4, 3.5, 5.2, 8) bound_knots <- c(- 1, 12) degree <- 4 foo <- function(...) { mat <- mSpline(..., intercept = TRUE, periodic = TRUE) imat <- mSpline(..., intercept = TRUE, periodic = TRUE, integral = TRUE) d1mat <- deriv(mat) d2mat <- deriv(d1mat) d3mat <- deriv(d2mat) list(basis = mat, integral = imat, d1 = d1mat, d2 = d2mat, d3 = d3mat, degree = attr(mat, "degree"), internal_knots = knots(mat), boundary_knots = attr(mat, "Boundary.knots")) } res <- foo(x = x, knots = inter_knots, degree = degree, Boundary.knots = bound_knots) ## default constructors with setter methods res00 <- rcpp_pmspline00(x, inter_knots, degree, bound_knots) expect_equivalent(res, res00) res01 <- rcpp_pmspline01(x, inter_knots, degree, bound_knots) expect_equivalent(res, res01) res02 <- rcpp_pmspline02(x, inter_knots, degree, bound_knots) expect_equivalent(res, res02) res03 <- rcpp_pmspline03(x, inter_knots, degree, bound_knots) expect_equivalent(res, res03) res04 <- rcpp_pmspline04(x, inter_knots, degree, bound_knots) expect_equivalent(res, res04) res05 <- rcpp_pmspline05(x, inter_knots, degree, bound_knots) expect_equivalent(res, res05) ## non-default constructor 1 res1 <- rcpp_pmspline1(x, inter_knots, degree, bound_knots) expect_equivalent(res, res1) ## non-default constructor 2 res2 <- rcpp_pmspline2(x, 10, degree, bound_knots) res20 <- foo(x = x, degree = degree, df = 10, Boundary.knots = bound_knots) expect_equivalent(res20, res2) ## non-default constructor 4 res4 <- rcpp_pmspline4(x, inter_knots, degree, bound_knots) expect_equivalent(res, res4) ## conversion from BernsteinPoly res5 <- rcpp_pmspline5(x, inter_knots, degree, bound_knots) expect_equivalent(res, res5) splines2/inst/rcpp-tests/test-BSpline.R0000644000176200001440000000516314030751506017534 0ustar liggesusersRcpp::sourceCpp("test-BSpline.cpp") x <- seq.int(0, 10, 0.02) inter_knots <- c(2.4, 3.5, 5.2, 8) bound_knots <- c(- 1, 12) degree <- 4 foo <- function(...) { mat <- bSpline(..., intercept = TRUE) imat <- ibs(..., intercept = TRUE) d1mat <- deriv(mat) d2mat <- deriv(d1mat) d3mat <- deriv(d2mat) list(basis = mat, integral = imat, d1 = d1mat, d2 = d2mat, d3 = d3mat, degree = attr(mat, "degree"), internal_knots = knots(mat), boundary_knots = attr(mat, "Boundary.knots")) } res <- foo(x = x, knots = inter_knots, degree = degree, Boundary.knots = bound_knots) ## default constructors with setter methods res00 <- rcpp_bspline00(x, inter_knots, degree, bound_knots) expect_equivalent(res, res00) res01 <- rcpp_bspline01(x, inter_knots, degree, bound_knots) expect_equivalent(res, res01) res02 <- rcpp_bspline02(x, inter_knots, degree, bound_knots) expect_equivalent(res, res02) res03 <- rcpp_bspline03(x, inter_knots, degree, bound_knots) expect_equivalent(res, res03) res04 <- rcpp_bspline04(x, inter_knots, degree, bound_knots) expect_equivalent(res, res04) res05 <- rcpp_bspline05(x, inter_knots, degree, bound_knots) expect_equivalent(res, res05) ## non-default constructor 1 res1 <- rcpp_bspline1(x, inter_knots, degree, bound_knots) expect_equivalent(res, res1) ## non-default constructor 2 res2 <- rcpp_bspline2(x, 10, degree, bound_knots) res20 <- foo(x = x, degree = degree, df = 10, Boundary.knots = bound_knots) expect_equivalent(res20, res2) ## non-default constructor 3: simple knot sequence knot_seq <- sort(c(rep(bound_knots, each = degree + 1), inter_knots)) res31 <- rcpp_bspline3(x, degree, knot_seq) expect_equivalent(res, res31) ## non-default constructor 3: extended knot sequence knot_seq <- sort(c(seq.int(0, 10, 1), 1, rep(4, 3), rep(7, 2))) res32 <- rcpp_bspline3(x, degree, knot_seq) expect_equivalent( res32$basis, splines::splineDesign(knot_seq, x, ord = degree + 1, outer.ok = TRUE) ) expect_equivalent( res32$d1, splines::splineDesign(knot_seq, x, ord = degree + 1, outer.ok = TRUE, derivs = 1) ) expect_equivalent( res32$d2, splines::splineDesign(knot_seq, x, ord = degree + 1, outer.ok = TRUE, derivs = 2) ) ## non-default constructor 4 res4 <- rcpp_bspline4(x, inter_knots, degree, bound_knots) expect_equivalent(res, res4) ## conversion from BernsteinPoly res5 <- rcpp_bspline5(x, inter_knots, degree, bound_knots) expect_equivalent(res, res5) ## conversion from PeriodicMSpline res6 <- rcpp_bspline6(x, inter_knots, degree, bound_knots) expect_equivalent(res, res6) splines2/inst/rcpp-tests/test-NaturalSpline.cpp0000644000176200001440000001115714030754345021346 0ustar liggesusers#include // [[Rcpp::plugins(cpp11)]] // [[Rcpp::depends(RcppArmadillo)]] #include "../include/splines2Armadillo.h" // helper function inline Rcpp::List return_list(splines2::NaturalSpline obj) { return Rcpp::List::create( Rcpp::Named("basis") = obj.basis(), Rcpp::Named("integral") = obj.integral(), Rcpp::Named("d1") = obj.derivative(), Rcpp::Named("d2") = obj.derivative(2), Rcpp::Named("d3") = obj.derivative(3), Rcpp::Named("degree") = obj.get_degree(), Rcpp::Named("internal_knots") = splines2::arma2rvec( obj.get_internal_knots()), Rcpp::Named("boundary_knots") = splines2::arma2rvec( obj.get_boundary_knots()) ); } // default constructor and setter methods // [[Rcpp::export]] Rcpp::List rcpp_nspline00(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj; // setter methods obj.set_x(x)-> set_internal_knots(iknots)-> set_boundary_knots(bknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_nspline01(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj; // setter methods obj.set_x(x)-> set_boundary_knots(bknots)-> set_internal_knots(iknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_nspline02(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj; // setter methods obj.set_internal_knots(iknots)-> set_x(x)-> set_boundary_knots(bknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_nspline03(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj; // setter methods obj.set_boundary_knots(bknots)-> set_x(x)-> set_internal_knots(iknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_nspline04(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj; // setter methods obj.set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_nspline05(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj; // setter methods obj.set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_x(x); return return_list(obj); } // non-default constructor 1 // [[Rcpp::export]] Rcpp::List rcpp_nspline1(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj { x, iknots, bknots }; return return_list(obj); } // non-default constructor 2 // [[Rcpp::export]] Rcpp::List rcpp_nspline2(const arma::vec& x, const unsigned int df, const arma::vec& bknots) { splines2::NaturalSpline obj { x, df, bknots }; return return_list(obj); } // non-default constructor 4 // [[Rcpp::export]] Rcpp::List rcpp_nspline4(const arma::vec& x, const arma::vec& iknots, const arma::vec& bknots) { splines2::NaturalSpline obj0; obj0.set_x(x)-> set_internal_knots(iknots)-> set_boundary_knots(bknots); splines2::NaturalSpline obj { &obj0 }; return return_list(obj); } // conversion from BernsteinPoly // [[Rcpp::export]] Rcpp::List rcpp_nspline5(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj0 { x, degree, bknots }; splines2::NaturalSpline obj { static_cast(obj0) }; obj.set_internal_knots(iknots); return return_list(obj); } // conversion from PeriodicMSpline // [[Rcpp::export]] Rcpp::List rcpp_nspline6(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj0 { x, iknots, degree, bknots }; splines2::NaturalSpline obj { static_cast(obj0) }; return return_list(obj); } splines2/inst/rcpp-tests/test-BernsteinPoly.R0000644000176200001440000000263114030757527021003 0ustar liggesusersRcpp::sourceCpp("test-BernsteinPoly.cpp") x <- seq.int(0, 10, 0.02) inter_knots <- c(2.4, 3.5, 5.2, 8) bound_knots <- c(- 1, 12) degree <- 4 foo <- function(...) { mat <- bernsteinPoly(..., intercept = TRUE) imat <- bernsteinPoly(..., intercept = TRUE, integral = TRUE) d1mat <- deriv(mat) d2mat <- deriv(d1mat) d3mat <- deriv(d2mat) list(basis = mat, integral = imat, d1 = d1mat, d2 = d2mat, d3 = d3mat, degree = attr(mat, "degree"), boundary_knots = attr(mat, "Boundary.knots")) } res <- foo(x = x, degree = degree, Boundary.knots = bound_knots) ## default constructors with setter methods res00 <- rcpp_bp00(x, degree, bound_knots) expect_equivalent(res, res00) res01 <- rcpp_bp01(x, degree, bound_knots) expect_equivalent(res, res01) res02 <- rcpp_bp02(x, degree, bound_knots) expect_equivalent(res, res02) res03 <- rcpp_bp03(x, degree, bound_knots) expect_equivalent(res, res03) res04 <- rcpp_bp04(x, degree, bound_knots) expect_equivalent(res, res04) res05 <- rcpp_bp05(x, degree, bound_knots) expect_equivalent(res, res05) ## non-default constructor 1 res1 <- rcpp_bp1(x, degree, bound_knots) expect_equivalent(res, res1) ## non-default constructor 4 res4 <- rcpp_bp4(x, inter_knots, degree, bound_knots) expect_equivalent(res, res4) ## conversion from PeriodicMSpline res6 <- rcpp_bp6(x, inter_knots, degree, bound_knots) expect_equivalent(res, res6) splines2/inst/rcpp-tests/test-CSpline.cpp0000644000176200001440000001266414030754324020123 0ustar liggesusers#include // [[Rcpp::plugins(cpp11)]] // [[Rcpp::depends(RcppArmadillo)]] #include "../include/splines2Armadillo.h" // helper function inline Rcpp::List return_list(splines2::CSpline obj) { return Rcpp::List::create( Rcpp::Named("basis") = obj.basis(), Rcpp::Named("d1") = obj.derivative(), Rcpp::Named("d2") = obj.derivative(2), Rcpp::Named("d3") = obj.derivative(3), Rcpp::Named("degree") = obj.get_degree(), Rcpp::Named("internal_knots") = splines2::arma2rvec( obj.get_internal_knots()), Rcpp::Named("boundary_knots") = splines2::arma2rvec( obj.get_boundary_knots()) ); } // default constructor and setter methods // [[Rcpp::export]] Rcpp::List rcpp_cspline00(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj; // setter methods obj.set_x(x)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_cspline01(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj; // setter methods obj.set_x(x)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_cspline02(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj; // setter methods obj.set_internal_knots(iknots)-> set_x(x)-> set_boundary_knots(bknots)-> set_degree(degree); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_cspline03(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_x(x)-> set_internal_knots(iknots); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_cspline04(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj; // setter methods obj.set_degree(degree)-> set_internal_knots(iknots)-> set_boundary_knots(bknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_cspline05(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj; // setter methods obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_x(x); return return_list(obj); } // non-default constructor 1 // [[Rcpp::export]] Rcpp::List rcpp_cspline1(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj { x, iknots, degree, bknots }; return return_list(obj); } // non-default constructor 2 // [[Rcpp::export]] Rcpp::List rcpp_cspline2(const arma::vec& x, const unsigned int df, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj { x, df, degree, bknots }; return return_list(obj); } // non-default constructor 3 // [[Rcpp::export]] Rcpp::List rcpp_cspline3(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::CSpline obj { x, degree, knot_seq }; return return_list(obj); } // non-default constructor 4 // [[Rcpp::export]] Rcpp::List rcpp_cspline4(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::CSpline obj0; obj0.set_x(x)-> set_internal_knots(iknots)-> set_degree(degree)-> set_boundary_knots(bknots); splines2::CSpline obj { &obj0 }; return return_list(obj); } // conversion from BernsteinPoly // [[Rcpp::export]] Rcpp::List rcpp_cspline5(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::BernsteinPoly obj0 { x, degree, bknots }; splines2::CSpline obj { static_cast(obj0) }; obj.set_internal_knots(iknots); return return_list(obj); } // conversion from PeriodicMSpline // [[Rcpp::export]] Rcpp::List rcpp_cspline6(const arma::vec& x, const arma::vec& iknots, const unsigned int degree, const arma::vec& bknots) { splines2::PeriodicMSpline obj0 { x, iknots, degree, bknots }; splines2::CSpline obj { static_cast(obj0) }; return return_list(obj); } splines2/inst/bib/0000755000176200001440000000000013700501340013513 5ustar liggesuserssplines2/inst/bib/splines2.bib0000644000176200001440000000465614037710076015757 0ustar liggesusers@book{boor1978practical, title = {A Practical Guide to Splines}, author = {De Boor, Carl}, volume = 27, year = 1978, publisher = Springer-Verlag, Address = {New York}, doi = {10.1002/zamm.19800600129} } @book{eddelbuettel2013springer, title = {Seamless {R} and {C++} Integration with {Rcpp}}, author = {Eddelbuettel, Dirk}, year = 2013, publisher = {Springer}, } @article{eddelbuettel2014csda, title = {{RcppArmadillo}: {A}ccelerating {R} with High-Performance {C++} Linear Algebra}, author = {Dirk Eddelbuettel and Conrad Sanderson}, journal = {Computational Statistics and Data Analysis}, year = 2014, volume = 71, month = {March}, pages = {1054--1063}, url = {http://dx.doi.org/10.1016/j.csda.2013.02.005}, } @article{meyer2008inference, author = {Mary C. Meyer}, title = {Inference Using Shape-Restricted Regression Splines}, journal = {The Annals of Applied Statistics}, volume = 2, number = 3, pages = {1013--1033}, year = 2008, doi = {10.1214/08-aoas167} } @book{piegl1997nurbs, title = {The {NURBS} Book}, author = {Piegl, Les and Tiller, Wayne}, year = 1997, edition = 2, publisher = {Springer Science \& Business Media}, } @article{ramsay1988monotone, title = {Monotone Regression Splines in Action}, author = {Ramsay, James O.}, journal = {Statistical Science}, volume = 3, number = 4, pages = {425--441}, year = 1988, publisher = {JSTOR}, doi = {10.1214/ss/1177012761} } @article{sanderson2016armadillo, title = {{Armadillo}: {A}n Open Source {C++} Linear Algebra Library for Fast Prototyping and Computationally Intensive Experiments}, author = {Sanderson, Conrad}, journal = {Journal of Open Source Software}, volume = 1, pages = 26, year = 2016, } @article{wang2012csda, title = {Shape Restricted Nonparametric Regression with {B}ernstein Polynomials}, author = {Wang, Jiangdian and Ghosh, Sujit K.}, journal = {Computational Statistics \& Data Analysis}, volume = 56, number = 9, pages = {2729--2741}, year = 2012, publisher = {Elsevier}, }