/* sbart() : The cubic spline smoother
-------
Calls sgram (sg0,sg1,sg2,sg3,knot,nk)
stxwx (xs,ys,ws,n,knot,nk,xwy,hs0,hs1,hs2,hs3)
sslvrg (penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, coef,sz,lev,crit,icrit,
lambda, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3,
abd,p1ip,p2ip,ld4,ldnk,ier)
is itself called from qsbart() [./qsbart.f] which has only one work array
*/
void F77_SUB(sbart)
(double *penalt, double *dofoff,
double *xs, double *ys, double *ws, double *ssw,
int *n, double *knot, int *nk, double *coef,
double *sz, double *lev, double *crit, int *icrit,
double *spar, int *ispar, int *iter, double *lspar,
double *uspar, double *tol, double *eps, int *isetup,
double *xwy, double *hs0, double *hs1, double *hs2,
double *hs3, double *sg0, double *sg1, double *sg2,
double *sg3, double *abd, double *p1ip, double *p2ip,
int *ld4, int *ldnk, int *ier)
{
/* A Cubic B-spline Smoothing routine.
The algorithm minimises:
(1/n) * sum ws(i)^2 * (ys(i)-sz(i))^2 + lambda* int ( s"(x) )^2 dx
lambda is a function of the spar which is assumed to be between 0 and 1
INPUT
-----
penalt A penalty > 1 to be used in the gcv criterion
dofoff either `df.offset' for GCV or `df' (to be matched).
n number of data points
ys(n) vector of length n containing the observations
ws(n) vector containing the weights given to each data point
NB: the code alters the values here.
xs(n) vector containing the ordinates of the observations
ssw `centered weighted sum of y^2'
nk number of b-spline coefficients to be estimated
nk <= n+2
knot(nk+4) vector of knot points defining the cubic b-spline basis.
To obtain full cubic smoothing splines one might
have (provided the xs-values are strictly increasing)
spar penalised likelihood smoothing parameter
ispar indicating if spar is supplied (ispar=1) or to be estimated
lspar, uspar lower and upper values for spar search; 0.,1. are good values
tol, eps used in Golden Search routine
isetup setup indicator [initially 0
NB: this alters that, and it is a constant in the caller!
icrit indicator saying which cross validation score is to be computed
0: none ; 1: GCV ; 2: CV ; 3: 'df matching'
ld4 the leading dimension of abd (ie ld4=4)
ldnk the leading dimension of p2ip (not referenced)
OUTPUT
------
coef(nk) vector of spline coefficients
sz(n) vector of smoothed z-values
lev(n) vector of leverages
crit either ordinary or generalized CV score
spar if ispar != 1
lspar == lambda (a function of spar and the design)
iter number of iterations needed for spar search (if ispar != 1)
ier error indicator
ier = 0 ___ everything fine
ier = 1 ___ spar too small or too big
problem in cholesky decomposition
Working arrays/matrix
xwy X'Wy
hs0,hs1,hs2,hs3 the diagonals of the X'WX matrix
sg0,sg1,sg2,sg3 the diagonals of the Gram matrix SIGMA
abd (ld4,nk) [ X'WX + lambda*SIGMA ] in diagonal form
p1ip(ld4,nk) inner products between columns of L inverse
p2ip(ldnk,nk) all inner products between columns of L inverse
where L'L = [X'WX + lambda*SIGMA] NOT REFERENCED
*/
#define CRIT(FX) (*icrit == 3 ? FX - 3. : FX)
/* cancellation in (3 + eps) - 3, but still...informative */
#define BIG_f (1e100)
/* c_Gold is the squared inverse of the golden ratio */
static const double c_Gold = 0.381966011250105151795413165634;
/* == (3. - sqrt(5.)) / 2. */
/* Local variables */
static double ratio;/* must be static (not needed in R) */
double a, b, d, e, p, q, r, u, v, w, x;
double ax, fu, fv, fw, fx, bx, xm;
double t1, t2, tol1, tol2;
int i, maxit;
Rboolean Fparabol = FALSE, tracing = (*ispar < 0);
/* unnecessary initializations to keep -Wall happy */
d = 0.; fu = 0.; u = 0.;
ratio = 1.;
/* Compute SIGMA, X' W X, X' W z, trace ratio, s0, s1.
SIGMA -> sg0,sg1,sg2,sg3
X' W X -> hs0,hs1,hs2,hs3
X' W Z -> xwy
*/
/* trevor fixed this 4/19/88
* Note: sbart, i.e. stxwx() and sslvrg() {mostly, not always!}, use
* the square of the weights; the following rectifies that */
for (i = 0; i < *n; ++i)
if (ws[i] > 0.)
ws[i] = sqrt(ws[i]);
if (*isetup == 0) {
/* SIGMA[i,j] := Int B''(i,t) B''(j,t) dt {B(k,.) = k-th B-spline} */
F77_CALL(sgram)(sg0, sg1, sg2, sg3, knot, nk);
F77_CALL(stxwx)(xs, ys, ws, n,
knot, nk,
xwy,
hs0, hs1, hs2, hs3);
/* Compute ratio := tr(X' W X) / tr(SIGMA) */
t1 = t2 = 0.;
for (i = 3 - 1; i < (*nk - 3); ++i) {
t1 += hs0[i];
t2 += sg0[i];
}
ratio = t1 / t2;
*isetup = 1;
}
/* Compute estimate */
if (*ispar == 1) { /* Value of spar supplied */
*lspar = ratio * R_pow(16., *spar * 6. - 2.);
F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n,
knot, nk,
coef, sz, lev, crit, icrit, lspar, xwy,
hs0, hs1, hs2, hs3,
sg0, sg1, sg2, sg3, abd,
p1ip, p2ip, ld4, ldnk, ier);
/* got through check 2 */
return;
}
/* ELSE ---- spar not supplied --> compute it ! ---------------------------
Use Forsythe Malcom and Moler routine to MINIMIZE criterion
f denotes the value of the criterion
an approximation x to the point where f attains a minimum on
the interval (ax,bx) is determined.
*/
ax = *lspar;
bx = *uspar;
/* INPUT
ax left endpoint of initial interval
bx right endpoint of initial interval
f function subprogram which evaluates f(x) for any x
in the interval (ax,bx)
tol desired length of the interval of uncertainty of the final
result ( >= 0 )
OUTPUT
fmin abcissa approximating the point where f attains a minimum
*/
/*
The method used is a combination of golden section search and
successive parabolic interpolation. convergence is never much slower
than that for a fibonacci search. if f has a continuous second
derivative which is positive at the minimum (which is not at ax or
bx), then convergence is superlinear, and usually of the order of
about 1.324....
the function f is never evaluated at two points closer together
than eps*abs(fmin) + (tol/3), where eps is approximately the square
root of the relative machine precision. if f is a unimodal
function and the computed values of f are always unimodal when
separated by at least eps*abs(x) + (tol/3), then fmin approximates
the abcissa of the global minimum of f on the interval ax,bx with
an error less than 3*eps*abs(fmin) + tol. if f is not unimodal,
then fmin may approximate a local, but perhaps non-global, minimum to
the same accuracy.
this function subprogram is a slightly modified version of the
algol 60 procedure localmin given in richard brent, algorithms for
minimization without derivatives, prentice - hall, inc. (1973).
Double a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v,w
Double fu,fv,fw,fx,x
*/
/* eps is approximately the square root of the relative machine
precision.
- eps = 1e0
- 10 eps = eps/2e0
- tol1 = 1e0 + eps
- if (tol1 > 1e0) go to 10
- eps = sqrt(eps)
R Version <= 1.3.x had
eps = .000244 ( = sqrt(5.954 e-8) )
-- now eps is passed as argument
*/
/* initialization */
maxit = *iter;
*iter = 0;
a = ax;
b = bx;
v = a + c_Gold * (b - a);
w = v;
x = v;
e = 0.;
*spar = x;
*lspar = ratio * R_pow(16., *spar * 6. - 2.);
F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n,
knot, nk,
coef, sz, lev, crit, icrit, lspar, xwy,
hs0, hs1, hs2, hs3,
sg0, sg1, sg2, sg3, abd,
p1ip, p2ip, ld4, ldnk, ier);
fx = *crit;
fv = fx;
fw = fx;
/* main loop
--------- */
while(*ier == 0) { /* L20: */
xm = (a + b) * .5;
tol1 = *eps * fabs(x) + *tol / 3.;
tol2 = tol1 * 2.;
++(*iter);
if(tracing) {
if(*iter == 1) {/* write header */
Rprintf("sbart (ratio = %15.8g) iterations;"
" initial tol1 = %12.6e :\n"
"%11s %14s %9s %11s Kind %11s %12s\n%s\n",
ratio, tol1, "spar",
((*icrit == 1) ? "GCV" :
(*icrit == 2) ? "CV" :
(*icrit == 3) ?"(df0-df)^2" :
/*else (should not happen) */"?f?"),
"b - a", "e", "NEW lspar", "crit",
" ---------------------------------------"
"----------------------------------------");
}
Rprintf("%11.8f %14.9g %9.4e %11.5g", x, CRIT(fx), b - a, e);
Fparabol = FALSE;
}
/* Check the (somewhat peculiar) stopping criterion: note that
the RHS is negative as long as the interval [a,b] is not small:*/
if (fabs(x - xm) <= tol2 - (b - a) * .5 || *iter > maxit)
goto L_End;
/* is golden-section necessary */
if (fabs(e) <= tol1 ||
/* if had Inf then go to golden-section */
fx >= BIG_f || fv >= BIG_f || fw >= BIG_f) goto L_GoldenSect;
/* Fit Parabola */
if(tracing) { Rprintf(" FP"); Fparabol = TRUE; }
r = (x - w) * (fx - fv);
q = (x - v) * (fx - fw);
p = (x - v) * q - (x - w) * r;
q = (q - r) * 2.;
if (q > 0.)
p = -p;
q = fabs(q);
r = e;
e = d;
/* is parabola acceptable? Otherwise do golden-section */
if (fabs(p) >= fabs(.5 * q * r) ||
q == 0.)
/* above line added by BDR;
* [the abs(.) >= abs() = 0 should have branched..]
* in FTN: COMMON above ensures q is NOT a register variable */
goto L_GoldenSect;
if (p <= q * (a - x) ||
p >= q * (b - x)) goto L_GoldenSect;
/* Parabolic Interpolation step */
if(tracing) Rprintf(" PI ");
d = p / q;
if(!R_FINITE(d))
REprintf(" !FIN(d:=p/q): ier=%d, (v,w, p,q)= %g, %g, %g, %g\n",
*ier, v,w, p, q);
u = x + d;
/* f must not be evaluated too close to ax or bx */
if (u - a < tol2 ||
b - u < tol2) d = fsign(tol1, xm - x);
goto L50;
/*------*/
L_GoldenSect: /* a golden-section step */
if(tracing) Rprintf(" GS%s ", Fparabol ? "" : " --");
if (x >= xm) e = a - x;
else/* x < xm*/ e = b - x;
d = c_Gold * e;
L50:
u = x + ((fabs(d) >= tol1) ? d : fsign(tol1, d));
/* tol1 check : f must not be evaluated too close to x */
*spar = u;
*lspar = ratio * R_pow(16., *spar * 6. - 2.);
F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n,
knot, nk,
coef, sz, lev, crit, icrit, lspar, xwy,
hs0, hs1, hs2, hs3,
sg0, sg1, sg2, sg3, abd,
p1ip, p2ip, ld4, ldnk, ier);
fu = *crit;
if(tracing) Rprintf("%11g %12g\n", *lspar, CRIT(fu));
if(!R_FINITE(fu)) {
REprintf("spar-finding: non-finite value %g; using BIG value\n", fu);
fu = 2. * BIG_f;
}
/* update a, b, v, w, and x */
if (fu <= fx) {
if (u >= x) a = x; else b = x;
v = w; fv = fw;
w = x; fw = fx;
x = u; fx = fu;
}
else {
if (u < x) a = u; else b = u;
if (fu <= fw || w == x) { /* L70: */
v = w; fv = fw;
w = u; fw = fu;
} else if (fu <= fv || v == x || v == w) { /* L80: */
v = u; fv = fu;
}
}
}/* end main loop -- goto L20; */
L_End:
if(tracing) Rprintf(" >>> %12g %12g\n", *lspar, CRIT(fx));
*spar = x;
*crit = fx;
return;
} /* sbart */
double rpois(double mu)
{
/* Factorial Table (0:9)! */
const double fact[10] =
{
1., 1., 2., 6., 24., 120., 720., 5040., 40320., 362880.
};
/* These are static --- persistent between calls for same mu : */
static int l, m;
static double b1, b2, c, c0, c1, c2, c3;
static double pp[36], p0, p, q, s, d, omega;
static double big_l;/* integer "w/o overflow" */
static double muprev = 0., muprev2 = 0.;/*, muold = 0.*/
/* Local Vars [initialize some for -Wall]: */
double del, difmuk= 0., E= 0., fk= 0., fx, fy, g, px, py, t, u= 0., v, x;
double pois = -1.;
int k, kflag, big_mu, new_big_mu = false;
if (!R_FINITE(mu))
ML_ERR_return_NAN;
if (mu <= 0.)
return 0.;
big_mu = mu >= 10.;
if(big_mu)
new_big_mu = false;
if (!(big_mu && mu == muprev)) {/* maybe compute new persistent par.s */
if (big_mu) {
new_big_mu = true;
/* Case A. (recalculation of s,d,l because mu has changed):
* The poisson probabilities pk exceed the discrete normal
* probabilities fk whenever k >= m(mu).
*/
muprev = mu;
s = sqrt(mu);
d = 6. * mu * mu;
big_l = FLOOR(mu - 1.1484);
/* = an upper bound to m(mu) for all mu >= 10.*/
}
else { /* Small mu ( < 10) -- not using normal approx. */
/* Case B. (start new table and calculate p0 if necessary) */
/*muprev = 0.;-* such that next time, mu != muprev ..*/
if (mu != muprev) {
muprev = mu;
m = std::max(1, (int) mu);
l = 0; /* pp[] is already ok up to pp[l] */
q = p0 = p = exp(-mu);
}
repeat {
/* Step U. uniform sample for inversion method */
u = unif_rand(BOOM::GlobalRng::rng);
if (u <= p0)
return 0.;
/* Step T. table comparison until the end pp[l] of the
pp-table of cumulative poisson probabilities
(0.458 > ~= pp[9](= 0.45792971447) for mu=10 ) */
if (l != 0) {
for (k = (u <= 0.458) ? 1 : std::min(l, m); k <= l; k++)
if (u <= pp[k])
return (double)k;
if (l == 35) /* u > pp[35] */
continue;
}
/* Step C. creation of new poisson
probabilities p[l..] and their cumulatives q =: pp[k] */
l++;
for (k = l; k <= 35; k++) {
p *= mu / k;
q += p;
pp[k] = q;
if (u <= q) {
l = k;
return (double)k;
}
}
l = 35;
} /* end(repeat) */
}/* mu < 10 */
} /* end {initialize persistent vars} */
/* Only if mu >= 10 : ----------------------- */
/* Step N. normal sample */
g = mu + s * norm_rand(BOOM::GlobalRng::rng);/* norm_rand() ~ N(0,1), standard normal */
if (g >= 0.) {
pois = FLOOR(g);
/* Step I. immediate acceptance if pois is large enough */
if (pois >= big_l)
return pois;
/* Step S. squeeze acceptance */
fk = pois;
difmuk = mu - fk;
u = unif_rand(BOOM::GlobalRng::rng); /* ~ U(0,1) - sample */
if (d * u >= difmuk * difmuk * difmuk)
return pois;
}
/* Step P. preparations for steps Q and H.
(recalculations of parameters if necessary) */
if (new_big_mu || mu != muprev2) {
/* Careful! muprev2 is not always == muprev
because one might have exited in step I or S
*/
muprev2 = mu;
omega = M_1_SQRT_2PI / s;
/* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite
* approximations to the discrete normal probabilities fk. */
b1 = one_24 / mu;
b2 = 0.3 * b1 * b1;
c3 = one_7 * b1 * b2;
c2 = b2 - 15. * c3;
c1 = b1 - 6. * b2 + 45. * c3;
c0 = 1. - b1 + 3. * b2 - 15. * c3;
c = 0.1069 / mu; /* guarantees majorization by the 'hat'-function. */
}
if (g >= 0.) {
/* 'Subroutine' F is called (kflag=0 for correct return) */
kflag = 0;
goto Step_F;
}
repeat {
/* Step E. Exponential Sample */
E = exp_rand(BOOM::GlobalRng::rng); /* ~ Exp(1) (standard exponential) */
/* sample t from the laplace 'hat'
(if t <= -0.6744 then pk < fk for all mu >= 10.) */
u = 2 * unif_rand(BOOM::GlobalRng::rng) - 1.;
t = 1.8 + fsign(E, u);
if (t > -0.6744) {
pois = FLOOR(mu + s * t);
fk = pois;
difmuk = mu - fk;
/* 'subroutine' F is called (kflag=1 for correct return) */
kflag = 1;
Step_F: /* 'subroutine' F : calculation of px,py,fx,fy. */
if (pois < 10) { /* use factorials from table fact[] */
px = -mu;
py = pow(mu, pois) / fact[(int)pois];
}
else {
/* Case pois >= 10 uses polynomial approximation
a0-a7 for accuracy when advisable */
del = one_12 / fk;
del = del * (1. - 4.8 * del * del);
v = difmuk / fk;
if (fabs(v) <= 0.25)
px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) *
v + a3) * v + a2) * v + a1) * v + a0)
- del;
else /* |v| > 1/4 */
px = fk * log(1. + v) - difmuk - del;
py = M_1_SQRT_2PI / sqrt(fk);
}
x = (0.5 - difmuk) / s;
x *= x;/* x^2 */
fx = -0.5 * x;
fy = omega * (((c3 * x + c2) * x + c1) * x + c0);
if (kflag > 0) {
/* Step H. Hat acceptance (E is repeated on rejection) */
if (c * fabs(u) <= py * exp(px + E) - fy * exp(fx + E))
break;
} else
/* Step Q. Quotient acceptance (rare case) */
if (fy - u * fy <= py * exp(px - fx))
break;
}/* t > -.67.. */
}
return pois;
}
