int lnsrlb(integer *n, double *l, double *u,
integer *nbd, double *x, double *f, double *fold,
double *gd, double *gdold, double *g, double *d__,
double *r__, double *t, double *z__, double *stp,
double *dnorm, double *dtd, double *xstep, double *
stpmx, integer *iter, integer *ifun, integer *iback, integer *nfgv,
integer *info, integer *task, logical *boxed, logical *cnstnd, integer *
csave, integer *isave, double *dsave) /* ftnlen task_len, ftnlen
csave_len) */
{
/*
**********
Subroutine lnsrlb
This subroutine calls subroutine dcsrch from the Minpack2 library
to perform the line search. Subroutine dscrch is safeguarded so
that all trial points lie within the feasible region.
Subprograms called:
Minpack2 Library ... dcsrch.
Linpack ... dtrsl, ddot.
* * *
NEOS, November 1994. (Latest revision June 1996.)
Optimization Technology Center.
Argonne National Laboratory and Northwestern University.
Written by
Ciyou Zhu
in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
**********
*/
/* Table of constant values */
static double c_b14 = FTOL;
static double c_b15 = GTOL;
static double c_b16 = XTOL;
static double c_b17 = STEPMIN;
/* System generated locals */
integer i__1;
double d__1;
/* Local variables */
static integer i__;
static double a1, a2;
/* Parameter adjustments */
--z__;
--t;
--r__;
--d__;
--g;
--x;
--nbd;
--u;
--l;
--isave;
--dsave;
/* Function Body */
if ( *task == FG_LN ) {
goto L556;
}
*dtd = ddot(n, &d__[1], &c__1, &d__[1], &c__1);
*dnorm = sqrt(*dtd);
/* Determine the maximum step length. */
*stpmx = 1e10;
if (*cnstnd) {
if (*iter == 0) {
*stpmx = 1.;
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
a1 = d__[i__];
if (nbd[i__] != 0) {
if (a1 < 0. && nbd[i__] <= 2) {
a2 = l[i__] - x[i__];
if (a2 >= 0.) {
*stpmx = 0.;
} else if (a1 * *stpmx < a2) {
*stpmx = a2 / a1;
}
} else if (a1 > 0. && nbd[i__] >= 2) {
a2 = u[i__] - x[i__];
if (a2 <= 0.) {
*stpmx = 0.;
} else if (a1 * *stpmx > a2) {
*stpmx = a2 / a1;
}
}
}
/* L43: */
}
}
}
if (*iter == 0 && ! (*boxed)) {
/* Computing MIN */
d__1 = 1. / *dnorm;
*stp = min(d__1,*stpmx);
} else {
*stp = 1.;
}
dcopy(n, &x[1], &c__1, &t[1], &c__1);
dcopy(n, &g[1], &c__1, &r__[1], &c__1);
*fold = *f;
*ifun = 0;
*iback = 0;
*csave = START;
L556:
*gd = ddot(n, &g[1], &c__1, &d__[1], &c__1);
if (*ifun == 0) {
*gdold = *gd;
if (*gd >= 0.) {
/* the directional derivative >=0. */
/* Line search is impossible. */
/*
* printf("ascend direction in projection gd = %.2e\n", *gd );
* */
*info = -4;
return 0;
}
}
dcsrch(f, gd, stp, &c_b14, &c_b15, &c_b16, &c_b17, stpmx, csave, &isave[
1], &dsave[1]);/* (ftnlen)60);*/
*xstep = *stp * *dnorm;
if ( !(IS_WARNING(*csave)) && !(IS_CONVERGED(*csave)) ) {
/* if ( !( (csave>=WARNING)&&(csave<=WARNING_END) ) && */
/* !( (csave>=CONVERGENCE)&&(csave<=CONVERGENCE_END) ) ) { */
/* if (s_cmp(csave, "CONV", (ftnlen)4, (ftnlen)4) != 0 && s_cmp(csave, "WARN" */
/* , (ftnlen)4, (ftnlen)4) != 0) { */
*task = FG_LNSRCH;
++(*ifun);
++(*nfgv);
*iback = *ifun - 1;
if (*stp == 1.) {
dcopy(n, &z__[1], &c__1, &x[1], &c__1);
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = *stp * d__[i__] + t[i__];
/* L41: */
}
}
} else {
*task = NEW_X;
}
return 0;
} /* lnsrlb */
/**
* Maximum full pseudolikelihood method to estimate parameters.
*
* Minimization done by gradient L-BFGS with wolfe
*
* @param [in] p Number of variables
* @param [in,out] mu pdim Real vector. Mu parameter of the mv-vm dist
* @param [in,out] kappa pdim Real vector. Kappa parameter of the mv-vm dist
* @param [in,out] lambda pxp Real matrix on row-leading order. Lambda parameter of the mv-vm dist
* @param [in] n Number of samples
* @param [in] samples
* @param [in] phi Prior matrix
* @param [in] H Confidence matrix
* @param [in] verbose
* @param [in] prec
* @param [in] tol
* @param [in] mprec
* @param [in] lower
* @param [in] upper
* @param [in] bounded
*
* @returns Natural logarithm of the pseudolikelihood of the fitted distribution (aprox)
*/
double mvvonmises_lbfgs_fit(int p, double* mu, double* kappa, double* lambda, int n, double *samples, double* phi, double *H,
int verbose, double prec, double tol, int mprec, double *lower, double *upper, int *bounded ){
uint_fast16_t i,j,k;
/* Von Mises computation parameters*/
long double *S,*C,*ro;
double *d_kappa,*d_lambda;
S = malloc(sizeof(long double)*n*p*3);
C = S + (n*p);
ro = C + (n*p);
/* Set up instance */
multiCircularMean(n,p,samples,mu);
// Do the theta transformation
mv_theta_cos_sinTransform(n,p,samples,mu,S,C);
/* Derivatives */
d_kappa = malloc(sizeof(double)*(p+(p*p)));
d_lambda = d_kappa + p;
#ifdef DEBUG
double *d_kappa_fd,*d_lambda_fd;
d_kappa_fd = malloc(sizeof(double)*(p+(p*p)));
d_lambda_fd = d_kappa_fd + p;
#endif
/* LBFGS variables */
/* integer and logical types come from lbfgsb.h */
integer iprint = verbose; // No output
double factr = prec; // Moderate prec
double pgtol = tol; // Gradient tolerance
integer m = mprec; // Number of corrections
/* Fixd workspaces */
integer taskValue;
integer *task = &taskValue;
integer csaveValue;
integer *csave = &csaveValue;
integer isave[44];
double dsave[29];
logical lsave[4];
/* Dynamic parameters (Given, but we might have to cast)*/
integer nvar = ((p*p)-p)/2 + p; // Number of variables
double f = DBL_MAX; // Eval value
double *g = calloc(sizeof(double),nvar*4); // Gradient value
double *l = g+nvar; // lower bounds
double *u = l+nvar; // upper bounds
double *x = u+nvar; // Point value
integer *nbd = calloc(sizeof(integer),nvar);
/* Dynamic Workspaces*/
double *wa = calloc(sizeof(double),( (2*m + 5)*nvar + 11 * m * m + 8 * m));
integer *iwa = calloc(sizeof(integer) , 3 * nvar );
/* Copy parameters (this way so casting is done)*/
for(i=0;i<nvar; i++){
l[i] = lower[i] ;
u[i] = upper[i];
nbd[i] = bounded[i];
}
/* Copy initial values to X*/
// Kappa values
for(i=0;i<p;i++){
x[i] = kappa[i];
}
// Lambda values
for(i=0, k=0; i < (p-1) ; i++) {
for( j=(i+1) ; j < p ; j++, k++){
x[p+k] = lambda[ i*p + j];
}
}
/* Set task to START*/
*task = (integer)START;
do{
setulb(&nvar,&m,x,l,u,nbd,&f,g,&factr,&pgtol,wa,iwa,task,&iprint,csave,lsave,isave,dsave);
// If F and G comp. is requiered
if( IS_FG(*task) ){
// Copy kappa
memcpy(kappa,x,sizeof(double)*p);
// Copy lambda
matrixUpperToFull(p,x+p,lambda);
// Call loss function with current x
f = mv_vonmises_lossFunction(n,p,kappa,lambda,S,C,ro,d_kappa,d_lambda);
/*******************************************************/
#ifdef DEBUG
// Approx DF for kappa
for(i=0;i<p;i++){
kappa[i]+=1E-9;
d_kappa_fd[i] = (mv_vonmises_lossFunction(n,p,kappa,lambda,S,C,ro,NULL,NULL)-f)/1E-9 ;
kappa[i]-=1E-9;
printf("KAPPA(%d): calc %f \t fd approx: %f \t DIFF: %f \n",i,d_kappa[i],d_kappa_fd[i],fabs(d_kappa[i]-d_kappa_fd[i]));
}
// Approx DF for lambda
for(i=0;i<(p-1);i++){
for(j=i+1;j<p;j++){
lambda[i*p + j] += 1E-9 ;
lambda[j*p + i] += 1E-9 ;
d_lambda_fd[i*p + j] = (mv_vonmises_lossFunction(n,p,kappa,lambda,S,C,ro,NULL,NULL)-f)/1E-9 ;
d_lambda_fd[j*p + i] = d_lambda_fd[i*p + j];
printf("Lambda(%d,%d): calc %f \t fd approx: %f \t DIFF: %f \n",i,j,d_lambda[i*p + j],d_lambda_fd[i*p +j],fabs(d_lambda[i*p +j ]-d_lambda_fd[i*p + j]));
lambda[i*p + j] -= 1E-9 ;
lambda[j*p + i] -= 1E-9 ;
}
}
#endif
/**************************************************************/
// Kappa partials
memcpy(g,d_kappa,sizeof(double)*p);
// Apply penalization
if( (phi!=NULL) && (H != NULL) ){
double fnorm = 0;
double fnorm_term;
// Compute f norm
for (i=0; i < (p-1); i++) {
for (j=i+1; j < p; j++){
// RECALL: P is actually diag(kappa) - lambda
fnorm_term = (-lambda[ i*p + j] - phi[ i*p + j]) * H[ i*p + j];
fnorm += fnorm_term * fnorm_term;
}
}
// We also need to include kappa
for (i=0; i<p; i++){
fnorm_term = (kappa[ i ] - phi[ i*p + i]) * H[ i*p + i];
fnorm += fnorm_term * fnorm_term;
}
// Add norm to F
fnorm = sqrtl(fnorm);
//f += log(n)*fnorm; // What is this logn doing here???
f += fnorm;
#ifdef DEBUG
printf("MATRIX P:\n");
for(i=0; i<p ; i++){
for(j = 0 ; j<p ; j++){
if( j == i ) printf( "%f\t", kappa[j]);
else printf( "%f\t", -lambda[i*p + j]);
}
printf("\n");
}
printf("MATRIX Phi:\n");
for(i=0; i<p ; i++){
for(j = 0 ; j<p ; j++){
printf( "%f\t", phi[i*p + j]);
}
printf("\n");
}
printf("MATRIX H:\n");
for(i=0; i<p ; i++){
for(j = 0 ; j<p ; j++){
printf( "%f\t", H[i*p + j]);
}
printf("\n");
}
printf("FNORM: %f\n", fnorm);
#endif
if(fnorm != 0){
// Modify lambda partials
for (i=0; i < (p-1); i++) {
for (j=i+1; j < p; j++){
// RECALL: P is actually diag(kappa) - lambda
// d_lambda[i*p + j] += log(n) * (-H[i*p + j] * H[i*p + j] * ( (-lambda[i*p + j]) - phi[ i*p + j] ) / fnorm) ;
d_lambda[i*p + j] += (-H[i*p + j] * H[i*p + j] * ( (-lambda[i*p + j]) - phi[ i*p + j] ) / fnorm) ;
d_lambda[j*p + i] = d_lambda[i*p + j];
}
}
// Modify kappa partials
for (i=0; i<p; i++){
//d_kappa[i]+= log(n) * H[i*p + i] * H[i*p + i] * ( kappa[i] - phi[ i*p + i] ) / fnorm ;
d_kappa[i]+= H[i*p + i] * H[i*p + i] * ( kappa[i] - phi[ i*p + i] ) / fnorm ;
}
}
}
// Lambda partials (to vector)
for(i=0, k=0; i < (p-1) ; i++) {
for( j=(i+1) ; j < p ; j++, k++){
g[p+k] = d_lambda[ i*p + j];
}
}
}
// Additional stopping criteria to avoid infinite looping
else if( *task == NEW_X ){
/* Control number of iterations */
if(isave[33] >= 100 ){
*task = STOP_ITER;
}
/* Terminate if |proj g| / (1+|f|) < 1E-10 */
else if ( dsave[12] <= (fabs(f) + 1) * 1E-10 ){
*task = STOP_GRAD;
}
}
}while( IS_FG(*task) || *task==NEW_X);
/* Copy back x */
for(i=0;i<p;i++) kappa[i]=x[i];
matrixUpperToFull(p,x+p,lambda);
/** FreE*/
#ifdef DEBUG
free(d_kappa_fd);
#endif
free(S); free(d_kappa); free(g);
free(wa); free(iwa); free(nbd);
if( IS_ERROR(*task) || IS_WARNING(*task) )
return NAN;
else
return (double)f;
}
/* ======================= The end of lnsrlb ============================= */
int dcsrch(double *f, double *g, double *stp,
double *ftol, double *gtol, double *xtol, double *
stpmin, double *stpmax, integer *task, integer *isave, double *
dsave) /* ftnlen task_len) */
{
/* System generated locals */
double d__1;
/* Local variables */
static double fm, gm, fx, fy, gx, gy, fxm, fym, gxm, gym, stx, sty;
static integer stage;
static double finit, ginit, width, ftest, gtest, stmin, stmax, width1;
static logical brackt;
/*
**********
Subroutine dcsrch
This subroutine finds a step that satisfies a sufficient
decrease condition and a curvature condition.
Each call of the subroutine updates an interval with
endpoints stx and sty. The interval is initially chosen
so that it contains a minimizer of the modified function
psi(stp) = f(stp) - f(0) - ftol*stp*f'(0).
If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the
interval is chosen so that it contains a minimizer of f.
The algorithm is designed to find a step that satisfies
the sufficient decrease condition
f(stp) <= f(0) + ftol*stp*f'(0),
and the curvature condition
abs(f'(stp)) <= gtol*abs(f'(0)).
If ftol is less than gtol and if, for example, the function
is bounded below, then there is always a step which satisfies
both conditions.
If no step can be found that satisfies both conditions, then
the algorithm stops with a warning. In this case stp only
satisfies the sufficient decrease condition.
A typical invocation of dcsrch has the following outline:
task = 'START'
10 continue
call dcsrch( ... )
if (task .eq. 'FG') then
Evaluate the function and the gradient at stp
goto 10
end if
NOTE: The user must no alter work arrays between calls.
The subroutine statement is
subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax,
task,isave,dsave)
where
f is a double precision variable.
On initial entry f is the value of the function at 0.
On subsequent entries f is the value of the
function at stp.
On exit f is the value of the function at stp.
g is a double precision variable.
On initial entry g is the derivative of the function at 0.
On subsequent entries g is the derivative of the
function at stp.
On exit g is the derivative of the function at stp.
stp is a double precision variable.
On entry stp is the current estimate of a satisfactory
step. On initial entry, a positive initial estimate
must be provided.
On exit stp is the current estimate of a satisfactory step
if task = 'FG'. If task = 'CONV' then stp satisfies
the sufficient decrease and curvature condition.
ftol is a double precision variable.
On entry ftol specifies a nonnegative tolerance for the
sufficient decrease condition.
On exit ftol is unchanged.
gtol is a double precision variable.
On entry gtol specifies a nonnegative tolerance for the
curvature condition.
On exit gtol is unchanged.
xtol is a double precision variable.
On entry xtol specifies a nonnegative relative tolerance
for an acceptable step. The subroutine exits with a
warning if the relative difference between sty and stx
is less than xtol.
On exit xtol is unchanged.
stpmin is a double precision variable.
On entry stpmin is a nonnegative lower bound for the step.
On exit stpmin is unchanged.
stpmax is a double precision variable.
On entry stpmax is a nonnegative upper bound for the step.
On exit stpmax is unchanged.
task is a character variable of length at least 60.
On initial entry task must be set to 'START'.
On exit task indicates the required action:
If task(1:2) = 'FG' then evaluate the function and
derivative at stp and call dcsrch again.
If task(1:4) = 'CONV' then the search is successful.
If task(1:4) = 'WARN' then the subroutine is not able
to satisfy the convergence conditions. The exit value of
stp contains the best point found during the search.
If task(1:5) = 'ERROR' then there is an error in the
input arguments.
On exit with convergence, a warning or an error, the
variable task contains additional information.
isave is an integer work array of dimension 2.
dsave is a double precision work array of dimension 13.
Subprograms called
MINPACK-2 ... dcstep
MINPACK-1 Project. June 1983.
Argonne National Laboratory.
Jorge J. More' and David J. Thuente.
MINPACK-2 Project. October 1993.
Argonne National Laboratory and University of Minnesota.
Brett M. Averick, Richard G. Carter, and Jorge J. More'.
**********
*/
/* Initialization block. */
/* Parameter adjustments */
--dsave;
--isave;
/* Function Body */
if ( *task == START ) {
/* Check the input arguments for errors. See lbfgsb.h for messages */
if (*stp < *stpmin) *task=ERROR_SMALLSTP;
if (*stp > *stpmax) *task=ERROR_LARGESTP;
if (*g >= 0.) *task=ERROR_INITIAL;
if (*ftol < 0.) *task=ERROR_FTOL;
if (*gtol < 0.) *task=ERROR_GTOL;
if (*xtol < 0.) *task=ERROR_XTOL;
if (*stpmin < 0.) *task=ERROR_STP0;
if (*stpmax < *stpmin) *task=ERROR_STP1;
/* Exit if there are errors on input. */
if ( IS_ERROR(*task) ) {
return 0;
}
/* Initialize local variables. */
brackt = FALSE_;
stage = 1;
finit = *f;
ginit = *g;
gtest = *ftol * ginit;
width = *stpmax - *stpmin;
width1 = width / .5;
/* The variables stx, fx, gx contain the values of the step, */
/* function, and derivative at the best step. */
/* The variables sty, fy, gy contain the value of the step, */
/* function, and derivative at sty. */
/* The variables stp, f, g contain the values of the step, */
/* function, and derivative at stp. */
stx = 0.;
fx = finit;
gx = ginit;
sty = 0.;
fy = finit;
gy = ginit;
stmin = 0.;
stmax = *stp + *stp * 4.;
/* s_copy(task, "FG", task_len, (ftnlen)2); */
*task = FG;
goto L1000;
} else {
/* Restore local variables. */
if (isave[1] == 1) {
brackt = TRUE_;
} else {
brackt = FALSE_;
}
stage = isave[2];
ginit = dsave[1];
gtest = dsave[2];
gx = dsave[3];
gy = dsave[4];
finit = dsave[5];
fx = dsave[6];
fy = dsave[7];
stx = dsave[8];
sty = dsave[9];
stmin = dsave[10];
stmax = dsave[11];
width = dsave[12];
width1 = dsave[13];
}
/* If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the */
/* algorithm enters the second stage. */
ftest = finit + *stp * gtest;
if (stage == 1 && *f <= ftest && *g >= 0.) {
stage = 2;
}
/* Test for warnings. */
if (brackt && (*stp <= stmin || *stp >= stmax)) {
*task = WARNING_ROUND;
}
if (brackt && stmax - stmin <= *xtol * stmax) {
*task = WARNING_XTOL;
}
if (*stp == *stpmax && *f <= ftest && *g <= gtest) {
*task = WARNING_STPMAX;
}
if (*stp == *stpmin && (*f > ftest || *g >= gtest)) {
*task = WARNING_STPMIN;
}
/* Test for convergence. */
if (*f <= ftest && abs(*g) <= *gtol * (-ginit)) {
*task = CONVERGENCE;
}
/* Test for termination. */
/* if ( ( (task>=WARNING)&&(task<=WARNING_END) ) || */
/* ( (task>=CONVERGENCE)&&(task<=CONVERGENCE_END) ) ) { */
if ( (IS_WARNING(*task)) || (IS_CONVERGED(*task) ) ) {
goto L1000;
}
/* A modified function is used to predict the step during the */
/* first stage if a lower function value has been obtained but */
/* the decrease is not sufficient. */
if (stage == 1 && *f <= fx && *f > ftest) {
/* Define the modified function and derivative values. */
fm = *f - *stp * gtest;
fxm = fx - stx * gtest;
fym = fy - sty * gtest;
gm = *g - gtest;
gxm = gx - gtest;
gym = gy - gtest;
/* Call dcstep to update stx, sty, and to compute the new step. */
dcstep(&stx, &fxm, &gxm, &sty, &fym, &gym, stp, &fm, &gm, &brackt, &
stmin, &stmax);
/* Reset the function and derivative values for f. */
fx = fxm + stx * gtest;
fy = fym + sty * gtest;
gx = gxm + gtest;
gy = gym + gtest;
} else {
/* Call dcstep to update stx, sty, and to compute the new step. */
dcstep(&stx, &fx, &gx, &sty, &fy, &gy, stp, f, g, &brackt, &stmin, &
stmax);
}
/* Decide if a bisection step is needed. */
if (brackt) {
if ((d__1 = sty - stx, abs(d__1)) >= width1 * .66) {
*stp = stx + (sty - stx) * .5;
}
width1 = width;
width = (d__1 = sty - stx, abs(d__1));
}
/* Set the minimum and maximum steps allowed for stp. */
if (brackt) {
stmin = min(stx,sty);
stmax = max(stx,sty);
} else {
stmin = *stp + (*stp - stx) * 1.1;
stmax = *stp + (*stp - stx) * 4.;
}
/* Force the step to be within the bounds stpmax and stpmin. */
*stp = max(*stp,*stpmin);
*stp = min(*stp,*stpmax);
/* If further progress is not possible, let stp be the best */
/* point obtained during the search. */
/* if (brackt && (*stp <= stmin || *stp >= stmax) || brackt && stmax - stmin */
/* SRB: guess the precedence. && precedence over || */
if ( (brackt && (*stp <= stmin || *stp >= stmax) ) || (brackt && stmax - stmin
<= *xtol * stmax)) {
*stp = stx;
}
/* Obtain another function and derivative. */
/* s_copy(task, "FG", task_len, (ftnlen)2); */
*task = FG;
L1000:
/* Save local variables. */
if (brackt) {
isave[1] = 1;
} else {
isave[1] = 0;
}
isave[2] = stage;
dsave[1] = ginit;
dsave[2] = gtest;
dsave[3] = gx;
dsave[4] = gy;
dsave[5] = finit;
dsave[6] = fx;
dsave[7] = fy;
dsave[8] = stx;
dsave[9] = sty;
dsave[10] = stmin;
dsave[11] = stmax;
dsave[12] = width;
dsave[13] = width1;
return 0;
} /* dcsrch */
