# 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.Rmd 0000644 0001762 0000144 00000023070 14425773431 017617 0 ustar ligges users --- 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
Using splines2 with Rcpp
Wenjie Wang
2024-05-09
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:
For ease of demonstration, we assume the following using-directives:
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
BSplinefor B-splines;MSplinefor M-splines;ISplinefor I-splines;CSplinefor C-splines;NaturalSplineandNaturalSplineKfor natural cubic splines;PeriodicMSplinefor periodic M-splines;PeriodicBSplinefor 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).
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:
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.4 Function Members
The main methods are
basis()for spline basis matrixderivative()for derivatives of spline basisintegral()for integrals of spline basis (except for theCSplineclass)
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:
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:
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 functionsderivative()for the derivatives of basis functionsintegral()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.
# 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.Rmd 0000644 0001762 0000144 00000023070 14425773431 017331 0 ustar ligges users --- 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
A Short Introduction to splines2
Wenjie Wang
2024-05-09
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.
## [1] '0.5.2'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.
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).
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).
We may also obtain the derivatives easily by the deriv()
method as follows:
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.
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:
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.
We may still specify the argument derivs in
mSpline() or use the corresponding deriv()
method to obtain the derivatives when periodic = TRUE.
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.
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.
The corresponding M-spline basis matrix can be obtained easily as the
first derivatives of the I-splines by the deriv()
method.
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.
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.
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.
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).](data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAqAAAAGACAIAAAD9Gkc5AAAACXBIWXMAAA7DAAAOwwHHb6hkAAAgAElEQVR4nOzdZ0AUV9cH8DvbWXbpTUAsoNiwF+wo9hZbNJZoNPYYW2IvMSb2GJ8Ea6LGGo0pRhN7w4q9C4JiRelLWdg+M+8H8hqCCyy7M3Nnd8/vUwLLnSPw58zO3LmXoGkaAQAAAMCxCHAXAAAAAADmQYMHAAAAHBA0eAAAAMABQYMHAAAAHBA0eAAAAMABQYMHAAAAHBA0eAAAAMABQYMHAAAAHJAIdwH/sW3btqVLl+KuAgAHNGnSpM8++wx3Ff8BeQeAJUV551eDf/nyZa9evaZOnYq7EAAcyq5du54/f467ipIg7wCw4W3emWzwtCbjyaOE5BSVWmsQSJVeQaF16tb0lxMVGsTT07N69eoMVgUA8Pb2zsrKYnZMyDsA/PQ278w0eFPK6W/nLYj5/dprDVVsaXtCIA9sMWDa0pXTOlTi16UCAIDVIO8A2AUGckjnnf6sU88txqgxX+3q0ap+aKCXUiai9GpV6rOH107u2/hVj46vDl/5X0f3ip3aAwB4CPIOgL2wvcHTqkMx23N6b7m7f0hA8Uj7VaocWrd5p/c/7Dy56cDvDi3q8KE3JB4AOwd5B8Bu2P6YHJX1JtUUGtncz3ycCffmLeuSaW+yKJuPBADADfIOgN2wvcELKzds4HF398bYTNLMZ+n8mxu2XVDWiwgW2nwkAABukHcA7AYD9+Dlneat7Nl+dNeaf7fr2bV1RGigt0IqpA0FqtRnD6+eOnwmSdF/67aurrYfCACAHeQdAHvBxGRXYdXhe2/V3hezfvfff2868CJLQ9IIESJX3yp1mkZN2b7zk0ENveB8HgDHAHkHwE4w9DSL0LvJsMXbhi1GCNEmnUZHCmUuMhGsgwuAI4K8A2APmM8kIZK5Klzfpp0ueHLx6NELj9V02V8GALBDkHcAeIv19SioF/umvPclNf/mzS/qCxHS6XQdO3Y0GAxmX/z06dPw8PDFixeXNtqIESNiYmLc3d3ZKhcAO2Si6Zmq3LXenrgLgbwDwDrL8856gxcE9126I5SuF1J0hi+TyX788UedTmf2xePHjxeLxWWM9ubNm8uXL3fv3p2FSgGwV/FG43OjCXcVCEHeAWCf5XlnvcET7vW6D6lX/CN169Yt7cUKhaLs0Vq2bBkXFweBB6C4O3pjQ6kEdxUIQd4BYJ/lebezeTFFgcddBQD8csdgaCgp662wnYK8A/Auy/NuZw0+MjLy2rVrJGlujQ0AnNVdg4En7+CZBXkH4F2W593OGryXl1elSpXi4+NxFwIAX2SSpIaiQ0QOuIEb5B2AEiqUdyZ2k8v5c0qvpVfMz5P95yg1x+3aOTaMkdUviq7aRUREMDEYAHbPhNAwhStnO7tA3gHAqEJ5Z6DBE25tx80eov5iya67xprdPmgT9O5VAWHlABlTf4CKAj9u3DiGxgPAvlUSCie7Kzk7HOQdAIwqlHdGlqr1jugzY2tNY0Kj/zWavnFTZ3bvBbZs2fLbb79l9RAA2JF7BkN9CYc34CHvAOBTobwzdg9eGBbVvgoXK1DXrVs3LS0tKyuLg2MBwHNGmh6Vka2nuV44DvIOAPcqmnfmJtmJmi48d3VZW9bfSQgEgmbNml27do3tAwHAfwlGY4hIJCU4uwX//yDvAHCuonlncBa9UOkf5CVjbrzSwdOxABS5ozc2wvOAHOQdAK5VNO929phckcjISAg8AAihuwZDA0dc4qY4yDsARSqad7ts8K1atbp27ZrJxIvFtwHA6JbegOkdPHcg7wAUqWje7bLBe3h4hISE3Lt3D3chAOCUSpJG2jGXuCkO8g4AsirvdtngEUKtWrW6dOkS7ioAwOmO3jFXqH0X5B0AK/Jurw2+devWly9fxl0FADjVkojHuZWzIZtjgLwDYEXe7bXBt2rV6sKFC7irAACnaiIRp0vc4AN5B8CKvNtrg69RowZJkq9evcJdCAB46Gj6l4JC3FVwBPIOnJx1ebfXBo8QioyMhKt2wGnd0RsOabS4q+AO5B04M+vybscNHubdAGd2y2Bo5BzX54tA3oEzsy7vdtzgYd4NcGa39YbGzjGFvgjkHTgz6/Juxw2+SZMmiYmJBQUFuAsBgGsUQncNRid5Rq4I5B04LavzbscNXiqVNmjQAHahAE7osdHoIxB4Cew4vxUFeQdOy+q82/cfiNatW1+8eBF3FQBwzRlWqH0X5B04J6vzbvcNHubdACf0wGBs4pQNHvIOnJDVebfvBt+mTZsrV67ALhTA2Ux1V/aSu+CugmuQd+CcrM67fTd4Ly+vypUr3717F3chAHDKTyiUEATuKrgGeQfOyeq823eDRwi1bdsWbssBp3JJp9+ldpY17EqAvANnY0ve7b7Bt2nTBgIPnMoprY7GXQMukHfgbGzJuyM0eNiFAjiVG3q9E86wKwJ5B87GlrzbfYOvUqWKVCp9/Pgx7kIA4EI+RaWayFoSMe5C8IC8A6diY97tvsEjuGoHnMlNvaGBVCLEXQZGkHfgPGzMOzR4AOzJTb2hqbNeny8CeQfOw8a8O0iDh9tywEncdLI9Zt4FeQfOw8a8O0KDr1u3rkqlSktLw10IAKzT0XQDZ9ol9l2Qd+A8bMy7IzR4gUDQunVrOKkHzuBAgK/M+Za4KQ7yDpyHjXl3hAaPEGrXrt358+dxVwEAuwy00z4A/x+Qd+AMbM+7gzT49u3bQ+CBw5uYpbpjMOCuAj/IO3AGtufdQRp8o0aNXrx4kZ2djbsQANhipOl7BkOYyEmfgC8O8g4cHiN5d5AGLxQKW7ZsCQ/PAAd232CsKhIpBE59A74I5B04PEby7iANHsFtOeDobugNzaRS3FXwBeQdODZG8g4NHgD74MxL0L8L8g4cGyN5d5wG36xZs8TExLy8PNyFAMA8EqE7BiM0+Lcg78CBMZV3x2nwEomkWbNmcXFxuAsBgHkJBmOgUOghcJzA2gjyDhwYU3l3qL8XcNUOOCoJgT5UuuKugl8g78BRMZV3h2rw7du3j42NxV0FAMyrKRYPcJXjroJfIO/AUTGVd4dq8JGRkffv31er1bgLAYBJFEKXdXrcVfAO5B04JAbz7lANXiaTNWnS5PLly7gLAYBJCQbjqtx83FXwDuQdOCQG8+5QDR4hFBUVBVftgIO5qtc7+R7wpYG8A8fDYN4drcF36NABAg8czDW9obkMlrgxA/IOHA+DeWeowdN5CUe3rVmyeOW22Jd6hLQJe2d0r185oHLdNn2n/ngjl7stsCIjIx8+fAi35YDDIBG6rTc049U7eMg7AOxgNu8iBsagXu4bGT16zzPk5kqrl8Yc+Wau69oZR3z6fDCymunRsZ0TO91RXz41ow4ne2RIpdKmTZteunSpW7duXBwPAJbFG4wBQqEnf56Ah7wDwBpm887AKLrYlbN+FQ77PTknN0/16MdWVz/79EDVFRcu/xqzctXGg9fOLKp545v/ndHafiALwW054Eiu6fUtZDx6+w55B4A9zObd9gZPvrx+Izti5Iw+VaQIudQYNmVgiKzZoEE1/ylRVn/wgHp5d++8Im0+koWioqLOnj3L1dEAYNdNfu0xA3kHgEXM5t32Bk9IXWR0fk4eVfS/hrzcQqpAXfjvbTiD3oBkLlLONrmMjIx89OhRfj48VgQcwcdKRVsezbCDvAPAImbzbnuDFwR36l7v1Y9TP/vp9JW4Yxs+mfOHRvxw85JfnuoQQnTBw80LNsaHRrUL4uwWYtEi1RcuXODqgACwqIlUIiP4swc85B0AFjGbdwYm2QnrTP1p3YP3p37cKYYmRAGdV5/ZLpjXbUSd4IU1/MmUJ69Mtaf/Oa0BE7P5LFZ01a5nz55cHhQAxp3S6twFAl5NoYe8A8ASxvPOSA5d6o7efW/g8oSEV6ZK9RuGKAh0MC7sh81/3M5Rvj+506DhPWopuX0HEh0d/cknn3B6SABY8HNB4QgF3/aYgbwDwArG887YibbIrXJEi8r//3/ysB7TVvdgauwKa9as2bNnz7Kysnx8fLAVAYBtDDR9T29o6u2FuxAzIO8AMIuNvLN+JY16unXEsC306F07x4YJEaJp+ueffy4sLDT74tTUVC8vBv55IpGodevWsbGxAwcOtH00ALC4bTCEicUKAX9uwJcP8g6AddjIO+sNniZ16txcSvfPUzMGgyEuLs5oNJp9sVqtlsuZ2ROzY8eOZ86cgcAD+3VVZ2jJo/nzFoG8A2AdNvLOeoMX1vjkYMK/t8ekUum6detKe3FiYiJTx42Ojv7hhx+YGg0A7l3R66e4KXFXUTGQdwCsw0beebP+JdPq16+vUqlSUlJwFwKANQppOslgbMin+fN8BnkHdo2lvDP1Dp7OTzzxy76/Ym8+TE5RqbUGgVTpFRRar3mHPkOGdKnJ8aRahBAiCCIqKurMmTMjRozg/OAA2CrZaGzIryfgi4O8A8AklvLOxDt4Ou/Kii61Irp/GnPyqcE7rGGLdh06tGoS7ke/it04rUe9Wt1WX1Nzt7/Uvzp27AhrWAI7VV8i2ejDx/nzkHcAGMdS3hl4B2+8uerjxfGNl1/YOqW1f4ktpMicOz9Nfn/qqOVRd5Y142R7qWKio6OXLVvG8UEBYIqYl2/fIe8AsIGNvNv+Dp56EXv2ed1JK6e9k3aEkNCz4cdrZ7V5GXvuBWXzkSqqRo0aBEEwOJEHAG6oKOq9tEzcVZgFeQeAYezlnYHNZuQKOcrNyDaU8nkyOyuHdpG72Hwga3Tq1OnUqVNYDg2A1a7o9MEiIe4qzIK8A8Aw9vLOQIMP6DU8Om/zh/3n777wRGUodvPNlPf86m/LhvZf9rTDsF6VsMzXh8ADe3RZp2/F0yfgIe8AMIy9vDNwD14QPHLbH+njxi0d2X4ZLXDx8PFSSIW0oSAnK0dDCtxq9//i4IZRIXiex+vcufPEiRONRqNYzPUdQQCsdkWvH61U4K7CPMg7AMxiL++MPCZH+LSb/Uf8Jy+ux56/Gf/sjUqtI4UypXdQ9bpN27VrEqLA97C9j49P1apVb9y40bJlS2xFAFARz00mE42qizndkK0iIO8AMIbVvDM3qEBRpUWvD1v0YmxAhnTu3PnkyZMQeGAvLuv0rXl6fb4YyDsATGA17w67kt1bcFsO2JfLOr3dLUHPH5B3YF9YzbvjN/h27drduXMnPz8fdyEAWKSqSNQGGry1IO/AvrCad8dv8C4uLs2aNTt//jzuQgCwyOcebh4Cxw8mSyDvwL6wmnen+DvSuXNnuGoH7MIToymf4n6RGIcCeQf2gu28O0WD79Kly4kTJ3BXAUD5FufkJpSyezqwEOQd2Au28+4UDb5Ro0Yqlerly5e4CwGgLAUUnWg0NpDAFrE2gbwDu8BB3p2iwRME0alTp5MnT+IuBICyXNHrG0l4u0Ws3YC8A7vAQd6dosEjhLp06XL8+HHcVQBQlos6XRuZDHcVjgDyDviPg7w7UYM/ffo0SZK4CwGgVPaxxI09gLwD/uMg787S4AMCAipXrnz9+nXchQBg3nOTyUijUP6uUGtPIO+A57jJu7M0eIRQ165d4aod4K0r8PadUZB3wGfc5B0aPAC80FYmm+SmxF2F44C8Az7jJu9O1ODbtGkTHx+vUqlwFwKAGUEiYaBIiLsKxwF5B3zGTd6dqMFLJJI2bdqcPn0adyEAlPTIaNxTUIi7CocCeQe8xVnenajBI4S6det27Ngx3FUAUNLfhdpcWKGWaZB3wE+c5d25GnzPnj2PHDlC0zTuQgD4j/M6XVuYYcc0yDvgJ87y7lwNvlq1am5ubnfv3sVdCAD/SiPJbJKqByvUMg3yDniIy7w7V4NHCPXo0ePIkSO4qwDgX+e1+jYyqdNFkROQd8A3XObd6f6qdO/e/ejRo7irAOBf53W6ti6wQi0rIO+Ab7jMu9M1+Pbt29+/fx8engE8YaLp63pDSyncgGcF5B3wCsd5d7oGL5VK27Rpc+rUKdyFAIAQQq9JsrZY7C10uiRyA/IOeIXjvDvjnxW4agf4o4pItN3PG3cVjgzyDviD47w7Y4Pv0aPHsWPH4OEZwAd6+D1kGeQd8AfHeXfGBl+tWjVPT88bN27gLgQ4u9cmckB6Ju4qHBzkHfAE93l3xgaPEOrVq9fhw4dxVwGc3VmdrgE8/s4+yDvgA+7z7qQNvmfPnhB4gN05ra49PCDHPsg74APu8+6kDb5NmzbPnj17/fo17kKA89LS9B2DAfaA5wDkHWCHJe9O2uCFQmHnzp1hIwqA0WWdvr5E4koQuAtxfJB3gB2WvDtpg0dw1Q7gFqvVtZfB9XmOQN4BXljy7rwNvkePHmfOnNHpdLgLAc6IRuiCTt/eBa7PcwTyDjDClXfnbfBeXl716tU7f/487kKAkxqmcK0iEuGuwllA3gFeWPLuvA0eIdSrV6+///4bdxXAGREIjXVT4K7CuUDeAS648u7UDb53796HDh3CXQVwRr8WaijcNTgbyDvABVfenbrB161bVyKR3Lt3D3chwLlkkOS3ufmwdCrHIO8AC4x5d+oGj+CkHuBwRqtr5yIV4i7DCUHeAfcw5h0aPAQecO2sVt8RHpDDAfIOuIcx787e4Nu2bfvs2bOUlBTchQBnoaHp2wZDG1ihFgfIO+AY3rw7e4MXCoXdunWDFTAAZy7q9A0lYljADgvIO+AY3rwz1eCpvMdnfz312IgQQojOe3jgf/MmjRg2evqXm44nFzJ0DJb06dPnr7/+wl0FcBZntboOdv/2HfIOgEXw5p2JBk9nn13Qvkad6JEbb+oRorNPTGvdfOCcH07GP71/eN20Ho3bz4nN4fGM4e7du1+8eFGtVuMuBDiFG3q9fTd4yDsAFsObdwYavP7Cko9XPWm85OSjXYMViHywfvbmzOiYWy8e34i7nvT89sbo1P99uvaOyfYDsUShUERGRp44cQJ3IcAp/ObvGyC04xn0kHcALIc377Y3ePJ53JW0upO+mRUdIicQUt++nuT7/vSxdVwRQgi51v7460n1np6JfcXnZT369u174MAB3FUAp+AusOuJL5B3ACoAb95tP7bAw8dLoFbl/HPKLnX3cBEQRPFLdARCiObxNTuE+vXrd+TIEYPBgLsQ4OAGpWeqKT73vnJB3gGwFPa8297gCb+eI7qrfxg7esPlVD1CsqgPB4n3r9j4oGiqjebRTwvXP6gW1T6Ez29b/P39a9WqFRsbi7sQ4MjiDcY8ilba9zt4yDsAFuFD3hnY3IYI+GDj/ifDhs9oEzIvJKJRveqe/tKzM5qH/di4lntuwu0k1HLxgZmN+b5rVr9+/Q4cONClSxfchQCHdUqr62zX0+sQQpB3ACzDh7wzcnJB+LRfePzx40t7vhweGSTKy6IDIhrWreol96jZbeauaw9PzGvpzvuHfvv16/fnn39S9n35FPDaKa22s9zuGzzkHQBL8CHvzJ1oyyq3HDS15SDGxuNYWFiYj4/PtWvXIiMjcdcCHNBLkymHoiIkEtyFMATyDkDpeJJ31m8PUOmn/zdnztqTqfw/VS66aoe7CuCYTmp1nV1c+HxnmhGQdwAQb/LOegF0VtzOb9fsuJxZNK1Wp9NVrlzZqxSXLl3KyMhgu6TSwMMzgD2ntbpo3DfkOAB5BwDxJu+sz4URhk89/nw0UvoVPeovk8ni4+NNJvPrYPTu3VskwjY9p3HjxiRJ3r17t0GDBrhqAI6qgUTSQuoo1+dLB3kHAPEm7+ynS6T0DVQW/4BSqSz1tfjSXqR///6///47BB4wbraHG+4SOAF5B4A3eWcuYKacpEunz918mJyiUmsNAqnSKyi0XvOo6FbhXmLGDsK2AQMGfPTRR0uWLMFdCHAo57S6ti4y7DfkmAR5B6AU/Mk7Iw2eSj/19ejxK48+1QrlXv7+XkqZiNKrVenp2RqTvHrPOT9undfBjw//2nK1aNFCq9XGx8fXqVMHdy3AQWST1CxV7sVAf4GDbBELeQegVLzKOwMxpF5sGfn+8sQG83+/mZKnzkp5mpQQH5+Y/CpTnZ927/DS1i9WDxy55Tn/J9UihBBBEP369fv9999xFwIcxwmttr1MKuZB2hkBeQegDLzKu+0Nnnrz974LPhO3753Xr3GgvPh4hMyvXvep236dF3Zh3+E39pF4hAYMGACBBww6odV1kbvgroIpkHcAysKrvDOxXaxOjxSeHqVd7Bd4eHkQOp3e9gNxo3Xr1pmZmYmJibgLAY4gh6IeGAxtZFLchTAG8g5AafiWdwZ2k6sS3aXGo/XTl518oX1nCyl92uV1k5dfrBYdxevNJ4oTCATwgCxgyhmtro1MJuPH9TomQN4BKBXf8s7AJDtRw8+2LrvWb27X0NVBdRvWCw30VkiFtKFAlfos/s6DF7rAXqv+mNPEfmbWIjRo0KDp06fPmTMHdyHA7h3RaAcrXHFXwSTIOwCl4VveGTnPVjSZ/ndC/Jlt8wc3DSByU54kPIx//CoH+Td+f/622MSEQ1Ma8+hfbIG2bdump6c/fvwYdyHAvulo+qHB2I431+sYAnkHwAwe5p2p5+AJ1+pRI2ZHjWBoOLwEAsGAAQP2798/f/583LUAOyYjiL8CfPlzvY45kHcASuJh3u3lThnXBg8evH//ftxVALvnKxTiLgGUD/IOGMG3vEODN69Vq1a5ubnx8fG4CwH2KpukRmRk4a4CWATyDmzEz7xDgzePIIgBAwb8+uuvuAsB9uqYVhuIe611YCHIO7ARP/MODb5UgwcP3rdvH+4qgL06qtH2kOPfLxJYCPIObMHPvEODL1Xz5s11Ot39+/dxFwLsTzpJJhtNLaU8mk8LygZ5B1bjbd6hwZeKIIjBgwfv3bsXdyHA/hzWaDu7yHiyHjWwBOQdWI23eYcGX5YhQ4bs2bOHpt9ZsQuAMh3WaHu68mU9amAhyDuwDm/zDg2+LA0aNHBzc4uLi8NdCLAnT42mTJJqyr/rdaBskHdgBT7nHRp8OT744AO4agcqhEZolocbv56HBZaBvIOK4nPeocGXY8iQIfv37zeZTLgLAXYjVCzqxZv9IkGFQN5BRfE579Dgy1G9evXq1aufOnUKdyHAPqSR5BX72SwVlAB5BxXC87xDgy/fkCFD4KodsNAOdeF1vQF3FcB6kHdgOZ7nHRp8+QYPHvzXX39pNBrchQC+IxE6otH24uV8WmAhyDuwEP/zDg2+fP7+/pGRkQcPHsRdCOC7Kzp9gFBYjX8rVgLLQd6Bhfifd2jwFvnwww937dqFuwrAd4c0mt48Pp0HFoK8A0vwP+/Q4C3St2/fa9eupaWl4S4E8JeWps9q9d1deB14YAnIOyiXXeQdGrxFXFxcevfuDXtRgDKc1OqaSCXeQsiU3YO8g3LZRd55XRyvfPjhh7t378ZdBeCvSzrdAFc57ioAMyDvoGx2kXdo8JaKiorKyMh48OAB7kIAT33t6dHJhXf7RQLrQN5B2ewi79DgLSUQCIYOHQon9cAsA03zcC8pYDXIOyiDveQdGnwFjBo1avfu3SRJ4i4E8M7g9KxkI6xv6lAg76A09pJ3aPAVEB4eHhwcfOLECdyFAH65bzAW0FR1MX8fhwVWgLwDs+wo79DgK2bkyJE7duzAXQXglwOFmv6ucju4YAcqCPIO3mVHeYcGXzFDhw49fvx4dnY27kIAXxhp+rhG25f382mBFSDvoAT7yjs0+Ipxd3fv1q3bL7/8grsQwBentLpwibiSkJ/7QQObQN5BCfaVd2jwFQZX7UBxfxZq+tnJ6TywAuQdFGdfeYcGX2GdO3d+8+YNPCALEEKZJHnXYOzM+8dhgdUg7+Atu8s7NPgKEwqFH3300bZt23AXAvBzFQi+8/GU2cMTscA6kHfwlt3lHRq8NUaPHr179269Xo+7EICZnCBaSKW4qwDsgryDInaXd2jw1qhWrVqDBg3+/PNP3IUAnB4YjDvUBbirAKyDvANkn3mHBm+ljz/+eOvWrbirADhtVxfYxXKVwHaQd2CPeYcGb6X+/fvfvXs3OTkZdyEAjzyKOq/T95LzejdowBTIu5Oz07xDg7eSRCIZOnQoPD/jtA4WajvIpG4CSJBTgLw7OTvNu52VyytjxozZtm2byWQHWw4Axv1WWDhAYTePwwLbQd6dmZ3mHRq89erWrVu1atW///4bdyGAazf1BhKhZnY1nxbYCPLutOw379DgbTJ+/PjNmzfjrgJwbX9B4WBXVzubbwNsBnl3Tvabd2jwNhk0aNCtW7eePHmCuxDAKQ+hoK+rnU23AbaDvDsn+807NHibSKXS4cOHwypXzmauh7vdTbcBtoO8Oyf7zTt7RdP5ibF/X3qmZe0APDFx4sStW7fCKldOgkbosMbhf6mtAHkHDsje885eg6ee75s2eP7fmRRrR+CHsLCwevXqwSpXTuKqTv9jvp2tZsUJyDtwQPaedxEDYxivrZsQc9VQ4qN07r2XhvRd00Zec0XCkP5ffdWvsl1e47DAxIkTY2JiBg8ejLsQwLqfCwo/sMOnZZgEeYe8Ow17zzsTDZ6QkS9O/3ImTRhQp0EV5duphhqVgdZmvngilCARoTLQDByJp/r27Tt9+vR79+7Vr1/fwi+hTSQhErJaFbCQzkQLBUgsKH+SbAZJXtMblnt7clAVf0HeIe/2zKnyzkSDF9Wfevx2w2/GjlqREDhw06ZpbfyECCHy3pdNWp79+MCZT0Mc9Uz+/4lEonHjxm3YsGHTpk0lPkUbTfpHydoHScaUNFNqpv+XU4RKBUIoc+02zdW7AheZKMBHHFzJZ8IQQirBUbsTMVL0o2xTHR+xkEDzzuXFvtQfHeTjLhXMOJ17+oVOQBCVFMLa3qJvOnq4iMyHf2+Bpo+ri6u9rUfNMMg75N0eQN4RMw0eIST0bz/74M3oTZ+O7N3o8MTN277oVZWhke3EhAkTwsPDly9f7un5n9M91fY/DM9TXOqHK9o2E1cJKko7Qshv5hqpa/kAACAASURBVFiEEFWoNaZlkqpcQvzPt0u19Vdx1SB58/pvXwlsVGikTzzTHXuqi3utD/UUbe7m5ScXTGumnBOpdJMKEEIbunoihPQk/UZNvlKTUiGBEOr/R1YlhXB9l39/mkaa/q2wcIevD65/CI9A3iHvfAV5L47BWBKeTSfuvtp+98wRHzU98f7aLcMd+CLdO3x9fbt3775jx46pn3yiPnFJElJJFhGOEPIeO6iMrxK4ukhDQ1BoyNuPyOrXKrxwPWfnny4Na7n1jpaGVWG9dEf3S4Lm6htDt+qy1R3cixKOEPKTl3ybKRUS1TxE1Tz+ScTu3t6Pc0wIoVw9dTBJ+34t+WmjrqZYXF3sXJ2sdJB3yDsfQd6LY7p6RZ3hGy+17r5o1Ph27xlpsh7Dw/PZpIkTf5v5xeuELEloiLyplf9yebMIebMISqsrPHdNH/8EAm+dNwXkpydyoqvKJjVWjK7vOrq+a0VHkIuJBn5ihJCIIO5mGDfcyqjWWjghSMlCsfYM8g555wHIe2nYOD2RVuuz8lSz7ptjDj0PbKi04/sXFRN25nYX76AnbepFffiBjUMJXGTKbu3e/q/25gPaaJK3aIDs+W4QN17lk5XdhK5i4tOmynaVGVg7WiEhvo32SFKZlsflr7mjjugp9nZx9JvMFQN5h7xjA3kvG1vXH0SVoj5ZFoUQQrRRpzEisYtM7OC/rJ4j+2dWcdv78w7bA1+CwMMte/PevEOnvT7qL61ZjdnBHUZCtnF5nDpbSx1+38ddKogKYXJnCLEb+qmn17mXelkp83GcHOSdQZB3S0DeLcH6DQYyfmWrRl9S82/e/KK+ECGSJL///nuDoeRTtEVevXrl5eXFdkkMonR6Y0pa0YU1SZWgD4YMmTN3bkJCQu3atRk8ijQ0JHDlrILz1zLXbHVt29RzeF8GB3cAGhO99pr60GPtlKbKD2oz/9BqJkkOSc86H+jfPkSKEEpSmdbdVH/Vzt1dasen9iyBvNsO8l42yLvlWG/whGejfqM/pht7FZ0IURSVl5en0+nMvthoNNK03czVMWVkpy/f5Nqiwds7ZxKJZPz48d9///3GjRsZPhhBKNq3kDdvYHj+muGR7d/ddKPORB8b7OspYyWBews0veUukv+/XhrqKarqIbqbYWTkkqCDgbwzA/JeOsi75QheBSwqKgohFBsbi7kOCxhfpaZ/vd69X5fiN88QQpmZmbVq1UpKSvL29ma1AN3Dx5IqQQJ7XmXJRoVGen+CZkSEq5DNq2gGmo5OTd/p51NNVPJs2EShTA1ZSWEHC5isW7cuMTExJiYGdyH/AXm3HOQd8m65t3ln/AzIpM3PyUxPz87VGHl05sAwMk+d9mWM54d9S6QdIeTr69unT5+tW7eyXYP+0dPXM5bp7ieyfSDe+upS/uMcE9u3yP7SaOtJJO+mHSH0poB87/esSynOvO8I5B3yzhHIuxUYavDG9Lhtc4d1qBfkLnf18PILCPDxVMjdAut2GDpv25V0EzMH4Q+h0jVg8RTXNk3Nfnbq1KkxMTFGo5HVGtwHdPX9dERmzK7cfYcR5ehbfBRDI5ReSCKEVkS5L2vvbsGKkzYda4e64EOF+aduQtyEG7p6Tj+de+W1+XvMDgvyXgzknVWQd1sw0eBNT7a937jdxG3xylYj5n77w/Y9+3755eedP/5v4ej23k93Tm7XdPBPyQ6WeYFAHBxQ2icbNmwYHh6+b98+tquQRdQMXDVbn/xCezue7WPxhNpATziWs/SympvDXdDpCUS0lJV6761pgCSms+eUUzkJ2ez+fecRyPt/Qd7ZA3m3FW0z9V8f+bs2nXdRRZn7bMG9NZ28Az76S23JUO3bt2/fvr3tJbHEmKlKX7aRpsz+Q//jyJEjERERlAWvBJZ7rDJG/5yx+EKekeToiNOzVIcKNeW+7NxLXVyKnoN6rBYTEzN58mRGhoK8vwvyzgbIu9Xe5t32d/Dk6wcP1Q0+GN3S0+y1E9eIMSPbFMQ/fE3afCS8aL0hY8Vmad0alqw+0b17d4FAcOrUKQ4Ke8vw/HVh3G0uj8ilZ7mmIYeyP2mi+KKNm4irx1WWeHr0lruU+7J2laWRQRIDSRtIx70R/Q/IuxmQd8ZB3hlh+3dO4BsSLH588VKq+dtCtOryhfvCSkE+9vcIYXE0nbVht6RqkHufaAu/YurUqWvWrGG1qBIEclnOnoM5Px9CTD8ZkapLeVyYgBDSU7q1T5dsefld0X/PShi/6cU3Rf+97VXMmayjzB63uECl8Le+3v1qlh8/phRQtKIid/wOJGnHH8uh+B55G0HezYO8MwvyzgjbY0h49Zk+1v/4uMioMV9tOXDm6r1HT54+e5aceP967KHtKyd3bz5wl3zM9D5edr0gUMG5a6b0bO/xFViyaujQoffv37937x57VZUg8vOutPxzfUJyxpqttMHWW0SvtM/PZZ9ACJE0uT1l/a28KwghiUDay//9AZWGI4SkAtmiGt8MDxpX9PEIZWMviQ9CKN+UO/nBsL1vmJlXbKLQlxfzb6QZpEKiijt3Gz+kkWTPtIwKfcnAWvL6fmL+n9TbBvJuHuTd1n8PQgjyzjhGrvibUs/9b0z76m4lHlAkRO6hHcevv5Rh6S0U3t6TI9WFpAX3ZkpYsWLF8OHD2ainDJTBmPnd9pxfj1r35a+1Lymaoml6w/NVB9P2WTeIjtTmGLJpmn6meTLlwYfns09aNw5N03fSDZ+eUBUaub67uSwnd1VOHscHZQ+D9+BpyHspIO+Qd554m3dGF7ox5L16kvjsjUqtI4UypXdQ9Zphwe7iCgxgRwtfWCI/Pz8sLOzatWtVq1bFXYtFdqRsSCqInx221E3kztSYKmMWTdPeEt87+ddSdC87+/SSCmSWfKHGREsEBGe334rLo6huqRkHA3z9hBVe1IKiUa9fM7f19Apw5dGCGKwsdAN5/y/IO4K88wM7C91I3CvXad6uU7eevXp269SuWe2KpZ2f1Ccu0qSVE4bc3NzGjBnD8Z254qgCjSlTVfZrCkz5e99svZd/AyE0NGjM0lrrGEw7QshL7OMt8UUIBcuq5hpV6fo3lnxViprs/WtW3Gs8a0rsUhd2kcusSDtCSECgPjVcPjuTy/ObcwyAvP8X5B1B3nnGvqfCsK3gdJz6xEXChk0bp02btmfPnrS0NAarspwhJTV17jf6Jy/KeE2mIV0qkFWX10QIiQkJe8X4SPyGB40LcamOEFr2ZM6ulE2lvTI51zTkYPawuvK2OBZ/1tL0vsLC0UqF1SOMa6ggEPrxTgGDVQEOQN4ZBHnnA2jwpTJl5eTsPug77SMksP675OfnN2TIkHXr1jFYmOVktUJ9Jg7NWL5J9yCpxKcOZ/z2TfIihFA1eY3+AcMUIjcuC5tebVFdZUOEEEVTJvo/84MSVaZhh7I/b6EcXd/8elJs+6WgsLlUWsXcWpUWEhBodQePLfcK3xTY+8NiTgTyzh7IOy7Q4Eul+vEXZc+oMlawstDnn3++efPmvLw8RqqqKJcm9Xw/G5259id94tPiH3cVKkeHTMFSEkLIRShv7B6JEEoqfPh5/NikwodvP1VooFZ38HivBnePx5Swr0Az1obT+SKVFMJ973n7yiFfdgPyzmJVkHdMeFcQT9B6AyGVuPftbPtQ1apV69Gjx/r1620fyjqyOjX8F04WKBX5ptzvny29nnsJIRTl3dVL7IOrpLdqKSJmh37tKwlACCWpTIVGunGABMuVurd2+nnXljBwMznUQyQWELl6J1o23H5B3rkBeecYNHjzCKnEd8ZoQsTMxMiFCxd+9913ajVHKyq/S1I1SBzoV2BS11M2auIeiasMsyrJgj3F3gnZxn5/Pj+QchpvMQaatm6ujVn5eqrzvsy0Qt5duAMlQN45A3nnEjR4LoSFhXXs2HHTplKnmbAqx5i9I2WDjtIGyio3u6HQ3eDjThX+cuH2Xu41PHGey/9ZqFmUw+SVVTepYFYLZZaGXyf1gG2Q93JB3rkBDb4k46tU1c4DjA+7cOHCtWvXajQaxkcu1+Wcs94Sv6KnUaW1qmdv3qu5zt16W+W6nW58lG30chE08/Nt4dEWIXQi89CVnHMcl0EitDm/YKCrnNlh368lr+dr/0+POS7IO8cg71yCBl+S6qffxH7ejA9bp06dVq1a/fDDD4yPXBqSJosWlO7pN7CX30ACEQghSdVg/3kTszfv1d56WN4AXLiRZhh/TKX/7zWtusqGl3LOlphty7bDGq2vUNBUyvyDQzoTveB8Hj8fkwWQdy5B3jkGDf4/NNfvm3LyFZ3bsDH4woULV69ezdlJ/aYX38RmH3v345Lqlf3mTMjasJvS6rippDTxWcZPjues7uDRwO8/57xBspDPqi8WEeJcoyrXWM7CHYwgEdqYp/7EXcnG4DIRkZxj+i0Rw5s5UDbIO5cg79yDBv8v2kTm7PzD66P+hJCVb0uDBg1atWq1ceNGNgZ/V/9Kw8aETDP7KWlYleCNSwQuFi0hyZLXanLUYdXKDh7tQ0q9D/dcm/xl0mc5xmy2izlUqPEWClpI2bojOL+V29pr6kIjP87qAUII8s4tyDsW0OD/Rev0rm2buTSozd4hFi9evGrVKlan197Iu1y0s1MlaXDRZTqzCDHmG0WeMsHWHl5RpacdIdTQrdnM0CVKlhflMNH0pvyCqe4sHqWer7h1sHTr3UL2DgEqCvLOJcg7FtDg/yVQyD0G9WD1EHXr1u3YseOGDRvYO8TN3Lg2XpZuYk2byJRJXxheWrReNFNeq8k7GUa5mLBkNkqgrLKIECcU3PszbS+NWDkjPqfTVxYJm7FwN664qc2UGhOPptcCyDs3IO8YQYPn2pIlS9auXZufn8/ssBRNFV3aGl/ls8qyqhZ+FSESeg57L/3rDca0TGbrKQ2N0Ii/Vc9yTRX6qiouoS+0ySm6shbZtlp7mTTGx4uNkYurrBTOieR0fVDAB5B3yDtG0OARQojS6rLW7+bmWDVq1OjatevatWuZHfaHl98eSv/Fii90bd3YY1D39K/WkyouFtckENrU1bNfzYqtTCkXuk6ttqCyrCpFUyTN5DoSeRQlJAgXG/YXqZA/k7Q5Ovzn9U4O8g55Z3DMMmDPOzR4hBDKPxxLm7hbfujLL7+MiYnJyMhgcMzmHm2HBY2z7muVnVq7dW1bcO4qg/W8S2Oi9yVoEEI1vKzf1+FmXtxXj2dqSGZubmlpuk9aZrq124Na4WGW8Yc7+O/MOTnIO+SdG9jzDg0eUTq9+kgs23fjiqtateqQIUNWrlxp+1AFJnXRWtON3VuICOuD5NYn2r1fF9vrKY2Roj85nhOfZeujrs08Wnf06W6kDIxUtUNd0FwqCWBurcpyTW+mHBCObV8NgCDvCCHIO1ew5x0aPCo4cVEWUVNcyZfLgy5atGjXrl0vX760cZxNL1an6V8zUlIRSqtDFMPXlGiE5p3LkwiJL1q72z5aO6/O7mLPTEO6jY/T5FPUbnXhp+w8C1sauZgI87T+7zKwHeS9OMg7q7DnHRo8MuXmuw/oxvFBfX19x48f/+WXX9o4zoQqn/f2H8RISUXy/jiRGbML0UzOX/32mjoln/y+sweDzxu/1D5d9mSOjtJaPcIP+QVd5C4hNuwDbR0aoV6/ZqkN+J+RdU6Q9+Ig72zDm3do8MhrRD9JSCD3x/38888PHz788KE1S0jmGXN+fv0jQkjB9DOjHu93J7NzVDuYXJ27dZD0h+5eUiGTE1uauLecUOVzCWHlUhVpJPl7oWaCm637QFuBQKiWt2j3Q7gTjwfkvTjIO9vw5h0aPDbu7u5z586dPXu2FV/7Z/peDzHzC2gjhAiJ2G/uBN2DpLyDp2wf7W6G0UjRkUESpYT5aauh8nABIbiZF5dlqPD0pf/lqYcoXBncKbJCxjdU7LhfqDPBm3gnAnm3EeTdCk7d4PVPXuiTnmEsYNKkSUlJSadOVThaI4Mn9fDrz0ZJCCGBi8x/3gT9o2QbL9xdTzVMOKZS69n9tdaSmu+efV2hL9HRdLzB8DGO0/kiNbxEDfwkvyVaf70RWAHybhbknW0Y8+7UDV710+9kDsMLUFSIWCxetmzZ559/Tlk2z0VLar5/tizflMt2YUIvD7/Z45FtT4sGKoQ7e3l7ubD7O9bGK3p2aMUCLyOIQwF+rlw9C2vWjOZKdynOApwQ5L00kHe24cq78zZ4ffJLUpUrbxaBt4wBAwbI5fI9e/ZY8uJ76psB0kA3kQfbVb1FkxSZV+GVtFMLyFf5ZJBSaMsjsJYrujF5MH1fIVlQ7otfmExcPghbmnAvUe8weF6OO5B3S0DeWYIr787b4NVHYpXd2iEB5u8AQRBr1qyZP39+YWH5szBaeLQdFPgR+0X9y5iS+mbmSlNGBR5QydZSw/5S3c/kdHdnhJCRMvyWurPs15AIfZKlemys2MKZLNEY6Z/jebGnpDOAvFsC8s4eLHl30gZPk5T2ToIyuhXuQhBCqGXLlm3btl21alVpL6ARvSNlw628K1xWVURSJcijf5f0pRsotUWzQDUmesxR1Xs1ZD1Cud6bcmClEcOCxpb9mp/Vhb5CYRsZW9tEVohQgL67rn6lxv/2wuFB3i0EeWcPlrw7aYMnhILgTUsECjnuQv6xatWqDRs2PH/+3Oxn8425GrKwnrIxt0X9Q9mtnbxZRPrKzbShnJN0GqEpJ3PCvcRTmnK6msRbIkKsMmYdSPvZ7D5U+RS1Wa2e64F/B4giUiGxo5eXv9xJM8glyLvlIO8swZJ35/3jgn2D5OKCgoImT548Z84cs591F3tOrDJTImB3f8MyeA57T1I12JiSVvbLjCQd4Ste2s4d42wWpcgtoeDe/fyb737quzx1NxeXmnz6udfyFksYfVwYlAbybjnIO0u4z7szNniqUEPz465McTNnzoyLi7tw4ULxD17PvbTl5Xe4SvoXQXiPGSSpXrmMl+hJWiIkpjZVMrh8lRXEhGRe2Ir6bk1LfPyx0XRco53M7UKVlth2r/DgY3hejkWQ9wqDvLOG47w7Y4PPXPuT9m4C7ipKksvlq1evnjRpktH475Wx+IK7Xf3ew1jVu8zuMnnwsXbYIZtWimbc1dwL99W33v7v1zl5n7grPXDPsXpXuJdoy11Y1Y5FkHdbQN6ZxXHeeffvZ5spI9vw9JVLg9q4CzFj0KBBwcHBGzdufPuRkcGTKsuq4qvIjNSFawvjbpf4oNZEr+rA3cM8lvCXBu5M2Vh0c45EqJ5EPEjhirsoM1oGSdUGivtJyE4C8m4jyDuzOM670zV49anLru2aE2Ke7uj1/ffff/3118mvn3z1eKYlT3lyz2/mWNWW/fpHT4v+V0/SCKEPasure/DrW1rVJXRFrU0EIhBCQoRmerjhWaayPAICDa4tL9o5GzAO8m4jyDuzOM67czV4mqQKYq8oO/HiaRmzatSoMWrUqK+2LWro1sxViG1txTJIqgb5TBmZsWar8U1GeiHZaW9mci7vbnAWERJChNC012ev6Sq8dgeX3q8lZ3Q3L/APyLvtIO+M4zLvztXgCQJ5DntPHByAu5CyLFy48OyWS8oEP9yFlMqlQS3PD/tm30kcczRnZIRrKM/O5YtLNBovUlUTVEdxF1IWHxfBsvYM7JwNSoC8MwLyziwu8+5cDR4JBIr2zXEXUZaTWX9d1Z3buHHj+PHjdTod7nJKJWvTbDZVt2mAZEwDPt7oKkIhtFiVN9vLb1gltjbqYNDFFD3uEhwO5J0hkHfGcZN3J2vw/EYj+kbu5cbukT169KhTp87KlStxV1SqOxkGH7lgQWs3qkBj4yZU7NlXUCgk0EBXVxEheqFNvpV3FXdFpaIRmnU27ylfL34CNkDemQV5f5cTNXjNlTuamw9wV1EWAhFzw5Z7ir0RQuvXr1+/fn1CAu8e7ynSNECypqOHkEA5uw9mb/0VdzlmZJHUhjz1l54eRetKyAQuO1M25BlzMJdVCgKhr9q5uYhg0RvGQN4ZBHlnFmd5d6IGn/v7MYEE2+JQZSskCza/WFN8wcXAwMAFCxZMnDiR5tn58h+J2h+LPcfpObKf/lFy3p8V3uKabUtycgcpXEP/f/q0vzTw6/B17mJPvFWVIbqKrJKCnzN/7RLknRGQd5Zwk3dnafDGlDQyr0BWNwx3IebFZh/zkvgUPePx1uTJk0mS3LRpE66qzPotUdO56r+bNwhcZP7zJqmPny84fx1jVSXc1huemkwT3P4zLVkhUiKEruZeMNIGTHWV43Cy9rEKrtIzAPLOFMg7ezjIO0MNnlLdPfD9F1PHjJ4457tD8XlU8U89P/DFlKWHX1OlfjEXCmKvKKKaY98ssjQ9/Qa+X2lkiQ8KBIItW7YsXLjw2bNnWKoy6+c+3lXd/zONVujl7jd3gu7eI1wlvau+VLLPz1dCmLkC9kB9+49Ui3bj5l5aIbX1nj2sagd5tw3knVmQ99IwEQDq9W+jmrcYMDPmrytxB2Nm9G3SbMSe5LcL9VDpcXt/+PVGNt4LT/pHzxRRLbCWYN6tvKvFV1gsITw8fMaMGWPHjsV+4e61mhx7VFXaZyUhgT6TP+SynjLcMxiECCkE5u9vjQie0MG7G8clWahPmMvJZzqdiV8XaUuCvNsA8s44yHsZGGjw+ourZu7Vdt94++XTBwmvMx//Mdb1zwnDVt3h1UM/AV9PFwf6466iJBNt3Jmy0UvsU8ZrZs2apVKptm/fzlVRZuTpqdFHVG2Cy99WmTYaaT3OC2JntbpZ2bllvEBMSPyklfJNuan6FM6qspCvXFDfT3zqOX8fl0KQdxtA3hkHeS+b7Q2efHn1akbEpKVj6igQQoS8et81exY3jF85dWMSpzvb2yMRIV5d54cgWUhZrxGJdu/ePWfOnBcvXnBWWHF6kp5wLCcqRDoyovxHYLW3HqbOX0Np8bSoHIpanJP3tVf5q2RnGtJXJy8qMPFuxasB4S6xL3nVK0uAvFsP8s4syHu5bG/whFAoRP95NFJc59PvPw+/sXTG9uf8iLzZDZHwohF9KuswjWgxUf5E3zp16kyfPn306NFYLtxtuFXgKxfOjnSz5MXyFg2l4aGZq3+kTRh+9l/l5PWWuzSVlv8tDZWHjwmZJhGU/x6FY73CXJbyelU7yLs1IO9sgLyXy/YGLwhuEVnpwQ+Ldzz6d/l8aaNZP84PO//50MUXVLgzr70dn7V+F+Yi3nE668idvKslptGWYdasWUajcd26daxWZda4hoq10R6l3OEyw/vjgYRMmr1hN8cLYvyt0SYZjZbvAF1HUV8ikGQbMlmtygpSIZ+fhoe8WwPyzjjIuyUYuAcvaTlzzUj54TH1g8Oa91p5pWi2jazhzD0/vJfzbafazSYfSMM5YaTw0k2XJhEYCzAr0qPt5GpzLX+9QCDYunXrV1999egRd5NXDyRpn+SYXMWEsEK/JgKB77RRtNFE5nF3QSyNJFfk5q308pSZm0lbhg0vVl3OOctSVda5+sYw6ThPF+hAkHerQN6ZBXm3EBOz6AUB722+ev2PVeM7hXtL3w4orv7BtkuXd01p5q3083OT4nlehTaaNNfvu0Y2xHJ0s3KM2Wn6NwqRm0zgUqEvrFGjxtKlS4cOHWowcDGrJUll+vaa2rofHCER+372sdDDoqt8jJivyh2pUNSViCv6heNCprsI5GyUZLUIX3G+Ae9TZmWCvFcE5J0NkHcLEdifxyguKioKIRQbG8vUgJrr9/P/PhPw5VSmBrQRjegvk2Z08e3TyrODdSMMHjy4SpUqq1atYrawd9EIFRpohcTWy0ekKldowSwYG53R6qJcZFZ3FYqmEEICgqePTdtu3bp1iYmJMTExuAv5D8h7uSDvZkHey/Y276z/C6n00/+bM2ftydS3pygajSanFCYTw8v6CD3dPIb0YnZMWxCI6B8w3Oq0I4Q2bNiwb9++06dPM1hVCY+yjQeStARCtqed0unfzFqpi3/MSGFmFdI0jVBHG9KOELqSe27d8xXFlw7F7rUa991sq0Dei4O8Mw7yXiGsN3g6K27nt2t2XM4s+l7qdLoaNWqEluLq1avp6ekMHl0aVkVWK5TBAW1RNL+jvlsTWwbx9vbevn37yJEjmf1GvfUqnxx9JEdpc9SLCGRS32mjMtdsM7x4zciAJRRQdP+0zESjsfyXlqmFRzsfia+B4svzaSSNev+Wlavj8YX6UkDe34K8Mw7yXlGsN3hh+NTjz1+cnFGnaFl9mUz2+vVrVSlat27t78+75SkY8VL7bMnjz3SU1vahOnbsOHr06CFDhpAkwyd9Ki01+ohqQiPXTlVlTI0pq1fTa8ygjGUbTRnZTI351pKc3NYyaS1xhW/FlSAkhEODxkoFjP2rbSQkUKsgyekXfPkDZDnIexHIO+Tdcuzlnf2bECKlb2Cgr1JU/iuZVnD2Cqkqa5EjLlE0Ob7K5xWdaFOaxYsXCwSCFStWMDLaW+OO5fQOcxlRr/wFLirEtWUjj0E99U8YXrhjX0FhotE0i7mpPTSilz+Zm2ssdYVOLnWuJjvxjNdL2pkHeUcIQd4h7xXEUt6Zy6EpJ+nS6XM3HyanqNRag0Cq9AoKrdc8KrpVuJet51tWoaic3Qdl9WriOLYZVeVMbmwlEAh27tzZtGnTVq1adehg/R2+Eua1VDYOYGWHTUV0S2YHjDcYY/LUP/v7VPQ5mTIQiGjk3uJ2/jU+LF7dIUT6xYU8rYnm6SbxkPcyQd6ZHRDybh1GGjyVfurr0eNXHn2qFcq9/P29lDIRpVer0tOzNSZ59Z5zftw6r4MfxxMWdYnPhN4eIl8vbg9rxrGMAxmGtBHBE5kdNjAwcM+ePcOHD7969WpwcLAtQ5E0OvVc17WajKW0F2d8kyHy9SLENv3i5VPU9OychZ7uVUQMv1Ps5tuX2QGt5iYVzGnpxsve1CA+OAAAIABJREFUDnkvC+S9OMi7hVjKOwMxpF5sGfn+8sQG83+/mZKnzkp5mpQQH5+Y/CpTnZ927/DS1i9WDxy55TnX04U0V+/Km9fn+KBmZRuzevm/z8bIHTp0+PTTTwcOHKjX23Tz5vsb6v0JmvJfxwT1sXOZ321HlE2/D3NVudEusm5yZq5/vutKzrkH6tssDW65D2rLZfx7+w55LxvkvTjIu+XYyLvtDZ568/e+Cz4Tt++d169xoLz4eITMr173qdt+nRd2Yd/hNxwnXnfvkbx5A26Pad6woLFl7x9li9mzZwcGBs6YMcOWQQaGy9d18WSqpLJ5juhPa/VZm/fasrBlf1f5Z2yuquEnrbT79Q/sjW+53Q81JL+m0kPeywF5Lw7yXiGM552J7WJ1eqTw9Cjt2onAw8uD0Om4ng/sv2CSJCSQ44MWRyN644vVbO9RSBDE9u3bz549u2XLFiu+/EiyTqWlKrsJObvRS4iEfrPGGl+l5ew5aMWXp5EkjVC0i0zIeGXFVJfX/DqcF2vCHEjU3EjDuR3nuyDvZkHezYK8VwjjeWdgs5kq0V1qPFo/fdnJF9p3ztH0aZfXTV5+sVp0VAjH9+Q4WE2pbM81TwyU3l/C+h8dNze3w4cPL1q06Ny5cxX6wp/jNauv5lu+qwRTCKnEf/5EouLPuiQZjQPTMlWcvKUVESIdpb2oYnGBEUssj/II98IwI710kHfzIO+lgbxbjvG8MzCWqOFnW5dd6ze3a+jqoLoN64UGeiukQtpQoEp9Fn/nwQtdYK9Vf8xpgmVmLU7V5DWmVlvA0bGqVfvpp5+GDh165cqVypUrW/IlBx9rN9wq2NvH28OmJaGsJHCVewzuWaEvyaWoyVmquZ7u3hXbCsN6AiQ4nPG7l8S3jgLbzd2a/OruCEHeSwF5LwPk3UKM552R752iyfS/E+LPbJs/uGkAkZvyJOFh/ONXOci/8fvzt8UmJhya0pjhBy3LRObkpS36H4cHLCnHmP1X+n6OD9q1a9fPP/+8d+/eanX5ezpdeW1YEZe/vadXZTdWL32VjyrU6O4nlvsyA01/mqXqLnfpydpEm3dJBNLZoV9Xc2HyeScrrLtZ8CqfV8vWQt7/A/JuOch7uZjNO1PnC4Rr9agRs6NGMDScLbS34oWe7hgL+D11V6AshPvjTp8+/cmTJ4MHDz506JCozOdJQtyFe9/zruqO/90hbTBmxuzyGtnftXXjUl+D0KKcPC+BYKo7d9tVFfEQeyGEnmuTA6WVJQLWnykyK1tLHU7WTmikwHL0UkDe/wV5txzkvVzM5t0Bt9PR3Hrg0rguxgJGVp7Uw68/lkN///33QqHwk08+Ke0FDzKNr/LJQIWQD2lHCAk93f0XTFJt/11z7V5pr9mQr042Gld6e+L6Zb2oOr3vzVZMB0cdqkhjX9rfmrWcgbxD3pnlSHl3tAZPG026+0kujetgOfqTwkdp+tdiAs+pH0JIKBTu2bMnLi5uzZo17372TQE5+ogqT8+v564kIYH+8yZm/7BXl5D87mcfGowHCzWbfLwZXMGqogZVGtnIvQWuo7cIlDzKNuby7KfGE5B3yDvjHCnvjtbgKXWBS5O6QiWG65kasnDd8xV6CvP64W5ubseOHVu3bt2OHTtKfMpPLtzf17ueL+8mQEmqBfsv+lTornz3U7Ul4j/8/TibaGOWRCCNUDamaFJLcrQ8SHFSIdEySPog09YdtBwS5B3yzjhHyrujNXihl4fv1I+wHFomcJkZuqSKC/7dKgMDA48cOTJnzpyTJ08WfeRBpvH0C51IgHhype5dkpBAcaBf8Y88NBgPa7QChBTcP9ljzlPN4yWPP8fyB/37zh6tg6XcH5f/IO8I8s4Ox8i7ozV4XF5qnwkIQRCOuTZm1a5d+7fffhs+fPiVK1fuZxo/PqKS8CM25VIfv6B7kPTEaJqQle0m4NHvZ5hrrY4+3bGc1IsF+K5XAnMg70yBvL+Lwbzz6BtqO1pvMKVncX/cG3mXN78wcw8Mr9atW+/evbvfxHkfHcpYFuXetrJ9vAUUVwm8t/2PMW/SZ3u4t5Xxq+bOPr2L5tlyb+xR1d0MuEr/H5D34iDvjHOAvDtUg1eficv76wz3x/UUe39abS73xy1X07bRfhN+ytg5o7L+Je5aLJVXo+r8KcM/OBwb/fg57lrMW5k8P1lT/rO8zGoaIHmZb+L4oDwHeS8B8s4Gu867QzV43d1Hsro1uDwiSZMGSh8qDw+QBnF5XAt5yARHhgZ/Nap7p06dnjx5gruc8mWQ5EcZ2UM9PUZFt8yK2UlpMc9gMquH34BHBfc5Puj4RoreYdwt+mEXIO8lQN7ZYNd55+kUDCvQJlIX/8Rn8odcHnTrq++CZVVxPQVbhqtvDK/yTQNryYOUwo8++oim6ejo6DNnzoSG4p8TVBotTX+UkT1QIR+lVKBwRfDGJVasX82BCGXjCGWpy3SwJ09PuUnt5M4q+yDvxUHe2WPXeXecd/D6pKfiIH+BQs7ZEWlEe4v9Ovv24uyIFqJoNPtsbrViG36NGjVqwYIF0dHRfD6vFyI028Pt4/9/5Olt2vl5Xn8r7+rRjANcHnHRhfzjT/n4rcAC8v4W5J0Ddpp3x2nwQg93j0E9uDwigYgBlYZjXOaiNAICxQ7zaxLwn8LGjh27YMGCDh06JCQk4CqsNKkkeUWnlxBEexeZmc/OW6M+dYn7qsoW5lorLidWR2k5O2Ijf/GFFFjS7h+Q97cg7xyw07w7ToMXB/q5NOJoQat8U+7CxClc/rAt9NsjzeKLeaV9dsyYMStWrIiOjr579y6XVZXtpck0PCPrDVnq/gr+cyfkHzyVd/AUl1WVy03kviT8O5mAu/vibStLL7yCBv8PyDuCvHPITvPuOA2eS08KH7X26sjlD9sSW+8VrrtZ8FFEWVt5DRs2LCYmpmvXrpcu8eIc+ZHROCIje5Kbsr9rqddaRX7eAV9OK4i9mrv/CJe1WeiXNz8ZKAMHBwr1ENE0epYLc+m5BnlnCuTdcozk3UEavOHpK108d3ebGrtHdvPty9nhLLHyinp/gmZf3/L3jBowYMDevXv79ev3xx9/cFNbaW7oDWMysud4uA0oPe1FhF7ulZZMI8rcMguXAlJ9IvMgN8ea2FgBS94gyDvkHR/7yjsfv4NWyD92Xlq9sqwO61v5Xs+9lG3M5Fvac/XUy3zTL329PaQWnbF16NDhyJEjffr0ycnJ+fjjj9kuz6wTWt2SnNw1Pp4tpBatbiFQurr378J2VVYYFTyZQhzt5zG0DndzyvgM8g55x8W+8u4g7+B19x7JGtTm4ECnsv6up2zEwYEspDXRuXrKQypY38XTwrQXadq0aWxs7IoVKxYsWEDTNHsVmnVOq1uek7fF19vCtBdHk2T25n2UupCNwqwgIAQiQvRM8/iF1szuWIw7/0pPcv3j4h3IO+QdF/vKuyM0eOObDISQuJIvB8eaG7Y8WFaFgwNZQmeiB/+ZfeixlXN/atasGRcXd/bs2eHDh+t0nD6a0lgq+SPAt5ZVj70SQqFA6Zo6fw2WZUpLo6d03z1baqJZv0G+9rr6TjoXtwB5C/Ju3ZdD3hlkL3l3hAavT3wqiwhn9RAUTe59sxXLxgNlEBBochPFiHplzbIpm4+Pz+nTpymKioqKSk1NZbA2s/IoakZ2TipJKgUCTxs2lvAc2tutV8fUBWv1Sc8YLM8WtRQRc8OWiwjW73lNaaL0dxWyfRQ+g7xbPQLknSn2kndHaPDyphGeQ3uzeoiruRfS9W9kQr5Mo73wSn8xRS8REl2qmXmQtEJkMtnPP//cp0+fFi1aXL9+nZHyzEo2mganZ1USCv2FDPQnZZc2PpOG5f5+3PahmOIr8UcI3c2/wepROlSRBiudusFD3m0BeWeKXeTdERq8QOkq9HRn9RCRnu2nVJ1PIF7MYN75oHB2bJ6XjLGfHUEQ8+bNW7duXc+ePbds2cLUsMUd12hHZGRNdFPM9HBjqm6XRnX8505gaDBm0Ig+mLY3NpvdP0O/JGiMlPPeh4e82wjyzhT+590RGjyrnmqSbuVdJRAhIPB/r4wUPe9c3i8J2v19vev4MLxuc58+fS5cuLB27doxY8YweIuORGh1bv43efk/+nq/V97jMVZTn7pE6/HfmSYQMa36wlqKeqwe5ddH2pupsHUsKyDvNoK8M86WvOP/JbZR4aVbBeeusjf+xherpQK+7FJ86LFObaB+7evN0kXa8PDwq1evFhYWtmzZMjGRgR0S1RQ1IiPridH4m79vHQmLO0kYkl+lzv/WlKli7xAWchN5BEiDco2qbEMmS4doGSSJe+OkS9pB3hkEebcdz/PuAA3+BqvrISyuubausiF741soV0chhAaEu8R09pSLWbxyqFAo9u7dO3HixLZt2+7cudPG0UwI9XOVb/L1drdhio0lvMd/oOgYmTr3G+09rnduNuul9umq5AV6ipW5ypGBkiuv8b99wQLyzizIOyN4m3c7b/AUpYt/Iqtbk/mBafJk5l80ol2FCsYHr6ijT3Xd9mdqjNzddh03btyZM2dWrVr1wQcf5OTkVPTLNTT9TW7+U6PJUyAY6Crn5k6mW48o3xmjVVv38+HaXX23psOCxgkJVt54NQ6QJGQbnfE2POSdHZB3G/E27/bd4A3PU4Se7kIPJeMjH8889LDgDk9m2VRSCH/t68Pqify76tWrd+PGjUqVKjVo0ODEiROWf+Edg6FfWmYuRVUScT3ZW1YnLOi7hYSUF/t91XdrIiLEr3UvacTwX2oXEbGzt7fY+baGh7yzB/JuI37m3c4b/Ks0l4asLGjV1qvTpCqz2RjZco+yjQvO5yGEGvqJK7theDJKJpOtXbv2p59+Gjdu3NixY/PySt23qoiOplfm5k/Nypnl4fa1l4cL1mXTCy/e4MNTs7+m7jyU/gvjwzb0Y/EGJ29B3lkFebcd3/Ju3w1e0b6518j+zI55X33rje6VQqSUCLCdGNII7XxQ+OHfqpZB+E9Oo6Oj79+/LxKJIiIiDh06VNrLruj076VlZpPkwQDfaHPbPHNM6O6WserH3N+OIYqjhaPNGhsyrZpLDcaHzdVTX1/OZ3xYnoO8cwDybgu+5d2+GzzjsgwZW19+h/cJmQIDPe6o6s8k7e/9fHqG8mKpDaVSuXHjxp07d86aNat///4pKSklXnCwUDM/J3euh9sqb08PlufXWEgWUTNw1Szdw6S0xTGm7FxcZbgKFfXdmpA0maor+U2zhYuI+PWRBhaltxHk3SzIu9X4lnde/GysRNM0STI7pLfEd3HNtQHSIGaHrZACI9UiULq/r08Ijst0ZYiKirp79279+vUbNWq0atUqg8FAIvTYaEIIdZW7HA3wi+LBiXxxQi+PgEWfypvWw37tTm3KW5k8/zlzu1NIhcTxwb5CXtwy5grknVuQd6vxJ+923ODVpy7l7jvM1GgZ+tSruRcIRHiIvZgas0Ly9dSKuPzUAjLAVTimgauIlz8ZqVS6ePHiK1euXLx4MWL48C5Jyevy8hFCMoKQ8HOjcoJw6xPt2hLzhmAeYq9p1RcpGJ2hHeBkK9JD3rkHebcOf/LOy18ry+juJ4mDA5gabf2LlST7WwOV4XCyzkAhLxd7+ImEVAnett13+crUNasfDH7/9u3buAuyCKXVpUxcVHCexfW3y1DVJdRH4p9tyGRqQYxX+eTs2HKmQTkSyDs2kPeK40ne7eHXqxS6hGRZ7VCmRpsV+nUrzw5MjWa59ELyzyQtQmhIHfmi1m5Sfl91TSXJBarckRlZzaWSs9Wr3lu/btCgQT179hwyZEhSUhLu6sohcJH5zRybf+hU+tINuLaefKV7viJ5HiPblHnKBEeTtc7zNDzknXuQdxthz7u9NnhjWiYhFIj8vG0cJ9+U98ubnxBC3C9wQdJo54PCXr9lpRX+X3v3Hd9UucYB/D1JTpJmJ01XuugGyixD9l5VZAk4kXkZXi/qVe5VQCiKbHDgQFQcBQEVUAEZAjJaQVaZpaW0BUp308w2TXLG/aOlDNuSNOOc9D7fP/xYcpI8eU9+eU9yzvu+bj6z6CElJDmupDyAy90XEjhFKsExjMfjzZo1Kycnp3379n369Jk+fXpeXh7TZTaFHx0esvI/wsS44jfXMDLPZSdZt1kRr/PdMRmqhI9FKXhXyv8vJqWHvHsf5N11jOfdVzt4usYqGdTT9cfZUZwq4jZ/feVmy9Lax+yoOJBfs220/+zOzE+e1YRCgtxgNNlpOpjLPaYJekUulT543axYLJ4/f/7169fDw8N79OgxefLkrKwspqp9JIzLlY8ZGvppCi+AmZOvseLWXIx72XS+0u7qt4puIfwzxcxP4+UFkHevgby7F7N599UOnt8qTDHxcdcfZ2r4y08GTXT9cZxVbaf/mSTZ8qR/jMKDE2u7KNNmf12rm1BabqMRF8MQQk1cWaNQKFJSUm7cuBEfHz9w4MAxY8akp6d7sVjncO5eAGzLKyh//2t7YamXC9DZtWvzUlx8kD5hglsG3/g66CLIuxdA3j2Hqbz7agfvIq2tfMWN+TbK299+1p42zdynQwglBfNHRLNrkEk9EqED1ZYXyiperqjswMd/1wTNlUsdfKPIZLIFCxbk5eUlJydPnTq1W7duqampVit7lz7DIzWCmIiSRR9ov9hO6k1ee95+qqFvRC9x8UEGRAje6+/ZldFbBsh7EyDvXsBU3n2yg6fthL2ozJVHuGw6313R12tzVxF351YKEnNZ/omcTxBDikpTzVUvSMS/a4ImSyVi58fD+Pn5zZo1Kysra/HixampqZGRkW+++WZurttGhboRxuXKRg0O/fBtjI8XvraUNJq99tRK3B8htLNkS351TrMfhKDcPfM1+0DePQfy7rWnZiTvPtnBV5++pN+2p3n3NRFGhNAA/+GD1MluLaphZhv9WYa5d2rpxTI7QuiFRFGAiHVtbqPp/dWWz4wmhFAol/ttoP/mQPUIkZ+L46w5HM7IkSMPHjx4/PhxkiR79eo1ePDg1NTU6mo3XFPqXhyJSDV5XPjnS7myuvOjtN1LF6/FihJ2lXzf7Lu/f8a0PZN17elekHf3grz//+Td7W8+wmLUlZeWavUeXO3Qej2PHxPRjDteMWW8nf2vKtIbR20Wgl53xjRwa1mujtgyyr8j+1YHoRA6bbUuqtT3LyrdXlUdj+MIIT6GRbh7ve34+PjVq1ffvn17zpw527dvDwsLmzx58oEDBwiCyYHIf4fx6/aRvaS8YObCyu92ERVOL53prA6yrv+OXowQstPN+QG5YyButDE4+TbkvQ7kvR7kvQlezrubOnh76clNbz0/sF2oXCRWqAKDg9VKiUimSRz43PxNp0rdvVut2fmChKhm3FHEFc+LedfTI2RqP+r0NZSNoHeMVa8ZpIhVsuvKmiy7/V2dYWBR6XKdsRXO2xUc8HWAv6dXjBAIBOPHj9+zZ09mZmaXLl1SUlI0Gs3MmTMPHDhg99bhs4Pw4ADNmrcQTRe9sbz8w2/ISm/MJ/P5rbW1I7icMixKOLOT16/KhrzfB/LeIMh707yTd4ymXT7wJm5sGt9/1j6i3fDRI3p1iNGopEIeZTVVFudfPX3o19/OY8mfH90+NcaB9/yAAQMQQkePHm1iG9pmvz31vxHfrMRwR4+RLWT1vrKdY4Kf5WAen93zpQO6XD1x4OkATz+Rs0wUdcpqa4PjYTzuD+ZqA0UNFQlbufvg3Sk3b97csWPHzp07r127NmzYsFGjRg0bNkytVjNY0kOoaov56F9+HdvgoUGefi4LWX1Kf3yg/whn72i0UlLBIxaL/vjjj7Ozs9evX9/s8u6BvN8H8u44yPv9vJR32mWm3VOCxF3np1VSDd1qvrR2iH/wlN0mRx6qf//+/fv3b3obymoz7D7sVIXf3/lyW+Emp+7ilMwK26pTxiITQdN0vt5OkJ57KufYKepcjfUTg/G50vKud4pmlWuzbDami2pAaWnpV199NXbsWIVC0b1794ULFx45cqSmpobpuh5Wuuyzis+31lzP9+iznNIdv2q84Pj2/zqoO5BnaXqb9evXv/zyy67VVQfyDnl3EeT9fh7Nu+s/0ZOFV66aOj4zraeywWMKcfsZk/uYM68Wumu4LsbHZSMHObIlRZMl1iKE0LOh05/WTHXT899TaaE+OW8evr189n4dzkFyAQch1ErO47LgqprbBPGPcm3PopJlekM1Rf9TJk3TBG9QqxIc/hrkTYGBgdOmTdu5c2dZWdmqVatomp4/f35AQMDgwYNTUlIOHz5sMnlvQEsT/Gc9y1MrK9an3nk5xbT/uIeeRYWrtxVtcnx6yzZq3rkSrw0Ag7xD3l0Feb+fR/Pu+i82nICIMDwnLb34tZjQBt7pdOWfJy5zQ8arvZ+CFbkLAvkhMyJece/DXiyzC3lYgoqXqbVrLdSy/vKkYD6DM0qTCOXZiSs22xWb/ZLN1paPL1EqlBzOJKlkLR+XsWO1ZgfhOF77rW7p0qUmkyktLS0tLS0lJeXChQvR0dE9e/bs2rVrly5d2rVrhzPxycVVyeXjhsvHDbfl3SbK667HoSw19jslgpgI5KamjhO3eSfhQ4SQmTBW2MpaiWKb3j4piL/6L699IELeIe9uA3lHHs676x08phr12j+WD5/ZY8DxmS8+0bt9jMZfIuDSNnNlcf7Vvw5u++Kb46LZ+0ap3BMJmq5KOyvu262JTSxkNRfj8jmCaeFzgwUatzxtoYmsstPxKl6W1r7wuGFWJ3GCitcnTNAnzA2TDDurhqaFGGaj6RV642Wb7Yad0PC47XA8kc8fKfJry8cRQlIOp5+QgdrcSCqVJicnJycnI4TsdntGRsbp06fT09M//PDD3NzchISETp06tWvXrn379m3atAkPD/dmbfzoCH503XXdRHmlduM2orzSr0NrYft4cY/OHKl7JkM1EPqPb654JnRaV3mvJjZrH4hna+1WkvbKyiWQd2+DvEPe7+dU3t1xzYWk74rf94e9veijNbM3LSLvu2YP48mj+z2z6tC7s3vJ3JN3e3G5buueJgKfZb786c1VMyP/3U7a2cW00whtz6z+q9h2tthmI+nnE8XxKklrf3z3eO9dFaKnqHw7cYckbxPELTtxiyDzCSIO520JVHMxrJOAP0rsl4Djfuxcm9l9cBzv3r179+7da/+0WCxXrly5ePHilStX9u3bd+3aNZPJlJCQEBsbGxcXFxsbGx0dHRUVpdFoMM+3DD9Co1n9JqkzWC5l1Vy6zlXKRV3bI4TsxeWU0cSPCq8fjeOsUGHE8jaf1v7/VdOFSL9oCU/2981EPOyZtiIbiQTeWSAe8u4xkPdakHd35d0dV9HXsxkKbmTnF1WaakiuUOofGh0fGyZ35sU+8qpa89G/LBeuBbw65aF/L7beKbUWdZJ1ryLNNspaO2eQ40gK6a2Uvx8HIbTohKG8mvpsuJKg0KpTxngVLymYH+2xGaRraLqEJCtJSktRZSRZTpIlJFVD0x/4KxFCT5dWYAiF8bgRPF4EjxuF86J4PN/6Fc47DAZDdnZ2Tk7O9evXc3Nz8/Pz8/PztVptWFhYeHh4eHh4aGioRqMJCQkJDg4OCAgICgpSKpUeLanqZIbxl0O2gmI8SI1HapTPPunKYmg/Faee1aevaLOheXd351X09SDvzoO8uwXkvWn1eXfr+5gvD2/bPbztg/9I22ssdoT7CXE3HFtZs/ME8XUjYm2UrdJeESzQEDSx4daavqqhCCExV9L0sNecSqK0mqz9qW3tadPFMnuBkSipomKVvNpD9QERwggZFyHE46D5vRo4gGqMhabtNF1F03aaNlE0F0OtcRwhdLym5qadNNOUmaKNFGWgKCNFE4j+LlDNRWhauVZLUmoux5/DCeRy1VxOTwE/Eq/bL9uDWDSGhM3kcvn9h/y1rFZrQUFBQUHBnTt3CgsLb9y4kZaWVlxcXFZWVlJSYrFY/O9SqVRKpVKhUMjlcrlcLpFI5HK5TCbz8/MTi8VyuZzH48nlchzHJRJHB6GKe3YW9+xME6S9oNhWUFy/3EXlpp+qz17mBfrz1EpegEo2chBH7IcQoqosNEVyJWLU0LeQ8SGTxodMQggZ7Lr3898dpE7upxpafytJoUytvX2Ad89TQt4h7wyBvDuYd48PiyQzV/bqvIRacO7c4g5chGw227x582pqahrcOCcnJyioqQGIL8ZG6P2VAysruRjncGGeneT74zwujSXplvSPlW00mn8rtlTZ6R4aPgdDp4pslRaKIBCWhTAamzlOVESRfxXbSAr1FPExDBWHkJIQ7AupMlLG+8xkfk2rQwghCUIUQtq6Z1ypUvAx7B2dIc9OmOm6KYSqKZpANB/DdgYF8DHs+bKK81abEMP4GCbCMBxDMg5HyuFsVKtwDLtqs+soSoJx1FxODM6TcTgyDhbE5db+vvJ9IETaUwQCQWxsbGxswxetWK1WrVar1WorKysrKyt1Op1erzcYDDdv3jSbzUaj0WAwWCyW6upqvV5PEITRaLTb7WazmcfjSaVShJBCocAwrP5PhJBUKuXdHWrc2KeDTCLx5+CK26Wym5iEwjIO77ZgNEJoaBU30cYRUsiK0VYMbZaTRg6NEOpj4YYQGIFohBCBocNiqirIvpm3NTN/p1BNZCTrojPE8szgdV1nXnopxgOt6BzIO+SdKZD3v/N4B48pO4+dNp1Oqrvohsfjde7c2WZr+Cr/nJycpq+eaCvlGwR4O1zAwTCONMZsoxFCPIS6BPN5HCwW5/WSCAgKxfJ5CCFNEM9OISkPG9XZTyHgHLXUKEluYuS9BScSlUjMwWJEOIZQDyE/nny4NRQcTu2CiRMlIj1J1a+LLOJgPISJMKz21i1NhnaOTNp0EwFGCAQCjUaj0Th94pYgiNphPHq9nqbp+j+FQ+ufAAAP9klEQVQRQiaTqX4+ztpPh7/f3Ww218/kZUWo/gtwJUInEEII4QTJIag4Yd3hOVZtM1bVcKm6U2mJAVKKw0EIKYRVkirrYxeq+XauX7jgaUkuQsx38JB3yDs7/X/m3a3n4F2WkpJS/18AgLt45By8yyDvAHiCZ87BI4QQYTGazBYbRyCVyUXuOA0HAGAtyDsA7OWTi80AAJgEeQfAF7jjGzxxY9OEusUnXnxr9kOLT3z3cr/UvY4uPgEAYDvIOwA+wg0pNO9/b/4hzX+OHFza++/TUy9dfXndmIHzl+6f8PVIry9qCQBwN8g7AL7C9xabAQAwB/IOgM9wvYOvX3yCavDmusUnQhlYfAIA4G6QdwB8hq8tNgMAYBLkHQCf4WOLzQAAGAZ5B8BHuOdSV25wv1e+OPrKJ64uPgEAYD/IOwA+wfOLzTgpPT195cqVjd26a9cuhULBYevySoWFhd5ZsrB52F9eaGgo01U0iuXllZWVTZgwobFbT5486f4ltP/v8+6giooKqVQqEPj2eu1ms5kkSblcznQhLrHb7TqdLjAwkOlCXOVg3tk1WHXs2LE1NTU6na6xDS5cuJCYmMjn8xvbgFmZmZk4juM4S7/FXL16VSAQ3F32gnUuX74sFApZ+2l+6dIlPz8/dh4e0TR9/vz5IUOGNLZB69atR48e7c2SHOHreXdQbm6uWq1WqVRMF+KSoqIigiAiIiKYLsQlRqOxoKCAtR/RDnI87+yai/6RQkJCMjIygoODmS6kYWq1Ojs729+/+csAe5RMJissLKxfColthEKhwWBg7RcdLpdrt9vZefxBEISfn1/9mhYtBsvz7qBx48ZNmjRp7NixTBfiklWrVmm12iZ+bvEJJ06cWLBgwfHjx5kuxCWO552Nn1YAAAAAcBF08AAAAEALBB08AAAA0AJBBw8AAAC0QNDBAwAAAC0QdPAAAABACwQdPAAAANAC+VgHLxKJ2DzrBcvLk0gkPB67pja6n1QqZe0kPAghuVzOzlluEEIcDkcmkzFdhfuxPFAOEgqFQqGQ6SpcJRQKWTtHheNaxr5wPO8+NtGN1Wpl85sMynMFlOcKlpfXPC3jRVmtVj6fz9qjQweRJEnTNJu/ITioxbypHHkVPtbBAwAAAMARPvYTPQAAAAAcwcYOnij8ffmLA9trlAFxPcfO25ZlcWkzhsqjjRe/efXxjmFyP4EkOPGJN76/YvTOTyXONgttPPPdii/TtV76IcfR8qw3d6dM6BahECvCO42a/0uelU3l0fqzG18a0SlKLVWEJfaftPJwEeGd8urYr2xZ/MXp6kZvZyoa7kCXHf5wxa83qUZvN1369rVRj8WoVWEdB09de7ys0S2ZQWtPrZ81PClC5R/V9fF/bjxnaChYdOkXw4XY/fC28896903UMAebF/aCN7mSd5ptas6lJPnxY0anfP3jlnXTkmR45Iy9lVRzN2OoPPJO6rggnqLL5GXf/rJ76+qpnRVc/+SNeSRLyruHqtg7I5qHd1t+jfB4bY6XR5Xtnh7Nl3eZunrzzu1rJ7WTCDu8dbKKLeWRt756wp8X1O+1z3bs+fnrxaOiBaIuS85ZPV9eHUr765Qw0RNfaxvZr0xFwy1s11b2Ese+cdLW8M1Uyfang3nKHrPXb/3hy/nJEbi079pMu3dLbApx45Mhcl7I4Hmf/7Dt07n9AngBY7698/fY20//N0EQ9/SyzzbctXH7X2XM7yMHmxf2gje5lHfWdfDGnc/7461fT6/9OCdufjxIJOz/0c2H946DmzFUHpG1ortA9sSmorpmJu98/aQST1xwztMhcLJZqOIfnwvjYpi3OngHyyMuv9NZEDBuc2HtDdbzb3fAVc/vMrGjPPLmh/34fsM3FtftXNOeqcF4412SG1H6q/u+ff+tZzurOEjQaOCZioaL7HdObt/w3ktDWgkxbqOtSWS+15Uve/yruneG8dBL0XjorIPV3iy0Kdbjr0bhmsm/1H6+UmXbJgbw2y08/7fYm3+YKJE9s8MLx6xOcbB5YS94hzvyzraf6G1nDx01Rjw+rpsIIYQQN3z0uMfo0weP6enmbMZUecT1zOuow5CBQXXXzXKCe/dNwApu3SFZUV4d6nbqnLnpvac/ofLS5b0Olkde//WXq/Inpo7R1L47+Z3e2H3+aEofTw+XcrA8uqbagnCFSlrXagJ/tRRZqqo9f46DKjz23aYdJwqEAcrGc8tUNFxlubzr8837LlkUAX6Nvh2pkj8OX+b1fmpkSO3rl/Z5akRQ+R+HLrHkZ1Ui68gfhfLB4wYrMYQQwgJGPDXA7/rhI7ce+gGbLMy/RYbFtGLZAEAHmxf2gpe4I+8s6+Bp3Y0bFZy4tnF3x2JwAhPiVWRedj7ZjM2YKg/xB648l/njjIi7rUsbLpy7gaLiojw7xMSpZiFyN86ad3nkZ++PDvJS/+5oeTVXLmRjiV07+dkq8y5mXC0wErKIdu1j1R4OoqPlcWNGPfMY9tuqRbuzddWm28c/eHdzQfSECd09/znBbTvn+6MnTpw48HbjBztMRcNl0hErD584ceLoFy9ENjoXApl3PY8Kah2vvPuOxeNax6CCnNzGT096FZF3PQ+1ahNfP85aHNc6HOVl5z7U9ZG38m6R9JVPRncIVcgC47qN/NeX5xs8S+xdDjYv7AUvcUfe2dbBmwwmmidXSuv7HI5CJUdGw4NXqDm4GVPlIUwSHB0dLKltXFp/7qMpr+3Ehr8yJdGz07g40Sy2zI+mL8yf+PmqEf5eews4WB5VUVRiw+grHwxuFRLbKaldpDIg8fkNF8wsKQ8hXttXv/90RMEHo1qrxLLI/v9Nj3v3pxUDJZ6uzzFMRcMraKPBiCmUivq3LEeuUnAoo8HMjhdnMRhtmEIlv1efQqlAJoPxwe+OtP5mvs5+I6Mk6fUNW79b9WLszW9nDxn/aQ7Th2AONi/sBRZ5VN7Z1sEjRCP0wDdKmkaIoii6GZsxVd49Vdk73hrWofd/zrVZtOObKREebm2Hy6vJWDVtqXbqF8sGK7w4+YajO7emxkrXHNt8OGFV+h2DsfTi9smi3XMnzP+jihXlIdqYtmjcnN8DJ6358XDa0V83vNIhe9G4ObuK2HEdMVPR8Iral4A99E80yZIXd7eIhwqkSeqh94aw9+upO4//+fO7k59MHjPl7S37P0xGR9d88qfNS4U2wsHmhb3AIo/KO8s6eI5MIccIg/7esSBl0BtomVzGacZmTJWHEEKI1p9ZP7Fz0rNfGUe8f+zC/oV9PX+m28HyrGeWTVtre+nLJX2lnq6oOeVhAoEA47X+5+cfvdBVI5MGth+/cs3UsJs/bE33bPIcLI8q2Lz4/atJ7+za9Pr4Qb37Pzlr3c8bxldtmb/+HCtOQTIVDSfZfp8dwq0bmtTmrTMONh1HrpAhg85Q/0lNGfQGiiOTSxl6cVXbnvKrG2El6PN+vkAuE9AP1qcz0GKF7MFTc5is7bAJY3qE4nV/c0LHjO/NLbp0ieHBZg42L+v2woMwP9/eC855VN5ZsUvuwZSxsQF03vW8u7+T0NrcXB0vJiGK24zNmCoPIVR9dtkTw+adbr3kyJU/N87pEeCVKdYdK482XDx9TZ/xXg9x7QdT8lcVtjNvteHxuy2/5tGfpxxsPU5AeKiQGx7T6m7yED8qNoJj1Ok924M6WB55OyefCEnqEnY3OpiiS/d4dCsnjxVH/kxFw0n83kvSrmVlZWVlZV3d93p7B69N4UXHx2ClObn1pxuI/Jx8FBYfK/JYoU0TPbH+Uu2ryLq8dUq4ICYhGt3Kya1/J1hybxRiMQkxD7a9pSgz49Jt073vuxiXx8UwvkDA7GS2DjYv6/bCQ3Df3gvOeVTeWdbBI7zL0IHy/H17LtfuHbp0/+5TWLeh/R/6+uvgZkyVR+ZseHVZZtfVB396o0+gFz9YHSoPUz6+Yt+hevuXJ8vxhOlfHzzw6XONX97kvfIQEvUc1BPP2P97SV32qNJjR66ghA5tPTx/tGPlcVvFRXEKT6bVX7JDV/x5IpOOjItmx9W4TEXDSaKgmPiEhISEhIT4VmpHF//AggYO6UCk7/69blqmmnN7DharBw3tiD/ijp6CSTVxCXUvI1yJc1sPGRSuP7w7ve6CEcPRPUerYocMfvDgiq459nb/rqPXXLzbA9Glv/3yJ9Wm12MM7yMHm5d1e+EhPr4XnPSovHtrTJ/DrBlLu4nFHWdsPJB25Ps3B6r5Uf/47e6Axt8Wv/Dcq5uvE01uxnx55O31A/h4xxmffHO/b384WeTxwcgOtt7999g3Xc331kQ3DpZnPv5GolCZNG3t9r17t62ZlqTAw5770fON51h5VOX+OXF8cfxTKd/8emDv1jX/6ObPCxy1Kd97A82Nm0cLHxwXy4pouIX9zFttBA+Og7df+Hzms5NWHjXRNE2V/vR8KB6SvOSnYyf2fPRCa6G83zo2TbFC5m4YrhLETly3+8SxnctGR/CDxqYW1L4zqtPWTHp2+qfn7DRtPPJqa4Ewbuw7qXsP7Pl+9bQkJb/V1J9Lmd9HTTQv7AXGuJJ39nXwNG2/s3/JuE4aiUCkThj6ypbMuxMRkPnv9+HfmwSjsc2YL892bG4D34U5IbMPeWG6Mwdbr55XO3iHy7Pm/7pwbOdQqZ80pE3viQt35ljYVJ7t9oHlLw7qEKkSyzVtej31321Xzd4pr9bfA8+SaLhBAx28df+MQE7966WMF76a3T9W5SeQhnd9ZsUfpSybwYeqSF836bEImdBPGd1nxmdndHf3knHzaCGmnLy7hqZp2nb74PIX+8SpxX6KiA4Dnn9nb773ZkJsUqPNC3uBMa7kHVaTAwAAAFogtp2DBwAAAIAbQAcPAAAAtEDQwQMAAAAtEHTwAAAAQAsEHTwAAADQAkEHDwAAALRA0MEDAAAALRB08AAAAEALBB08AAAA0AJBBw+cQhuOLBkzbMY3N+pWL7JmfPTc0OfXX7QyWxYAwAMg774NOnjgFEzed0Ifyw/zXvvuNoUQce3juW//oRj5VHsPr/QGAGAA5N23wVz0wGnWC0v79vk0+qsz7+mnd18kXHdu5+QwOFIEoGWCvPsu6OBBM1hOL+gx4Gt7pK08esXZ3TMiIe4AtFyQd18FHTxoFuOeqa1Hbw54++y5lI48posBAHgU5N03waEYaAa67ND2Q5U87Nr2b0+amS4GAOBRkHdfBR08cBqt3fvmv3/WLPj1yzH6DXNXnqlhuiAAgMdA3n0X/EQPnETr9s/uOu7kxD/+Wt6t7IuRSa/p5p069mY7PtN1AQDcD/Luy6CDB06hDYfndht5YMTesx8NkiFEZK0b1P0d3tIzv8+N4zJdGwDAvSDvvg06eOAUquLaycwqTVKXKAmGEELIXnL5VI49sktShIjh0gAAbgZ5923QwQMAAAAtEFxkBwAAALRA0MEDAAAALdD/ABSvSAahiP+KAAAAAElFTkSuQmCC)
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.
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).
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.
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:
## [1] 0.2 0.3 0.4 0.5 0.68.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.125stopifnot(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] TRUE8.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.
## [1] 0.025 0.025Reference
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.