/* sbart.f -- translated by f2c (version 20010821).

 * ------- and f2c-clean,v 1.9 2000/01/13

 *

 * According to the GAMFIT sources, this was derived from code by

 * Finbarr O'Sullivan.

 */

#include <R.h>

#include <Rmath.h>

#include <R_ext/PrtUtil.h>



#include "modreg.h"



/* 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

   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

   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 */

