/** *************************************************************************************************************************/
double compute_mlik_pois_marg_brent(double finitestepsize, void *params)
{
struct fnparams *gparams = ((struct fnparams *) params);
gsl_vector *myBeta=gparams->betastatic;
int n=gparams->nDim;
int m=gparams->mDim;
gsl_permutation *perm=gparams->perm;
gsl_matrix *hessgvalues=gparams->mattmp2;
gsl_matrix *hessgvalues3pt=gparams->mattmp3;
double gvalue=gparams->gvalue;
int status,sss;
double mydet;
double logscore,logscore3pt;
double error_val=0.0;
/** ***/
/*double finitestepsize=gsl_vector_get(finitestepsize_vec,0);*/
/** ***/
/*Rprintf("got h=%e n=%d m=%d gvalue=%e\n",finitestepsize,n,m,gvalue);*/
/*for(i=0;i<myBeta->size;i++){Rprintf("beta= %f ",gsl_vector_get(myBeta,i));}Rprintf("\n");*/
rv_hessg_pois_outer_marg(myBeta,gparams, hessgvalues,finitestepsize,hessgvalues3pt);/** start with LARGEST STEPSIZE **/
/*for(i=0;i<hessgvalues3pt->size1;i++){for(j=0;j<hessgvalues3pt->size2;j++){Rprintf("%e ",gsl_matrix_get(hessgvalues3pt,i,j));}Rprintf("\n");}*/
status=gsl_linalg_LU_decomp(hessgvalues,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
status=gsl_linalg_LU_decomp(hessgvalues3pt,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues3pt);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore3pt= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
error_val=fabs(logscore-logscore3pt);
/*Rprintf("error_val=%e\n",error_val);*/
/*gparams->logscore=logscore;
gparams->logscore3pt=logscore3pt;*/
/*Rprintf("logscore=%e logscore3pt=%e\n",logscore,logscore3pt);*/
if(gsl_isnan(error_val) || gsl_isinf(error_val)){return(DBL_MAX);/*error("Non-finite value in mlik error estimation");*/}
return(error_val);
}
double gaussian_pdf_log(const gaussian_t* dist,
const gsl_vector* x) {
double r = 0.0;
double logdet = 0.0;
if (gaussian_isdiagonal(dist)) {
size_t i;
double dx, dd;
for (i = 0; i < dist->dim; i++) {
dx = gsl_vector_get(x, i) - gsl_vector_get(dist->mean, i);
dd = gsl_vector_get(dist->diag, i);
r += dx * dx / dd;
logdet += DEBUG_LOG(dd);
}
}
else {
int signum;
gsl_vector* w1 = gsl_vector_alloc(dist->dim);
gsl_vector* w2 = gsl_vector_alloc(dist->dim);
gsl_vector_memcpy(w1, x);
gsl_vector_sub(w1, dist->mean);
gsl_matrix* v = gsl_matrix_alloc(dist->dim, dist->dim);
gsl_matrix_memcpy(v, dist->cov);
gsl_permutation* p = gsl_permutation_alloc(dist->dim);
gsl_linalg_LU_decomp(v, p, &signum);
gsl_linalg_LU_solve(v, p, w1, w2);
gsl_blas_ddot(w1, w2, &r);
logdet = gsl_linalg_LU_lndet(v);
assert(gsl_linalg_LU_sgndet(v, signum) == 1.0);
gsl_vector_free(w1);
gsl_vector_free(w2);
gsl_matrix_free(v);
gsl_permutation_free(p);
}
/* Use log to avoid underflow !
here
r = (x - mean)^T * cov^-1 * (x - mean)
logdet = log(det(cov))
then
logpdf = -.5 * (k * log(2*pi) + logdet + r);
*/
r = r + dist->dim * DEBUG_LOG(2 * M_PI) + logdet;
r = -0.5 * r;
assert(!isnan(r));
return r;
}
double mygsl_linalg_det(const gsl_matrix * A)
{
double det = NaN;
gsl_matrix * tmp = gsl_matrix_alloc(A->size1, A->size2);
gsl_matrix_memcpy(tmp, A);
gsl_permutation * perm = gsl_permutation_alloc(A->size1);
int signum;
gsl_linalg_LU_decomp(tmp, perm, &signum);
gsl_linalg_LU_lndet(tmp);
gsl_matrix_free(tmp);
gsl_permutation_free(perm);
return det;
}
double compute_mlik(double finitestepsize, void *params)
{
struct fnparams *gparams = ((struct fnparams *) params);
gsl_vector *myBeta=gparams->betaincTau;
int n=gparams->nDim;
int m=gparams->mDim;
gsl_permutation *perm=gparams->perm;
gsl_matrix *hessgvalues=gparams->mattmp2;
gsl_matrix *hessgvalues3pt=gparams->mattmp3;
double gvalue=gparams->betafixed;
int status,sss;
double mydet;
double logscore,logscore3pt;
/*int i,j;*/
/*Rprintf("got h=%e n=%d m=%d gvalue=%e\n",finitestepsize,n,m,gvalue);
for(i=0;i<myBeta->size;i++){Rprintf("beta= %f ",gsl_vector_get(myBeta,i));}Rprintf("\n");
*/
rv_hessg_outer(myBeta,gparams, hessgvalues,finitestepsize,hessgvalues3pt);/** start with LARGEST STEPSIZE **/
/*for(i=0;i<hessgvalues3pt->size1;i++){for(j=0;j<hessgvalues3pt->size2;j++){Rprintf("%e ",gsl_matrix_get(hessgvalues3pt,i,j));}Rprintf("\n");}*/
status=gsl_linalg_LU_decomp(hessgvalues,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
status=gsl_linalg_LU_decomp(hessgvalues3pt,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues3pt);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore3pt= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
/*gparams->logscore=logscore;
gparams->logscore3pt=logscore3pt;*/
/*Rprintf("logscore=%e logscore3pt=%e\n",logscore,logscore3pt);*/
return(fabs(logscore-logscore3pt));
}
/*
* log determinant using blas
*
*/
double log_det(gsl_matrix* m) {
gsl_matrix* lu;
gsl_permutation* p;
double result;
int signum;
p = gsl_permutation_alloc(m->size1);
lu = gsl_matrix_alloc(m->size1, m->size2);
gsl_matrix_memcpy(lu, m);
gsl_linalg_LU_decomp(lu, p, &signum);
result = gsl_linalg_LU_lndet(lu);
gsl_matrix_free(lu);
gsl_permutation_free(p);
return(result);
}
double execute_chi2_t(chi2_t *chichi)
{
//-- Let Delta X = X_model - X_obs,
//-- L = 1 / sqrt[(2 pi)^d * det(Cov)] * exp[-0.5 *(Delta X)^T * Cov^-1 * (Delta X)]
//-- -2 ln L = -2 * [ -0.5 * ln (2 pi)^d - 0.5 * ln det(Cov) - 0.5 * (Delta X)^T * Cov^-1 * (Delta X) ]
//-- = cst + ln det(Cov) + (Delta X)^T * Cov^-1 * (Delta X)
//-- We set chi2 = ln det(Cov) + (Delta X)^T * Cov^-1 * (Delta X)
//-- data should be N*d matrix
int N = chichi->N;
int d = chichi->d;
gsl_vector *X_model = chichi->X_model;
double value;
gsl_vector_sub(X_model, chichi->X_obs); //-- X_model -= X_obs
gsl_blas_dsymv(CblasUpper, 1.0, chichi->invCov, X_model, 0.0, chichi->intermediate); //-- intermediate = invCov * (X_model - X_obs)
gsl_blas_ddot(X_model, chichi->intermediate, &value);
value += gsl_linalg_LU_lndet(chichi->cov);
return value;
}
/**
* C++ version of gsl_linalg_LU_lndet().
* @param LU An LU decomposition matrix
* @return The logarithm of the absolute value of
* the determinant of the matrix with LU decomposition @c LU
*/
inline double LU_lndet( matrix& LU ){ return gsl_linalg_LU_lndet( LU.get() ); }
/** ****************************************************************************************************
***** calc an individual logistic regression model
*******************************************************************************************************/
void calc_node_Score_binary_rv_R(network *dag, datamatrix *obsdata, int nodeid, int errverbose,
datamatrix *designmatrix, const double priormean, const double priorsd, const double priorgamshape, const double priorgamscale,
const int maxiters, const double epsabs,int storeModes, double epsabs_inner, int maxiters_inner, double finitestepsize, int verbose,
double h_guess, double h_epsabs, int maxiters_hessian, int ModesONLY,
double max_hessian_error,double myfactor_brent, int maxiters_hessian_brent, double num_intervals_brent)
{
#ifdef NOPRIOR
Rprintf("############ Warning - Priors turned off - use only for checking mlik value! ################\n");
#endif
int i,status=GSL_SUCCESS,sss,index=0,iter;
/*int j;*/
gsl_vector *myBeta,*vectmp1,*vectmp2,*vectmp1long,*vectmp2long,*localbeta,*localbeta2,/* *dgvalues,*/ *finitefactors,/* *factorindexes,*/ *finitestepsize_vec=0,*nmstepsize=0;/** this will hold the parameter point estimates + 1 is for precision of rv's */
struct fnparams gparams;/** for passing to the gsl zero finding functions */
double gvalue;double nm_size=0.0;
gsl_matrix *mattmp2,*mattmp3,*mattmp4,*hessgvalues,*hessgvalues3pt;
double mydet=0.0,logscore=0.0;/*,logscore3pt=0.0;*/
gsl_permutation *initsperm;
gsl_permutation *perm=0;
const gsl_multimin_fminimizer_type *T;
gsl_multimin_fminimizer *s;
gsl_multimin_function F;
double lower,upper,lower_f,upper_f;int found=0; double delta=0.0,new_f_min=0.0, finitestepsize_nm=0.0, increLogscale=0.0, best_Error=0.0,best_h=0.0;
const gsl_min_fminimizer_type *T1;
gsl_min_fminimizer *s1;
int n,m;
/* double min_error,cur_error,accurate_logscore=0,accurate_logscore3pt=0,bestsize=0,lowerend,upperend,h_guess,h_epsabs;*/
/*const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
gsl_function F;*/
/*double h_lowerbound[1],h_upperbound[1],h_guess_array[1];
int h_nbd[1];*/
int nDim;/** dimension of optim problem */
int *nbd;/** nbd is an integer array of dimension nDim.
On entry nbd represents the type of bounds imposed on the variables, and must be specified as follows:
nbd(i)=0 if x(i) is unbounded,
1 if x(i) has only a lower bound,
2 if x(i) has both lower and upper bounds, and
3 if x(i) has only an upper bound.
On exit nbd is unchanged.*/
double *lowerbounds,*upperbounds; /* h_gvalue;*//*,lowestHesserror,beststepsize;*/
int failcode;/** check code see R ?optim - if non-zero then a problem **/
double factr=1e-07;/** error size scaler - this is the default value*/
double pgtol=1e-07;/** default value is zero - this is the gradient tolerance - mmm what does that actually mean? */
int fncount,grcount;/** hold number of evaluations */
char msg[60];/** error message */
int trace=errverbose;/** like verbose */
int nREPORT=1000;/** report freq*/
int lmm=5;/** see R ?optim - number of function evals to store - default is 5 */
/** want to find the modes of the function g(betas) where betas=b_0,b_1,,...,tau, the latter being precision */
/** g(betas) is not differentiable as it contains integrals (which themselves need Laplace estimates **/
/** SETUP things which are the same across all data chunks - groups */
/** build design matrix which is designmatrix->datamatrix=X, designmatrix->Y=Y plus priors designmatrix->priorsd, designmatrix->priormean **/
/** NOTE: design matrix here does include the random effect term **/
/** note - numparams does NOT include precision term - numpars +1 */
build_designmatrix_rv(dag,obsdata,priormean, priorsd,priorgamshape,priorgamscale,designmatrix,nodeid,storeModes);
nDim=designmatrix->numparams+1;
lowerbounds=(double *)R_alloc(nDim,sizeof(double*));
upperbounds=(double *)R_alloc(nDim,sizeof(double*));
nbd=(int *)R_alloc(nDim,sizeof(int*));
for(i=0;i<nDim-1;i++){lowerbounds[i]=-DBL_MAX;
upperbounds[i]=DBL_MAX;
nbd[i]=0;}
nbd[nDim-1]=1;lowerbounds[nDim-1]=0.001;/** lower bound for precision */
finitefactors = gsl_vector_alloc(7);/** used to change stepsize in hessian estimate **/
gsl_vector_set(finitefactors,0,1.0E-03);gsl_vector_set(finitefactors,1,1.0E-02);gsl_vector_set(finitefactors,2,1.0E-01);
gsl_vector_set(finitefactors,3,1.0);gsl_vector_set(finitefactors,4,1.0E+01);gsl_vector_set(finitefactors,5,1.0E+02);
gsl_vector_set(finitefactors,6,1.0E+03);
/*factorindexes = gsl_vector_alloc(7);*//** used to change stepsize in hessian estimate **/
/*for(i=0;i<7;i++){gsl_vector_set(factorindexes,i,i);}*/
/** change finite.step.size by 0.1,1, and 10 factors respectively **/
/*dgvalues = gsl_vector_alloc (designmatrix->numparams+1);*//** inc rv precision */
myBeta = gsl_vector_alloc (designmatrix->numparams+1);/** inc rv precision */
vectmp1 = gsl_vector_alloc (designmatrix->numparams);/** scratch space **/
vectmp2 = gsl_vector_alloc (designmatrix->numparams);/** scratch space **/
mattmp2 = gsl_matrix_alloc (obsdata->numDataPts,designmatrix->numparams);
mattmp3 = gsl_matrix_alloc (designmatrix->numparams,designmatrix->numparams);
mattmp4 = gsl_matrix_alloc (designmatrix->numparams,designmatrix->numparams);
initsperm = gsl_permutation_alloc (designmatrix->numparams);/** for use with initial guesses */
vectmp1long = gsl_vector_alloc (obsdata->numDataPts);/** scratch space **/
vectmp2long = gsl_vector_alloc (obsdata->numDataPts);
localbeta = gsl_vector_alloc (designmatrix->numparams);/** scratch space in later functions - excl. precision **/
localbeta2 = gsl_vector_alloc (designmatrix->numparams+1);/** scratch space in later functions - inc. precision **/
hessgvalues = gsl_matrix_alloc (designmatrix->numparams+1,designmatrix->numparams+1);
hessgvalues3pt = gsl_matrix_alloc (designmatrix->numparams+1,designmatrix->numparams+1);
gparams.designdata=designmatrix;
gparams.vectmp1=vectmp1;
gparams.vectmp2=vectmp2;
gparams.mattmp2=mattmp2;
gparams.mattmp3=mattmp3;
gparams.mattmp4=mattmp4;
gparams.perm=initsperm;
gparams.vectmp1long=vectmp1long;
gparams.vectmp2long=vectmp2long;
gparams.beta=localbeta;
gparams.betaincTau=localbeta2;
gparams.epsabs_inner=epsabs_inner;
gparams.maxiters_inner=maxiters_inner;
gparams.verbose=verbose;
gparams.finitestepsize=finitestepsize;
dag->nodeScoresErrCode[nodeid]=0;/** reset error code to no error **/
/*status=GSL_SUCCESS;*/
generate_rv_inits(myBeta,&gparams);
/*Rprintf("starting optimisation\n");*/
/** run a loop over different stepsize - starting with the smallest first as this is more likely successful **/
for(i=0;i<finitefactors->size;i++){/** go forwards through the factors so start with SMALLEST STEPSIZE */
/*Rprintf("step size iteration %d\n",i);*/
failcode=0;/** reset*/
gparams.finitestepsize=gsl_vector_get(finitefactors,i)*finitestepsize;
lbfgsb(nDim, lmm, myBeta->data, lowerbounds, upperbounds, nbd, &gvalue, &g_outer_R,
&rv_dg_outer_R, &failcode,
&gparams,
factr,
pgtol, &fncount, &grcount,
maxiters, msg, trace, nREPORT);
if(!failcode){dag->nodeScoresErrCode[nodeid]=0;/*bestsize=gparams.finitestepsize;*/break;}/** break out of for loop if no error as we are done **/
} /** end of for loop so now have mode estimates */
if(failcode){Rprintf("%s at node %d\n",msg,nodeid+1);/** notify if there is an error and set final error code **/
dag->nodeScoresErrCode[nodeid]=1;
}
gparams.finitestepsize=finitestepsize;/** reset */
if(storeModes){/** keep a copy of the parameter modes found for use later in other function calls etc**/
index=0; /*Rprintf("size of beta=%d %f %f\n",myBeta->size, gsl_vector_get(myBeta,0),gsl_vector_get(myBeta,1));*/
for(i=0;i<dag->numNodes+3;i++){/** roll myBeta into dag->modes into the appropriate columns**/
if(gsl_matrix_get(dag->modes,nodeid,i)!=DBL_MAX){
gsl_matrix_set(dag->modes,nodeid,i,gsl_vector_get(myBeta,index++));}}
/*for(i=0;i<dag->numNodes+3;i++){Rprintf("%e ",gsl_matrix_get(dag->modes,nodeid,i));}Rprintf("\n");*/
}
if(!ModesONLY){/** only want modes so can skip the rest **/
/** now compute the hessian at the step size with lowest error **/
/*Rprintf("starting hessian estimation\n");*/
n=obsdata->numDataPts;
m=designmatrix->numparams+1;/** inc precision */
perm = gsl_permutation_alloc (m);
/** just re-use as much of existing gparams as possible - so names are meaningless e.g. betafixed is actually gvalue */
gparams.betaincTau=myBeta;
gparams.nDim=n;
gparams.mDim=m;
gparams.perm=perm;
gparams.mattmp2=hessgvalues;
gparams.mattmp3=hessgvalues3pt;
gparams.betafixed=gvalue;
F.f = &compute_mlik_nm;
F.params = &gparams;
F.n = 1;
T = gsl_multimin_fminimizer_nmsimplex2;
s = gsl_multimin_fminimizer_alloc (T, 1);
finitestepsize_vec = gsl_vector_alloc (1);
gsl_vector_set (finitestepsize_vec, 0, h_guess);
nmstepsize = gsl_vector_alloc (1);
gsl_vector_set_all (nmstepsize, h_guess);
gsl_multimin_fminimizer_set (s, &F, finitestepsize_vec,nmstepsize);
status = GSL_SUCCESS;
iter=0;
do
{
iter++;/*Rprintf("iter=%d\n",iter);*/
status = gsl_multimin_fminimizer_iterate (s);
if (status)
break;
nm_size = gsl_multimin_fminimizer_size (s);
status = gsl_multimin_test_size (nm_size, h_epsabs);
/*
if (status == GSL_SUCCESS)
{
Rprintf ("converged to minimum at\n");
}
*/
/*Rprintf ("iter=%5d error in mlik=%3.5e using fin.diff step= %3.2e nmsize=%3.2e\n", iter,s->fval,gsl_vector_get (s->x, 0),nm_size);*/
}
while (status == GSL_CONTINUE && iter < maxiters_hessian);
if( (status != GSL_SUCCESS)){/*actual_status=status;*//** copy for use later **/
status=GSL_FAILURE;} /** solution failed to achieve a value below h_epsabs **/
finitestepsize=gsl_vector_get(s->x,0);/** get best fin.diff stepsize **/
finitestepsize_nm=finitestepsize;/** save nelder mead estimate */
dag->hessianError[nodeid]= s->fval;/** get fin.diff error **/
gsl_multimin_fminimizer_free (s);
/** README - it might be possible to avoid the brent by increasing the epsabs error in nelder mead (and no. of iterations), although for hard cases
this probably will not work but may give a little greater accuracy for easier cases, These are the hessian.params arg in R */
if(dag->hessianError[nodeid]!=DBL_MAX && dag->hessianError[nodeid]>max_hessian_error){Rprintf("Error in mlik = %e > tolerance of %e so continuing optimisation using Brent initial guess h=%e\n",
dag->hessianError[nodeid],max_hessian_error,finitestepsize);
/* Rprintf("stepsize after NM= %e\n",finitestepsize);*/
T1 = gsl_min_fminimizer_brent;
s1 = gsl_min_fminimizer_alloc (T1);
/** must find lower and upper such that f(lower)<f(finitestepsize)<f(upper) **/
/** use an interval of lower=finitestepsize/FACTOR, upper=finitestepsize*FACTOR and then start at the lower end and travel up until
find suitable endpoints - seems to work but not exactly fast!**/
best_Error=dag->hessianError[nodeid];/** original error from nelder */
best_h=finitestepsize; /** original stepsize from nelder */
found=0;/** flag for found good result */
lower=finitestepsize/myfactor_brent;
upper=myfactor_brent*finitestepsize;
lower_f=compute_mlik_brent(lower, &gparams);/** value at lower point **/
upper_f=compute_mlik_brent(upper, &gparams);/** value at higher point **/
increLogscale=(gsl_sf_log(upper)-gsl_sf_log(lower))/num_intervals_brent;/** on a log scale */
for(delta=gsl_sf_log(lower)+increLogscale;delta<gsl_sf_log(upper);delta+=increLogscale){/** linear increments on a log scale **/
R_CheckUserInterrupt();/** allow an interupt from R console */
/** find a point which has f(x) lower than f(lower) and f(upper) **/
new_f_min=compute_mlik_brent(gsl_sf_exp(delta), &gparams);
/* Rprintf("lower=%e, delta=%e, upper=%e\n",lower,gsl_sf_exp(delta),upper);*/
if(lower_f>new_f_min && new_f_min<upper_f && get_best_stepsize(gsl_sf_exp(delta),lower,upper,maxiters_hessian_brent,&gparams, &compute_mlik_brent,
s1,&finitestepsize,&(dag->hessianError[nodeid]) )<=max_hessian_error){/** have an interval suitable for bracketing **/
/** above is address so can store error withouth rerunning function */
/*finitestepsize=delta;*/
found=1;
status=GSL_SUCCESS;
break;/** break out of delta - so have found new x_min **/
} else {/** have not got a good enough error but save the best error and stepsize so far found **/
if(dag->hessianError[nodeid]<best_Error){best_Error=dag->hessianError[nodeid];
best_h=finitestepsize;
}
}
} /** end of search for interval and good error **/
if(!found){/** have not found a suitably small error but may have found a better error than nelder mead **/
/** best_Error will either be the original nelder mean value or better, and best_h is the corresponding stepsize**/
dag->hessianError[nodeid]=best_Error;
finitestepsize=best_h;
/** reset back to nelder-mead estimate **/
status=GSL_FAILURE;/** set to failure since we did not achieve the lower error asked for */
Rprintf("failed to meet tolerance of %e and using best error estimate found of %e\n",max_hessian_error,dag->hessianError[nodeid]);}
gsl_min_fminimizer_free (s1);
} /** end of error being too large **/
if(dag->hessianError[nodeid]==DBL_MAX){/** in this case nelder mead could not estimate the hessian error so abort as something is probably
very wrong here */
error("");}/** use the R tryCatch rather than the switch for status below **/
switch(status){ /** choose which type of node we have */
case GSL_SUCCESS:{
/** successful finite diff so now do final computation with the optimal step size **/
/*Rprintf("search for optimal step size : status = %s at nodeid %d\n", gsl_strerror (status),nodeid+1);*/
rv_hessg_outer(myBeta,&gparams, hessgvalues,finitestepsize,hessgvalues3pt);/** EDIT BACK to "finitestepsize" start with LARGEST STEPSIZE **/
/* Rprintf("HESSIAN using stepsize=%e\n",finitestepsize);
for(i1=0;i1<hessgvalues->size1;i1++){
for(i2=0;i2<hessgvalues->size2;i2++){Rprintf("%e ",gsl_matrix_get(hessgvalues,i1,i2));}Rprintf("\n");} */
status=gsl_linalg_LU_decomp(hessgvalues,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
if(gsl_isnan(logscore)){logscore= R_NaN;dag->nodeScoresErrCode[nodeid]=2;}
dag->nodeScores[nodeid]=logscore;
break;
}
case GSL_FAILURE: {/** the minimiser did not find a minimum meeting the accuracy requirements and so may be unreliable **/
Rprintf ("-- ERROR! -- search for optimal step size error: status = %s at nodeid %d\n", gsl_strerror (status),nodeid+1);
rv_hessg_outer(myBeta,&gparams, hessgvalues,finitestepsize,hessgvalues3pt);/** start with LARGEST STEPSIZE **/
/*Rprintf("HESSIAN using stepsize=%e\n",finitestepsize);
for(i1=0;i1<hessgvalues->size1;i1++){
for(i2=0;i2<hessgvalues->size2;i2++){Rprintf("%e ",gsl_matrix_get(hessgvalues,i1,i2));}Rprintf("\n");} */
status=gsl_linalg_LU_decomp(hessgvalues,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
dag->nodeScoresErrCode[nodeid]=4;
if(gsl_isnan(logscore)){logscore= R_NaN;dag->nodeScoresErrCode[nodeid]=2;}
dag->nodeScores[nodeid]=logscore;
break;
}
default:{Rprintf("got case %s\n",gsl_strerror (status)); error("in default switch in calc_node_Score_binary_rv_R() - should never get here!");}
}
/** try the bounded search for h stepsize rather than one-dim min which needs bound specified **/
} /** end of ModesONLY **/
/** now free up allocated memory **/
for(i=0;i<designmatrix->numUnqGrps;i++){gsl_matrix_free(designmatrix->array_of_designs[i]);
gsl_vector_free(designmatrix->array_of_Y[i]);}
gsl_vector_free(designmatrix->priormean);
gsl_vector_free(designmatrix->priorsd);
gsl_vector_free(designmatrix->priorgamshape);
gsl_vector_free(designmatrix->priorgamscale);
gsl_vector_free(designmatrix->Y);
gsl_matrix_free(designmatrix->datamatrix_noRV);
/*gsl_vector_free(dgvalues);*/
gsl_vector_free(myBeta);
gsl_vector_free(vectmp1);
gsl_vector_free(vectmp2);
gsl_matrix_free(mattmp2);
gsl_matrix_free(mattmp3);
gsl_matrix_free(mattmp4);
gsl_permutation_free(initsperm);
gsl_vector_free(vectmp1long);
gsl_vector_free(vectmp2long);
gsl_vector_free(localbeta);
gsl_vector_free(localbeta2);
gsl_matrix_free(hessgvalues);
gsl_matrix_free(hessgvalues3pt);
gsl_vector_free(finitefactors);
/*gsl_vector_free(factorindexes);*/
if(!ModesONLY){/** didn't allocate these so don't unallocate! */
gsl_permutation_free(perm);
gsl_vector_free(finitestepsize_vec);
gsl_vector_free(nmstepsize);}
/*if(!failcode){*//*}*/
/*dag->nodeScores[nodeid]=logscore;*/
}
double Matrix::lnAbsDetLU () const {
return gsl_linalg_LU_lndet( const_cast<gsl_matrix*>( &matrix ) );
}
/** ****************************************************************************************************
***** calc an individual logistic regression model
*******************************************************************************************************/
void calc_poisson_marginal_rv_R(network *dag, datamatrix *obsdata, int nodeid, int errverbose,
datamatrix *designmatrix, const double priormean, const double priorsd, const double priorgamshape, const double priorgamscale,
const int maxiters, const double epsabs, double epsabs_inner, int maxiters_inner, double finitestepsize, int verbose,
double h_guess, double h_epsabs, int maxiters_hessian,
double *denom_modes, int paramid, double betafixed, double mlik, double *posterior,
double max_hessian_error,double myfactor_brent, int maxiters_hessian_brent, double num_intervals_brent){
int i,j,status,sss,haveprecision,iter=0;
gsl_vector *myBeta,*vectmp1,*vectmp2,*vectmp1long,*vectmp2long,*localbeta,*localbeta2,/* *dgvalues,*/ *betafull,*finitefactors,*finitestepsize_vec,*nmstepsize;/** this will hold the parameter point estimates + 1 is for precision of rv's */
struct fnparams gparams;/** for passing to the gsl zero finding functions */
double gvalue;
gsl_matrix *mattmp2,*mattmp3,*mattmp4,*hessgvalues,*hessgvaluesfull,*hessgvalues3pt,*hessgvaluesfull3pt;
double mydet=0.0,logscore=0.0;
gsl_permutation *initsperm;
gsl_permutation *perm=0;
int n,m;
double val=0.0;double nm_size=0.0;
const gsl_multimin_fminimizer_type *T;
gsl_multimin_fminimizer *s;
gsl_multimin_function F;
double lower,upper,lower_f,upper_f;int found=0; double delta=0.0,new_f_min=0.0;
double increLogscale=0.0, best_Error=0.0,best_h=0.0, hessian_Error=0.0;
const gsl_min_fminimizer_type *T1;
gsl_min_fminimizer *s1;
/*const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
gsl_function F;*/
int nDim;/** dimension of optim problem */
int *nbd;/** nbd is an integer array of dimension nDim.
On entry nbd represents the type of bounds imposed on the variables, and must be specified as follows:
nbd(i)=0 if x(i) is unbounded,
1 if x(i) has only a lower bound,
2 if x(i) has both lower and upper bounds, and
3 if x(i) has only an upper bound.
On exit nbd is unchanged.*/
double *lowerbounds,*upperbounds;
int failcode;/** check code see R ?optim - if non-zero the a problem **/
double factr=1e-07;/** error size scaler - this is the default value*/
double pgtol=1e-07;/** again default value */
int fncount,grcount;/** hold number of evaluations */
char msg[60];/** error message */
int trace=0;/** like verbose */
int nREPORT=1000;/** report freq*/
int lmm=5;/** see R ?optim - number of function evals to store - default */
/** want to find the modes of the function g(betas) where betas=b_0,b_1,,...,tau, the latter being precision */
/** g(betas) is not differentiable as it contains integrals (which themselves need Laplace estimates **/
/** SETUP things which are the same across all data chunks - groups */
/** build design matrix which is designmatrix->datamatrix=X, designmatrix->Y=Y plus priors designmatrix->priorsd, designmatrix->priormean **/
/** NOTE: design matrix here does include the random effect term **/
/** note - numparams does NOT include precision term - numpars +1 */
build_designmatrix_pois_rv(dag,obsdata,priormean, priorsd,priorgamshape,priorgamscale,designmatrix,nodeid,0);
nDim=designmatrix->numparams+1-1;/** +1 for prec -1 for marginal */
lowerbounds=(double *)R_alloc(nDim,sizeof(double*));
upperbounds=(double *)R_alloc(nDim,sizeof(double*));
nbd=(int *)R_alloc(nDim,sizeof(int*));
for(i=0;i<nDim;i++){lowerbounds[i]=-DBL_MAX;
upperbounds[i]=DBL_MAX;
nbd[i]=0;}
/** unbounded - by default */
if(paramid==(designmatrix->numparams+1)-1){haveprecision=1;} else {haveprecision=0;}
if(!haveprecision){/** we are NOT marginalising over the precision parameter and so need a contrained optimiser where the LAST term is the precision term
and so we set a bound for this */
nbd[nDim-1]=1;/** enforce a lower bound */
lowerbounds[nDim-1]=0.001;/** a hard lower bound - set to zero would cause a problem */
}
finitefactors = gsl_vector_alloc(7);/** used to change stepsize in hessian estimate **/
gsl_vector_set(finitefactors,0,1.0E-03);gsl_vector_set(finitefactors,1,1.0E-02);gsl_vector_set(finitefactors,2,1.0E-01);
gsl_vector_set(finitefactors,3,1.0);gsl_vector_set(finitefactors,4,1.0E+01);gsl_vector_set(finitefactors,5,1.0E+02);
gsl_vector_set(finitefactors,6,1.0E+03);
/*Rprintf("nDim=%d paramID=%d\n",nDim,paramid);
for(i=0;i<nDim;i++){Rprintf("lower=%d ",lowerbounds[i]);}Rprintf("\n");*/
vectmp1 = gsl_vector_alloc (designmatrix->numparams);/** scratch space **/
vectmp2 = gsl_vector_alloc (designmatrix->numparams);/** scratch space **/
mattmp2 = gsl_matrix_alloc (obsdata->numDataPts,designmatrix->numparams);
mattmp3 = gsl_matrix_alloc (designmatrix->numparams,designmatrix->numparams);
mattmp4 = gsl_matrix_alloc (designmatrix->numparams,designmatrix->numparams);
initsperm = gsl_permutation_alloc (designmatrix->numparams);/** for use with initial guesses */
vectmp1long = gsl_vector_alloc (obsdata->numDataPts);/** scratch space **/
vectmp2long = gsl_vector_alloc (obsdata->numDataPts);
localbeta = gsl_vector_alloc (designmatrix->numparams);/** scratch space in later functions - excl. precision **/
localbeta2 = gsl_vector_alloc (designmatrix->numparams+1);/** scratch space in later functions - excl. precision **/
betafull = gsl_vector_alloc (designmatrix->numparams+1);/** */
hessgvaluesfull = gsl_matrix_alloc (designmatrix->numparams+1,designmatrix->numparams+1); /** */
hessgvaluesfull3pt = gsl_matrix_alloc (designmatrix->numparams+1,designmatrix->numparams+1);
myBeta = gsl_vector_alloc (designmatrix->numparams+1-1);/** inc rv precision : -1 as marginal calc */
hessgvalues = gsl_matrix_alloc (designmatrix->numparams+1-1,designmatrix->numparams+1-1); /** -1 as marginal calc */
hessgvalues3pt = gsl_matrix_alloc (designmatrix->numparams+1-1,designmatrix->numparams+1-1);
/*dgvalues = gsl_vector_alloc (designmatrix->numparams+1-1);*//** inc rv precision : -1 as marginal calc */
gparams.designdata=designmatrix;
gparams.vectmp1=vectmp1;
gparams.vectmp2=vectmp2;
gparams.mattmp2=mattmp2;
gparams.mattmp3=mattmp3;
gparams.mattmp4=mattmp4;
gparams.perm=initsperm;
gparams.vectmp1long=vectmp1long;
gparams.vectmp2long=vectmp2long;
gparams.beta=localbeta;/** beta without precision */
gparams.hessgvalues=hessgvaluesfull;
gparams.hessgvalues3pt=hessgvaluesfull3pt;
gparams.betafull=betafull;/** will hold the full beta inc. precision not just marginal */
gparams.epsabs_inner=epsabs_inner;
gparams.maxiters_inner=maxiters_inner;
gparams.verbose=verbose;
gparams.finitestepsize=finitestepsize;
gparams.betafixed=0.0;/** these will be changed in loop below*/
gparams.betaindex=paramid;/** this is fixed - the variable for which the posterior is calculated **/
n=obsdata->numDataPts;
m=designmatrix->numparams+1-1;/** inc precision, -1 marginal */
perm = gsl_permutation_alloc (m);
j=0;
for(i=0;i<designmatrix->numparams+1;i++){if(i!= paramid){gsl_vector_set(myBeta,j++,denom_modes[i]);}} /** use modes as initial values **/
/*Rprintf("MODES: ");for(i=0;i<designmatrix->numparams;i++){Rprintf("= %f\n",gsl_vector_get(myBeta,i));}Rprintf("\nEND\n");*/
status=GSL_SUCCESS;
gparams.betafixed=betafixed;
/*Rprintf("evaluating marginal at %f\n",gparams.betafixed);*/
for(i=0;i<finitefactors->size;i++){/** go forwards through the factors so start with SMALLEST STEPSIZE */
/*Rprintf("step size iteration %d\n",i);*/
failcode=0;/** reset*/
gparams.finitestepsize=gsl_vector_get(finitefactors,i)*finitestepsize;
lbfgsb(nDim, lmm, myBeta->data, lowerbounds, upperbounds, nbd, &gvalue, &g_pois_outer_marg_R,
&rv_dg_pois_outer_marg_R, &failcode,
&gparams,
factr,
pgtol, &fncount, &grcount,
maxiters, msg, trace, nREPORT);
if(!failcode){dag->nodeScoresErrCode[nodeid]=0;/*bestsize=gparams.finitestepsize;*/break;}
}
if(failcode){Rprintf("%s at node %d\n",msg,nodeid+1);/** notify if there is an error and set final error code **/
}
/*Rprintf("MARGINAL gvalue=%f nodeid=%d\n",gvalue,nodeid+1);*/
gparams.finitestepsize=finitestepsize;/** reset */
/*for(i=0;i<myBeta->size;i++){Rprintf("%f ",gsl_vector_get(myBeta,i));}Rprintf("\n");*/
/** just re-use as much of existing gparams as possible - so names are meaningless e.g. betafixed is actually gvalue */
/*gparams.betaincTau=betafull;*/
gparams.betastatic=myBeta;/** this is important as we are passing the addres of myBeta and so don't want any other function changing this! **/
gparams.nDim=n;
gparams.mDim=m;
gparams.perm=perm;
gparams.mattmp2=hessgvalues;
gparams.mattmp3=hessgvalues3pt;
gparams.betafixed=betafixed;
gparams.gvalue=gvalue;
F.f = &compute_mlik_pois_marg_nm;
F.params = &gparams;
F.n = 1;
T = gsl_multimin_fminimizer_nmsimplex2;
s = gsl_multimin_fminimizer_alloc (T, 1);
finitestepsize_vec = gsl_vector_alloc (1);
gsl_vector_set (finitestepsize_vec, 0, h_guess);
nmstepsize = gsl_vector_alloc (1);
gsl_vector_set_all (nmstepsize, h_guess);
gsl_multimin_fminimizer_set (s, &F, finitestepsize_vec, nmstepsize);
status = GSL_SUCCESS;
iter=0;
do
{
iter++;
status = gsl_multimin_fminimizer_iterate (s);
if (status)
break;
nm_size = gsl_multimin_fminimizer_size (s);
status = gsl_multimin_test_size (nm_size, h_epsabs);
/*
if (status == GSL_SUCCESS)
{
Rprintf ("converged to minimum at\n");
}
Rprintf ("iter=%5d error in mlik=%10.10e using fin.diff step= %10.10e\n", iter,s->fval,gsl_vector_get (s->x, 0));
*/
}
while (status == GSL_CONTINUE && iter < maxiters_hessian);
if( (status != GSL_SUCCESS)){/*actual_status=status;*//** copy for use later **/
status=GSL_FAILURE;} /** solution failed to achieve a value below h_epsabs **/
finitestepsize=gsl_vector_get(s->x,0);/** get best fin.diff stepsize **/
/*dag->hessianError[nodeid]= s->fval;*//** get fin.diff error **/
hessian_Error=s->fval;
gsl_multimin_fminimizer_free (s);
if(hessian_Error>max_hessian_error){Rprintf("Error in mlik = %e > tolerance of %e so continuing optimisation using Brent\n",hessian_Error,max_hessian_error);
/* Rprintf("stepsize after NM= %e\n",finitestepsize);*/
T1 = gsl_min_fminimizer_brent;
s1 = gsl_min_fminimizer_alloc (T1);
/** must find lower and upper such that f(lower)<f(finitestepsize)<f(upper) **/
/** use an interval of lower=finitestepsize/FACTOR, upper=finitestepsize*FACTOR and then start at the lower end and travel up until
find suitable endpoints - seems to work but not exactly fast!**/
best_Error=hessian_Error;/** original error from nelder */
best_h=finitestepsize; /** original stepsize from nelder */
found=0;/** flag for found good result */
lower=finitestepsize/myfactor_brent;
upper=myfactor_brent*finitestepsize;
lower_f=compute_mlik_pois_marg_brent(lower, &gparams);/** value at lower point **/
upper_f=compute_mlik_pois_marg_brent(upper, &gparams);/** value at higher point **/
increLogscale=(gsl_sf_log(upper)-gsl_sf_log(lower))/num_intervals_brent;/** on a log scale */
for(delta=gsl_sf_log(lower)+increLogscale;delta<gsl_sf_log(upper);delta+=increLogscale){/** linear increments on a log scale **/
R_CheckUserInterrupt();/** allow an interupt from R console */
/** find a point which has f(x) lower than f(lower) and f(upper) **/
new_f_min=compute_mlik_pois_marg_brent(gsl_sf_exp(delta), &gparams);
Rprintf("lower=%e, delta=%e, upper=%e\n",lower,gsl_sf_exp(delta),upper);
if(lower_f>new_f_min && new_f_min<upper_f && get_best_stepsize_pois_marg(gsl_sf_exp(delta),lower,upper,maxiters_hessian_brent,&gparams, &compute_mlik_pois_marg_brent,
s1,&finitestepsize,&hessian_Error)<=max_hessian_error){/** have an interval suitable for bracketing **/
/** above is address so can store error withouth rerunning function */
/*finitestepsize=delta;*/
found=1;
status=GSL_SUCCESS;
break;/** break out of delta - so have found new x_min **/
} else {/** have not got a good enough error but save the best error and stepsize so far found **/
if(hessian_Error<best_Error){best_Error=hessian_Error;
best_h=finitestepsize;}
}
} /** end of search for interval and good error **/
if(!found){/** have not found a suitably small error but may have found a better error than nelder mead **/
/** best_Error will either be the original nelder mean value or better, and best_h is the corresponding stepsize**/
hessian_Error=best_Error;
finitestepsize=best_h;
/** reset back to nelder-mead estimate **/
status=GSL_FAILURE;/** set to failure since we did not achieve the lower error asked for */
Rprintf("failed to meet tolerance of %e and using best error estimate found of %e\n",max_hessian_error,hessian_Error);}
gsl_min_fminimizer_free (s1);
} /** end of error being too large **/
switch(status){ /** choose which type of node we have */
case GSL_SUCCESS:{
/** successful finite diff so now do final computation with the optimal step size **/
/*Rprintf("search for optimal step size : status = %s at nodeid %d\n", gsl_strerror (status),nodeid+1);*/
rv_hessg_pois_outer_marg(myBeta,&gparams, hessgvalues,finitestepsize,hessgvalues3pt);/** start with LARGEST STEPSIZE **/
/* Rprintf("HESSIAN MARGINAL using stepsize =%e\n",finitestepsize);
for(i1=0;i1<hessgvalues->size1;i1++){
for(i2=0;i2<hessgvalues->size2;i2++){Rprintf("%e ",gsl_matrix_get(hessgvalues,i1,i2));}Rprintf("\n");}*/
status=gsl_linalg_LU_decomp(hessgvalues,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
val=exp(logscore-mlik); /*Rprintf("f(node)=%f %f %f %f\n",val, mydet,logscore,mlik); */
*posterior=val;
break;
}
case GSL_FAILURE: {/** the minimiser did not find a minimum meeting the accuracy requirements and so may be unreliable **/
Rprintf ("-- ERROR! -- search for optimal step size error: status = %s at nodeid %d\n", gsl_strerror (status),nodeid+1);
rv_hessg_pois_outer_marg(myBeta,&gparams, hessgvalues,finitestepsize,hessgvalues3pt);/** start with LARGEST STEPSIZE **/
/*Rprintf("HESSIAN MARGINAL using stepsize =%e\n",finitestepsize);
for(i1=0;i1<hessgvalues->size1;i1++){
for(i2=0;i2<hessgvalues->size2;i2++){Rprintf("%e ",gsl_matrix_get(hessgvalues,i1,i2));}Rprintf("\n");}*/
status=gsl_linalg_LU_decomp(hessgvalues,perm,&sss);
mydet=gsl_linalg_LU_lndet(hessgvalues);/** compute determinant but this might be a nan - overflow? gsl_linalg_LU_lndet*/
logscore= -n*gvalue-0.5*mydet+(m/2.0)*log((2.0*M_PI)/n);/** this is the final value */
val=exp(logscore-mlik); /*Rprintf("f(node)=%f %f %f %f\n",val, mydet,logscore,mlik); */
*posterior=val;
break;
}
default:{Rprintf("got case %s\n",gsl_strerror (status)); error("in default switch in calc_node_Score_binary_rv_R() - should never get here!");}
}
/** now free up allocated memory **/
for(i=0;i<designmatrix->numUnqGrps;i++){gsl_matrix_free(designmatrix->array_of_designs[i]);
gsl_vector_free(designmatrix->array_of_Y[i]);}
gsl_vector_free(designmatrix->priormean);
gsl_vector_free(designmatrix->priorsd);
gsl_vector_free(designmatrix->priorgamshape);
gsl_vector_free(designmatrix->priorgamscale);
gsl_vector_free(designmatrix->Y);
gsl_matrix_free(designmatrix->datamatrix_noRV);
/*gsl_vector_free(dgvalues);*/
gsl_vector_free(myBeta);
gsl_vector_free(vectmp1);
gsl_vector_free(vectmp2);
gsl_matrix_free(mattmp2);
gsl_matrix_free(mattmp3);
gsl_matrix_free(mattmp4);
gsl_permutation_free(initsperm);
gsl_vector_free(vectmp1long);
gsl_vector_free(vectmp2long);
gsl_vector_free(localbeta);
gsl_vector_free(localbeta2);
gsl_vector_free(betafull);
gsl_matrix_free(hessgvalues);
gsl_matrix_free(hessgvalues3pt);
gsl_matrix_free(hessgvaluesfull);
gsl_matrix_free(hessgvaluesfull3pt);
gsl_permutation_free(perm);
gsl_vector_free(finitefactors);
gsl_vector_free(finitestepsize_vec);
gsl_vector_free(nmstepsize);
}
CAMLprim value ml_gsl_linalg_LU_lndet(value LU)
{
_DECLARE_MATRIX(LU);
_CONVERT_MATRIX(LU);
return copy_double(gsl_linalg_LU_lndet(&m_LU));
}
