/* called from splineDesign() : */
SEXP
spline_basis(SEXP knots, SEXP order, SEXP xvals, SEXP derivs)
{
/* evaluate the non-zero B-spline basis functions (or their derivatives)
* at xvals. */
PROTECT(knots = coerceVector(knots, REALSXP));
double *kk = REAL(knots); int nk = length(knots);
int ord = asInteger(order);
PROTECT(xvals = coerceVector(xvals, REALSXP));
double *xx = REAL(xvals); int nx = length(xvals);
PROTECT(derivs = coerceVector(derivs, INTSXP));
int *ders = INTEGER(derivs), nd = length(derivs);
splPTR sp = (struct spl_struct *) R_alloc(1, sizeof(struct spl_struct));
/* fill sp : */
sp->order = ord;
sp->ordm1 = ord - 1;
sp->rdel = (double *) R_alloc(sp->ordm1, sizeof(double));
sp->ldel = (double *) R_alloc(sp->ordm1, sizeof(double));
sp->knots = kk; sp->nknots = nk;
sp->a = (double *) R_alloc(ord, sizeof(double));
SEXP val = PROTECT(allocMatrix(REALSXP, ord, nx)),
offsets = PROTECT(allocVector(INTSXP, nx));
double *valM = REAL(val);
int *ioff = INTEGER(offsets);
for(int i = 0; i < nx; i++) {
set_cursor(sp, xx[i]);
// ==> io \in {0,..,nk} is the knot-interval "number"
int io = ioff[i] = sp->curs - ord,
der_i = ders[i % nd];
if (io < 0 || io > nk) {
for (int j = 0; j < ord; j++) {
valM[i * ord + j] = R_NaN;
}
} else if (der_i > 0) { /* slow method for derivatives */
if (der_i >= ord) {
if(nd == 1) {
error(_("derivs = %d >= ord = %d, but should be in {0,..,ord-1}"),
der_i, ord);
} else {
error(_("derivs[%d] = %d >= ord = %d, but should be in {0,..,ord-1}"),
i+1, der_i, ord);
}
}
for(int ii = 0; ii < ord; ii++) {
for(int j = 0; j < ord; j++) sp->a[j] = 0;
sp->a[ii] = 1;
valM[i * ord + ii] =
evaluate(sp, xx[i], der_i);
}
} else { /* fast method for value */
basis_funcs(sp, xx[i], valM + i * ord);
}
}
setAttrib(val, install("Offsets"), offsets);
UNPROTECT(5);
return val;
}
/* called from splineDesign() : */
SEXP
spline_basis(SEXP knots, SEXP order, SEXP xvals, SEXP derivs)
{
/* evaluate the non-zero B-spline basis functions (or their derivatives)
* at xvals. */
int nd, nk, nx, i, j, *ders;
double *kk, *xx;
SEXP val, offsets;
splPTR sp = (struct spl_struct *) R_alloc(1, sizeof(struct spl_struct));
PROTECT(knots = coerceVector(knots, REALSXP));
kk = REAL(knots); nk = length(knots);
PROTECT(order = coerceVector(order, INTSXP));
PROTECT(xvals = coerceVector(xvals, REALSXP));
xx = REAL(xvals); nx = length(xvals);
PROTECT(derivs = coerceVector(derivs, INTSXP));
ders = INTEGER(derivs); nd = length(derivs);
/* fill sp : */
sp->order = INTEGER(order)[0];
sp->ordm1 = sp->order - 1;
sp->rdel = (double *) R_alloc(sp->ordm1, sizeof(double));
sp->ldel = (double *) R_alloc(sp->ordm1, sizeof(double));
sp->knots = kk; sp->nknots = nk;
sp->a = (double *) R_alloc(sp->order, sizeof(double));
PROTECT(val = allocMatrix(REALSXP, sp->order, nx));
PROTECT(offsets = allocVector(INTSXP, nx));
for(i = 0; i < nx; i++) {
set_cursor(sp, xx[i]);
INTEGER(offsets)[i] = j = sp->curs - sp->order;
if (j < 0 || j > nk) {
for (j = 0; j < sp->order; j++) {
REAL(val)[i * sp->order + j] = R_NaN;
}
} else {
if (ders[i % nd] > 0) { /* slow method for derivatives */
int ii;
for(ii = 0; ii < sp->order; ii++) {
for(j = 0; j < sp->order; j++) sp->a[j] = 0;
sp->a[ii] = 1;
REAL(val)[i * sp->order + ii] =
evaluate(sp, xx[i], ders[i % nd]);
}
} else { /* fast method for value */
basis_funcs(sp, xx[i], REAL(val) + i * sp->order);
}
}
}
setAttrib(val, install("Offsets"), offsets);
UNPROTECT(6);
return val;
}
/* called from splineDesign() : */
SEXP
spline_basis(SEXP knots, SEXP order, SEXP xvals, SEXP derivs)
{
/* evaluate the non-zero B-spline basis functions (or their derivatives)
* at xvals. */
PROTECT(knots = coerceVector(knots, REALSXP));
double *kk = REAL(knots); int nk = length(knots);
int ord = asInteger(order);
PROTECT(xvals = coerceVector(xvals, REALSXP));
double *xx = REAL(xvals); int nx = length(xvals);
PROTECT(derivs = coerceVector(derivs, INTSXP));
int *ders = INTEGER(derivs), nd = length(derivs);
splPTR sp = (struct spl_struct *) R_alloc(1, sizeof(struct spl_struct));
/* fill sp : */
sp->order = ord;
sp->ordm1 = ord - 1;
sp->rdel = (double *) R_alloc(sp->ordm1, sizeof(double));
sp->ldel = (double *) R_alloc(sp->ordm1, sizeof(double));
sp->knots = kk; sp->nknots = nk;
sp->a = (double *) R_alloc(sp->order, sizeof(double));
SEXP val = PROTECT(allocMatrix(REALSXP, sp->order, nx)),
offsets = PROTECT(allocVector(INTSXP, nx));
double *valM = REAL(val);
int *ioff = INTEGER(offsets);
for(int i = 0; i < nx; i++) {
set_cursor(sp, xx[i]);
int io = ioff[i] = sp->curs - sp->order;
if (io < 0 || io > nk) {
for (int j = 0; j < sp->order; j++) {
valM[i * sp->order + j] = R_NaN;
}
} else if (ders[i % nd] > 0) { /* slow method for derivatives */
for(int ii = 0; ii < sp->order; ii++) {
for(int j = 0; j < sp->order; j++) sp->a[j] = 0;
sp->a[ii] = 1;
valM[i * sp->order + ii] =
evaluate(sp, xx[i], ders[i % nd]);
}
} else { /* fast method for value */
basis_funcs(sp, xx[i], valM + i * sp->order);
}
}
setAttrib(val, install("Offsets"), offsets);
UNPROTECT(5);
return val;
}
const Vec & Spline::basis(double x, Vec &ans)const{
set_cursor(x);
int offsets = curs - order_;
int j = offsets;
int nk = nknots();
ans.resize(order_);
if (j < 0 || j > nk) {
std::ostringstream err;
err << "a bad bad thing happened in Spline::basis()" << endl
<< "x = " << x << endl
<< "j = " << j << endl
<< "nk = " << nk << endl
<< "curs = " << curs << endl
<< "offsets = " << offsets << endl
;
report_error(err.str());
} else {
basis_funcs(x, ans);
}
return ans;
}
