splines2/0000755000176200001440000000000014760246062012020 5ustar liggesuserssplines2/tests/0000755000176200001440000000000014716263615013166 5ustar liggesuserssplines2/tests/tinytest.R0000644000176200001440000000107114407704203015161 0ustar liggesusersif (requireNamespace("tinytest", quietly = TRUE) && utils::packageVersion("tinytest") >= "1.2.2") { set.seed(808) is_at_home <- function() { identical(tolower(Sys.getenv("TT_AT_HOME")), "true") } if (is_at_home()) { ## only run the following tests if "at home" (not at cran) tinytest::test_package("splines2", ncpu = NULL, testdir = "rcpp-tests") } ## always run the following checks tinytest::test_package("splines2", ncpu = NULL, side_effects = TRUE) } splines2/MD50000644000176200001440000001410114760246062012325 0ustar liggesusers067170cc8c2667f89ae0a3d72c5cc5fe *DESCRIPTION bcc21228edc85b98332c9410bfc08dcd *NAMESPACE 8ebcaefc6a6f55f33217163aa173f028 *NEWS.md 68a43fe4d30924665636b6ab92e6def2 *R/RcppExports.R 07dd3c2814562fd4dae92330c9a795b7 *R/bSpline.R 62ed06faf7cfa6445e3d231d389a8b73 *R/bernsteinPoly.R 84684bc04f6528c2c876c9894b2b41da *R/cSpline.R 90675749f56ac26ee4df453ccd196853 *R/deriv.R e3e9fb30dd038210f0da4adb0386fd56 *R/extract.R d1b32037c5d380e93a42323f5280fd7a *R/iSpline.R 3cfc12d93f587cc733913b331cb376dd *R/knots.R 736182e66e78cf1e307a0b33dbe452bb *R/mSpline.R f26d0b5ab71d449accaf880cf2cb59b1 *R/makepredictcall.R 9913911b7e9cd853aca3df315d100e0f *R/misc.R 59a7f7103d2f0f574d0fcf110c1b5a87 *R/naturalSpline.R 2fc05cd6b4b87093391ff65f1293b567 *R/plot.R a3bfc2104140d2f7129e9962a604e99a *R/predict.R 993fe8948e164e6daa811e98cfc0c93d *R/print.R ab9c9f51d8852bf86e4ead177ad089e7 *R/splines2-package.R 7c630ec0032107b54decda126d588340 *R/update.R 1968b71f1277f40c35d1baae8ce5abcc *R/zzz.R cc3d57af8aa943cbf6aeb3f4a12876ee *README.md ddfaa611f48b16473400e46174e43c89 *build/vignette.rds c4ffa5882a209573e7f73906dd8983ec *inst/CITATION 83e11a62d0abf8387bfcf8310693b0b8 *inst/bib/splines2.bib 9e409ffa90725fee7a5d9d7b6ef09e85 *inst/doc/splines2-intro.R baa6bfe2c8618d851c720147eff5a2de *inst/doc/splines2-intro.Rmd 581cf6942d5d1da18ee7588c29afb818 *inst/doc/splines2-intro.html 101b59ecbfce0dd8762a3bbe473b1407 *inst/doc/splines2-wi-rcpp.Rmd 254f84fe599962b63dc6a764dbc3055b *inst/doc/splines2-wi-rcpp.html 1b4278b7f20aee4e8f67233232f9ddfb *inst/examples/ex-bSpline.R 843d187e13f2ced3fa891796cf826275 *inst/examples/ex-bernsteinPoly.R 31109e342cd3f84236b3647225f95e6d *inst/examples/ex-cSpline.R e4a8667814d05d10e8f5508676df2edc *inst/examples/ex-deriv.R e807a8e1338a70fd773aa27aa3c1e55b *inst/examples/ex-iSpline.R 91679c2c786e7fa71d6962f9c56b84ea *inst/examples/ex-knots.R 7ca0183b4b9b355b07527577c8e638b0 *inst/examples/ex-mSpline.R 0a8579e9c791997472cf9367892eb1ab *inst/examples/ex-naturalSpline.R e25ff8ef0d49acf3d89dddabcef289f4 *inst/examples/ex-predict.R eb5090e9191419bb8fe33ab9c2f15965 *inst/examples/ex-update.R 80f0680c522afcfe6f3327742962e936 *inst/include/splines2Armadillo.h 703ed3b0a1743ae649257e52355155dc *inst/include/splines2Armadillo/BSpline.h cb19181c90c287a0afac125ad77a78b6 *inst/include/splines2Armadillo/BernsteinPoly.h 4bf32cbd5df8232d30add3f1c16b2de9 *inst/include/splines2Armadillo/CSpline.h 94c5ad465b1fcb45f8bc1c36583b7594 *inst/include/splines2Armadillo/ISpline.h 66c102368fe7b28194c5110625a81c6b *inst/include/splines2Armadillo/MSpline.h 1e0246ccd6212c780b62ec1e5c133bce *inst/include/splines2Armadillo/NaturalSpline.h 59496571e9b990b6f0695553e7551bee *inst/include/splines2Armadillo/NaturalSplineK.h 0112c23a2452fd1d1845cbde8b9d1f88 *inst/include/splines2Armadillo/PeriodicSpline.h 47785b197bf4eb19b5da2ebde89c8b33 *inst/include/splines2Armadillo/SplineBase.h e55a3f561f87a5a32139bd322267f8dc *inst/include/splines2Armadillo/common.h 61dc38b88c6a04e387a037553797a0f1 *inst/include/splines2Armadillo/utils.h e609575b077a44a293455642be4d0162 *inst/rcpp-tests/test-BSpline.R d13785e1c71f9e7071d74ed3cd4ae7c3 *inst/rcpp-tests/test-BSpline.cpp 368f01a543d2bed03c3be4d902876e66 *inst/rcpp-tests/test-BernsteinPoly.R 205a5d872b5e324962330287642e683e *inst/rcpp-tests/test-BernsteinPoly.cpp c2112e9c9285eaa92f7a82b59de5d880 *inst/rcpp-tests/test-CSpline.R 88debc9e61ca12cb760a0357700e9581 *inst/rcpp-tests/test-CSpline.cpp 07adc3e0e990b30e82fc40a3674a4d50 *inst/rcpp-tests/test-ISpline.R e0ecc24cf97630c89d8b2a39544a03d4 *inst/rcpp-tests/test-ISpline.cpp c3e1fc0a8b0ec7c26a47caacee8f0686 *inst/rcpp-tests/test-MSpline.R 02799b34c2e9bd676ea9f1ebc08b94b8 *inst/rcpp-tests/test-MSpline.cpp 55050cfcaad26d6e5c0e1806006819dc *inst/rcpp-tests/test-NaturalSpline.R abe4a7c5d43872b4406673aed7b751cb *inst/rcpp-tests/test-NaturalSpline.cpp da63a5c9feb91a0b28f193d57a7a5170 *inst/rcpp-tests/test-PeriodicMSpline.R 32da8a167febaa4921d92265d92149d3 *inst/rcpp-tests/test-PeriodicMSpline.cpp 8e6f4e4810600944040f45a16326dda5 *inst/run_rcpp_test.R c11583fd1474ee7869525bdda2469c70 *inst/tinytest/test-bSpline.R b722d62efda89b0e2eb4db29459d6ce4 *inst/tinytest/test-bernsteinPoly.R 4a72641314dbc9184ac6e3e8430f90fd *inst/tinytest/test-cSpline.R 57dd1d7657fd2480bff584e54e0ff810 *inst/tinytest/test-dbs.R dfbed460456a7ca467efc1f1b6097390 *inst/tinytest/test-deriv.R 04e64e47bbbb4ef4ef6b73a9796a3d23 *inst/tinytest/test-extract.R f384054f7f7c84f5aefa469ac716b4fe *inst/tinytest/test-iSpline.R aa1fec80e8e1b545e134a75c8488bdbc *inst/tinytest/test-ibs.R a94d69e80f513c1643b5f38caf394f08 *inst/tinytest/test-knots.R 4d267298e1e446f34faefc72d1e0e191 *inst/tinytest/test-mSpline.R b6a6ee95102f55f43a7fd0bc0ef6c405 *inst/tinytest/test-makepredictcall.R df1b34114aff3a49be33961097fa0003 *inst/tinytest/test-naturalSpline.R 11e1ae114f021836619bc8db0e97925c *inst/tinytest/test-nsk.R 5be2b6103eac9f7f5f9918a409dc4d1e *inst/tinytest/test-plot.R 7adc0392ab4c69bf80450a7ce142f4bc *inst/tinytest/test-predict.R 1158260f290e4d803a6ecccb67b0528b *inst/tinytest/test-print.R 8a2624c82a7da0b188ab91609220c43e *inst/tinytest/test-update.R 0a7dba2b9760ab7526f8287a65c54994 *inst/tinytest/utils.R 012f00f4a21841b8f30237bc559ad3e4 *inst/v0.2.8.R f408ab8359c0a18a1c8f28016796e29e *man/bSpline.Rd e03d3d4eb5d7c24f817a7b6e1a602ce4 *man/bernsteinPoly.Rd beb73e1f17a130cc73cf47088a65ce52 *man/cSpline.Rd 0bf26bfd1f582fdb5f61182f4877e6e2 *man/deriv.Rd 802023ae85b33699d5f509ac574d4bc4 *man/iSpline.Rd 6c6e3aa490375138ebcc7ee6ba213542 *man/knots.Rd 005c97a68d434fdf1ab5e1fe2b5bb1d0 *man/mSpline.Rd 21180eab280bc527bf47be3ac1d2b989 *man/naturalSpline.Rd 3a7fb1426a10e7a5b519741e4e1b3a60 *man/plot.splines2.Rd 14c752c80d3a0e7af50f8e5f66038aaa *man/predict.Rd 1fa79cbc25f9ae3b67d7a979f57f89d0 *man/splines2.Rd 9f5a06e51e4a909cd6d405de87e83ede *man/update.Rd 8e2f5a16098b61b7b003f066f73fd0c6 *src/Makevars 2f634a6bd06b673a6333fe2846188f54 *src/Makevars.win 0d92ce1e7f4cd172485f7e08635688d3 *src/RcppExports.cpp 6b9e9640a717daac7525b5d3c451e6a1 *src/splines2_export.cpp 677aaddb17ed3aa8e1a00cd4ab576ebd *tests/tinytest.R baa6bfe2c8618d851c720147eff5a2de *vignettes/splines2-intro.Rmd 101b59ecbfce0dd8762a3bbe473b1407 *vignettes/splines2-wi-rcpp.Rmd splines2/R/0000755000176200001440000000000014760217640012221 5ustar liggesuserssplines2/R/plot.R0000644000176200001440000000651314760217640013327 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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. ## ##' Visualize Spline Basis Functions ##' ##' Plot spline basis functions by lines in different colors. ##' ##' This function is intended to quickly visualize the spline basis functions. ##' ##' @param x A \code{splines2} object. ##' @param y An argument that is not used. ##' @param from,to Two numbers representing the start and end point for the ##' plot, respectively. ##' @param n An integer, the number of x values at which to evaluate. ##' @param coef A numeric vector specifying the coefficients of the spline basis ##' functions. If it is \code{NULL} (by default), the spline basis ##' functions will be plotted. Otherwise, the resulting spline function ##' will be plotted. ##' @param mark_knots A character vector specifying if knot placement should be ##' indicated by vertical lines. ##' @param ... Additional arguments (other than \code{x} and \code{y}) that ##' would be passed to \code{matplot()}. ##' ##' @importFrom graphics matplot abline ##' @export plot.splines2 <- function(x, y, from = NULL, to = NULL, n = 101, coef = NULL, mark_knots = c("none", "internal", "boundary", "all"), ...) { dots <- list(...) x_ <- attr(x, "x") if (is.null(from)) { from <- min(x_, na.rm = TRUE) } if (is.null(to)) { to <- max(x_, na.rm = TRUE) } x_seq <- seq.int(from = from, to = to, length.out = n) default_args <- list(type = "l", xlab = "x", ylab = "") call_args <- modify_list(default_args, dots) call_args$x <- x_seq ## temporarily disable unnecessary warning messages old_op <- options("splines2.warn.outside") on.exit(options(old_op)) options("splines2.warn.outside" = FALSE) call_args$y <- predict(x, newx = x_seq, coef = coef) do.call(graphics::matplot, call_args) mark_knots <- match.arg(mark_knots, choices = c("none", "internal", "boundary", "all")) ## prepare for marks ik <- knots(x, "internal") bk <- knots(x, "boundary") if (mark_knots != "none" && isTRUE(attr(x, "periodic"))) { dist_bk <- bk[2] - bk[1] range_x <- range(x_seq) k1 <- (bk[1] - range_x[1]) %/% dist_bk k2 <- (range_x[2] - bk[1]) %/% dist_bk shifts <- seq.int(k1, k2) * dist_bk ik <- unique(as.numeric(sapply(shifts, function(a) ik + a))) bk <- unique(as.numeric(sapply(shifts, function(a) bk + a))) } if (mark_knots == "internal" || mark_knots == "all") { graphics::abline(v = ik, col = "gray70", lty = 3) } if (mark_knots == "boundary" || mark_knots == "all") { graphics::abline(v = bk, col = "gray50", lty = 2) } invisible(x) } splines2/R/RcppExports.R0000644000176200001440000000375514760217640014647 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, complete_basis = TRUE, periodic = FALSE, derivs = 0L, integral = FALSE) { .Call('_splines2_rcpp_bSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, complete_basis, periodic, derivs, integral) } rcpp_mSpline <- function(x, df, degree, internal_knots, boundary_knots, complete_basis = TRUE, periodic = FALSE, derivs = 0L, integral = FALSE) { .Call('_splines2_rcpp_mSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, complete_basis, periodic, derivs, integral) } rcpp_bernsteinPoly <- function(x, degree, boundary_knots, complete_basis = TRUE, derivs = 0L, integral = FALSE) { .Call('_splines2_rcpp_bernsteinPoly', PACKAGE = 'splines2', x, degree, boundary_knots, complete_basis, derivs, integral) } rcpp_iSpline <- function(x, df, degree, internal_knots, boundary_knots, complete_basis = FALSE, derivs = 0L, integral = FALSE) { .Call('_splines2_rcpp_iSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, complete_basis, derivs, integral) } rcpp_cSpline <- function(x, df, degree, internal_knots, boundary_knots, complete_basis = FALSE, derivs = 0L) { .Call('_splines2_rcpp_cSpline', PACKAGE = 'splines2', x, df, degree, internal_knots, boundary_knots, complete_basis, derivs) } rcpp_naturalSpline <- function(x, df, internal_knots, boundary_knots, trim = 0.0, complete_basis = FALSE, derivs = 0L, integral = FALSE) { .Call('_splines2_rcpp_naturalSpline', PACKAGE = 'splines2', x, df, internal_knots, boundary_knots, trim, complete_basis, derivs, integral) } rcpp_nsk <- function(x, df, internal_knots, boundary_knots, trim = 0.0, complete_basis = FALSE, derivs = 0L, integral = FALSE) { .Call('_splines2_rcpp_nsk', PACKAGE = 'splines2', x, df, internal_knots, boundary_knots, trim, complete_basis, derivs, integral) } splines2/R/print.R0000644000176200001440000000213114760217640013475 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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.splines2 <- 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/splines2-package.R0000644000176200001440000000436014760217640015477 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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 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 ##' ##' @name splines2 ##' @aliases splines2-package ##' @keywords internal "_PACKAGE" splines2/R/iSpline.R0000644000176200001440000001170414760217640013752 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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). The function \code{isp()} is an ##' alias of to encourage the use in a model formula. ##' ##' @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. ##' ##' @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. 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. ##' ##' @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, warn.outside = getOption("splines2.warn.outside", TRUE), ...) { ## 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, periodic = FALSE, derivs = derivs - 1L, integral = FALSE)) } ## 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 (warn.outside && 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("ISpline", "splines2", "matrix") out } ##' @rdname iSpline ##' @export isp <- iSpline splines2/R/bernsteinPoly.R0000644000176200001440000000720014760217640015200 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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 Functions ##' ##' Returns generalized Bernstein polynomial basis functions of the given degree ##' over the specified range. ##' ##' The Bernstein polynomial basis functions are defined over the support from 0 ##' to 1. The generalized Bernstein polynomial basis functions extend the ##' support to any finite interval in the real line. ##' ##' The function \code{bpoly()} is an alias to encourage the use in a model ##' formula. ##' ##' @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 \code{BernsteinPoly} object that is essentially 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, boundary_knots = Boundary.knots, complete_basis = intercept, derivs = derivs, integral = integral ) ## 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("BernsteinPoly", "splines2", "matrix") ## return out } ##' @rdname bernsteinPoly ##' @export bpoly <- bernsteinPoly splines2/R/misc.R0000644000176200001440000000407514760217640013305 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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 simple 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] } ## simplified version of utils::modifyList with keep.null = TRUE modify_list <- function (x, val) { stopifnot(is.list(x), is.list(val)) xnames <- names(x) vnames <- names(val) vnames <- vnames[nzchar(vnames)] for (v in vnames) { x[v] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) list(modify_list(x[[v]], val[[v]])) else val[v] } x } splines2/R/update.R0000644000176200001440000000721614760217640013634 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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. ## ##' Update Spline Basis Functions ##' ##' Update the knot placement, polynomial degree, and any other options ##' available when constructing the given spline object. ##' ##' @name update ##' ##' @inheritParams predict ##' ##' @param ... Other arguments passed to the corresponing constructor function. ##' ##' @return An updated object of the same class as the input object with the ##' specified updates. ##' ##' @example inst/examples/ex-update.R ##' ##' @importFrom stats update NULL ## the helper function for update helper_update <- function(object, ..., .FUN, .KEY_ATTR) { dot_list <- list(...) if (length(dot_list) == 0L) { return(object) } check_attr(object, .KEY_ATTR) exclude_attrs <- c("class", "dimnames") if (! is.null(dot_list$df)) { exclude_attrs <- c(exclude_attrs, "knots") } if (! is.null(dot_list$trim)) { exclude_attrs <- c(exclude_attrs, "Boundary.knots") } call_attr <- pred_attr(object, except = exclude_attrs) call_list <- modify_list(call_attr, dot_list) do.call(.FUN, call_list) } ##' @rdname update ##' @export update.BSpline <- function(object, ...) { helper_update( object, ..., .FUN = bSpline, .KEY_ATTR = c("x", "degree", "knots", "Boundary.knots", "intercept", "derivs", "integral", "periodic") ) } ##' @rdname update ##' @export update.MSpline <- function(object, ...) { helper_update( object, ..., .FUN = mSpline, .KEY_ATTR = c("x", "degree", "knots", "Boundary.knots", "intercept", "derivs", "integral", "periodic") ) } ##' @rdname update ##' @export update.ISpline <- function(object, ...) { helper_update( object, ..., .FUN = iSpline, .KEY_ATTR = c("x", "degree", "knots", "Boundary.knots", "intercept", "derivs") ) } ##' @rdname update ##' @export update.CSpline <- function(object, ...) { helper_update( object, ..., .FUN = cSpline, .KEY_ATTR = c("x", "degree", "knots", "Boundary.knots", "intercept", "derivs", "scale") ) } ##' @rdname update ##' @export update.BernsteinPoly <- function(object, ...) { helper_update( object, ..., .FUN = bernsteinPoly, .KEY_ATTR = c("x", "degree", "Boundary.knots", "intercept", "derivs", "integral") ) } ##' @rdname update ##' @export update.NaturalSpline <- function(object, ...) { helper_update( object, ..., .FUN = naturalSpline, .KEY_ATTR = c("x", "knots", "Boundary.knots", "trim", "intercept", "derivs", "integral") ) } ##' @rdname update ##' @export update.NaturalSplineK <- function(object, ...) { helper_update( object, ..., .FUN = nsk, .KEY_ATTR = c("x", "knots", "Boundary.knots", "trim", "intercept", "derivs", "integral") ) } splines2/R/naturalSpline.R0000644000176200001440000002071514760217640015172 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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 ##' ##' Functions \code{naturalSpline()} and \code{nsk()} generate the natural cubic ##' spline basis functions, the corresponding derivatives or integrals (from the ##' left boundary knot). Both of them are different from \code{splines::ns()}. ##' However, for a given model fitting procedure, using different variants of ##' spline basis functions should result in identical prediction values. The ##' coefficient estimates of the spline basis functions returned by \code{nsk()} ##' are more interpretable compared to \code{naturalSpline()} or ##' \code{splines::ns()} . ##' ##' The constructed spline basis functions from \code{naturalSpline()} are ##' nonnegative within boundary with the second derivatives being zeros at ##' boundary knots. The implementation utilizes the close-form null space that ##' can be derived from the recursive formula for the second derivatives of ##' B-splines. The function \code{nsp()} is an alias of \code{naturalSpline()} ##' to encourage the use in a model formula. ##' ##' The function \code{nsk()} produces another variant of natural cubic spline ##' matrix such that only one of the basis functions is nonzero and takes a ##' value of one at every boundary and internal knot. As a result, the ##' coefficients of the resulting fit are the values of the spline function at ##' the knots, which makes it easy to interpret the coefficient estimates. In ##' other words, the coefficients of a linear model will be the heights of the ##' function at the knots if \code{intercept = TRUE}. If \code{intercept = ##' FALSE}, the coefficients will be the change in function value between each ##' knot. This implementation closely follows the function \code{nsk()} of the ##' \pkg{survival} package (version 3.2-8). The idea corresponds directly to ##' the physical implementation of a spline by passing a flexible strip of wood ##' or metal through a set of fixed points, which is a traditional way to create ##' smooth shapes for things like a ship hull. ##' ##' The returned basis matrix can be obtained by transforming the corresponding ##' B-spline basis matrix with the matrix \code{H} provided in the attribute of ##' the returned object. Each basis is assumed to follow a linear trend for ##' \code{x} outside of boundary. 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. See ##' Supplementray Materials of Wang and Yan (2021) for a more detailed ##' introduction. ##' ##' @name naturalSpline ##' ##' @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. ##' @param trim The fraction (0 to 0.5) of observations to be trimmed from each ##' end of \code{x} before placing the default internal and boundary knots. ##' This argument will be ignored if \code{Boundary.knots} is specified. ##' The default value is \code{0} for backward compatibility, which sets the ##' boundary knots as the range of \code{x}. If a positive fraction is ##' specified, the default boundary knots will be equivalent to ##' \code{quantile(x, probs = c(trim, 1 - trim), na.rm = TRUE)}, which can ##' be a more sensible choice in practice due to the existence of outliers. ##' The default internal knots are placed within the boundary afterwards. ##' ##' @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. ##' NULL ## engine function .engine_nsp <- function(x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, trim = 0, derivs = 0L, integral = FALSE, ..., .FUN = c("nsp", "nsk")) { ## 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 .FUN <- match.arg(.FUN, choices = c("nsp", "nsk")) if (.FUN == "nsp") { out <- rcpp_naturalSpline( x = xx, df = df, internal_knots = knots, boundary_knots = Boundary.knots, trim = trim, complete_basis = intercept, derivs = derivs, integral = integral ) nsp_class <- "NaturalSpline" } else { out <- rcpp_nsk( x = xx, df = df, internal_knots = knots, boundary_knots = Boundary.knots, trim = trim, complete_basis = intercept, derivs = derivs, integral = integral ) nsp_class <- "NaturalSplineK" } ## 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(nsp_class, "splines2", "matrix") out } ##' @rdname naturalSpline ##' @export naturalSpline <- function(x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, trim = 0, derivs = 0L, integral = FALSE, ...) { .engine_nsp( x = x, df = df, knots = knots, intercept = intercept, Boundary.knots = Boundary.knots, trim = trim, derivs = derivs, integral = integral, .FUN = "nsp" ) } ##' @rdname naturalSpline ##' @export nsp <- naturalSpline ##' @rdname naturalSpline ##' @export nsk <- function(x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, trim = 0, derivs = 0L, integral = FALSE, ...) { .engine_nsp( x = x, df = df, knots = knots, intercept = intercept, Boundary.knots = Boundary.knots, trim = trim, derivs = derivs, integral = integral, .FUN = "nsk" ) } splines2/R/bSpline.R0000644000176200001440000002123714760217640013745 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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 spline basis matrix for B-splines 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 functions by allowing piecewise constant (left-closed and ##' right-open except on the right boundary) spline basis of degree zero. In ##' addition, the function provides derivatives or integrals of the B-spline ##' basis functions when one specifies the arguments \code{derivs} or ##' \code{integral} appropriately. The function constructs periodic B-splines ##' when \code{periodic} is \code{TRUE}. All the implementations are based on ##' the closed-form recursion formula following De Boor (1978) and Wang and Yan ##' (2021). ##' ##' The functions \code{ibs()} and \code{dbs()} are provided for convenience. ##' The former provides the integrals of B-splines and is equivalent to ##' \code{bSpline()} with \code{integral = TRUE}. The latter produces the ##' derivatives of given order of B-splines and is equivalent to ##' \code{bSpline()} with default \code{derivs = 1}. The function \code{bsp()} ##' is an alias of to encourage the use in a model formula. ##' ##' @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. For periodic splines, \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, the number of knots ##' must be greater or equal to the specified \code{degree - 1}. ##' Duplicated internal knots are not allowed. ##' @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}. For periodic splines, the specified bounary ##' knots define the cyclic interval. ##' @param periodic A logical value. If \code{TRUE}, the periodic splines will ##' be returned. The default value is \code{FALSE}. ##' @param derivs A nonnegative integer specifying the order of derivatives of ##' splines basis function. The default value is \code{0}. ##' @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. ##' @param warn.outside A logical value indicating if a warning should be thrown ##' out when any \code{x} is outside the boundary. This option can also be ##' set through \code{options("splines2.warn.outside")} after the package is ##' loaded. ##' @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. 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 ##' De Boor, Carl. (1978). \emph{A practical guide to splines}. ##' Vol. 27. New York: Springer-Verlag. ##' ##' Wang, W., & Yan, J. (2021). \emph{Shape-restricted regression splines with R ##' package splines2}. Journal of Data Science, 19(3),498--517. ##' ##' @example inst/examples/ex-bSpline.R ##' ##' @seealso ##' \code{\link{knots}} for extracting internal and boundary knots. ##' ##' @export bSpline <- function(x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, periodic = FALSE, derivs = 0L, integral = FALSE, warn.outside = getOption("splines2.warn.outside", 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 } ## call the engine function out <- rcpp_bSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, complete_basis = intercept, periodic = periodic, derivs = derivs, integral = integral ) ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (warn.outside && ! 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_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("BSpline", "splines2", "matrix") ## return out } ##' @rdname bSpline ##' @export ibs <- function(x, df = NULL, knots = NULL, degree = 3, intercept = FALSE, Boundary.knots = NULL, ...) { bSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots, integral = TRUE, ...) } ##' @rdname bSpline ##' @export dbs <- function(x, derivs = 1L, df = NULL, knots = NULL, degree = 3, intercept = FALSE, Boundary.knots = NULL, ...) { bSpline(x = x, df = df, knots = knots, degree = degree, intercept = intercept, Boundary.knots = Boundary.knots, derivs = derivs, ...) } ##' @rdname bSpline ##' @export bsp <- bSpline splines2/R/mSpline.R0000644000176200001440000001047314760217640013760 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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. For shape-restricted ##' regression, see Wang and Yan (2021) for examples. ##' ##' The function \code{msp()} is an alias of to encourage the use in a model ##' formula. ##' ##' @inheritParams bSpline ##' @inherit bSpline return ##' ##' @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. ##' ##' Wang, W., & Yan, J. (2021). \emph{Shape-restricted regression splines with R ##' package splines2}. Journal of Data Science, 19(3),498--517. ##' ##' @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, warn.outside = getOption("splines2.warn.outside", 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.") } 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 <- rcpp_mSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, complete_basis = intercept, periodic = periodic, derivs = derivs, integral = integral ) ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (warn.outside && ! 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("MSpline", "splines2", "matrix") out } ##' @rdname mSpline ##' @export msp <- mSpline splines2/R/zzz.R0000644000176200001440000000200014760217640013171 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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. ## ## set default options splines2_default_options <- list( splines2.warn.outside = TRUE ) ## set options for splines2 .onLoad <- function(libname, pkgname) { op <- options() toset <- ! names(splines2_default_options) %in% names(op) if (any(toset)) { options(splines2_default_options[toset]) } invisible() } splines2/R/extract.R0000644000176200001440000000140114760217640014012 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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 `$.splines2` <- function(x, name) { attr(x, name, exact = FALSE) } splines2/R/deriv.R0000644000176200001440000001370614760217640013464 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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.BSpline <- 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", "periodic", "derivs", "integral")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(bSpline, attributes(expr)) } ##' @rdname deriv ##' @export deriv.MSpline <- 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", "periodic", "derivs", "integral")) 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, ...) { ## 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", "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, ...) { ## 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", "derivs", "integral", "knots", "Boundary.knots", "trim", "intercept")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(naturalSpline, attributes(expr)) } ##' @rdname deriv ##' @export deriv.NaturalSplineK <- 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", "derivs", "integral", "knots", "Boundary.knots", "trim", "intercept")) attr(expr, "derivs") <- attr(expr, "derivs") + derivs do.call(nsk, attributes(expr)) } splines2/R/cSpline.R0000644000176200001440000001357114760217640013750 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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. The function \code{csp()} is ##' an alias of to encourage the use in a model formula. ##' ##' @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 iSpline 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, warn.outside = getOption("splines2.warn.outside", 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, complete_basis = intercept, derivs = derivs ) } else { if (derivs == 0) { rcpp_iSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, complete_basis = intercept, derivs = 0, integral = TRUE ) } else { rcpp_iSpline( x = xx, df = df, degree = degree, internal_knots = knots, boundary_knots = Boundary.knots, complete_basis = intercept, derivs = derivs - 1, integral = FALSE ) } } ## throw warning if any x is outside of the boundary b_knots <- attr(out, "Boundary.knots") if (warn.outside && 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("CSpline", "splines2", "matrix") } else if (derivs == 1) { class(out) <- c("ISpline", "splines2", "matrix") } else { class(out) <- c("MSpline", "splines2", "matrix") } ## return out } ##' @rdname cSpline ##' @export csp <- cSpline splines2/R/makepredictcall.R0000644000176200001440000000745714760217640015505 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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) ## remedy for dbs and ibs flag <- if (fun_name == "bSpline") { flag <- grepl(c("^(splines2::)?(bSpline|bsp|dbs|ibs)$"), as.character(call)[1L]) flag || { is.call(call) && { tmp <- eval(call[[1L]]) (identical(tmp, bSpline) || identical(tmp, dbs) || identical(tmp, ibs)) } } } else { as.character(call)[1L] == fun_name || (is.call(call) && identical(eval(call[[1L]]), eval(fun_symbol))) } ## not much we can do for customized wrap functions ## that return the basis functions if (flag) { ## throw warnings instead res <- tryCatch(check_attr(var, .KEY_ATTR), error = function(e) e) if (inherits(res, "error")) { warning(res, call. = FALSE) } else { at <- attributes(var)[.KEY_ATTR] call <- call[1L:2L] call[names(at)] <- at } } ## return call } ##' @export makepredictcall.BSpline <- function(var, call) { helper_makepredictcall( var, call, .FUN = bSpline, .KEY_ATTR = c("degree", "knots", "Boundary.knots", "intercept", "periodic", "derivs", "integral") ) } ##' @export makepredictcall.NaturalSpline <- function(var, call) { helper_makepredictcall( var, call, .FUN = naturalSpline, .KEY_ATTR = c("knots", "Boundary.knots", "trim", "intercept", "derivs", "integral") ) } ##' @export makepredictcall.NaturalSplineK <- function(var, call) { helper_makepredictcall( var, call, .FUN = nsk, .KEY_ATTR = c("knots", "Boundary.knots", "trim", "intercept", "derivs", "integral") ) } ##' @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/knots.R0000644000176200001440000000316314760217640013505 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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 ##' @rdname knots ##' @export knots.splines2 <- 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") } } splines2/R/predict.R0000644000176200001440000001000414760217640013771 0ustar liggesusers## ## R package splines2 by Wenjie Wang and Jun Yan ## Copyright (C) 2016-2025 ## ## 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. ## ##' Compute Spline Function for Given Coefficients ##' ##' Returns the spline function (with the specified coefficients) or evaluate ##' the basis functions at the specified \code{x} if the coefficients are not ##' specified. ##' ##' @name predict ##' @param object Spline objects produced by the \code{splines2} package. ##' @param newx The \code{x} values at which evaluations are required. If it is ##' \code{NULL} (by default), the original \code{x} used to create the ##' spline object will be used. ##' @param coef A numeric vector specifying the coefficients of the spline basis ##' functions. If it is \code{NULL} (by default), the spline basis ##' functions will be returned. Otherwise, the resulting spline function ##' will be returned. ##' @param ... Other options passed to the corresponding function that ##' constructs the input \code{object}. For example, the additional options ##' will be passed to \code{bSpline()} for a \code{BSpline} object. ##' ##' @return The function returns the spline basis functions with the new values ##' of \code{x} if \code{coef} is not specified. Otherwise, the function ##' returns the resulting spline function (or its derivative if ##' \code{derivs} is specified as a positive integer through \code{...}). ##' ##' @example inst/examples/ex-predict.R ##' ##' @importFrom stats predict NULL ## the helper function for predict helper_predict <- function(object, newx = NULL, coef = NULL, ..., .FUN) { res <- if (is.null(newx)) { update(object, ...) } else { update(object, x = newx, ...) } if (is.null(coef)) { return(res) } as.numeric(res %*% coef) } ##' @rdname predict ##' @export predict.BSpline <- function(object, newx = NULL, coef = NULL, ...) { helper_predict( object = object, newx = newx, coef = coef, ..., .FUN = bSpline ) } ##' @rdname predict ##' @export predict.MSpline <- function(object, newx = NULL, coef = NULL, ...) { helper_predict( object = object, newx = newx, coef = coef, ..., .FUN = mSpline ) } ##' @rdname predict ##' @export predict.ISpline <- function(object, newx = NULL, coef = NULL, ...) { helper_predict( object = object, newx = newx, coef = coef, ..., .FUN = iSpline ) } ##' @rdname predict ##' @export predict.CSpline <- function(object, newx = NULL, coef = NULL, ...) { helper_predict( object = object, newx = newx, coef = coef, ..., .FUN = cSpline ) } ##' @rdname predict ##' @export predict.BernsteinPoly <- function(object, newx = NULL, coef = NULL, ...) { helper_predict( object = object, newx = newx, coef = coef, ..., .FUN = bernsteinPoly ) } ##' @rdname predict ##' @export predict.NaturalSpline <- function(object, newx = NULL, coef = NULL, ...) { helper_predict( object = object, newx = newx, coef = coef, ..., .FUN = naturalSpline ) } ##' @rdname predict ##' @export predict.NaturalSplineK <- function(object, newx = NULL, coef = NULL, ...) { helper_predict( object = object, newx = newx, coef = coef, ..., .FUN = nsk ) } splines2/vignettes/0000755000176200001440000000000014760217644014034 5ustar liggesuserssplines2/vignettes/splines2-intro.Rmd0000644000176200001440000005420214665461570017376 0ustar liggesusers--- title: "A Short Introduction to splines2" author: Wenjie Wang date: "`r Sys.Date()`" bibliography: - ../inst/bib/splines2.bib vignette: > %\VignetteIndexEntry{A Short Introduction to splines2} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} output: rmarkdown::html_vignette: number_sections: yes toc: yes --- ```{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.5, 0.1), mgp = c(1.5, 0.5, 0)) ```
# Introduction The R package **splines2** is intended to be a user-friendly supplementary package to the base package **splines**. It provides functions to construct 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()`. More specifically, **splines2** allows users to construct the basis functions of - B-splines - M-splines - I-splines - C-splines - periodic 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 **splines**, the package **splines2** provides convenient interfaces for spline derivatives with consistent handling on `NA`'s. Most of the implementations are in *C++* with the help of **Rcpp** and **RcppArmadillo** since v0.3.0, which boosted the computational performance. In the remainder of this vignette, we illustrate the basic usage of most functions in the package through examples. We refer readers to [Wang and Yan (2021)](https://dx.doi.org/10.6339/21-JDS1020) for a more formal introduction to the package with applications to shape-restricted regression. See the package manual for more details about function usage. ```{r load-lib} library(splines2) packageVersion("splines2") ```
# B-splines {#bSpline} ## B-spline Basis Functions The `bSpline()` function generates the basis matrix for B-splines and extends the function `bs()` of the package **splines** by providing 1) the piece-wise constant basis functions when `degree = 0`, 2) the derivatives of basis functions for a positive `derivs`, 3) the integrals of basis functions if `integral = TRUE`, 4) periodic basis functions based on B-splines if `periodic = TRUE`. One example of linear B-splines with three internal knots is as follows: ```{r bSpline, fig.cap="B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6."} knots <- c(0.3, 0.5, 0.6) x <- seq(0, 1, 0.01) bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) plot(bsMat, mark_knots = "all") ``` ## Integrals and Derivatives of B-splines For convenience, the package also provides functions `ibs()` and `dbs()` for constructing the B-spline integrals and derivatives, respectively. Two toy examples are as follows: ```{r ibs, fig.cap="Piecewise linear B-splines (left) and their integrals (right)."} ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) op <- par(mfrow = c(1, 2)) plot(bsMat, mark_knots = "internal") plot(ibsMat, mark_knots = "internal") abline(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) plot(bsMat, mark_knots = "internal") plot(dbsMat, mark_knots = "internal") ``` 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))) ``` ## Periodic B-splines The function `bSpline()` produces periodic spline basis functions following @piegl1997nurbs [chapter 12] when `periodic = TRUE` is specified. Different from the regular basis functions, the `x` is allowed to be placed outside the boundary and the `Boundary.knots` defines the cyclic interval. For instance, one may obtain the periodic cubic B-spline basis functions with cyclic interval (0, 1) as follows: ```{r pbs} px <- seq(0, 3, 0.01) pbsMat <- bSpline(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) ipMat <- ibs(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) dp1Mat <- deriv(pbsMat) dp2Mat <- deriv(pbsMat, derivs = 2) par(mfrow = c(1, 2)) plot(pbsMat, ylab = "Periodic B-splines", mark_knots = "boundary") plot(ipMat, ylab = "The integrals", mark_knots = "boundary") plot(dp1Mat, ylab = "The 1st derivatives", mark_knots = "boundary") plot(dp2Mat, ylab = "The 2nd derivatives", mark_knots = "boundary") ``` For reference, the corresponding integrals and derivatives are also visualized.
# M-Splines {#mSpline} ## M-spline Basis Functions M-splines [@ramsay1988monotone] can be 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 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) par(op) plot(msMat, mark_knots = "all") ``` The derivative of the given order of M-splines can be obtained by specifying a positive integer to argument `dervis` of `mSpline()`. Similarly, for an existing `mSpline` object generated by `mSpline()`, one can use the `deriv()` method for derivaitives. 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 `mSpline()` function produces periodic splines based on M-spline basis functions when `periodic = TRUE` is specified. The `Boundary.knots` defines the cyclic interval, which is the same with the periodic B-splines. ```{r pms-basis, fig.cap = "Cubic periodic M-splines."} pmsMat <- mSpline(px, knots = knots, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1)) plot(pmsMat, ylab = "Periodic Basis", mark_knots = "boundary") ``` 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) plot(dpmsMat, ylab = "The 1st derivatives", mark_knots = "boundary") ``` 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(px, knots = knots, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE) plot(ipmsMat, ylab = "Integrals", mark_knots = "boundary") abline(h = seq.int(0, 3), lty = 2, col = "gray") ```
# I-Splines {#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 the 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) plot(isMat, mark_knots = "internal") ``` 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 `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 {#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 the 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) plot(csMat1) 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 a higher order. 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 are equivalent to B-splines without internal knots and have also been applied to shape-constrained regression analysis [e.g., @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$. 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)) plot(bpMat1) plot(bpMat2) ``` 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)) plot(ibpMat1, ylab = "Integrals") plot(ibpMat2, ylab = "Integrals") plot(dbpMat1, ylab = "Derivatives") plot(dbpMat2, ylab = "Derivatives") ``` 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 ## Nonnegative Natural Cubic Basis Functions The package provides two variants of the natural cubic splines that can be constructed by `naturalSpline()` and `nsk()`, respectively, both of which are different from `splines::ns()`. The `naturalSpline()` function returns nonnegative basis functions (within the boundary) for natural cubic splines by utilizing a closed-form null space derived from the second derivatives of cubic B-splines. When `integral = TRUE`, the function `naturalSpline()` returns the 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)) plot(nsMat, ylab = "Basis") plot(insMat, ylab = "Integrals") stopifnot(is_equivalent(nsMat, deriv(insMat))) ``` Similarly, one may directly 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) matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives") matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives") ``` ## Natural Cubic Basis Functions with Unit Heights at Knots The function `nsk()` produces another variant of natural cubic splines, where only one of the spline basis functions is nonzero with unit height at every boundary and internal knot. As a result, the coefficients of the basis functions are the values of the spline function at the knots, which makes it more straightforward to interpret the coefficient estimates. This idea originated from the function `nsk()` of the **survival** package (introduced in version 3.2-8). The implementation of the `nsk()` of **splines2** essentially follows the `survival::nsk()` function. One noticeable argument for `nsk()` is `trim` (equivalent to the argument `b` of `survival::nsk()`). One may specify `trim = 0.05` to exclude 5% of the data from both sides when setting the boundary knots, which can be a more sensible choice in practice due to possible outliers. The `trim` argument is also available for `naturalSpline()`, which however is zero by default for backward compatibility. An illustration of the basis functions generated by `nsk()` is as follows: ```{r nsk} nskMat <- nsk(x, knots = knots, intercept = TRUE) par(op) plot(nskMat, ylab = "nsk()", mark_knots = "all") abline(h = 1, col = "red", lty = 3) ``` We can visually verify that only one basis function takes a value of one at each knot.
# Helper and Alias Functions ## Update Spline's Specification by `update()` {#update} The `update()` function is an S3 method to generate spline basis functions with new `x`, `degree`, `knots`, or `df` specifications. The first argument is an existing `splines2` object and additional named arguments will be passed to the corresponding functions to update the spline basis functions. Suppose we want to add two more knots to `nskMat` for natural cubic spline basis functions and exclude 5% of the data from both sides in total when placing the boundary knots. We can utilize the `update()` method as follows: ```{r update-nsk} nskMat2 <- update(nskMat, knots = c(knots, 0.2, 0.4), trim = 0.025) knots(nskMat2) stopifnot(all.equal(quantile(x, c(0.025, 0.975), names = FALSE), knots(nskMat2, "boundary"))) ``` ## Evaluation by `predict()` {#predict} The `predict()` method for `splines2` objects allows one to evaluate the spline function if a coefficient vector is specified via the `coef` argument. In addition, it internally calls the `update()` method to update the basis functions before computing the spline function, which can be useful to get the derivatives of the spline function. If the `coef` argument is not specified, the `predict()` method will be equivalent to the `update()` method. For instance, we can compute the first derivative of the I-spline function from the previous example with a coefficient vector `seq(0.1, by = 0.1, length.out = ncol(isMat))` at $x = (0.275, 0.525, 0.8)$ as follows: ```{r predict} new_x <- c(0.275, 0.525, 0.8) names(new_x) <- paste0("x=", new_x) (isMat2 <- predict(isMat, newx = new_x)) # the basis functions at new x stopifnot(all.equal(predict(isMat, newx = new_x), update(isMat, x = new_x))) ## compute the first derivative of the I-spline function in different ways beta <- seq(0.1, by = 0.1, length.out = ncol(isMat)) deriv_ispline1 <- predict(isMat, newx = new_x, coef = beta, derivs = 1) deriv_ispline2 <- predict(update(isMat, x = new_x, derivs = 1), coef = beta) deriv_ispline3 <- c(predict(deriv(isMat), newx = new_x) %*% beta) stopifnot(all.equal(deriv_ispline1, deriv_ispline2)) stopifnot(all.equal(deriv_ispline2, deriv_ispline3)) ``` ## Visualization by `plot()` {#plot} As one may notice in the previous examples, we may visualize the spline basis functions easily with the `plot()` method. By default, the spline basis functions are visualized at 101 equidistant grid points within the range of `x`, which can be tweaked by arguments `from`, `to`, and `n`. In addition, we can indicate the placement of knots by vertical lines through the argument `mark_knots`. The available options are `"none"`, `"internal"`, `"boundary"`, and `"all"`. A fitted spline function can be visualized by specifying the argument `coef`. An example of `nsk()` is as follows: ```{r plot-coef} beta <- seq.int(0.2, length.out = ncol(nskMat), by = 0.2) plot(nskMat, ylab = "nsk()", mark_knots = "all", coef = beta) abline(h = beta, col = seq_along(beta), lty = 3) ``` ## Including Spline Basis Functions in Model Formulas It is common to directly include spline basis functions in a model formula. To avoid a lengthy model formula, the package provides alias functions that are summarized in the following table: | Function | Equivalent Alias | |-------------------|------------------| | `bSpline()` | `bsp()` | | `mSpline()` | `msp()` | | `iSpline()` | `isp()` | | `cSpline()` | `csp()` | | `bernsteinPoly()` | `bpoly()` | | `naturalSpline()` | `nsp()` | One may create new alias functions. For example, we can create a new alias function simply named `b()` for B-splines and obtain equivalent models as follows: ```{r formula-alias} b <- bSpline # create an alias for B-splines mod1 <- lm(weight ~ b(height, degree = 1, df = 3), data = women) iknots <- with(women, knots(bSpline(height, degree = 1, df = 3))) mod2 <- lm(weight ~ bSpline(height, degree = 1, knots = iknots), data = women) pred1 <- predict(mod1, head(women, 10)) pred2 <- predict(mod2, head(women, 10)) stopifnot(all.equal(pred1, pred2)) ``` Nevertheless, there is a possible pitfall when using a customized wrapper function for spline basis functions along with a data-dependent placement of knots. When we make model predictions for a given new data, the placement of the internal/boundary knots can be different from the original placement that depends on the training set. As a result, the spline basis functions generated for prediction may not be the same as the counterparts used in the model fitting. A simple example is as follows: ```{r formula-wrap-failed} ## generates quadratic spline basis functions based on log(x) qbs <- function(x, ...) { splines2::bSpline(log(x), ..., degree = 2) } mod3 <- lm(weight ~ qbs(height, df = 5), data = women) mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women) stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef pred3 <- predict(mod3, head(women, 10)) pred4 <- predict(mod4, head(women, 10)) all.equal(pred3, pred4) pred0 <- predict(qbs(women$height, df = 5), newx = head(log(women$height), 10), coef = coef(mod3)[- 1]) + coef(mod3)[1] stopifnot(all.equal(pred0, pred4, check.names = FALSE)) ``` Although the coefficient estimates are the same, the prediction results by using the `predict.lm()` differ. Using an alias function in the model formula produces correct results. To resolve this issue, we can create an S3 method for `stats::makepredictcall()` as follows: ```{r predict-qbs} ## generates quadratic spline basis functions based on log(x) with a new class qbs <- function(x, ...) { res <- splines2::bSpline(log(x), ..., degree = 2) class(res) <- c("qbs", class(res)) return(res) } ## a utility to help model.frame() create the right matrices makepredictcall.qbs <- function(var, call) { if (as.character(call)[1L] == "qbs" || (is.call(call) && identical(eval(call[[1L]]), qbs))) { at <- attributes(var)[c("knots", "Boundary.knots", "intercept", "periodic", "derivs", "integral")] call <- call[1L:2L] call[names(at)] <- at } call } ## the same example mod3 <- lm(weight ~ qbs(height, df = 5), data = women) mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women) stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef pred3 <- predict(mod3, head(women, 10)) pred4 <- predict(mod4, head(women, 10)) all.equal(pred3, pred4) # should be TRUE this time ``` ## Extract Specifications by `$` The basis specifications are saved as attributes of the returned *splines2* objects, which means that we can extract one of the specifications by `attr()`. Alternatively, we can treat *splines2* objects as lists and use the corresponding `$` method. For example, it is straightforward to extract the specified `trim` of `nskMat2` by `attr(nskMat2, "trim")` or simply `nskMat2$trim`. ```{r extract} c(nskMat2$trim, attr(nskMat2, "trim")) ```
# Reference {-} splines2/vignettes/splines2-wi-rcpp.Rmd0000644000176200001440000002307014425773431017617 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} %\VignetteEncoding{UTF-8} output: rmarkdown::html_vignette: number_sections: yes toc: yes --- # Introduction In this vignette, we introduce how to use the C++ header-only library that **splines2** contains with the **Rcpp** package [@eddelbuettel2013springer] for constructing spline basis functions directly in C++. The introduction is intended for package developers who would like to use **splines2** package in C++ by adding **splines2** to the `LinkingTo` field of the package `DESCRIPTION` file. # Header Files and Namespace Different from 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 the help of **RcppArmadillo** [@eddelbuettel2014csda] and require C++11. We assume that C++11 is enabled and the header file named `splines2Armadillo.h` is included for access to all the classes and implementations in the namespace `splines2` henceforth. ```cpp #include #include // include header files from splines2 // [[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 ``` # 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` and `NaturalSplineK` for natural cubic splines; - `PeriodicMSpline` for periodic M-splines; - `PeriodicBSpline` for periodic B-splines; ## 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. specify x, internal knots, degree, and boundary 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 (DF) of the *complete spline basis functions* (different from the `df` argument 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 the boundary. ```cpp // 2. specify x, spline DF, degree, and boundary knots 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 the basis functions with an extended knot sequence, where the multiplicities of the knots can be more than one. ```cpp // 3. specify x, 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 can create a `BSpline` object named `bsp_obj` from an existing `MSpline` object named `msp_obj` with the same specification as follows: ```cpp BSpline bsp_obj { &msp_obj }; ``` ## Constructors of `PeriodicMSpline` and `PeriodicBSpline` The `PeriodicMSpline` and `PeriodicBSpline` classes are intended for constructing the periodic M-splines and periodic B-splines, respectively, which provide the same set of non-default constructors with `BSpline`. The only difference is that the knot sequence specified for the third non-default constructor must be a *simple knot sequence*. ## Constructors of `NaturalSpline` and `NaturalSplineK` The classes `NaturalSpline` and `NaturalSplineK` are intended for natural cubic splines. The former corresponds to the function `splines2::naturalSpline()` (or `splines2::nsp()`) in R, while the latter is the engine of the function `splines2::nsk()`. They have the same constructors that do not allow the specification of the `degree`. Taking `NaturalSpline` as an example, the first non-default constructor is called when internal knots are explicitly specified. ```cpp // 1. specify x, internal knots, and boundary 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 from the `df` argument 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. specify x, spline DF, and boundary knots 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); ``` ## 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); ``` We can 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`. # Generalized Bernstein Polynomials The `BernsteinPoly` class is provided 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 the basis functions - `derivative()` for the derivatives of basis functions - `integral()` for the 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. # Reference {-} splines2/src/0000755000176200001440000000000014760217644012613 5ustar liggesuserssplines2/src/RcppExports.cpp0000644000176200001440000002445414760217640015615 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 bool complete_basis, const bool periodic, const unsigned int derivs, const bool integral); RcppExport SEXP _splines2_rcpp_bSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP, SEXP periodicSEXP, SEXP derivsSEXP, SEXP integralSEXP) { 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::traits::input_parameter< const bool >::type periodic(periodicSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_bSpline(x, df, degree, internal_knots, boundary_knots, complete_basis, periodic, derivs, integral)); 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 bool complete_basis, const bool periodic, const unsigned int derivs, const bool integral); RcppExport SEXP _splines2_rcpp_mSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP, SEXP periodicSEXP, SEXP derivsSEXP, SEXP integralSEXP) { 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::traits::input_parameter< const bool >::type periodic(periodicSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_mSpline(x, df, degree, internal_knots, boundary_knots, complete_basis, periodic, derivs, integral)); return rcpp_result_gen; END_RCPP } // rcpp_bernsteinPoly Rcpp::NumericMatrix rcpp_bernsteinPoly(const arma::vec& x, const unsigned int degree, const arma::vec& boundary_knots, const bool complete_basis, const unsigned int derivs, const bool integral); RcppExport SEXP _splines2_rcpp_bernsteinPoly(SEXP xSEXP, SEXP degreeSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP, SEXP derivsSEXP, SEXP integralSEXP) { 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 arma::vec& >::type boundary_knots(boundary_knotsSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_bernsteinPoly(x, degree, boundary_knots, complete_basis, derivs, integral)); 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 bool complete_basis, const unsigned int derivs, const bool integral); RcppExport SEXP _splines2_rcpp_iSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP, SEXP derivsSEXP, SEXP integralSEXP) { 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::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_iSpline(x, df, degree, internal_knots, boundary_knots, complete_basis, derivs, integral)); 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 bool complete_basis, const unsigned int derivs); RcppExport SEXP _splines2_rcpp_cSpline(SEXP xSEXP, SEXP dfSEXP, SEXP degreeSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP complete_basisSEXP, SEXP derivsSEXP) { 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::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_cSpline(x, df, degree, internal_knots, boundary_knots, complete_basis, derivs)); 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 double trim, const bool complete_basis, const unsigned int derivs, const bool integral); RcppExport SEXP _splines2_rcpp_naturalSpline(SEXP xSEXP, SEXP dfSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP trimSEXP, SEXP complete_basisSEXP, SEXP derivsSEXP, SEXP integralSEXP) { 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 double >::type trim(trimSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_naturalSpline(x, df, internal_knots, boundary_knots, trim, complete_basis, derivs, integral)); return rcpp_result_gen; END_RCPP } // rcpp_nsk Rcpp::NumericMatrix rcpp_nsk(const arma::vec& x, const unsigned int df, const arma::vec& internal_knots, const arma::vec& boundary_knots, const double trim, const bool complete_basis, const unsigned int derivs, const bool integral); RcppExport SEXP _splines2_rcpp_nsk(SEXP xSEXP, SEXP dfSEXP, SEXP internal_knotsSEXP, SEXP boundary_knotsSEXP, SEXP trimSEXP, SEXP complete_basisSEXP, SEXP derivsSEXP, SEXP integralSEXP) { 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 double >::type trim(trimSEXP); Rcpp::traits::input_parameter< const bool >::type complete_basis(complete_basisSEXP); Rcpp::traits::input_parameter< const unsigned int >::type derivs(derivsSEXP); Rcpp::traits::input_parameter< const bool >::type integral(integralSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_nsk(x, df, internal_knots, boundary_knots, trim, complete_basis, derivs, integral)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { {"_splines2_rcpp_bSpline", (DL_FUNC) &_splines2_rcpp_bSpline, 9}, {"_splines2_rcpp_mSpline", (DL_FUNC) &_splines2_rcpp_mSpline, 9}, {"_splines2_rcpp_bernsteinPoly", (DL_FUNC) &_splines2_rcpp_bernsteinPoly, 6}, {"_splines2_rcpp_iSpline", (DL_FUNC) &_splines2_rcpp_iSpline, 8}, {"_splines2_rcpp_cSpline", (DL_FUNC) &_splines2_rcpp_cSpline, 7}, {"_splines2_rcpp_naturalSpline", (DL_FUNC) &_splines2_rcpp_naturalSpline, 8}, {"_splines2_rcpp_nsk", (DL_FUNC) &_splines2_rcpp_nsk, 8}, {NULL, NULL, 0} }; RcppExport void R_init_splines2(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } splines2/src/Makevars.win0000644000176200001440000000024014412404436015066 0ustar liggesusersPKG_CPPFLAGS = -I../inst/include PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) CXX_STD=CXX17 splines2/src/splines2_export.cpp0000644000176200001440000003070114760217640016454 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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 #include template Rcpp::NumericMatrix bm_spline( 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, const unsigned int derivs = 0, const bool integral = false ) { Rcpp::NumericMatrix out; T sp_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 }; sp_obj = T(x, spline_df, degree, boundary_knots); } else { // else ignore df sp_obj = T(x, internal_knots, degree, boundary_knots); } // 1) basis, 2) derivative, or 3) integral if (integral && derivs == 0) { // integrals out = splines2::arma2rmat(sp_obj.integral(complete_basis)); } else if ((! integral && derivs == 0) || (integral && derivs == 1)) { // basis functions out = splines2::arma2rmat(sp_obj.basis(complete_basis)); } else { // derivatives out = splines2::arma2rmat( sp_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(sp_obj.get_degree()); out.attr("knots") = splines2::arma2rvec(sp_obj.get_internal_knots()); out.attr("Boundary.knots") = splines2::arma2rvec(sp_obj.get_boundary_knots()); out.attr("intercept") = complete_basis; out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; // out.attr("x_index") = splines2::arma2ivec(sp_obj.get_x_index()) + 1; return out; } // [[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 bool complete_basis = true, const bool periodic = false, const unsigned int derivs = 0, const bool integral = false ) { Rcpp::NumericMatrix out; if (periodic) { out = bm_spline( x, df, degree, internal_knots, boundary_knots, complete_basis, derivs, integral); } else { out = bm_spline( x, df, degree, internal_knots, boundary_knots, complete_basis, derivs, integral); } out.attr("periodic") = periodic; return out; } // [[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 bool complete_basis = true, const bool periodic = false, const unsigned int derivs = 0, const bool integral = false ) { Rcpp::NumericMatrix out; if (periodic) { out = bm_spline( x, df, degree, internal_knots, boundary_knots, complete_basis, derivs, integral); } else { out = bm_spline( x, df, degree, internal_knots, boundary_knots, complete_basis, derivs, integral); } out.attr("periodic") = periodic; return out; } // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_bernsteinPoly( const arma::vec& x, const unsigned int degree, const arma::vec& boundary_knots, const bool complete_basis = true, const unsigned int derivs = 0, const bool integral = false ) { 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("intercept") = complete_basis; out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; return out; } // [[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 bool complete_basis = false, const unsigned int derivs = 0, const bool integral = false ) { 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("intercept") = complete_basis; out.attr("derivs") = static_cast(derivs); // out.attr("x_index") = splines2::arma2ivec(is_obj.get_x_index()) + 1; return out; } // [[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 bool complete_basis = false, const unsigned int derivs = 0 ) { 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("intercept") = complete_basis; out.attr("derivs") = static_cast(derivs); // out.attr("x_index") = splines2::arma2ivec(cs_obj.get_x_index()) + 1; out.attr("scales") = splines2::arma2rvec(cs_obj.get_scales()); return out; } template Rcpp::NumericMatrix template_naturalSpline( const arma::vec& x, const unsigned int df, const arma::vec& internal_knots, const arma::vec& boundary_knots, const double trim = 0.0, const bool complete_basis = false, const unsigned int derivs = 0, const bool integral = false ) { T ns_obj; arma::vec bknots { boundary_knots }; if (bknots.n_elem == 0) { arma::vec p_trim { trim, 1 - trim }; bknots = splines2::quantile(x, p_trim); } // 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 = T(x, spline_df, bknots); } else { // else ignore df ns_obj = T(x, internal_knots, bknots); } 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(bknots); out.attr("trim") = trim; out.attr("intercept") = complete_basis; out.attr("derivs") = static_cast(derivs); out.attr("integral") = integral; // out.attr("x_index") = splines2::arma2ivec(ns_obj.get_x_index()) + 1; out.attr("H") = ns_obj.get_transform_matrix(); return out; } // [[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 double trim = 0.0, const bool complete_basis = false, const unsigned int derivs = 0, const bool integral = false ) { return template_naturalSpline( x, df, internal_knots, boundary_knots, trim, complete_basis, derivs, integral ); } // [[Rcpp::export]] Rcpp::NumericMatrix rcpp_nsk( const arma::vec& x, const unsigned int df, const arma::vec& internal_knots, const arma::vec& boundary_knots, const double trim = 0.0, const bool complete_basis = false, const unsigned int derivs = 0, const bool integral = false ) { return template_naturalSpline( x, df, internal_knots, boundary_knots, trim, complete_basis, derivs, integral ); } splines2/src/Makevars0000644000176200001440000000047114412404431014273 0ustar liggesusers## generated by RcppArmadillo.package.skeleton() PKG_CPPFLAGS = -I../inst/include PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) CXX_STD=CXX17 ## for profiling # PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) -lprofiler splines2/NAMESPACE0000644000176200001440000000263514423311457013242 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",splines2) S3method(deriv,BSpline) S3method(deriv,BernsteinPoly) S3method(deriv,CSpline) S3method(deriv,ISpline) S3method(deriv,MSpline) S3method(deriv,NaturalSpline) S3method(deriv,NaturalSplineK) S3method(knots,splines2) S3method(makepredictcall,BSpline) S3method(makepredictcall,BernsteinPoly) S3method(makepredictcall,CSpline) S3method(makepredictcall,ISpline) S3method(makepredictcall,MSpline) S3method(makepredictcall,NaturalSpline) S3method(makepredictcall,NaturalSplineK) S3method(plot,splines2) S3method(predict,BSpline) S3method(predict,BernsteinPoly) S3method(predict,CSpline) S3method(predict,ISpline) S3method(predict,MSpline) S3method(predict,NaturalSpline) S3method(predict,NaturalSplineK) S3method(print,splines2) S3method(update,BSpline) S3method(update,BernsteinPoly) S3method(update,CSpline) S3method(update,ISpline) S3method(update,MSpline) S3method(update,NaturalSpline) S3method(update,NaturalSplineK) export(bSpline) export(bernsteinPoly) export(bpoly) export(bsp) export(cSpline) export(csp) export(dbs) export(iSpline) export(ibs) export(isp) export(mSpline) export(msp) export(naturalSpline) export(nsk) export(nsp) importFrom(Rcpp,sourceCpp) importFrom(graphics,abline) importFrom(graphics,matplot) importFrom(stats,deriv) importFrom(stats,knots) importFrom(stats,makepredictcall) importFrom(stats,predict) importFrom(stats,update) useDynLib(splines2) splines2/NEWS.md0000644000176200001440000002275014760107703013122 0ustar liggesusers# splines2 0.5.4 ## Minor changes * Suppressed the warning message for data outside boundary from the `plot()` methods. ## Bug fixes * Fixed the implementation of natural cubic splines with one internal knot: [issue 18](https://github.com/wenjie2wang/splines2/issues/22). # splines2 0.5.3 ## Minor changes * Incorporated changes suggested by GCC compiler for C++20 to suppress the warning: `warning: template-id not allowed for constructor in C++20`. # splines2 0.5.2 ## New features * Added a new argument named `coef` to the `plot()` method for `splines2` objects, allowing visualization of the fitted spline function with a given coefficient vector. ## Minor changes * Made the error message more clear for duplicated internal knots. # splines2 0.5.1 ## Minor changes * Fixed broken `@docType package` documentation. # splines2 0.5.0 ## New features * Added a new function named `nsk()` for natural cubic spline basis functions following the function `survival::nsk()` (introduced in **survival** package version 3.2-8). * Added `plot()` methods to quickly visualize the spline basis functions. * Added `$` method to extract an attribute of the returned `splines2` object. * Added a new argument named `periodic` to `bSpline()` for periodic B-splines and a new class named `PeriodicBSpline` to the **Rcpp** interface: [issue 19](https://github.com/wenjie2wang/splines2/issues/19). * Added a new argument named `coef` to the `predict()` methods to compute the responding spline function and made it possible to obtain the derivatives or update spline basis functions by passing `...` to the `update()` methods. * Added a new argument named `trim` to `naturalSpline()` to set the default boundary knots after trimming a fraction of observations. * Added a new argument named `warn.outside` and a package option named `splines2.warn.outside` to specify if a warning should be thrown out for B-splines, etc. when any `x` is placed outside the boundary. * Added the following function aliases to encourage the use in a model formula: * `bsp()` = `bSpline()` * `msp()` = `mSpline()` * `isp()` = `iSpline()` * `csp()` = `cSpline()` * `nsp()` = `naturalSpline()` * `bpoly()` = `bernsteinPoly()` * Added a matrix named `H` to the attribution of objects for natural cubic splines so that users may transform cubic B-splines (from other software/packages) to the natural cubic splines (returned by `naturalSpline()`/`nsp()` or `nsk()`). ## Major changes * Adjusted the class order of the returned objects. * Adjusted the default placement of the internal knots from the specified `df` to be equidistant if the internal knots resulting from quantiles are problematic. A warning will be thrown out in that case. # splines2 0.4.8 ## Bug fixes * Fixed the Rcpp interface of `PeriodicMSpline` so that a simple knot sequence can be specified through `set_knot_sequence`: [issue 18](https://github.com/wenjie2wang/splines2/issues/18). # splines2 0.4.7 ## Minor changes * Adjusted the column arrangement of the natural cubic spline basis matrix so that it matches the equations given in the JDS paper: [issue 17](https://github.com/wenjie2wang/splines2/issues/17). # splines2 0.4.6 ## New features * Added `update()` methods to produce new spline basis functions based on the given object with specified updates in terms of `degree` and `knots`, etc. ## Minor changes * Appended a new class named `splines2` to the output matrices to simplify some common S3 methods. # 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/inst/0000755000176200001440000000000014760217644013001 5ustar liggesuserssplines2/inst/include/0000755000176200001440000000000014760217640014420 5ustar liggesuserssplines2/inst/include/splines2Armadillo.h0000644000176200001440000000216714760217640020163 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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 #ifndef ARMA_NO_DEBUG #define ARMA_NO_DEBUG #endif #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/NaturalSplineK.h" #include "splines2Armadillo/PeriodicSpline.h" #endif splines2/inst/include/splines2Armadillo/0000755000176200001440000000000014760246062020004 5ustar liggesuserssplines2/inst/include/splines2Armadillo/ISpline.h0000644000176200001440000000730214760217640021522 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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 I-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/CSpline.h0000644000176200001440000000706414760217640021521 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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 C-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/BernsteinPoly.h0000644000176200001440000002351314760217640022756 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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.h0000644000176200001440000004451014760217640022206 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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(); } } // helper to generate default internal knots // goal: unique, inside boundary, of the specified length inline rvec gen_default_internal_knots( const rvec& x_inside, const rvec& boundary_knots, const unsigned int n_internal_knots) const { rvec prob_vec { linspace_inside(0, 1, n_internal_knots) }; // 1. set knots based on quantiles // 2. check if 1) any duplicated, 2) coincide with boundary // 3. set knots to have equal distance as the last resort rvec internal_knots { quantile(x_inside, prob_vec) }; const bool any_dup { any_duplicated(internal_knots) }; if (any_dup) { Rcpp::warning( "Set equidistant internal knots " "(found duplicated knots from quantiles)."); return linspace_inside(boundary_knots(0), boundary_knots(1), n_internal_knots); } // else double min_int_knots { internal_knots(0) }; double max_int_knots { internal_knots(internal_knots.n_elem - 1) }; if (boundary_knots(0) >= min_int_knots || boundary_knots(1) <= max_int_knots) { Rcpp::warning("Set equidistant internal knots " "(found on-boundary knots from quantiles)"); return linspace_inside(boundary_knots(0), boundary_knots(1), n_internal_knots); } return internal_knots; } // 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 ) const { 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 set_simple_knot_sequence() { 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)) ) || has_internal_multiplicity_; // 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 { set_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_) { throw std::range_error("Found duplicated internal knots"); } if (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->has_internal_multiplicity_ }, 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; } // 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; } // 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_ }; simplify_knots(rvec(), boundary_knots); if (n_internal_knots > 0) { rvec x_inside { get_inside_x(x, boundary_knots_) }; internal_knots_ = gen_default_internal_knots( x_inside, boundary_knots_, n_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_) { // if a knot sequence has been set and it is extended, // update knot sequence // so that internal/boundary knots are update-to-date 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_; } inline uvec get_x_index() { update_x_index(); return x_index_; } // 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/utils.h0000644000176200001440000001567314760217640021331 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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 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; } // x of length inside (start, end) from seq(start, end, length.out + 2) inline arma::vec linspace_inside(const double start, const double end, const unsigned int length) { arma::vec out { arma::linspace(start, end, length + 2) }; return out.subvec(1, length); } // 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()); } template inline Rcpp::IntegerVector arma2ivec(const T& x) { return Rcpp::IntegerVector(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/NaturalSplineK.h0000644000176200001440000000351414760217640023054 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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_NATURALSPLINEK_H #define SPLINES2_NATURALSPLINEK_H #include #include "common.h" #include "utils.h" #include "NaturalSpline.h" namespace splines2 { // define a class for Natural cubic splines class NaturalSplineK : public NaturalSpline { protected: // compute the transformation matrix so that only one of the basis // functions attains one at the internal and boundary knots inline void set_null_colvecs(const bool standardize = true) override { // get natural spline basis functions at knots NaturalSpline nsp_obj { this }; rvec flat_knots { get_simple_knot_sequence(nsp_obj.get_internal_knots(), nsp_obj.get_boundary_knots(), 1) }; nsp_obj.set_x(flat_knots); rmat kmat { nsp_obj.basis(true) }; null_colvecs_ = nsp_obj.get_transform_matrix() * arma::inv(kmat); } public: // the default constructor NaturalSplineK() {} using NaturalSpline::NaturalSpline; }; } // splines2 #endif /* SPLINES2_NATURALSPLINEK_H */ splines2/inst/include/splines2Armadillo/BSpline.h0000644000176200001440000002351314760217640021515 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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/MSpline.h0000644000176200001440000002471214760217640021532 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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/NaturalSpline.h0000644000176200001440000003416214760217640022744 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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 cubic splines class NaturalSpline : public SplineBase { private: using SplineBase::set_order; protected: rmat null_colvecs_ = rmat(); // 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 virtual void set_null_colvecs(const bool standardize = true) { // initialize null_colvecs or // update null_colvecs_ if the knot sequence has been updated if (! null_colvecs_.is_empty() && is_knot_sequence_latest_) { return; } null_colvecs_ = arma::zeros(spline_df_ + 2, spline_df_); size_t n_knots { internal_knots_.n_elem }; // see Supplementary of 10.6339/21-JDS1020 for details 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 const double w1 { internal_knots_(0) - boundary_knots_(0) }; const double w2 { boundary_knots_(1) - internal_knots_(0) }; const double w3 { w1 + w2 }; null_colvecs_(0, 0) = 1.0 + w1 / w3; null_colvecs_(1, 0) = 1.0; null_colvecs_(1, 1) = 1.0 / (1.0 + w3 / w1); null_colvecs_(2, 1) = 1.0; null_colvecs_(3, 1) = 1.0 / (1.0 + w3 / w2); null_colvecs_(3, 2) = 1.0; null_colvecs_(4, 2) = 1.0 + w2 / w3; } 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, spline_df_ - 1) = 1.0; } null_colvecs_(1, 1) = 1.0; null_colvecs_(2, 1) = 1.0 + (internal_knots_(1) - boundary_knots_(0)) / (internal_knots_(0) - boundary_knots_(0)); null_colvecs_(spline_df_ - 1, spline_df_ - 2) = 1.0 + (boundary_knots_(1) - internal_knots_(n_knots - 2)) / (boundary_knots_(1) - internal_knots_(n_knots - 1)); null_colvecs_(spline_df_, spline_df_ - 2) = 1.0; if (spline_df_ > 4) { for (size_t j {0}; j < spline_df_ - 4; ++j) { null_colvecs_(j + 3, j + 2) = 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(); 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 }; simplify_knots(rvec(), boundary_knots); if (n_internal_knots > 0) { // get quantiles of x within boundary only rvec x_inside { get_inside_x(x, boundary_knots_) }; internal_knots_ = gen_default_internal_knots( x_inside, boundary_knots_, n_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(); 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 set_null_colvecs(); 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(); 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 set_null_colvecs(); 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(); 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 set_null_colvecs(); 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; } inline NaturalSpline* set_degree(const unsigned int degree) override { if (degree > 0) {} return this; } // get the null space matrix for transformation inline rmat get_transform_matrix() { set_null_colvecs(); return null_colvecs_; } }; } // splines2 #endif /* SPLINES2_NATURALSPLINE_H */ splines2/inst/include/splines2Armadillo/PeriodicSpline.h0000644000176200001440000003130114760217640023064 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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_PERIODICSPLINE_H #define SPLINES2_PERIODICSPLINE_H #include #include #include "common.h" #include "utils.h" #include "SplineBase.h" #include "MSpline.h" #include "BSpline.h" namespace splines2 { // define a class for nonnegative periodic spline basis over [a, b] // with unit integral over [a, b] template class PeriodicSpline : 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) { if (is_extended_knot_sequence_) { set_extended_knot_sequence(knot_sequence_); } else { // if it is a simple knot sequence previously, // we will assume a simple knot sequence set_simple_knot_sequence(); } } stopifnot_simple_knot_sequence(); extend_knot_sequence(); } 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: PeriodicSpline() {} explicit PeriodicSpline(const SplineBase* pSplineBase) : SplineBase(pSplineBase) { // stopifnot_simple_knot_sequence(); update_spline_df(); } // given boundary_knots for consistency with SplineBase PeriodicSpline(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(); } PeriodicSpline(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 }; simplify_knots(rvec(), boundary_knots); // get quantiles of x in range set_x_in_range(); internal_knots_ = gen_default_internal_knots( x_in_range_, boundary_knots_, n_internal_knots); } // possible to specify knot sequence directly. But it must be a simple // knot sequence. PeriodicSpline(const rvec& x, const unsigned int degree, const rvec& knot_sequence) { x_ = x; degree_ = degree; order_ = degree_ + 1; set_extended_knot_sequence(knot_sequence); stopifnot_simple_knot_sequence(); } inline SplineBase* set_knot_sequence( const rvec& knot_sequence ) override { set_extended_knot_sequence(knot_sequence); return this; } //! 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 { update_knot_sequence(); set_x_in_range(); // create a Spline object for the extended knot sequence T_sp bs_obj { x_in_range_, degree_, knot_sequence_ }; rmat b_mat { bs_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 { update_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 set_x_in_range(); // create a Spline object for the extended knot sequence T_sp bs_obj { x_in_range_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat b_mat { bs_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 { update_knot_sequence(); set_x_in_range(); // create a Spline object for the extended knot sequence T_sp bs_obj { x_in_range_, surrogate_internal_knots_, degree_, surrogate_boundary_knots_ }; rmat b_mat { bs_obj.integral(true) }; // remove first and last #degree basis functions b_mat = b_mat.cols(degree_, b_mat.n_cols - order_); if constexpr (std::is_same::value) { // unit integrals for M-splines inside boundary // get initial values at the left boundary knot rmat v0 { bs_obj.set_x(boundary_knots_(0))->integral(true) }; // remove first and last #degree basis functions v0 = v0.cols(degree_, v0.n_cols - order_); for (size_t j {0}; j < v0.n_cols; ++j) { // clear initial values b_mat.col(j) -= v0(0, j); } // 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) = (x_num_shift_ >= 0) % (b_mat.col(j) + x_num_shift_); } } else { // more general // get initial values at the boundary knots rmat v0 { bs_obj.set_x(boundary_knots_)->integral(true) }; // remove first and last #degree basis functions v0 = v0.cols(degree_, v0.n_cols - order_); // post-processing b_mat = clamp_basis(b_mat); v0 = clamp_basis(v0); arma::rowvec diff_v0 { v0.row(1) - v0.row(0) }; // get cumulative sum of integral from left boundary knot for (size_t j {0}; j < b_mat.n_cols; ++j) { // clear initial values b_mat.col(j) -= v0(0, j); b_mat.col(j) = (x_num_shift_ >= 0) % (b_mat.col(j) + diff_v0(j) * x_num_shift_); } } // return if (complete_basis) { return b_mat; } // else return mat_wo_col1(b_mat); } }; // end of PeriodicSpline // from the template using PeriodicBSpline = PeriodicSpline; using PeriodicMSpline = PeriodicSpline; } // splines2 #endif /* SPLINES2_PERIODICSPLINE_H */ splines2/inst/include/splines2Armadillo/common.h0000644000176200001440000000166714760217640021457 0ustar liggesusers// // R package splines2 by Wenjie Wang and Jun Yan // Copyright (C) 2016-2025 // // 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/CITATION0000644000176200001440000000132114760217640014127 0ustar liggesusersbibentry( key = "splines2-package", bibtype = "Manual", title = "{splines2}: {R}egression Spline Functions and Classes", author = c( as.person("Wenjie Wang"), as.person("Jun Yan") ), year = "2025", url = "https://CRAN.R-project.org/package=splines2", note = "R package version 0.5.4" ) 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/examples/0000755000176200001440000000000014716263527014621 5ustar liggesuserssplines2/inst/examples/ex-cSpline.R0000644000176200001440000000154714441404666016756 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) plot(csMat, ylab = "C-spline basis", mark_knots = "internal") isMat <- deriv(csMat) msMat <- deriv(csMat, derivs = 2) plot(isMat, ylab = "scaled I-spline basis") plot(msMat, 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)) splines2/inst/examples/ex-bernsteinPoly.R0000644000176200001440000000221714441404173020202 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)) plot(bMat1) plot(bMat2) ## 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)) plot(d1Mat1) plot(d1Mat2) plot(d2Mat1) plot(d2Mat2) ## 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-naturalSpline.R0000644000176200001440000000302414760105107020162 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## naturalSpline() nsMat0 <- naturalSpline(x, knots = knots, intercept = TRUE) nsMat1 <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) nsMat2 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) 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)) plot(nsMat0, ylab = "basis") plot(nsMat1, ylab = "integral") plot(nsMat2, ylab = "1st derivative") plot(nsMat3, ylab = "2nd derivative") par(op) # reset to previous plotting settings ## nsk() nskMat <- nsk(x, knots = knots, intercept = TRUE) plot(nskMat, ylab = "nsk()", mark_knots = "all") abline(h = 1, col = "red", lty = 3) ## 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)) ## a linear model example fit1 <- lm(weight ~ -1 + nsk(height, df = 4, intercept = TRUE), data = women) fit2 <- lm(weight ~ nsk(height, df = 3), data = women) ## the knots (same for both fits) knots <- unlist(attributes(fit1$model[[2]])[c("Boundary.knots", "knots")]) ## predictions at the knot points predict(fit1, data.frame(height = sort(unname(knots)))) unname(coef(fit1)) # equal to the coefficient estimates ## different interpretation when "intercept = FALSE" unname(coef(fit1)[-1] - coef(fit1)[1]) # differences: yhat[2:4] - yhat[1] unname(coef(fit2))[-1] # ditto 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-update.R0000644000176200001440000000033114271256757016640 0ustar liggesuserslibrary(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## quadratic B-splines bsMat2 <- bSpline(x, knots = knots, degree = 2, intercept = TRUE) ## cubic B-splines bsMat3 <- update(bsMat2, degree = 3) splines2/inst/examples/ex-predict.R0000644000176200001440000000233714665461570017016 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) ## Cubic B-spline basis functions bs_mat <- bSpline(x, knots = knots) ## compute the B-spline basis functions at new x predict(bs_mat, newx) ## compute the B-spline function for the specified coefficients beta <- runif(ncol(bs_mat)) predict(bs_mat, coef = beta) ## compute the first derivative of the B-spline function predict(bs_mat, coef = beta, derivs = 1) ## or equivalently predict(deriv(bs_mat), coef = beta) ## compute the second derivative predict(bs_mat, coef = beta, derivs = 2) ## or equivalently predict(deriv(bs_mat, derivs = 2), coef = beta) ## compute the integral predict(bs_mat, coef = beta, integral = TRUE) ## or equivalently predict(update(bs_mat, integral = TRUE), coef = beta) ## visualize op <- par(mfrow = c(2, 2), mar = c(2.5, 2.5, 0.5, 0.1), mgp = c(1.5, 0.5, 0)) plot(bs_mat, coef = beta, ylab = "B-Spline Function", mark_knots = "all") plot(deriv(bs_mat), coef = beta, ylab = "1st Derivative", mark_knots = "all") plot(deriv(bs_mat, derivs = 2), coef = beta, ylab = "2nd Derivative", mark_knots = "all") plot(update(bs_mat, integral = TRUE), coef = beta, ylab = "Integral", mark_knots = "all") par(op) splines2/inst/examples/ex-iSpline.R0000644000176200001440000000103014441404547016745 0ustar liggesuserslibrary(splines2) ## an example given in 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)) plot(isMat, ylab = "I-spline basis", mark_knots = "internal") par(op) # reset to previous plotting settings ## 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-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-mSpline.R0000644000176200001440000000455014605645205016763 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)) plot(msMat, mark_knots = "internal") ## 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)) plot(pMat, ylab = "Periodic Basis", mark_knots = "boundary") plot(iMat, ylab = "Integrals from 0") abline(v = seq.int(0, max(x)), h = seq.int(0, max(x)), lty = 2, col = "grey") plot(dMat1, ylab = "1st derivatives by 'derivs=1'", mark_knots = "boundary") plot(dMat2, ylab = "1st derivatives by 'deriv()'", mark_knots = "boundary") par(op) # reset to previous plotting settings ### 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 <- mSpline(x, degree = degree, df = df, periodic = TRUE, intercept = intercept) ## 2. specify knots spline_basis2 <- 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.R0000644000176200001440000000224514617015220016736 0ustar liggesuserslibrary(splines2) set.seed(1) x <- runif(100) knots <- c(0.3, 0.5, 0.6) # internal knots ## cubic B-splines bsMat <- bSpline(x, knots = knots, degree = 3, intercept = TRUE) ibsMat <- update(bsMat, integral = TRUE) # the integrals d1Mat <- deriv(bsMat) # the 1st derivaitves d2Mat <- deriv(bsMat, 2) # the 2nd derivaitves op <- par(mfrow = c(2, 2), mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) plot(bsMat, ylab = "Cubic B-splines") plot(ibsMat, ylab = "The integrals") plot(d1Mat, ylab = "The 1st derivatives") plot(d2Mat, ylab = "The 2nd derivatives") ## evaluate at new values predict(bsMat, c(0.125, 0.801)) ## periodic B-splines px <- seq(0, 3, 0.01) pbsMat <- bSpline(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) ipMat <- update(pbsMat, integral = TRUE) dpMat <- deriv(pbsMat) dp2Mat <- deriv(pbsMat, 2) plot(pbsMat, ylab = "Periodic B-splines", mark_knots = "b") plot(ipMat, ylab = "The integrals", mark_knots = "b") plot(dpMat, ylab = "The 1st derivatives", mark_knots = "b") plot(dp2Mat, ylab = "The 2nd derivatives", mark_knots = "b") par(op) # reset to previous plotting settings splines2/inst/rcpp-tests/0000755000176200001440000000000014716263527015107 5ustar liggesuserssplines2/inst/rcpp-tests/test-NaturalSpline.R0000644000176200001440000000351614412337673020772 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 = unclass(mat), integral = unclass(imat), d1 = unclass(d1mat), d2 = unclass(d2mat), d3 = unclass(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-PeriodicMSpline.R0000644000176200001440000000451714412337355021236 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 order <- degree + 1 knot_seq <- c(rep(bound_knots[1], order), inter_knots, rep(bound_knots[2], order)) 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 = unclass(mat), integral = unclass(imat), d1 = unclass(d1mat), d2 = unclass(d2mat), d3 = unclass(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) res06 <- rcpp_pmspline06(x, degree, knot_seq) expect_equivalent(res, res06) res07 <- rcpp_pmspline07(x, degree, knot_seq) expect_equivalent(res, res07) res08 <- rcpp_pmspline08(x, degree, knot_seq) expect_equivalent(res, res08) ## 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 3 res3 <- rcpp_pmspline3(x, degree, knot_seq) expect_equivalent(res, res3) ## 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-ISpline.cpp0000644000176200001440000001265614412336745020141 0ustar liggesusers// [[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-CSpline.R0000644000176200001440000000501414412340067017530 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 = unclass(mat), d1 = unclass(d1mat), d2 = unclass(d2mat), d3 = unclass(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-CSpline.cpp0000644000176200001440000001257414412336724020127 0ustar liggesusers// [[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/rcpp-tests/test-MSpline.cpp0000644000176200001440000001265614412336741020141 0ustar liggesusers// [[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-BernsteinPoly.cpp0000644000176200001440000000723314412336734021364 0ustar liggesusers// [[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-BSpline.cpp0000644000176200001440000001265614412336750020126 0ustar liggesusers// [[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-PeriodicMSpline.cpp0000644000176200001440000001377514412336705021623 0ustar liggesusers// [[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; 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; 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; 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; 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; 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; obj.set_degree(degree)-> set_boundary_knots(bknots)-> set_internal_knots(iknots)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline06(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::PeriodicMSpline obj; obj.set_degree(degree)-> set_knot_sequence(knot_seq)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline07(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::PeriodicMSpline obj; obj.set_knot_sequence(knot_seq)-> set_degree(degree)-> set_x(x); return return_list(obj); } // [[Rcpp::export]] Rcpp::List rcpp_pmspline08(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::PeriodicMSpline obj; obj.set_x(x)-> set_degree(degree)-> set_knot_sequence(knot_seq); 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 3 // [[Rcpp::export]] Rcpp::List rcpp_pmspline3(const arma::vec& x, const unsigned int degree, const arma::vec& knot_seq) { splines2::PeriodicMSpline obj { x, degree, knot_seq }; 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-BernsteinPoly.R0000644000176200001440000000274114412337750021001 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 = unclass(mat), integral = unclass(imat), d1 = unclass(d1mat), d2 = unclass(d2mat), d3 = unclass(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-BSpline.R0000644000176200001440000000527314412340047017534 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 = unclass(mat), integral = unclass(imat), d1 = unclass(d1mat), d2 = unclass(d2mat), d3 = unclass(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-MSpline.R0000644000176200001440000000515314412340001017532 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 = unclass(mat), integral = unclass(imat), d1 = unclass(d1mat), d2 = unclass(d2mat), d3 = unclass(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-ISpline.R0000644000176200001440000000515114412340022017527 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 = unclass(mat), integral = unclass(imat), d1 = unclass(d1mat), d2 = unclass(d2mat), d3 = unclass(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-NaturalSpline.cpp0000644000176200001440000001106714412336730021344 0ustar liggesusers// [[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/doc/0000755000176200001440000000000014760217644013546 5ustar liggesuserssplines2/inst/doc/splines2-intro.R0000644000176200001440000002377114760217643016572 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.5, 0.1), mgp = c(1.5, 0.5, 0)) ## ----load-lib----------------------------------------------------------------- library(splines2) packageVersion("splines2") ## ----bSpline, fig.cap="B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6."---- knots <- c(0.3, 0.5, 0.6) x <- seq(0, 1, 0.01) bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) plot(bsMat, mark_knots = "all") ## ----ibs, fig.cap="Piecewise linear B-splines (left) and their integrals (right)."---- ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) op <- par(mfrow = c(1, 2)) plot(bsMat, mark_knots = "internal") plot(ibsMat, mark_knots = "internal") abline(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) plot(bsMat, mark_knots = "internal") plot(dbsMat, mark_knots = "internal") ## ----dbsMat------------------------------------------------------------------- is_equivalent <- function(a, b) { all.equal(a, b, check.attributes = FALSE) } stopifnot(is_equivalent(dbsMat, deriv(bsMat))) ## ----pbs---------------------------------------------------------------------- px <- seq(0, 3, 0.01) pbsMat <- bSpline(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) ipMat <- ibs(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) dp1Mat <- deriv(pbsMat) dp2Mat <- deriv(pbsMat, derivs = 2) par(mfrow = c(1, 2)) plot(pbsMat, ylab = "Periodic B-splines", mark_knots = "boundary") plot(ipMat, ylab = "The integrals", mark_knots = "boundary") plot(dp1Mat, ylab = "The 1st derivatives", mark_knots = "boundary") plot(dp2Mat, ylab = "The 2nd derivatives", mark_knots = "boundary") ## ----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) par(op) plot(msMat, mark_knots = "all") ## ----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."------------------------- pmsMat <- mSpline(px, knots = knots, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1)) plot(pmsMat, ylab = "Periodic Basis", mark_knots = "boundary") ## ----pms-deriv, fig.cap = "The first derivatives of the periodic M-splines."---- dpmsMat <- deriv(pmsMat) plot(dpmsMat, ylab = "The 1st derivatives", mark_knots = "boundary") ## ----pms-integral, fig.cap = "The integrals of the periodic M-splines."------- ipmsMat <- mSpline(px, knots = knots, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE) plot(ipmsMat, ylab = "Integrals", mark_knots = "boundary") abline(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) plot(isMat, mark_knots = "internal") ## ----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) plot(csMat1) 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)) plot(bpMat1) plot(bpMat2) ## ----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)) plot(ibpMat1, ylab = "Integrals") plot(ibpMat2, ylab = "Integrals") plot(dbpMat1, ylab = "Derivatives") plot(dbpMat2, ylab = "Derivatives") ## ----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)) plot(nsMat, ylab = "Basis") plot(insMat, 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) matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives") matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives") ## ----nsk---------------------------------------------------------------------- nskMat <- nsk(x, knots = knots, intercept = TRUE) par(op) plot(nskMat, ylab = "nsk()", mark_knots = "all") abline(h = 1, col = "red", lty = 3) ## ----update-nsk--------------------------------------------------------------- nskMat2 <- update(nskMat, knots = c(knots, 0.2, 0.4), trim = 0.025) knots(nskMat2) stopifnot(all.equal(quantile(x, c(0.025, 0.975), names = FALSE), knots(nskMat2, "boundary"))) ## ----predict------------------------------------------------------------------ new_x <- c(0.275, 0.525, 0.8) names(new_x) <- paste0("x=", new_x) (isMat2 <- predict(isMat, newx = new_x)) # the basis functions at new x stopifnot(all.equal(predict(isMat, newx = new_x), update(isMat, x = new_x))) ## compute the first derivative of the I-spline function in different ways beta <- seq(0.1, by = 0.1, length.out = ncol(isMat)) deriv_ispline1 <- predict(isMat, newx = new_x, coef = beta, derivs = 1) deriv_ispline2 <- predict(update(isMat, x = new_x, derivs = 1), coef = beta) deriv_ispline3 <- c(predict(deriv(isMat), newx = new_x) %*% beta) stopifnot(all.equal(deriv_ispline1, deriv_ispline2)) stopifnot(all.equal(deriv_ispline2, deriv_ispline3)) ## ----plot-coef---------------------------------------------------------------- beta <- seq.int(0.2, length.out = ncol(nskMat), by = 0.2) plot(nskMat, ylab = "nsk()", mark_knots = "all", coef = beta) abline(h = beta, col = seq_along(beta), lty = 3) ## ----formula-alias------------------------------------------------------------ b <- bSpline # create an alias for B-splines mod1 <- lm(weight ~ b(height, degree = 1, df = 3), data = women) iknots <- with(women, knots(bSpline(height, degree = 1, df = 3))) mod2 <- lm(weight ~ bSpline(height, degree = 1, knots = iknots), data = women) pred1 <- predict(mod1, head(women, 10)) pred2 <- predict(mod2, head(women, 10)) stopifnot(all.equal(pred1, pred2)) ## ----formula-wrap-failed------------------------------------------------------ ## generates quadratic spline basis functions based on log(x) qbs <- function(x, ...) { splines2::bSpline(log(x), ..., degree = 2) } mod3 <- lm(weight ~ qbs(height, df = 5), data = women) mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women) stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef pred3 <- predict(mod3, head(women, 10)) pred4 <- predict(mod4, head(women, 10)) all.equal(pred3, pred4) pred0 <- predict(qbs(women$height, df = 5), newx = head(log(women$height), 10), coef = coef(mod3)[- 1]) + coef(mod3)[1] stopifnot(all.equal(pred0, pred4, check.names = FALSE)) ## ----predict-qbs-------------------------------------------------------------- ## generates quadratic spline basis functions based on log(x) with a new class qbs <- function(x, ...) { res <- splines2::bSpline(log(x), ..., degree = 2) class(res) <- c("qbs", class(res)) return(res) } ## a utility to help model.frame() create the right matrices makepredictcall.qbs <- function(var, call) { if (as.character(call)[1L] == "qbs" || (is.call(call) && identical(eval(call[[1L]]), qbs))) { at <- attributes(var)[c("knots", "Boundary.knots", "intercept", "periodic", "derivs", "integral")] call <- call[1L:2L] call[names(at)] <- at } call } ## the same example mod3 <- lm(weight ~ qbs(height, df = 5), data = women) mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women) stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef pred3 <- predict(mod3, head(women, 10)) pred4 <- predict(mod4, head(women, 10)) all.equal(pred3, pred4) # should be TRUE this time ## ----extract------------------------------------------------------------------ c(nskMat2$trim, attr(nskMat2, "trim")) splines2/inst/doc/splines2-intro.html0000644000176200001440000426616514760217644017350 0ustar liggesusers A Short Introduction to splines2

A Short Introduction to splines2

Wenjie Wang

2025-02-27


1 Introduction

The R package splines2 is intended to be a user-friendly supplementary package to the base package splines. It provides functions to construct 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(). More specifically, splines2 allows users to construct the basis functions of

  • B-splines
  • M-splines
  • I-splines
  • C-splines
  • periodic 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 splines, the package splines2 provides convenient interfaces for spline derivatives with consistent handling on NA’s. Most of the implementations are in C++ with the help of Rcpp and RcppArmadillo since v0.3.0, which boosted the computational performance.

In the remainder of this vignette, we illustrate the basic usage of most functions in the package through examples. We refer readers to Wang and Yan (2021) for a more formal introduction to the package with applications to shape-restricted regression. See the package manual for more details about function usage.

library(splines2)
packageVersion("splines2")
## [1] '0.5.4'


2 B-splines

2.1 B-spline Basis Functions

The bSpline() function generates the basis matrix for B-splines and extends the function bs() of the package splines by providing 1) the piece-wise constant basis functions when degree = 0, 2) the derivatives of basis functions for a positive derivs, 3) the integrals of basis functions if integral = TRUE, 4) periodic basis functions based on B-splines if periodic = TRUE.

One example of linear B-splines with three internal knots is as follows:

knots <- c(0.3, 0.5, 0.6)
x <- seq(0, 1, 0.01)
bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE)
plot(bsMat, mark_knots = "all")
B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6.
B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6.

2.2 Integrals and Derivatives of B-splines

For convenience, the package also provides functions ibs() and dbs() for constructing the B-spline integrals and derivatives, respectively. Two toy examples are as follows:

ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE)
op <- par(mfrow = c(1, 2))
plot(bsMat, mark_knots = "internal")
plot(ibsMat, mark_knots = "internal")
abline(h = c(0.15, 0.2, 0.25), lty = 2, col = "gray")
Piecewise linear B-splines (left) and their integrals (right).
Piecewise linear B-splines (left) and their integrals (right).
bsMat <- bSpline(x, knots = knots, intercept = TRUE)
dbsMat <- dbs(x, knots = knots, intercept = TRUE)
plot(bsMat, mark_knots = "internal")
plot(dbsMat, mark_knots = "internal")
Cubic B-spline (left) and their first derivative (right).
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)))

2.3 Periodic B-splines

The function bSpline() produces periodic spline basis functions following Piegl and Tiller (1997, chap. 12) when periodic = TRUE is specified. Different from the regular basis functions, the x is allowed to be placed outside the boundary and the Boundary.knots defines the cyclic interval. For instance, one may obtain the periodic cubic B-spline basis functions with cyclic interval (0, 1) as follows:

px <- seq(0, 3, 0.01)
pbsMat <- bSpline(px, knots = knots, Boundary.knots = c(0, 1),
                  intercept = TRUE, periodic = TRUE)
ipMat <- ibs(px, knots = knots, Boundary.knots = c(0, 1),
             intercept = TRUE, periodic = TRUE)
dp1Mat <- deriv(pbsMat)
dp2Mat <- deriv(pbsMat, derivs = 2)
par(mfrow = c(1, 2))
plot(pbsMat, ylab = "Periodic B-splines", mark_knots = "boundary")
plot(ipMat, ylab = "The integrals", mark_knots = "boundary")

plot(dp1Mat, ylab = "The 1st derivatives", mark_knots = "boundary")
plot(dp2Mat, ylab = "The 2nd derivatives", mark_knots = "boundary")

For reference, the corresponding integrals and derivatives are also visualized.


3 M-Splines

3.1 M-spline Basis Functions

M-splines (Ramsay 1988) can be 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)
par(op)
plot(msMat, mark_knots = "all")
Quadratic M-spline with three internal knots placed at 0.3, 0.5, and 0.6.
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(). Similarly, for an existing mSpline object generated by mSpline(), one can use the deriv() method for derivaitives. 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))

3.2 Periodic M-Splines

The mSpline() function produces periodic splines based on M-spline basis functions when periodic = TRUE is specified. The Boundary.knots defines the cyclic interval, which is the same with the periodic B-splines.

pmsMat <- mSpline(px, knots = knots, intercept = TRUE,
                  periodic = TRUE, Boundary.knots = c(0, 1))
plot(pmsMat, ylab = "Periodic Basis", mark_knots = "boundary")
Cubic periodic M-splines.
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)
plot(dpmsMat, ylab = "The 1st derivatives", mark_knots = "boundary")
The first derivatives of the periodic M-splines.
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(px, knots = knots, intercept = TRUE,
                   periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE)
plot(ipmsMat, ylab = "Integrals", mark_knots = "boundary")
abline(h = seq.int(0, 3), lty = 2, col = "gray")
The integrals of the periodic M-splines.
The integrals of the periodic M-splines.


4 I-Splines

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 the 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)
plot(isMat, mark_knots = "internal")
I-splines of degree two with three internal knots placed at 0.3, 0.5, and 0.6.
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 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))


5 C-Splines

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 the 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)
plot(csMat1)
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.
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 a higher order. 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))))

6 Generalized Bernstein Polynomials

The Bernstein polynomials are equivalent to B-splines without internal knots and have also been applied to shape-constrained regression analysis (e.g., 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\). 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))
plot(bpMat1)
plot(bpMat2)
Bernstein polynomials of degree 4 over [0, 1] (left) and the generalized version over [- 1, 1] (right).
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))
plot(ibpMat1, ylab = "Integrals")
plot(ibpMat2, ylab = "Integrals")
plot(dbpMat1, ylab = "Derivatives")
plot(dbpMat2, ylab = "Derivatives")
The integrals (upper panel) and the first derivatives (lower panel) of Bernstein polynomials of degree 4.
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)))


7 Natural Cubic Splines

7.1 Nonnegative Natural Cubic Basis Functions

The package provides two variants of the natural cubic splines that can be constructed by naturalSpline() and nsk(), respectively, both of which are different from splines::ns().

The naturalSpline() function returns nonnegative basis functions (within the boundary) for natural cubic splines by utilizing a closed-form null space derived from the second derivatives of cubic B-splines. When integral = TRUE, the function naturalSpline() returns the 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))
plot(nsMat, ylab = "Basis")
plot(insMat, ylab = "Integrals")
Nonnegative natural cubic splines (left) and corresponding integrals (right).
Nonnegative natural cubic splines (left) and corresponding integrals (right).
stopifnot(is_equivalent(nsMat, deriv(insMat)))

Similarly, one may directly 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)
matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives")
matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives")
The derivatives of natural cubic splines.
The derivatives of natural cubic splines.

7.2 Natural Cubic Basis Functions with Unit Heights at Knots

The function nsk() produces another variant of natural cubic splines, where only one of the spline basis functions is nonzero with unit height at every boundary and internal knot. As a result, the coefficients of the basis functions are the values of the spline function at the knots, which makes it more straightforward to interpret the coefficient estimates. This idea originated from the function nsk() of the survival package (introduced in version 3.2-8). The implementation of the nsk() of splines2 essentially follows the survival::nsk() function. One noticeable argument for nsk() is trim (equivalent to the argument b of survival::nsk()). One may specify trim = 0.05 to exclude 5% of the data from both sides when setting the boundary knots, which can be a more sensible choice in practice due to possible outliers. The trim argument is also available for naturalSpline(), which however is zero by default for backward compatibility. An illustration of the basis functions generated by nsk() is as follows:

nskMat <- nsk(x, knots = knots, intercept = TRUE)
par(op)
plot(nskMat, ylab = "nsk()", mark_knots = "all")
abline(h = 1, col = "red", lty = 3)

We can visually verify that only one basis function takes a value of one at each knot.


8 Helper and Alias Functions

8.1 Update Spline’s Specification by update()

The update() function is an S3 method to generate spline basis functions with new x, degree, knots, or df specifications. The first argument is an existing splines2 object and additional named arguments will be passed to the corresponding functions to update the spline basis functions. Suppose we want to add two more knots to nskMat for natural cubic spline basis functions and exclude 5% of the data from both sides in total when placing the boundary knots. We can utilize the update() method as follows:

nskMat2 <- update(nskMat, knots = c(knots, 0.2, 0.4), trim = 0.025)
knots(nskMat2)
## [1] 0.2 0.3 0.4 0.5 0.6
stopifnot(all.equal(quantile(x, c(0.025, 0.975), names = FALSE),
                    knots(nskMat2, "boundary")))

8.2 Evaluation by predict()

The predict() method for splines2 objects allows one to evaluate the spline function if a coefficient vector is specified via the coef argument. In addition, it internally calls the update() method to update the basis functions before computing the spline function, which can be useful to get the derivatives of the spline function. If the coef argument is not specified, the predict() method will be equivalent to the update() method. For instance, we can compute the first derivative of the I-spline function from the previous example with a coefficient vector seq(0.1, by = 0.1, length.out = ncol(isMat)) at \(x = (0.275, 0.525, 0.8)\) as follows:

new_x <- c(0.275, 0.525, 0.8)
names(new_x) <- paste0("x=", new_x)
(isMat2 <- predict(isMat, newx = new_x)) # the basis functions at 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
stopifnot(all.equal(predict(isMat, newx = new_x), update(isMat, x = new_x)))
## compute the first derivative of the I-spline function in different ways
beta <- seq(0.1, by = 0.1, length.out = ncol(isMat))
deriv_ispline1 <- predict(isMat, newx = new_x, coef = beta, derivs = 1)
deriv_ispline2 <- predict(update(isMat, x = new_x, derivs = 1), coef = beta)
deriv_ispline3 <- c(predict(deriv(isMat), newx = new_x) %*% beta)
stopifnot(all.equal(deriv_ispline1, deriv_ispline2))
stopifnot(all.equal(deriv_ispline2, deriv_ispline3))

8.3 Visualization by plot()

As one may notice in the previous examples, we may visualize the spline basis functions easily with the plot() method. By default, the spline basis functions are visualized at 101 equidistant grid points within the range of x, which can be tweaked by arguments from, to, and n. In addition, we can indicate the placement of knots by vertical lines through the argument mark_knots. The available options are "none", "internal", "boundary", and "all". A fitted spline function can be visualized by specifying the argument coef. An example of nsk() is as follows:

beta <- seq.int(0.2, length.out = ncol(nskMat), by = 0.2)
plot(nskMat, ylab = "nsk()", mark_knots = "all", coef = beta)
abline(h = beta, col = seq_along(beta), lty = 3)

8.4 Including Spline Basis Functions in Model Formulas

It is common to directly include spline basis functions in a model formula. To avoid a lengthy model formula, the package provides alias functions that are summarized in the following table:

Function Equivalent Alias
bSpline() bsp()
mSpline() msp()
iSpline() isp()
cSpline() csp()
bernsteinPoly() bpoly()
naturalSpline() nsp()

One may create new alias functions. For example, we can create a new alias function simply named b() for B-splines and obtain equivalent models as follows:

b <- bSpline # create an alias for B-splines
mod1 <- lm(weight ~ b(height, degree = 1, df = 3), data = women)
iknots <- with(women, knots(bSpline(height, degree = 1, df = 3)))
mod2 <- lm(weight ~ bSpline(height, degree = 1, knots = iknots), data = women)
pred1 <- predict(mod1, head(women, 10))
pred2 <- predict(mod2, head(women, 10))
stopifnot(all.equal(pred1, pred2))

Nevertheless, there is a possible pitfall when using a customized wrapper function for spline basis functions along with a data-dependent placement of knots. When we make model predictions for a given new data, the placement of the internal/boundary knots can be different from the original placement that depends on the training set. As a result, the spline basis functions generated for prediction may not be the same as the counterparts used in the model fitting. A simple example is as follows:

## generates quadratic spline basis functions based on log(x)
qbs <- function(x, ...) {
    splines2::bSpline(log(x), ..., degree = 2)
}
mod3 <- lm(weight ~ qbs(height, df = 5), data = women)
mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women)
stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef
pred3 <- predict(mod3, head(women, 10))
pred4 <- predict(mod4, head(women, 10))
all.equal(pred3, pred4)
## [1] "Mean relative difference: 0.07185939"
pred0 <- predict(qbs(women$height, df = 5),
                 newx = head(log(women$height), 10),
                 coef = coef(mod3)[- 1]) + coef(mod3)[1]
stopifnot(all.equal(pred0, pred4, check.names = FALSE))

Although the coefficient estimates are the same, the prediction results by using the predict.lm() differ. Using an alias function in the model formula produces correct results.

To resolve this issue, we can create an S3 method for stats::makepredictcall() as follows:

## generates quadratic spline basis functions based on log(x) with a new class
qbs <- function(x, ...) {
    res <- splines2::bSpline(log(x), ..., degree = 2)
    class(res) <- c("qbs", class(res))
    return(res)
}
## a utility to help model.frame() create the right matrices
makepredictcall.qbs <- function(var, call) {
    if (as.character(call)[1L] == "qbs" ||
    (is.call(call) && identical(eval(call[[1L]]), qbs))) {
        at <- attributes(var)[c("knots", "Boundary.knots", "intercept",
                                "periodic", "derivs", "integral")]
        call <- call[1L:2L]
        call[names(at)] <- at
    }
    call
}
## the same example
mod3 <- lm(weight ~ qbs(height, df = 5), data = women)
mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women)
stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef
pred3 <- predict(mod3, head(women, 10))
pred4 <- predict(mod4, head(women, 10))
all.equal(pred3, pred4) # should be TRUE this time
## [1] TRUE

8.5 Extract Specifications by $

The basis specifications are saved as attributes of the returned splines2 objects, which means that we can extract one of the specifications by attr(). Alternatively, we can treat splines2 objects as lists and use the corresponding $ method. For example, it is straightforward to extract the specified trim of nskMat2 by attr(nskMat2, "trim") or simply nskMat2$trim.

c(nskMat2$trim, attr(nskMat2, "trim"))
## [1] 0.025 0.025


Reference

Meyer, Mary C. 2008. “Inference Using Shape-Restricted Regression Splines.†The Annals of Applied Statistics 2 (3): 1013–33.
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.
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-wi-rcpp.html0000644000176200001440000011106014760217644017551 0ustar liggesusers Using splines2 with Rcpp

Using splines2 with Rcpp

Wenjie Wang

2025-02-27

1 Introduction

In this 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 directly in C++. The introduction is intended for package developers who would like to use splines2 package in C++ by adding splines2 to the LinkingTo field of the package DESCRIPTION file.

2 Header Files and Namespace

Different from 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 the help of RcppArmadillo (Eddelbuettel and Sanderson 2014) and require C++11. We assume that C++11 is enabled and the header file named splines2Armadillo.h is included for access to all the classes and implementations in the namespace splines2 henceforth.

#include <RcppArmadillo.h>
#include <splines2Armadillo.h>  // include header files from splines2
// [[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

3 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 and NaturalSplineK for natural cubic splines;
  • PeriodicMSpline for periodic M-splines;
  • PeriodicBSpline for periodic B-splines;

3.1 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. specify x, internal knots, degree, and boundary 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 (DF) of the complete spline basis functions (different from the df argument 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 the boundary.

// 2. specify x, spline DF, degree, and boundary knots
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 the basis functions with an extended knot sequence, where the multiplicities of the knots can be more than one.

// 3. specify x, 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 can create a BSpline object named bsp_obj from an existing MSpline object named msp_obj with the same specification as follows:

BSpline bsp_obj { &msp_obj };

3.2 Constructors of PeriodicMSpline and PeriodicBSpline

The PeriodicMSpline and PeriodicBSpline classes are intended for constructing the periodic M-splines and periodic B-splines, respectively, which provide the same set of non-default constructors with BSpline. The only difference is that the knot sequence specified for the third non-default constructor must be a simple knot sequence.

3.3 Constructors of NaturalSpline and NaturalSplineK

The classes NaturalSpline and NaturalSplineK are intended for natural cubic splines. The former corresponds to the function splines2::naturalSpline() (or splines2::nsp()) in R, while the latter is the engine of the function splines2::nsk(). They have the same constructors that do not allow the specification of the degree. Taking NaturalSpline as an example, the first non-default constructor is called when internal knots are explicitly specified.

// 1. specify x, internal knots, and boundary 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 from the df argument 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. specify x, spline DF, and boundary knots
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);

3.4 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);

We can 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.

4 Generalized Bernstein Polynomials

The BernsteinPoly class is provided for the generalized Bernstein polynomials.

4.1 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.

4.2 Function Members

The main methods are

  • basis() for the basis functions
  • derivative() for the derivatives of basis functions
  • integral() for the 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.

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.
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.Rmd0000644000176200001440000005420214665461570017110 0ustar liggesusers--- title: "A Short Introduction to splines2" author: Wenjie Wang date: "`r Sys.Date()`" bibliography: - ../inst/bib/splines2.bib vignette: > %\VignetteIndexEntry{A Short Introduction to splines2} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} output: rmarkdown::html_vignette: number_sections: yes toc: yes --- ```{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.5, 0.1), mgp = c(1.5, 0.5, 0)) ```
# Introduction The R package **splines2** is intended to be a user-friendly supplementary package to the base package **splines**. It provides functions to construct 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()`. More specifically, **splines2** allows users to construct the basis functions of - B-splines - M-splines - I-splines - C-splines - periodic 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 **splines**, the package **splines2** provides convenient interfaces for spline derivatives with consistent handling on `NA`'s. Most of the implementations are in *C++* with the help of **Rcpp** and **RcppArmadillo** since v0.3.0, which boosted the computational performance. In the remainder of this vignette, we illustrate the basic usage of most functions in the package through examples. We refer readers to [Wang and Yan (2021)](https://dx.doi.org/10.6339/21-JDS1020) for a more formal introduction to the package with applications to shape-restricted regression. See the package manual for more details about function usage. ```{r load-lib} library(splines2) packageVersion("splines2") ```
# B-splines {#bSpline} ## B-spline Basis Functions The `bSpline()` function generates the basis matrix for B-splines and extends the function `bs()` of the package **splines** by providing 1) the piece-wise constant basis functions when `degree = 0`, 2) the derivatives of basis functions for a positive `derivs`, 3) the integrals of basis functions if `integral = TRUE`, 4) periodic basis functions based on B-splines if `periodic = TRUE`. One example of linear B-splines with three internal knots is as follows: ```{r bSpline, fig.cap="B-splines of degree one with three internal knots placed at 0.3, 0.5, and 0.6."} knots <- c(0.3, 0.5, 0.6) x <- seq(0, 1, 0.01) bsMat <- bSpline(x, knots = knots, degree = 1, intercept = TRUE) plot(bsMat, mark_knots = "all") ``` ## Integrals and Derivatives of B-splines For convenience, the package also provides functions `ibs()` and `dbs()` for constructing the B-spline integrals and derivatives, respectively. Two toy examples are as follows: ```{r ibs, fig.cap="Piecewise linear B-splines (left) and their integrals (right)."} ibsMat <- ibs(x, knots = knots, degree = 1, intercept = TRUE) op <- par(mfrow = c(1, 2)) plot(bsMat, mark_knots = "internal") plot(ibsMat, mark_knots = "internal") abline(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) plot(bsMat, mark_knots = "internal") plot(dbsMat, mark_knots = "internal") ``` 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))) ``` ## Periodic B-splines The function `bSpline()` produces periodic spline basis functions following @piegl1997nurbs [chapter 12] when `periodic = TRUE` is specified. Different from the regular basis functions, the `x` is allowed to be placed outside the boundary and the `Boundary.knots` defines the cyclic interval. For instance, one may obtain the periodic cubic B-spline basis functions with cyclic interval (0, 1) as follows: ```{r pbs} px <- seq(0, 3, 0.01) pbsMat <- bSpline(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) ipMat <- ibs(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) dp1Mat <- deriv(pbsMat) dp2Mat <- deriv(pbsMat, derivs = 2) par(mfrow = c(1, 2)) plot(pbsMat, ylab = "Periodic B-splines", mark_knots = "boundary") plot(ipMat, ylab = "The integrals", mark_knots = "boundary") plot(dp1Mat, ylab = "The 1st derivatives", mark_knots = "boundary") plot(dp2Mat, ylab = "The 2nd derivatives", mark_knots = "boundary") ``` For reference, the corresponding integrals and derivatives are also visualized.
# M-Splines {#mSpline} ## M-spline Basis Functions M-splines [@ramsay1988monotone] can be 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 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) par(op) plot(msMat, mark_knots = "all") ``` The derivative of the given order of M-splines can be obtained by specifying a positive integer to argument `dervis` of `mSpline()`. Similarly, for an existing `mSpline` object generated by `mSpline()`, one can use the `deriv()` method for derivaitives. 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 `mSpline()` function produces periodic splines based on M-spline basis functions when `periodic = TRUE` is specified. The `Boundary.knots` defines the cyclic interval, which is the same with the periodic B-splines. ```{r pms-basis, fig.cap = "Cubic periodic M-splines."} pmsMat <- mSpline(px, knots = knots, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1)) plot(pmsMat, ylab = "Periodic Basis", mark_knots = "boundary") ``` 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) plot(dpmsMat, ylab = "The 1st derivatives", mark_knots = "boundary") ``` 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(px, knots = knots, intercept = TRUE, periodic = TRUE, Boundary.knots = c(0, 1), integral = TRUE) plot(ipmsMat, ylab = "Integrals", mark_knots = "boundary") abline(h = seq.int(0, 3), lty = 2, col = "gray") ```
# I-Splines {#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 the 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) plot(isMat, mark_knots = "internal") ``` 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 `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 {#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 the 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) plot(csMat1) 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 a higher order. 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 are equivalent to B-splines without internal knots and have also been applied to shape-constrained regression analysis [e.g., @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$. 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)) plot(bpMat1) plot(bpMat2) ``` 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)) plot(ibpMat1, ylab = "Integrals") plot(ibpMat2, ylab = "Integrals") plot(dbpMat1, ylab = "Derivatives") plot(dbpMat2, ylab = "Derivatives") ``` 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 ## Nonnegative Natural Cubic Basis Functions The package provides two variants of the natural cubic splines that can be constructed by `naturalSpline()` and `nsk()`, respectively, both of which are different from `splines::ns()`. The `naturalSpline()` function returns nonnegative basis functions (within the boundary) for natural cubic splines by utilizing a closed-form null space derived from the second derivatives of cubic B-splines. When `integral = TRUE`, the function `naturalSpline()` returns the 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)) plot(nsMat, ylab = "Basis") plot(insMat, ylab = "Integrals") stopifnot(is_equivalent(nsMat, deriv(insMat))) ``` Similarly, one may directly 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) matplot(x, d1nsMat, type = "l", ylab = "The 1st derivatives") matplot(x, d2nsMat, type = "l", ylab = "The 2nd derivatives") ``` ## Natural Cubic Basis Functions with Unit Heights at Knots The function `nsk()` produces another variant of natural cubic splines, where only one of the spline basis functions is nonzero with unit height at every boundary and internal knot. As a result, the coefficients of the basis functions are the values of the spline function at the knots, which makes it more straightforward to interpret the coefficient estimates. This idea originated from the function `nsk()` of the **survival** package (introduced in version 3.2-8). The implementation of the `nsk()` of **splines2** essentially follows the `survival::nsk()` function. One noticeable argument for `nsk()` is `trim` (equivalent to the argument `b` of `survival::nsk()`). One may specify `trim = 0.05` to exclude 5% of the data from both sides when setting the boundary knots, which can be a more sensible choice in practice due to possible outliers. The `trim` argument is also available for `naturalSpline()`, which however is zero by default for backward compatibility. An illustration of the basis functions generated by `nsk()` is as follows: ```{r nsk} nskMat <- nsk(x, knots = knots, intercept = TRUE) par(op) plot(nskMat, ylab = "nsk()", mark_knots = "all") abline(h = 1, col = "red", lty = 3) ``` We can visually verify that only one basis function takes a value of one at each knot.
# Helper and Alias Functions ## Update Spline's Specification by `update()` {#update} The `update()` function is an S3 method to generate spline basis functions with new `x`, `degree`, `knots`, or `df` specifications. The first argument is an existing `splines2` object and additional named arguments will be passed to the corresponding functions to update the spline basis functions. Suppose we want to add two more knots to `nskMat` for natural cubic spline basis functions and exclude 5% of the data from both sides in total when placing the boundary knots. We can utilize the `update()` method as follows: ```{r update-nsk} nskMat2 <- update(nskMat, knots = c(knots, 0.2, 0.4), trim = 0.025) knots(nskMat2) stopifnot(all.equal(quantile(x, c(0.025, 0.975), names = FALSE), knots(nskMat2, "boundary"))) ``` ## Evaluation by `predict()` {#predict} The `predict()` method for `splines2` objects allows one to evaluate the spline function if a coefficient vector is specified via the `coef` argument. In addition, it internally calls the `update()` method to update the basis functions before computing the spline function, which can be useful to get the derivatives of the spline function. If the `coef` argument is not specified, the `predict()` method will be equivalent to the `update()` method. For instance, we can compute the first derivative of the I-spline function from the previous example with a coefficient vector `seq(0.1, by = 0.1, length.out = ncol(isMat))` at $x = (0.275, 0.525, 0.8)$ as follows: ```{r predict} new_x <- c(0.275, 0.525, 0.8) names(new_x) <- paste0("x=", new_x) (isMat2 <- predict(isMat, newx = new_x)) # the basis functions at new x stopifnot(all.equal(predict(isMat, newx = new_x), update(isMat, x = new_x))) ## compute the first derivative of the I-spline function in different ways beta <- seq(0.1, by = 0.1, length.out = ncol(isMat)) deriv_ispline1 <- predict(isMat, newx = new_x, coef = beta, derivs = 1) deriv_ispline2 <- predict(update(isMat, x = new_x, derivs = 1), coef = beta) deriv_ispline3 <- c(predict(deriv(isMat), newx = new_x) %*% beta) stopifnot(all.equal(deriv_ispline1, deriv_ispline2)) stopifnot(all.equal(deriv_ispline2, deriv_ispline3)) ``` ## Visualization by `plot()` {#plot} As one may notice in the previous examples, we may visualize the spline basis functions easily with the `plot()` method. By default, the spline basis functions are visualized at 101 equidistant grid points within the range of `x`, which can be tweaked by arguments `from`, `to`, and `n`. In addition, we can indicate the placement of knots by vertical lines through the argument `mark_knots`. The available options are `"none"`, `"internal"`, `"boundary"`, and `"all"`. A fitted spline function can be visualized by specifying the argument `coef`. An example of `nsk()` is as follows: ```{r plot-coef} beta <- seq.int(0.2, length.out = ncol(nskMat), by = 0.2) plot(nskMat, ylab = "nsk()", mark_knots = "all", coef = beta) abline(h = beta, col = seq_along(beta), lty = 3) ``` ## Including Spline Basis Functions in Model Formulas It is common to directly include spline basis functions in a model formula. To avoid a lengthy model formula, the package provides alias functions that are summarized in the following table: | Function | Equivalent Alias | |-------------------|------------------| | `bSpline()` | `bsp()` | | `mSpline()` | `msp()` | | `iSpline()` | `isp()` | | `cSpline()` | `csp()` | | `bernsteinPoly()` | `bpoly()` | | `naturalSpline()` | `nsp()` | One may create new alias functions. For example, we can create a new alias function simply named `b()` for B-splines and obtain equivalent models as follows: ```{r formula-alias} b <- bSpline # create an alias for B-splines mod1 <- lm(weight ~ b(height, degree = 1, df = 3), data = women) iknots <- with(women, knots(bSpline(height, degree = 1, df = 3))) mod2 <- lm(weight ~ bSpline(height, degree = 1, knots = iknots), data = women) pred1 <- predict(mod1, head(women, 10)) pred2 <- predict(mod2, head(women, 10)) stopifnot(all.equal(pred1, pred2)) ``` Nevertheless, there is a possible pitfall when using a customized wrapper function for spline basis functions along with a data-dependent placement of knots. When we make model predictions for a given new data, the placement of the internal/boundary knots can be different from the original placement that depends on the training set. As a result, the spline basis functions generated for prediction may not be the same as the counterparts used in the model fitting. A simple example is as follows: ```{r formula-wrap-failed} ## generates quadratic spline basis functions based on log(x) qbs <- function(x, ...) { splines2::bSpline(log(x), ..., degree = 2) } mod3 <- lm(weight ~ qbs(height, df = 5), data = women) mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women) stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef pred3 <- predict(mod3, head(women, 10)) pred4 <- predict(mod4, head(women, 10)) all.equal(pred3, pred4) pred0 <- predict(qbs(women$height, df = 5), newx = head(log(women$height), 10), coef = coef(mod3)[- 1]) + coef(mod3)[1] stopifnot(all.equal(pred0, pred4, check.names = FALSE)) ``` Although the coefficient estimates are the same, the prediction results by using the `predict.lm()` differ. Using an alias function in the model formula produces correct results. To resolve this issue, we can create an S3 method for `stats::makepredictcall()` as follows: ```{r predict-qbs} ## generates quadratic spline basis functions based on log(x) with a new class qbs <- function(x, ...) { res <- splines2::bSpline(log(x), ..., degree = 2) class(res) <- c("qbs", class(res)) return(res) } ## a utility to help model.frame() create the right matrices makepredictcall.qbs <- function(var, call) { if (as.character(call)[1L] == "qbs" || (is.call(call) && identical(eval(call[[1L]]), qbs))) { at <- attributes(var)[c("knots", "Boundary.knots", "intercept", "periodic", "derivs", "integral")] call <- call[1L:2L] call[names(at)] <- at } call } ## the same example mod3 <- lm(weight ~ qbs(height, df = 5), data = women) mod4 <- lm(weight ~ bsp(log(height), degree = 2, df = 5), data = women) stopifnot(all.equal(unname(coef(mod3)), unname(coef(mod4)))) # the same coef pred3 <- predict(mod3, head(women, 10)) pred4 <- predict(mod4, head(women, 10)) all.equal(pred3, pred4) # should be TRUE this time ``` ## Extract Specifications by `$` The basis specifications are saved as attributes of the returned *splines2* objects, which means that we can extract one of the specifications by `attr()`. Alternatively, we can treat *splines2* objects as lists and use the corresponding `$` method. For example, it is straightforward to extract the specified `trim` of `nskMat2` by `attr(nskMat2, "trim")` or simply `nskMat2$trim`. ```{r extract} c(nskMat2$trim, attr(nskMat2, "trim")) ```
# Reference {-} splines2/inst/doc/splines2-wi-rcpp.Rmd0000644000176200001440000002307014425773431017331 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} %\VignetteEncoding{UTF-8} output: rmarkdown::html_vignette: number_sections: yes toc: yes --- # Introduction In this vignette, we introduce how to use the C++ header-only library that **splines2** contains with the **Rcpp** package [@eddelbuettel2013springer] for constructing spline basis functions directly in C++. The introduction is intended for package developers who would like to use **splines2** package in C++ by adding **splines2** to the `LinkingTo` field of the package `DESCRIPTION` file. # Header Files and Namespace Different from 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 the help of **RcppArmadillo** [@eddelbuettel2014csda] and require C++11. We assume that C++11 is enabled and the header file named `splines2Armadillo.h` is included for access to all the classes and implementations in the namespace `splines2` henceforth. ```cpp #include #include // include header files from splines2 // [[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 ``` # 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` and `NaturalSplineK` for natural cubic splines; - `PeriodicMSpline` for periodic M-splines; - `PeriodicBSpline` for periodic B-splines; ## 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. specify x, internal knots, degree, and boundary 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 (DF) of the *complete spline basis functions* (different from the `df` argument 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 the boundary. ```cpp // 2. specify x, spline DF, degree, and boundary knots 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 the basis functions with an extended knot sequence, where the multiplicities of the knots can be more than one. ```cpp // 3. specify x, 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 can create a `BSpline` object named `bsp_obj` from an existing `MSpline` object named `msp_obj` with the same specification as follows: ```cpp BSpline bsp_obj { &msp_obj }; ``` ## Constructors of `PeriodicMSpline` and `PeriodicBSpline` The `PeriodicMSpline` and `PeriodicBSpline` classes are intended for constructing the periodic M-splines and periodic B-splines, respectively, which provide the same set of non-default constructors with `BSpline`. The only difference is that the knot sequence specified for the third non-default constructor must be a *simple knot sequence*. ## Constructors of `NaturalSpline` and `NaturalSplineK` The classes `NaturalSpline` and `NaturalSplineK` are intended for natural cubic splines. The former corresponds to the function `splines2::naturalSpline()` (or `splines2::nsp()`) in R, while the latter is the engine of the function `splines2::nsk()`. They have the same constructors that do not allow the specification of the `degree`. Taking `NaturalSpline` as an example, the first non-default constructor is called when internal knots are explicitly specified. ```cpp // 1. specify x, internal knots, and boundary 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 from the `df` argument 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. specify x, spline DF, and boundary knots 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); ``` ## 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); ``` We can 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`. # Generalized Bernstein Polynomials The `BernsteinPoly` class is provided 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 the basis functions - `derivative()` for the derivatives of basis functions - `integral()` for the 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. # Reference {-} splines2/inst/tinytest/0000755000176200001440000000000014760107703014656 5ustar liggesuserssplines2/inst/tinytest/test-update.R0000644000176200001440000000256614271374301017246 0ustar liggesusersx <- c(seq.int(0, 10, 0.5), NA) knots <- c(1, 4, 8) ## bSpline bsMat0 <- bSpline(x, degree = 2) bsMat1 <- update(bsMat0, degree = 3) expect_equal(attr(bsMat1, "degree"), 3L) ## ibs ibsMat0 <- ibs(x, degree = 3) ibsMat1 <- update(ibsMat0, knots = c(2, 4, 8)) expect_equal(knots(ibsMat1), c(2, 4, 8)) ## dbs dbsMat0 <- dbs(x, df = 6) dbsMat1 <- update(dbsMat0, df = 8) expect_equal(ncol(dbsMat1), 8L) ## mSpline msMat0 <- mSpline(x, derivs = 1) msMat1 <- update(msMat0, derivs = 2) expect_equal(deriv(msMat0), msMat1) msMat0 <- mSpline(x, integral = TRUE) msMat1 <- update(msMat0, integral = FALSE) expect_equivalent(deriv(msMat0), msMat1) msMat0 <- mSpline(x, knots = knots, periodic = TRUE) msMat1 <- update(msMat0, periodic = FALSE) expect_false(attr(msMat1, "periodic")) ## iSpline isMat0 <- iSpline(x, intercept = TRUE) isMat1 <- update(isMat0, intercept = FALSE) expect_equal(ncol(isMat1) + 1L, ncol(isMat0)) ## cSpline csMat0 <- cSpline(x) csMat1 <- update(csMat0, scale = FALSE) expect_true(attr(csMat0, "scale")) expect_false(attr(csMat1, "scale")) ## bernsteinPoly bpMat0 <- bernsteinPoly(x) bpMat1 <- update(bpMat0, degree = 4) expect_equal(ncol(bpMat0) + 1L, ncol(bpMat1)) expect_equal(bpMat0, update(bpMat0, knots = knots)) expect_equal(bpMat0, update(bpMat0)) ## naturalSpline nsMat0 <- naturalSpline(x, df = 3) nsMat1 <- update(nsMat0, df = 4) expect_equal(ncol(nsMat1), 4L) splines2/inst/tinytest/test-nsk.R0000644000176200001440000001106214437762126016560 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## 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 <- nsk(x, df = 2, intercept = TRUE) nsMat0b <- nsk(x, intercept = TRUE) ## integrals nsMat1 <- nsk(x, intercept = FALSE, integral = TRUE) ## first derivatives nsMat2 <- nsk(x, intercept = FALSE, derivs = 1) ## second derivatives nsMat3 <- nsk(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 <- nsk(x, knots = knots, intercept = TRUE) ## integrals nsMat1 <- nsk(x, knots = knots, intercept = TRUE, integral = TRUE) ## first derivatives nsMat2 <- nsk(x, knots = knots, intercept = TRUE, derivs = 1) ## second derivatives nsMat3 <- nsk(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)) ## update trim to 0 nsMat0 <- update(nsMat0, trim = 0) nsMat1 <- update(nsMat1, trim = 0) nsMat2 <- update(nsMat2, trim = 0) nsMat3 <- update(nsMat3, trim = 0) ## check the returned H matrix in attribute h_mat <- attr(nsMat0, "H") bsMat <- bSpline(x, knots = knots, intercept = TRUE) expect_eqt(nsMat0, bsMat %*% h_mat) expect_eqt(nsMat1, ibs(x, knots = knots, intercept = TRUE) %*% h_mat) expect_eqt(nsMat2, deriv(bsMat) %*% h_mat) expect_eqt(nsMat3, deriv(bsMat, 2) %*% h_mat) ## specify df directly instead of knots for (j in seq.int(2, 10)) { expect_true(isNumMatrix( nsk(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(nsk(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 <- nsk(xx, knots = knots, intercept = TRUE, Boundary.knots = b_knots) d1Mat <- nsk(xx, knots = knots, intercept = TRUE, Boundary.knots = b_knots, derivs = 1) d2Mat <- nsk(xx, knots = knots, intercept = TRUE, Boundary.knots = b_knots, derivs = 2) iMat <- nsk(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), 5] - iMat[seq.int(length(xx) - 9, length(xx) - 4), 5] < iMat[seq.int(length(xx) - 9, length(xx) - 4), 5] - iMat[seq.int(length(xx) - 8, length(xx) - 3), 5] )) ### 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(nsk(x2, df = 5, derivs = - 1)) expect_error(nsk(x2, df = 1)) expect_error(nsk(rep(NA, 10), df = 2)) ## make sure internal knots are unique x1 <- c(rep(0, 100), runif(10)) expect_warning(nsk(x1, df = 5), "duplicated 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-iSpline.R0000644000176200001440000001061614412342135017357 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## 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_eqt(iSpline(x), v2$iSpline(x)) ## cubic splines with specified df expect_eqt(iSpline(x, df = 5), v2$iSpline(x, df = 5)) ## cubic splines with specified internal knots expect_eqt(iSpline(x, knots = knots), v2$iSpline(x, knots = knots)) ## qudractic splines without internal knots expect_eqt(iSpline(x, degree = 2L), v2$iSpline(x, degree = 2L)) ## complete basis with intercept expect_eqt(iSpline(x, intercept = TRUE), v2$iSpline(x, intercept = TRUE)) ## specified knots expect_eqt(iSpline(x, knots = knots, intercept = TRUE), v2$iSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_eqt(iSpline(x, df = 6, intercept = TRUE), v2$iSpline(x, df = 6, intercept = TRUE)) ## degree zero expect_eqt(iSpline(x, df = 5, degree = 0), v2$iSpline(x, df = 5, degree = 0)) expect_eqt(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_eqt( iSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$iSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_eqt( 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_eqt( iSpline(x, df = 5, derivs = 1), mSpline(x, df = 5, intercept = TRUE) ) expect_eqt( iSpline(x, knots = knots, degree = 2, derivs = 2), mSpline(x, knots = knots, degree = 2, derivs = 1, intercept = TRUE) ) expect_eqt( 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-ibs.R0000644000176200001440000001331114412343232016523 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first ## without internal knots x <- seq.int(0, 1, 0.1) ## degree = 0 expect_eqt(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_eqt(matrix(b2(x)), ibs(x, degree = 1)) expect_eqt(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_eqt(cbind(b2(x), b3(x)), ibs(x, degree = 2)) expect_eqt(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_eqt(cbind(b2(x), b3(x), b4(x)), ibs(x, degree = 3)) expect_eqt(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_eqt(cbind(b2(x), b3(x)), ibs(x, knots = knots, degree = 0)) expect_eqt(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_eqt(cbind(b2(x), b3(x), b4(x)), ibs(x, knots = knots, degree = 1)) expect_eqt(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_eqt(ibs(x), v2$ibs(x)) ## cubic splines with specified df expect_eqt(ibs(x, df = 5), v2$ibs(x, df = 5)) ## cubic splines with specified internal knots expect_eqt(ibs(x, knots = knots), v2$ibs(x, knots = knots)) ## qudractic splines without internal knots expect_eqt(ibs(x, degree = 2L), v2$ibs(x, degree = 2L)) ## complete basis with intercept expect_eqt(ibs(x, intercept = TRUE), v2$ibs(x, intercept = TRUE)) ## specified knots expect_eqt(ibs(x, knots = knots, intercept = TRUE), v2$ibs(x, knots = knots, intercept = TRUE)) ## specified df expect_eqt(ibs(x, df = 6, intercept = TRUE), v2$ibs(x, df = 6, intercept = TRUE)) ## degree zero expect_eqt(ibs(x, df = 5, degree = 0), v2$ibs(x, df = 5, degree = 0)) expect_eqt(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_eqt( ibs(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$ibs(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_eqt( 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-extract.R0000644000176200001440000000057014441355544017436 0ustar liggesusers## test the $ method 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) b_knots <- c(0, 1) res <- bSpline(x, df = 6) expect_equal(res$knots, knots(res)) expect_equal(res$Boundary.knots, b_knots) expect_equal(res$degree, 3L) expect_equal(res$derivs, 0L) expect_false(res$integral) expect_false(res$periodic) expect_false(res$intercept) splines2/inst/tinytest/test-plot.R0000644000176200001440000000132514667174613016747 0ustar liggesusers## test the $ method 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) b_knots <- c(0, 1) ## periodic = FALSE res <- bSpline(x, df = 6) plot(res, mark_knots = "none") # current default plot(res, mark_knots = "internal") plot(res, mark_knots = "boundary") plot(res, mark_knots = "all") ## periodic = TRUE res <- bSpline(c(x, 2 * x), df = 6, periodic = TRUE) plot(res, mark_knots = "none") # current default plot(res, mark_knots = "internal") plot(res, mark_knots = "boundary") plot(res, mark_knots = "all") ## test warning messages x <- seq.int(- 1, 2, by = 0.1) bs0 <- bsp(x, degree = 0, knots = 0.4, Boundary.knots = c(0, 1), intercept = TRUE) expect_silent(plot(bs0)) splines2/inst/tinytest/test-bSpline.R0000644000176200001440000002701314441357741017362 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## 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_eqt(bSpline(x), v2$bSpline(x)) expect_eqt(bSpline(x, derivs = 1), dbs(x)) expect_eqt(bSpline(x, derivs = 2), dbs(x, derivs = 2)) expect_eqt(bSpline(x, integral = TRUE), ibs(x)) expect_eqt(bSpline(x), bSpline(x, derivs = 1, integral = TRUE)) ## cubic splines with specified df expect_eqt(bSpline(x, df = 5), v2$bSpline(x, df = 5)) ## cubic splines with specified internal knots expect_eqt(bSpline(x, knots = knots), v2$bSpline(x, knots = knots)) ## qudractic splines without internal knots expect_eqt(bSpline(x, degree = 2L), v2$bSpline(x, degree = 2L)) ## complete basis with intercept expect_eqt(bSpline(x, intercept = TRUE), v2$bSpline(x, intercept = TRUE)) ## specified knots expect_eqt(bSpline(x, knots = knots, intercept = TRUE), v2$bSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_eqt(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_eqt(bSpline(x, knots = knots2, degree = 0), v2$bSpline(x, knots = knots2, degree = 0)) expect_eqt(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_eqt(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_eqt( bSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$bSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_eqt( 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))) options("splines2.warn.outside" = FALSE) expect_silent(bSpline(c(x, 10), knots = knots, degree = 0, Boundary.knots = c(0, 1))) expect_silent(bSpline(c(x, 10), knots = knots, degree = 3, Boundary.knots = c(0, 1))) options("splines2.warn.outside" = TRUE) ## warning if it cannot set internal knots based on quantiles expect_warning(bSpline(rep(0.5, 10), df = 10, Boundary.knots = c(0, 1)), pattern = "duplicated") expect_warning(bSpline(c(0, rep(1, 10)), df = 4, Boundary.knots = c(0, 1)), pattern = "boundary") ### periodic B-splines ## 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 <- bSpline(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 <- bSpline(x, df = 6, degree = 3, intercept = TRUE, Boundary.knots = b_knots, periodic = TRUE) tmp <- bSpline(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_eqt(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_eqt(res0, tmp) ## first derivatives res1 <- bSpline(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_eqt(deriv(res0), res1) expect_eqt(deriv(tmp), res1) expect_eqt(matrix(predict(res1, 0.25), nrow = 4, ncol = ncol(res1), byrow = TRUE), predict(res1, 0.25 + 1:4)) ## second derivatives res2 <- bSpline(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_eqt(deriv(res1), res2) expect_eqt(deriv(res0, 2), res2) expect_eqt(deriv(tmp, 2), res2) expect_eqt(matrix(predict(res2, 0.25), nrow = 4, ncol = ncol(res2), byrow = TRUE), predict(res2, 0.25 + 1:4)) ## third derivatives res3 <- bSpline(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_eqt(deriv(res2), res3) expect_eqt(deriv(res1, 2), res3) expect_eqt(deriv(res0, 3), res3) expect_eqt(deriv(tmp, 3), res3) expect_eqt(matrix(predict(res3, 0.25), nrow = 4, ncol = ncol(res3), byrow = TRUE), predict(res3, 0.25 + 1:4)) ## fourth derivatives res4 <- bSpline(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_eqt(res4[1, , drop = FALSE], matrix(0, ncol = ncol(res4), nrow = 1)) ## integrals res3 <- bSpline(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_eqt(deriv(res3), res0) expect_eqt(deriv(res3), tmp) expect_eqt(deriv(res3, 2), res1) expect_eqt(deriv(res3, 3), res2) expect_eqt(matrix(predict(res3, 0.25), byrow = TRUE, nrow = 4, ncol = ncol(res3)) + predict(res3, 1:4), predict(res3, 0.25 + 1:4)) ## intercept = FALSE ## basis res0 <- bSpline(x, df = 6, degree = 3, intercept = FALSE, Boundary.knots = b_knots, periodic = TRUE) tmp <- bSpline(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_eqt(matrix(predict(res0, 0.25), nrow = 4, ncol = ncol(res0), byrow = TRUE), predict(res0, 0.25 + 1:4)) expect_eqt(res0, tmp) expect_true(isNumMatrix(res0, length(x), 6)) expect_true(all(is_in(attr(res0, "knots"), 0, 1))) ## first derivatives res1 <- bSpline(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_eqt(deriv(res0), res1) expect_eqt(deriv(tmp), res1) expect_eqt(matrix(predict(res1, 0.25), nrow = 4, ncol = ncol(res1), byrow = TRUE), predict(res1, 0.25 + 1:4)) ## second derivatives res2 <- bSpline(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_eqt(deriv(res1), res2) expect_eqt(deriv(res0, 2), res2) expect_eqt(deriv(tmp, 2), res2) expect_eqt(matrix(predict(res2, 0.25), nrow = 4, ncol = ncol(res2), byrow = TRUE), predict(res2, 0.25 + 1:4)) ## third derivatives res3 <- bSpline(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_eqt(deriv(res2), res3) expect_eqt(deriv(res1, 2), res3) expect_eqt(deriv(res0, 3), res3) expect_eqt(deriv(tmp, 3), res3) expect_eqt(matrix(predict(res3, 0.25), nrow = 4, ncol = ncol(res3), byrow = TRUE), predict(res3, 0.25 + 1:4)) ## fourth derivatives res4 <- bSpline(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_eqt(res4[1, , drop = FALSE], matrix(0, ncol = ncol(res4), nrow = 1)) ## integrals res3 <- bSpline(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_eqt(deriv(res3), res0) expect_eqt(deriv(res3), tmp) expect_eqt(deriv(res3, 2), res1) expect_eqt(deriv(res3, 3), res2) expect_eqt(matrix(predict(res3, 0.25), byrow = TRUE, nrow = 4, ncol = ncol(res3)) + predict(res3, 1:4), predict(res3, 0.25 + 1:4)) splines2/inst/tinytest/test-makepredictcall.R0000644000176200001440000000524114441353604021103 0ustar liggesusers## helper function get_predvars <- function(mod, key_attr) { out <- as.list(attr(terms(mod$model), "predvars")[[3]])[key_attr] if (any(sapply(out, is.null))) stop("Found not matched key attribute.") out } get_attr <- function(x, key_attr) { out <- attributes(x)[key_attr] if (any(sapply(out, is.null))) stop("Found not matched key attribute.") out } ## 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 ~ bsp(x, df = 6)) key_attr <- c("degree", "knots", "Boundary.knots", "intercept", "periodic", "derivs", "integral") 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) ## design matrix X <- bsp(x, df = 6) mod <- lm(y ~ X) expect_error(get_predvars(mod, key_attr), "not matched key attribute") ## naturalSpline() mod <- lm(y ~ naturalSpline(x, df = 6)) key_attr <- c("knots", "Boundary.knots", "intercept") expect_equal( get_attr(nsp(x, df = 6), key_attr), get_predvars(mod, key_attr) ) ## design matrix X <- nsp(x, df = 6) mod <- lm(y ~ X) expect_error(get_predvars(mod, key_attr), "not matched key attribute") ## 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/utils.R0000644000176200001440000000030014412341535016127 0ustar liggesusers## check essentials expect_eqt <- function(current, target, ...) { tinytest::expect_equivalent(current = unclass(current), target = unclass(target), ...) } splines2/inst/tinytest/test-naturalSpline.R0000644000176200001440000001144114760107703020600 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## helper functions isNumMatrix <- v2$isNumMatrix ### 1. check correctness first x <- seq.int(0, 2, 0.1) knots <- c(0.3, 0.5, 1.6) b_knots <- c(0, 2) ## without internal knots nsMat0a <- naturalSpline(x, df = 2, intercept = TRUE) nsMat0b <- naturalSpline(x, intercept = TRUE) ## check second derivatives at boundary knots expect_true(all(abs(predict(nsMat0a, 0, derivs = 2)) < 1e-12)) ## 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)) ## with one internal knot nsMat1a <- naturalSpline(x, knots = 0.3, intercept = TRUE) ## check second derivatives at boundary knots expect_true(all(abs( predict(nsMat1a, newx = knots(nsMat1a, "boundary"), derivs = 2) ) < 1e-12)) ## 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)) ## check the returned H matrix in attribute h_mat <- attr(nsMat0, "H") bsMat <- bSpline(x, knots = knots, intercept = TRUE) expect_eqt(nsMat0, bsMat %*% h_mat) expect_eqt(nsMat1, ibs(x, knots = knots, intercept = TRUE) %*% h_mat) expect_eqt(nsMat2, deriv(bsMat) %*% h_mat) expect_eqt(nsMat3, deriv(bsMat, 2) %*% h_mat) ## 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, knots(nsMat3, "boundary"))) < 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), 5] - iMat[seq.int(length(xx) - 9, length(xx) - 4), 5] < iMat[seq.int(length(xx) - 9, length(xx) - 4), 5] - iMat[seq.int(length(xx) - 8, length(xx) - 3), 5] )) ### 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-predict.R0000644000176200001440000000665614421014164017415 0ustar liggesuserssource("utils.R") x <- c(seq.int(0, 10, 0.5), NA) bsMat <- bSpline(x, df = 6) ibsMat <- ibs(x, df = 6) dbsMat <- dbs(x, df = 6) msMat <- mSpline(x, df = 6) isMat <- iSpline(x, df = 6) csMat1 <- cSpline(x, df = 6) csMat2 <- cSpline(x, df = 6, scale = FALSE) bpMat <- bernsteinPoly(x, degree = 6) nsMat <- naturalSpline(x, df = 6) ## with newx expect_eqt(predict(bsMat, 1), bsMat[3L, , drop = FALSE]) expect_eqt(predict(ibsMat, 1), ibsMat[3L, , drop = FALSE]) expect_eqt(predict(dbsMat, 1), dbsMat[3L, , drop = FALSE]) expect_eqt(predict(msMat, 1), msMat[3L, , drop = FALSE]) expect_eqt(predict(isMat, 1), isMat[3L, , drop = FALSE]) expect_eqt(predict(csMat1, 1), csMat1[3L, , drop = FALSE]) expect_eqt(predict(csMat2, 1), csMat2[3L, , drop = FALSE]) expect_eqt(predict(bpMat, 1), bpMat[3L, , drop = FALSE]) expect_eqt(predict(nsMat, 1), nsMat[3L, , drop = FALSE]) ## without newx expect_eqt(predict(bsMat), bsMat) expect_eqt(predict(ibsMat), ibsMat) expect_eqt(predict(dbsMat), dbsMat) expect_eqt(predict(msMat), msMat) expect_eqt(predict(isMat), isMat) expect_eqt(predict(csMat1), csMat1) expect_eqt(predict(csMat2), csMat2) expect_eqt(predict(bpMat), bpMat) expect_eqt(predict(nsMat), nsMat) ## with coef beta <- runif(ncol(bsMat)) expect_eqt(predict(bsMat, coef = beta), as.numeric(bsMat %*% beta)) expect_eqt(predict(ibsMat, coef = beta), as.numeric(ibsMat %*% beta)) expect_eqt(predict(dbsMat, coef = beta), as.numeric(dbsMat %*% beta)) expect_eqt(predict(msMat, coef = beta), as.numeric(msMat %*% beta)) expect_eqt(predict(isMat, coef = beta), as.numeric(isMat %*% beta)) expect_eqt(predict(csMat1, coef = beta), as.numeric(csMat1 %*% beta)) expect_eqt(predict(csMat2, coef = beta), as.numeric(csMat2 %*% beta)) expect_eqt(predict(bpMat, coef = beta), as.numeric(bpMat %*% beta)) expect_eqt(predict(nsMat, coef = beta), as.numeric(nsMat %*% beta)) ## update without coef expect_eqt(predict(bsMat, derivs = 1), update(bsMat, derivs = 1)) expect_eqt(predict(ibsMat, derivs = 1), update(ibsMat, derivs = 1)) expect_eqt(predict(dbsMat, derivs = 1), update(dbsMat, derivs = 1)) expect_eqt(predict(msMat, derivs = 1), update(msMat, derivs = 1)) expect_eqt(predict(isMat, derivs = 1), update(isMat, derivs = 1)) expect_eqt(predict(csMat1, derivs = 1), update(csMat1, derivs = 1)) expect_eqt(predict(csMat2, derivs = 1), update(csMat2, derivs = 1)) expect_eqt(predict(bpMat, derivs = 1), update(bpMat, derivs = 1)) expect_eqt(predict(nsMat, derivs = 1), update(nsMat, derivs = 1)) ## update with coef expect_eqt(predict(bsMat, derivs = 1, coef = beta), as.numeric(deriv(bsMat, derivs = 1) %*% beta)) expect_eqt(predict(ibsMat, derivs = 1, coef = beta), as.numeric(deriv(ibsMat, derivs = 1) %*% beta)) expect_eqt(predict(dbsMat, derivs = 1, coef = beta), as.numeric(deriv(dbsMat, derivs = 1) %*% beta)) expect_eqt(predict(msMat, derivs = 1, coef = beta), as.numeric(deriv(msMat, derivs = 1) %*% beta)) expect_eqt(predict(isMat, derivs = 1, coef = beta), as.numeric(deriv(isMat, derivs = 1) %*% beta)) expect_eqt(predict(csMat1, derivs = 1, coef = beta), as.numeric(deriv(csMat1, derivs = 1) %*% beta)) expect_eqt(predict(csMat2, derivs = 1, coef = beta), as.numeric(deriv(csMat2, derivs = 1) %*% beta)) expect_eqt(predict(bpMat, derivs = 1, coef = beta), as.numeric(deriv(bpMat, derivs = 1) %*% beta)) expect_eqt(predict(nsMat, derivs = 1, coef = beta), as.numeric(deriv(nsMat, derivs = 1) %*% beta)) splines2/inst/tinytest/test-bernsteinPoly.R0000644000176200001440000001323714412343705020617 0ustar liggesuserssource("utils.R") ### 1. test correctness first x <- seq.int(0, 1, 0.1) ## degree 0: basis res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE) expect_eqt(matrix(1, nrow = length(x)), res0) res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE, derivs = 1, integral = TRUE) expect_eqt(matrix(1, nrow = length(x)), res0) ## degree 0: derivative res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE, derivs = 1) expect_eqt(matrix(0, nrow = length(x)), res0) ## degree 0: integral res0 <- bernsteinPoly(x, degree = 0, intercept = TRUE, integral = TRUE) expect_eqt(matrix(x, nrow = length(x)), res0) ## degree 1: basis bp1 <- function(x) { cbind(1 - x, x) } res1 <- bernsteinPoly(x, degree = 1, intercept = TRUE) expect_eqt(bp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, derivs = 1, integral = TRUE) expect_eqt(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_eqt(dbp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, derivs = 2, integral = TRUE) expect_eqt(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_eqt(ddbp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, derivs = 3, integral = TRUE) expect_eqt(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_eqt(ibp1(x), res1) res1 <- bernsteinPoly(x, degree = 1, intercept = FALSE, integral = TRUE) expect_eqt(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_eqt(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_eqt(dbp2(x), res2) res2 <- bernsteinPoly(x, degree = 2, intercept = TRUE, derivs = 2, integral = TRUE) expect_eqt(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_eqt(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_eqt(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_eqt(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_eqt(dbp3(x), res3) res3 <- bernsteinPoly(x, degree = 3, intercept = TRUE, derivs = 2, integral = TRUE) expect_eqt(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_eqt(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_eqt(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_eqt(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_eqt(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_eqt(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_eqt(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/tinytest/test-deriv.R0000644000176200001440000001313714412343156017072 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(bsMat, 0)) expect_error(deriv(dbsMat, 0)) expect_error(deriv(ibsMat, 0)) expect_error(deriv(msMat, 0)) expect_error(deriv(isMat, 0)) expect_error(deriv(csMat, 0)) expect_error(deriv(bpMat, 0)) expect_error(deriv(bsMat, - 1)) expect_error(deriv(dbsMat, - 1)) expect_error(deriv(ibsMat, - 1)) expect_error(deriv(msMat, - 1)) expect_error(deriv(isMat, - 1)) expect_error(deriv(csMat, - 1)) expect_error(deriv(bpMat, - 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-dbs.R0000644000176200001440000001370314412343252016525 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## 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_eqt(dbs(x, derivs = 1, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 1)) expect_eqt(dbs(x, derivs = 2, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 2)) ## except at right boundary knots expect_eqt( 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_eqt(dbs(x, derivs = 1, knots = knots, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 1)) expect_eqt(dbs(x, derivs = 2, knots = knots, intercept = TRUE), splines::splineDesign(aKnots, x = x, derivs = 2)) expect_eqt( 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_eqt(dbs(x, 1, knots = knots, degree = 4, intercept = TRUE), splines::splineDesign(aKnots, x, ord, derivs = 1)) expect_eqt(dbs(x, 2, knots = knots, degree = 4, intercept = TRUE), splines::splineDesign(aKnots, x, ord, derivs = 2)) expect_eqt(dbs(x, 3, knots = knots, degree = 4, intercept = TRUE), splines::splineDesign(aKnots, x, ord, derivs = 3)) expect_eqt( 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_eqt(dbs(x), v2$dbs(x)) ## cubic splines with specified df expect_eqt(dbs(x, df = 5), v2$dbs(x, df = 5)) ## cubic splines with specified internal knots expect_eqt(dbs(x, knots = knots), v2$dbs(x, knots = knots)) ## qudractic splines without internal knots expect_eqt(dbs(x, degree = 2L), v2$dbs(x, degree = 2L)) ## complete basis with intercept expect_eqt(dbs(x, intercept = TRUE), v2$dbs(x, intercept = TRUE)) ## specified knots expect_eqt(dbs(x, knots = knots, intercept = TRUE), v2$dbs(x, knots = knots, intercept = TRUE)) ## specified df expect_eqt(dbs(x, df = 6, intercept = TRUE), v2$dbs(x, df = 6, intercept = TRUE)) ## degree zero expect_eqt(dbs(x, df = 5, degree = 0), v2$dbs(x, df = 5, degree = 0)) expect_eqt(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_eqt( dbs(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$dbs(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_eqt( 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-mSpline.R0000644000176200001440000004040714412341566017373 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## 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_eqt(mSpline(x), v2$mSpline(x)) ## cubic splines with specified df expect_eqt(mSpline(x, df = 5), v2$mSpline(x, df = 5)) ## cubic splines with specified internal knots expect_eqt(mSpline(x, knots = knots), v2$mSpline(x, knots = knots)) ## qudractic splines without internal knots expect_eqt(mSpline(x, degree = 2L), v2$mSpline(x, degree = 2L)) ## complete basis with intercept expect_eqt(mSpline(x, intercept = TRUE), v2$mSpline(x, intercept = TRUE)) ## specified knots expect_eqt(mSpline(x, knots = knots, intercept = TRUE), v2$mSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_eqt(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_eqt(msMat0b, msMat0b2) expect_eqt(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_eqt(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_eqt(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_eqt( mSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$mSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_eqt( 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_eqt(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_eqt(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_eqt(deriv(res0), res1) expect_eqt(deriv(tmp), res1) expect_eqt(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_eqt(deriv(res1), res2) expect_eqt(deriv(res0, 2), res2) expect_eqt(deriv(tmp, 2), res2) expect_eqt(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_eqt(deriv(res2), res3) expect_eqt(deriv(res1, 2), res3) expect_eqt(deriv(res0, 3), res3) expect_eqt(deriv(tmp, 3), res3) expect_eqt(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_eqt(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_eqt(deriv(res3), res0) expect_eqt(deriv(res3), tmp) expect_eqt(deriv(res3, 2), res1) expect_eqt(deriv(res3, 3), res2) expect_eqt(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_eqt(matrix(predict(res0, 0.25), nrow = 4, ncol = ncol(res0), byrow = TRUE), predict(res0, 0.25 + 1:4)) expect_eqt(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_eqt(deriv(res0), res1) expect_eqt(deriv(tmp), res1) expect_eqt(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_eqt(deriv(res1), res2) expect_eqt(deriv(res0, 2), res2) expect_eqt(deriv(tmp, 2), res2) expect_eqt(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_eqt(deriv(res2), res3) expect_eqt(deriv(res1, 2), res3) expect_eqt(deriv(res0, 3), res3) expect_eqt(deriv(tmp, 3), res3) expect_eqt(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_eqt(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_eqt(deriv(res3), res0) expect_eqt(deriv(res3), tmp) expect_eqt(deriv(res3, 2), res1) expect_eqt(deriv(res3, 3), res2) expect_eqt(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_eqt(res0, tmp) expect_true(isNumMatrix(res0, length(x), length(knots) + 1L)) expect_eqt(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_eqt(deriv(res0), res1) expect_eqt(deriv(tmp), res1) expect_eqt(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_eqt(deriv(res1), res2) expect_eqt(deriv(res0, 2), res2) expect_eqt(deriv(tmp, 2), res2) expect_eqt(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_eqt(deriv(res3), res0) expect_eqt(deriv(res3), tmp) expect_eqt(deriv(res3, 2), res1) expect_eqt(deriv(res3, 3), res2) expect_eqt(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_eqt(res0, tmp) expect_eqt(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_eqt(deriv(res0), res1) expect_eqt(deriv(tmp), res1) expect_eqt(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_eqt(deriv(res1), res2) expect_eqt(deriv(res0, 2), res2) expect_eqt(deriv(tmp, 2), res2) expect_eqt(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_eqt(deriv(res3), res0) expect_eqt(deriv(res3), tmp) expect_eqt(deriv(res3, 2), res1) expect_eqt(deriv(res3, 3), res2) expect_eqt(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-cSpline.R0000644000176200001440000001270414412342160017347 0ustar liggesusers## get implementations of v0.2.8 for reference v2 <- new.env() source("../v0.2.8.R", v2) source("utils.R") ## 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_eqt(cSpline(x), v2$cSpline(x)) ## cubic splines with specified df expect_eqt(cSpline(x, df = 5), v2$cSpline(x, df = 5)) ## cubic splines with specified internal knots expect_eqt(cSpline(x, knots = knots), v2$cSpline(x, knots = knots)) ## qudractic splines without internal knots expect_eqt(cSpline(x, degree = 2L), v2$cSpline(x, degree = 2L)) ## complete basis with intercept expect_eqt(cSpline(x, intercept = TRUE), v2$cSpline(x, intercept = TRUE)) ## specified knots expect_eqt(cSpline(x, knots = knots, intercept = TRUE), v2$cSpline(x, knots = knots, intercept = TRUE)) ## specified df expect_eqt(cSpline(x, df = 6, intercept = TRUE), v2$cSpline(x, df = 6, intercept = TRUE)) ## degree zero expect_eqt(cSpline(x, df = 5, degree = 0), v2$cSpline(x, df = 5, degree = 0)) expect_eqt(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_eqt( cSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots), v2$cSpline(x2, df = 6, degree = 3, Boundary.knots = b_knots) ) }) suppressWarnings({ expect_eqt( 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_eqt( cSpline(x, df = 5, derivs = 1, scale = FALSE, intercept = TRUE), iSpline(x, df = 5, intercept = TRUE) ) expect_eqt( cSpline(x, knots = knots, derivs = 1, scale = FALSE, intercept = TRUE), iSpline(x, knots = knots, intercept = TRUE) ) expect_eqt( cSpline(x, df = 6, degree = 2, derivs = 2, intercept = TRUE, scale = FALSE), iSpline(x, df = 6, degree = 2, derivs = 1, intercept = TRUE) ) expect_eqt( cSpline(x, knots = knots, degree = 2, derivs = 2, intercept = TRUE, scale = FALSE), iSpline(x, knots = knots, degree = 2, derivs = 1, intercept = TRUE) ) expect_eqt( cSpline(x, df = 6, degree = 2, derivs = 3, intercept = TRUE, scale = FALSE), iSpline(x, df = 6, degree = 2, derivs = 2, intercept = TRUE) ) expect_eqt( cSpline(x, knots = knots, degree = 2, derivs = 3, intercept = TRUE, scale = FALSE), iSpline(x, knots = knots, degree = 2, derivs = 2, intercept = TRUE) ) expect_eqt( cSpline(x, df = 6, degree = 2, derivs = 4, intercept = TRUE, scale = FALSE), iSpline(x, df = 6, degree = 2, derivs = 3, intercept = TRUE) ) expect_eqt( 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/bib/0000755000176200001440000000000014716263527013537 5ustar liggesuserssplines2/inst/bib/splines2.bib0000644000176200001440000000526014426000523015736 0ustar liggesusers@book{boor1978practical, title = {A Practical Guide to Splines}, author = {De Boor, Carl}, volume = 27, year = 1978, publisher = Springer-Verlag, Address = {New York} } @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} } @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 } @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} } @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}, } @article{wang2021shape, author = {Wang, Wenjie and Yan, Jun}, title = {Shape-Restricted Regression Splines with {R} Package {splines2}}, journal = {Journal of Data Science}, volume = 19, number = 3, year = 2021, pages = {498--517}, doi = {10.6339/21-JDS1020}, issn = {1680-743X}, publisher = {School of Statistics, Renmin University of China}, } splines2/inst/run_rcpp_test.R0000644000176200001440000000012514407174372016007 0ustar liggesuserslibrary(tinytest) library(splines2) tinytest::run_test_dir(dir = "inst/rcpp-tests") 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/README.md0000644000176200001440000002341414760110272013274 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://app.codecov.io/gh/wenjie2wang/splines2) [![JDS](https://img.shields.io/badge/JDS-10.6339%2F21--JDS1020-brightgreen)](https://doi.org/10.6339/21-JDS1020) **Package website**: [release](https://wwenjie.org/splines2) \| [development](https://wwenjie.org/splines2/dev) The R package **splines2** is intended to be a user-friendly *supplementary* package to the base package **splines**. ## Features The package **splines2** provides functions to construct basis matrices of - B-splines - M-splines - I-splines - convex splines (C-splines) - periodic 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 version 0.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 below for reference. ``` r library(microbenchmark) options(microbenchmark.unit="relative") 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]]), unclass(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 ) ``` Unit: relative expr min lq mean median uq max neval splines::bs 3.5101 2.7677 2.4657 2.8721 2.2682 1.5334 100 splines::splineDesign 2.4324 1.9049 1.9833 2.1624 1.7941 8.4094 100 splines2::bSpline 1.0000 1.0000 1.0000 1.0000 1.0000 1.0000 100 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 ) ``` Unit: relative expr min lq mean median uq max neval splines::splineDesign 2.7082 2.4949 2.0586 2.0985 2.1164 1.5585 100 splines2::dbs 1.0000 1.0000 1.0000 1.0000 1.0000 1.0000 100 The **splines** package does not contain an implementation for integrals of B-splines. Thus, we performed a comparison with package **ibs** (version 1.4), 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 ) ``` Unit: relative expr min lq mean median uq max neval ibs::ibs 53.484 45.639 42.991 42.464 39.945 30.853 100 splines2::ibs 1.000 1.000 1.000 1.000 1.000 1.000 100 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::nsp()` 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::nsp" = nsp( x, knots = internal_knots, intercept = TRUE, Boundary.knots = boundary_knots ) ) ``` Unit: relative expr min lq mean median uq max neval splines::ns 5.8949 5.4165 4.8466 4.5983 5.1892 3.7201 100 splines2::nsp 1.0000 1.0000 1.0000 1.0000 1.0000 1.0000 100 The functions `bSpline()` and `mSpline()` produce periodic spline basis functions based on B-splines and M-splines, respectively, when `periodic = TRUE` is specified. The `splines::periodicSpline()` returns a periodic interpolation spline (based on B-splines) instead of basis matrix. We performed a comparison with package **pbs** (version 1.1), where the function `pbs::pbs()` produces a basis matrix of periodic B-spline by using `splines::spline.des()`. ``` r microbenchmark( "pbs::pbs" = pbs::pbs(x, knots = internal_knots, degree = degree, intercept = TRUE, periodic = TRUE, Boundary.knots = boundary_knots), "splines2::bSpline" = bSpline( x, knots = internal_knots, degree = degree, intercept = TRUE, Boundary.knots = boundary_knots, periodic = TRUE ), "splines2::mSpline" = mSpline( x, knots = internal_knots, degree = degree, intercept = TRUE, Boundary.knots = boundary_knots, periodic = TRUE ) ) ``` Unit: relative expr min lq mean median uq max neval pbs::pbs 4.2867 3.8656 2.6849 3.6822 2.8756 1.00982 100 splines2::bSpline 1.0000 1.0000 1.0000 1.0000 1.0000 1.00000 100 splines2::mSpline 1.0787 1.0477 0.8013 1.1933 1.0466 0.11527 100
Session Information for Benchmarks ``` r sessionInfo() ``` R version 4.4.2 (2024-10-31) Platform: x86_64-pc-linux-gnu Running under: Arch Linux Matrix products: default BLAS/LAPACK: /usr/lib/libopenblas.so.0.3; LAPACK version 3.12.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 time zone: America/Indianapolis tzcode source: system (glibc) attached base packages: [1] splines stats graphics grDevices utils datasets methods base other attached packages: [1] splines2_0.5.4 microbenchmark_1.5.0 loaded via a namespace (and not attached): [1] digest_0.6.37 codetools_0.2-20 ibs_1.4 fastmap_1.2.0 xfun_0.51 [6] pbs_1.1 knitr_1.49 htmltools_0.5.8.1 rmarkdown_2.29 cli_3.6.4 [11] compiler_4.4.2 tools_4.4.2 evaluate_1.0.3 Rcpp_1.0.14 yaml_2.3.10 [16] rlang_1.1.5
## License [GNU General Public License](https://www.gnu.org/licenses/) (≥ 3) splines2/build/0000755000176200001440000000000014760217644013123 5ustar liggesuserssplines2/build/vignette.rds0000644000176200001440000000037714760217644015471 0ustar liggesusers‹uOM‹Â0muUdëÂóìÁ ˆ ^ÄðZÚ¬ ´II"Å›¿Ü:­“b»Hfæ½y3/ç1!Ä!žçÇ…ÔõáÀ¾p2‚ø­ó” ¦s.Œ’Á>‹‘™5LÁç*Êóšk«é’© ÝTâø.5’Z-öýž4—¥7 ÝÃÌÎ<¿ã&1YŠÔÏ?;5ÙÖO»¿A¼:~Ý÷ê'oñîUXõ}fL#9@Ð[ó”Ù†#7MáîVkL{ÖÁ׊åLÄËá–Ý © n/)YvÙ¤rv‡§,ËG×Q”†Ú:²à8Mü)ÐCõx?Áósplines2/man/0000755000176200001440000000000014716263527012601 5ustar liggesuserssplines2/man/mSpline.Rd0000644000176200001440000001631114605645205014473 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mSpline.R \name{mSpline} \alias{mSpline} \alias{msp} \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, warn.outside = getOption("splines2.warn.outside", TRUE), ... ) msp( x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, periodic = FALSE, derivs = 0L, integral = FALSE, warn.outside = getOption("splines2.warn.outside", 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. For periodic splines, \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, the number of knots must be greater or equal to the specified \code{degree - 1}. Duplicated internal knots are not allowed.} \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, the specified bounary knots define the cyclic interval.} \item{periodic}{A logical value. If \code{TRUE}, the periodic splines will be returned. The default value is \code{FALSE}.} \item{derivs}{A nonnegative integer specifying the order of derivatives of splines basis function. The default value is \code{0}.} \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{warn.outside}{A logical value indicating if a warning should be thrown out when any \code{x} is outside the boundary. This option can also be set through \code{options("splines2.warn.outside")} after the package is loaded.} \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. For shape-restricted regression, see Wang and Yan (2021) for examples. The function \code{msp()} is an alias of to encourage the use in a model formula. } \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)) plot(msMat, mark_knots = "internal") ## 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)) plot(pMat, ylab = "Periodic Basis", mark_knots = "boundary") plot(iMat, ylab = "Integrals from 0") abline(v = seq.int(0, max(x)), h = seq.int(0, max(x)), lty = 2, col = "grey") plot(dMat1, ylab = "1st derivatives by 'derivs=1'", mark_knots = "boundary") plot(dMat2, ylab = "1st derivatives by 'deriv()'", mark_knots = "boundary") par(op) # reset to previous plotting settings ### 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 <- mSpline(x, degree = degree, df = df, periodic = TRUE, intercept = intercept) ## 2. specify knots spline_basis2 <- 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. Wang, W., & Yan, J. (2021). \emph{Shape-restricted regression splines with R package splines2}. Journal of Data Science, 19(3),498--517. } \seealso{ \code{\link{bSpline}} for B-splines; \code{\link{iSpline}} for I-splines; \code{\link{cSpline}} for C-splines. } splines2/man/deriv.Rd0000644000176200001440000000636414421235063014175 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deriv.R \name{deriv} \alias{deriv} \alias{deriv.BSpline} \alias{deriv.MSpline} \alias{deriv.ISpline} \alias{deriv.CSpline} \alias{deriv.BernsteinPoly} \alias{deriv.NaturalSpline} \alias{deriv.NaturalSplineK} \title{Derivatives of Spline Basis Functions} \usage{ \method{deriv}{BSpline}(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, ...) \method{deriv}{NaturalSplineK}(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/iSpline.Rd0000644000176200001440000001062014577421431014465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/iSpline.R \name{iSpline} \alias{iSpline} \alias{isp} \title{I-Spline Basis for Polynomial Splines} \usage{ iSpline( x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = NULL, derivs = 0L, warn.outside = getOption("splines2.warn.outside", TRUE), ... ) isp( x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = NULL, derivs = 0L, warn.outside = getOption("splines2.warn.outside", 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. For periodic splines, \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, the number of knots must be greater or equal to the specified \code{degree - 1}. Duplicated internal knots are not allowed.} \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}. For periodic splines, the specified bounary knots define the cyclic interval.} \item{derivs}{A nonnegative integer specifying the order of derivatives of I-splines.} \item{warn.outside}{A logical value indicating if a warning should be thrown out when any \code{x} is outside the boundary. This option can also be set through \code{options("splines2.warn.outside")} after the package is loaded.} \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. Attributes that correspond to the arguments specified are returned for usage of 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). The function \code{isp()} is an alias of to encourage the use in a model formula. } \examples{ library(splines2) ## an example given in 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)) plot(isMat, ylab = "I-spline basis", mark_knots = "internal") par(op) # reset to previous plotting settings ## 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/predict.Rd0000644000176200001440000000631014665461570014523 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.R \name{predict} \alias{predict} \alias{predict.BSpline} \alias{predict.MSpline} \alias{predict.ISpline} \alias{predict.CSpline} \alias{predict.BernsteinPoly} \alias{predict.NaturalSpline} \alias{predict.NaturalSplineK} \title{Compute Spline Function for Given Coefficients} \usage{ \method{predict}{BSpline}(object, newx = NULL, coef = NULL, ...) \method{predict}{MSpline}(object, newx = NULL, coef = NULL, ...) \method{predict}{ISpline}(object, newx = NULL, coef = NULL, ...) \method{predict}{CSpline}(object, newx = NULL, coef = NULL, ...) \method{predict}{BernsteinPoly}(object, newx = NULL, coef = NULL, ...) \method{predict}{NaturalSpline}(object, newx = NULL, coef = NULL, ...) \method{predict}{NaturalSplineK}(object, newx = NULL, coef = NULL, ...) } \arguments{ \item{object}{Spline objects produced by the \code{splines2} package.} \item{newx}{The \code{x} values at which evaluations are required. If it is \code{NULL} (by default), the original \code{x} used to create the spline object will be used.} \item{coef}{A numeric vector specifying the coefficients of the spline basis functions. If it is \code{NULL} (by default), the spline basis functions will be returned. Otherwise, the resulting spline function will be returned.} \item{...}{Other options passed to the corresponding function that constructs the input \code{object}. For example, the additional options will be passed to \code{bSpline()} for a \code{BSpline} object.} } \value{ The function returns the spline basis functions with the new values of \code{x} if \code{coef} is not specified. Otherwise, the function returns the resulting spline function (or its derivative if \code{derivs} is specified as a positive integer through \code{...}). } \description{ Returns the spline function (with the specified coefficients) or evaluate the basis functions at the specified \code{x} if the coefficients are not specified. } \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) ## Cubic B-spline basis functions bs_mat <- bSpline(x, knots = knots) ## compute the B-spline basis functions at new x predict(bs_mat, newx) ## compute the B-spline function for the specified coefficients beta <- runif(ncol(bs_mat)) predict(bs_mat, coef = beta) ## compute the first derivative of the B-spline function predict(bs_mat, coef = beta, derivs = 1) ## or equivalently predict(deriv(bs_mat), coef = beta) ## compute the second derivative predict(bs_mat, coef = beta, derivs = 2) ## or equivalently predict(deriv(bs_mat, derivs = 2), coef = beta) ## compute the integral predict(bs_mat, coef = beta, integral = TRUE) ## or equivalently predict(update(bs_mat, integral = TRUE), coef = beta) ## visualize op <- par(mfrow = c(2, 2), mar = c(2.5, 2.5, 0.5, 0.1), mgp = c(1.5, 0.5, 0)) plot(bs_mat, coef = beta, ylab = "B-Spline Function", mark_knots = "all") plot(deriv(bs_mat), coef = beta, ylab = "1st Derivative", mark_knots = "all") plot(deriv(bs_mat, derivs = 2), coef = beta, ylab = "2nd Derivative", mark_knots = "all") plot(update(bs_mat, integral = TRUE), coef = beta, ylab = "Integral", mark_knots = "all") par(op) } splines2/man/plot.splines2.Rd0000644000176200001440000000225314665461570015607 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.R \name{plot.splines2} \alias{plot.splines2} \title{Visualize Spline Basis Functions} \usage{ \method{plot}{splines2}( x, y, from = NULL, to = NULL, n = 101, coef = NULL, mark_knots = c("none", "internal", "boundary", "all"), ... ) } \arguments{ \item{x}{A \code{splines2} object.} \item{y}{An argument that is not used.} \item{from, to}{Two numbers representing the start and end point for the plot, respectively.} \item{n}{An integer, the number of x values at which to evaluate.} \item{coef}{A numeric vector specifying the coefficients of the spline basis functions. If it is \code{NULL} (by default), the spline basis functions will be plotted. Otherwise, the resulting spline function will be plotted.} \item{mark_knots}{A character vector specifying if knot placement should be indicated by vertical lines.} \item{...}{Additional arguments (other than \code{x} and \code{y}) that would be passed to \code{matplot()}.} } \description{ Plot spline basis functions by lines in different colors. } \details{ This function is intended to quickly visualize the spline basis functions. } splines2/man/bernsteinPoly.Rd0000644000176200001440000000607114441405225015715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bernsteinPoly.R \name{bernsteinPoly} \alias{bernsteinPoly} \alias{bpoly} \title{Generalized Bernstein Polynomial Basis Functions} \usage{ bernsteinPoly( x, degree = 3, intercept = FALSE, Boundary.knots = NULL, derivs = 0L, integral = FALSE, ... ) bpoly( 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 \code{BernsteinPoly} object that is essentially a numeric matrix of dimension \code{length(x)} by \code{degree + as.integer(intercept)}. } \description{ Returns generalized Bernstein polynomial basis functions of the given degree over the specified range. } \details{ The Bernstein polynomial basis functions are defined over the support from 0 to 1. The generalized Bernstein polynomial basis functions extend the support to any finite interval in the real line. The function \code{bpoly()} is an alias to encourage the use in a model formula. } \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)) plot(bMat1) plot(bMat2) ## 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)) plot(d1Mat1) plot(d1Mat2) plot(d2Mat1) plot(d2Mat2) ## 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/update.Rd0000644000176200001440000000235714421235063014344 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/update.R \name{update} \alias{update} \alias{update.BSpline} \alias{update.MSpline} \alias{update.ISpline} \alias{update.CSpline} \alias{update.BernsteinPoly} \alias{update.NaturalSpline} \alias{update.NaturalSplineK} \title{Update Spline Basis Functions} \usage{ \method{update}{BSpline}(object, ...) \method{update}{MSpline}(object, ...) \method{update}{ISpline}(object, ...) \method{update}{CSpline}(object, ...) \method{update}{BernsteinPoly}(object, ...) \method{update}{NaturalSpline}(object, ...) \method{update}{NaturalSplineK}(object, ...) } \arguments{ \item{object}{Spline objects produced by the \code{splines2} package.} \item{...}{Other arguments passed to the corresponing constructor function.} } \value{ An updated object of the same class as the input object with the specified updates. } \description{ Update the knot placement, polynomial degree, and any other options available when constructing the given spline object. } \examples{ library(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## quadratic B-splines bsMat2 <- bSpline(x, knots = knots, degree = 2, intercept = TRUE) ## cubic B-splines bsMat3 <- update(bsMat2, degree = 3) } splines2/man/bSpline.Rd0000644000176200001440000001530114577421431014457 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bSpline.R \name{bSpline} \alias{bSpline} \alias{ibs} \alias{dbs} \alias{bsp} \title{B-Spline Basis for Polynomial Splines} \usage{ bSpline( x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, periodic = FALSE, derivs = 0L, integral = FALSE, warn.outside = getOption("splines2.warn.outside", TRUE), ... ) ibs( x, df = NULL, knots = NULL, degree = 3, intercept = FALSE, Boundary.knots = NULL, ... ) dbs( x, derivs = 1L, df = NULL, knots = NULL, degree = 3, intercept = FALSE, Boundary.knots = NULL, ... ) bsp( x, df = NULL, knots = NULL, degree = 3L, intercept = FALSE, Boundary.knots = NULL, periodic = FALSE, derivs = 0L, integral = FALSE, warn.outside = getOption("splines2.warn.outside", 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. For periodic splines, \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, the number of knots must be greater or equal to the specified \code{degree - 1}. Duplicated internal knots are not allowed.} \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, the specified bounary knots define the cyclic interval.} \item{periodic}{A logical value. If \code{TRUE}, the periodic splines will be returned. The default value is \code{FALSE}.} \item{derivs}{A nonnegative integer specifying the order of derivatives of splines basis function. The default value is \code{0}.} \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{warn.outside}{A logical value indicating if a warning should be thrown out when any \code{x} is outside the boundary. This option can also be set through \code{options("splines2.warn.outside")} after the package is loaded.} \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 spline basis matrix for B-splines 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 functions by allowing piecewise constant (left-closed and right-open except on the right boundary) spline basis of degree zero. In addition, the function provides derivatives or integrals of the B-spline basis functions when one specifies the arguments \code{derivs} or \code{integral} appropriately. The function constructs periodic B-splines when \code{periodic} is \code{TRUE}. All the implementations are based on the closed-form recursion formula following De Boor (1978) and Wang and Yan (2021). The functions \code{ibs()} and \code{dbs()} are provided for convenience. The former provides the integrals of B-splines and is equivalent to \code{bSpline()} with \code{integral = TRUE}. The latter produces the derivatives of given order of B-splines and is equivalent to \code{bSpline()} with default \code{derivs = 1}. The function \code{bsp()} is an alias of to encourage the use in a model formula. } \examples{ library(splines2) set.seed(1) x <- runif(100) knots <- c(0.3, 0.5, 0.6) # internal knots ## cubic B-splines bsMat <- bSpline(x, knots = knots, degree = 3, intercept = TRUE) ibsMat <- update(bsMat, integral = TRUE) # the integrals d1Mat <- deriv(bsMat) # the 1st derivaitves d2Mat <- deriv(bsMat, 2) # the 2nd derivaitves op <- par(mfrow = c(2, 2), mar = c(2.5, 2.5, 0.2, 0.1), mgp = c(1.5, 0.5, 0)) plot(bsMat, ylab = "Cubic B-splines") plot(ibsMat, ylab = "The integrals") plot(d1Mat, ylab = "The 1st derivatives") plot(d2Mat, ylab = "The 2nd derivatives") ## evaluate at new values predict(bsMat, c(0.125, 0.801)) ## periodic B-splines px <- seq(0, 3, 0.01) pbsMat <- bSpline(px, knots = knots, Boundary.knots = c(0, 1), intercept = TRUE, periodic = TRUE) ipMat <- update(pbsMat, integral = TRUE) dpMat <- deriv(pbsMat) dp2Mat <- deriv(pbsMat, 2) plot(pbsMat, ylab = "Periodic B-splines", mark_knots = "b") plot(ipMat, ylab = "The integrals", mark_knots = "b") plot(dpMat, ylab = "The 1st derivatives", mark_knots = "b") plot(dp2Mat, ylab = "The 2nd derivatives", mark_knots = "b") par(op) # reset to previous plotting settings } \references{ De Boor, Carl. (1978). \emph{A practical guide to splines}. Vol. 27. New York: Springer-Verlag. Wang, W., & Yan, J. (2021). \emph{Shape-restricted regression splines with R package splines2}. Journal of Data Science, 19(3),498--517. } \seealso{ \code{\link{knots}} for extracting internal and boundary knots. } splines2/man/knots.Rd0000644000176200001440000000216714271262203014216 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/knots.R \name{knots} \alias{knots} \alias{knots.splines2} \title{Extract Knots from the Given Object} \usage{ \method{knots}{splines2}(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/cSpline.Rd0000644000176200001440000001225714577421431014467 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cSpline.R \name{cSpline} \alias{cSpline} \alias{csp} \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, warn.outside = getOption("splines2.warn.outside", TRUE), ... ) csp( x, df = NULL, knots = NULL, degree = 3L, intercept = TRUE, Boundary.knots = NULL, derivs = 0L, scale = TRUE, warn.outside = getOption("splines2.warn.outside", 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. For periodic splines, \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, the number of knots must be greater or equal to the specified \code{degree - 1}. Duplicated internal knots are not allowed.} \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}. For periodic splines, the specified bounary knots define the cyclic interval.} \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{warn.outside}{A logical value indicating if a warning should be thrown out when any \code{x} is outside the boundary. This option can also be set through \code{options("splines2.warn.outside")} after the package is loaded.} \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. Attributes that correspond to the arguments specified are returned for usage of 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. The function \code{csp()} is an alias of to encourage the use in a model formula. } \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) plot(csMat, ylab = "C-spline basis", mark_knots = "internal") isMat <- deriv(csMat) msMat <- deriv(csMat, derivs = 2) plot(isMat, ylab = "scaled I-spline basis") plot(msMat, 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)) } \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/naturalSpline.Rd0000644000176200001440000001665114605645205015714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/naturalSpline.R \name{naturalSpline} \alias{naturalSpline} \alias{nsp} \alias{nsk} \title{Natural Cubic Spline Basis for Polynomial Splines} \usage{ naturalSpline( x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, trim = 0, derivs = 0L, integral = FALSE, ... ) nsp( x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, trim = 0, derivs = 0L, integral = FALSE, ... ) nsk( x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, trim = 0, 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. For periodic splines, the number of knots must be greater or equal to the specified \code{degree - 1}. Duplicated internal knots are not allowed.} \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, the specified bounary knots define the cyclic interval.} \item{trim}{The fraction (0 to 0.5) of observations to be trimmed from each end of \code{x} before placing the default internal and boundary knots. This argument will be ignored if \code{Boundary.knots} is specified. The default value is \code{0} for backward compatibility, which sets the boundary knots as the range of \code{x}. If a positive fraction is specified, the default boundary knots will be equivalent to \code{quantile(x, probs = c(trim, 1 - trim), na.rm = TRUE)}, which can be a more sensible choice in practice due to the existence of outliers. The default internal knots are placed within the boundary afterwards.} \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{ Functions \code{naturalSpline()} and \code{nsk()} generate the natural cubic spline basis functions, the corresponding derivatives or integrals (from the left boundary knot). Both of them are different from \code{splines::ns()}. However, for a given model fitting procedure, using different variants of spline basis functions should result in identical prediction values. The coefficient estimates of the spline basis functions returned by \code{nsk()} are more interpretable compared to \code{naturalSpline()} or \code{splines::ns()} . } \details{ The constructed spline basis functions from \code{naturalSpline()} are nonnegative within boundary with the second derivatives being zeros at boundary knots. The implementation utilizes the close-form null space that can be derived from the recursive formula for the second derivatives of B-splines. The function \code{nsp()} is an alias of \code{naturalSpline()} to encourage the use in a model formula. The function \code{nsk()} produces another variant of natural cubic spline matrix such that only one of the basis functions is nonzero and takes a value of one at every boundary and internal knot. As a result, the coefficients of the resulting fit are the values of the spline function at the knots, which makes it easy to interpret the coefficient estimates. In other words, the coefficients of a linear model will be the heights of the function at the knots if \code{intercept = TRUE}. If \code{intercept = FALSE}, the coefficients will be the change in function value between each knot. This implementation closely follows the function \code{nsk()} of the \pkg{survival} package (version 3.2-8). The idea corresponds directly to the physical implementation of a spline by passing a flexible strip of wood or metal through a set of fixed points, which is a traditional way to create smooth shapes for things like a ship hull. The returned basis matrix can be obtained by transforming the corresponding B-spline basis matrix with the matrix \code{H} provided in the attribute of the returned object. Each basis is assumed to follow a linear trend for \code{x} outside of boundary. 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. See Supplementray Materials of Wang and Yan (2021) for a more detailed introduction. } \examples{ library(splines2) x <- seq.int(0, 1, 0.01) knots <- c(0.3, 0.5, 0.6) ## naturalSpline() nsMat0 <- naturalSpline(x, knots = knots, intercept = TRUE) nsMat1 <- naturalSpline(x, knots = knots, intercept = TRUE, integral = TRUE) nsMat2 <- naturalSpline(x, knots = knots, intercept = TRUE, derivs = 1) 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)) plot(nsMat0, ylab = "basis") plot(nsMat1, ylab = "integral") plot(nsMat2, ylab = "1st derivative") plot(nsMat3, ylab = "2nd derivative") par(op) # reset to previous plotting settings ## nsk() nskMat <- nsk(x, knots = knots, intercept = TRUE) plot(nskMat, ylab = "nsk()", mark_knots = "all") abline(h = 1, col = "red", lty = 3) ## 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)) ## a linear model example fit1 <- lm(weight ~ -1 + nsk(height, df = 4, intercept = TRUE), data = women) fit2 <- lm(weight ~ nsk(height, df = 3), data = women) ## the knots (same for both fits) knots <- unlist(attributes(fit1$model[[2]])[c("Boundary.knots", "knots")]) ## predictions at the knot points predict(fit1, data.frame(height = sort(unname(knots)))) unname(coef(fit1)) # equal to the coefficient estimates ## different interpretation when "intercept = FALSE" unname(coef(fit1)[-1] - coef(fit1)[1]) # differences: yhat[2:4] - yhat[1] unname(coef(fit2))[-1] # ditto } \seealso{ \code{\link{bSpline}} for B-splines; \code{\link{mSpline}} for M-splines; \code{\link{iSpline}} for I-splines. } splines2/man/splines2.Rd0000644000176200001440000000370414577421431014626 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/splines2-package.R \docType{package} \name{splines2} \alias{splines2} \alias{splines2-package} \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 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. } \seealso{ Useful links: \itemize{ \item \url{https://wwenjie.org/splines2} \item \url{https://github.com/wenjie2wang/splines2} \item Report bugs at \url{https://github.com/wenjie2wang/splines2/issues} } } \author{ \strong{Maintainer}: Wenjie Wang \email{wang@wwenjie.org} (\href{https://orcid.org/0000-0003-0363-3180}{ORCID}) Authors: \itemize{ \item Jun Yan (\href{https://orcid.org/0000-0003-4401-7296}{ORCID}) } } \keyword{internal} splines2/DESCRIPTION0000644000176200001440000000266114760246062013533 0ustar liggesusersPackage: splines2 Title: Regression Spline Functions and Classes Version: 0.5.4 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 functions of B-splines, M-splines, I-splines, convex splines (C-splines), periodic splines, natural cubic splines, generalized Bernstein polynomials, their derivatives, and integrals (except C-splines) by closed-form recursive formulas. It also contains a C++ head-only library integrated with Rcpp. See Wang and Yan (2021) for details. Imports: stats, graphics, Rcpp LinkingTo: Rcpp, RcppArmadillo Suggests: knitr, rmarkdown, tinytest, RcppArmadillo 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.3.2 NeedsCompilation: yes Packaged: 2025-02-28 02:29:56 UTC; wenjie Author: Wenjie Wang [aut, cre] (), Jun Yan [aut] () Maintainer: Wenjie Wang Repository: CRAN Date/Publication: 2025-02-28 05:40:02 UTC