// -----------------------------------------------------------------
// Returns ratio (Omega / Omega_*)^(2(alpha + 1))
double star(double delta, double epsilon, int order, double *c,
double alpha) {
double pow = alpha + 1.0;
double intres, interr, ret, temp, seps = sqrt(epsilon);
error2_pars_type error2_pars;
error2_pars.epsilon = epsilon;
error2_pars.order = order;
error2_pars.c = c;
error2_pars.alpha = alpha;
gsl_function gsl_error2 = {&error2, &error2_pars};
gsl_integration_workspace *gsl_ws_int
= gsl_integration_workspace_alloc(1000000);
gsl_integration_qag(&gsl_error2, -seps, seps, 1.e-2, 0, 1000000,
GSL_INTEG_GAUSS15, gsl_ws_int, &intres, &interr);
temp = gsl_sf_exp(pow * gsl_sf_log((1.0 - seps) / (1.0 + seps)) / 2.0);
ret = temp + pow * intres;
temp = gsl_sf_exp(gsl_sf_log(ret) / pow); // A**B = exp[B log A]
ret = temp * temp; // Squared!
gsl_integration_workspace_free(gsl_ws_int);
return ret;
}
double sample_lambda_doublepareto(const gsl_rng *random, double *beta,
int dk_rows, int *dk_rowbreaks, int *dk_cols, double *dk_vals,
double a, double b,
double lam0, double gamma, double lam_walk_stdev)
{
int i;
double lam1;
double sum_term;
double dotprod;
double accept_ratio;
double log_accept_ratio;
int prev_break;
lam1 = gsl_sf_exp(gsl_ran_gaussian(random, lam_walk_stdev) + gsl_sf_log(lam0));
/* Lambda as an inverse scale parameter */
sum_term = 0;
prev_break = 0;
for (i = 0; i < dk_rows; i++){
dotprod = fabs(vec_dot_beta(dk_rowbreaks[i] - prev_break, dk_cols + prev_break, dk_vals + prev_break, beta));
sum_term += gsl_sf_log(1 + lam1 * dotprod / gamma) - gsl_sf_log(1 + lam0 * dotprod / gamma);
prev_break = dk_rowbreaks[i];
}
log_accept_ratio = (a - 1 + dk_rows) * (gsl_sf_log(lam1) - gsl_sf_log(lam0)) - b * (lam1 - lam0) - (gamma + 1) * sum_term;
if(log_accept_ratio < -20)
return lam0;
else if(log_accept_ratio > 0)
return lam1;
accept_ratio = gsl_sf_exp(log_accept_ratio);
if (gsl_ran_flat(random, 0, 1) <= accept_ratio)
return lam1;
return lam0;
}
void sample_likelihood_poisson(const gsl_rng *random,
int n, int *obs,
int *dk_rowbreaks, int *dk_cols, double *dk_vals,
double *s, int **coefs, int *coef_breaks,
double *beta)
{
int i;
int j;
int k;
int row;
int j_idx;
double a;
double lower;
double upper;
double left;
double right;
for(j = 0; j < n; j++)
{
if (obs[j] > 0){
lower = lex_ran_flat(random, 0, gsl_sf_exp(obs[j]*beta[j]));
lower = gsl_sf_log(lower) / (double)obs[j];
} else {
lower = -INFINITY;
}
upper = lex_ran_flat(random, 0, beta[j] < -160 ? 1 : gsl_sf_exp(-gsl_sf_exp(beta[j])));
upper = gsl_sf_log(-gsl_sf_log(upper));
/* Bound the sampling range */
for (i = 0; i < coef_breaks[j]; i++)
{
/* current row that has a non-zero value for column j */
row = coefs[j][i];
/* Calculate Dk[i].dot(b_notj), the inner product of the i'th row
and the beta vector, excluding the j'th column. */
a = 0;
for (k = row == 0 ? 0 : dk_rowbreaks[row-1]; k < dk_rowbreaks[row]; k++){
if (dk_cols[k] == j){
j_idx = k;
} else{
a += dk_vals[k] * beta[dk_cols[k]];
}
}
/* Find the left and right bounds */
left = (-s[row] - a) / dk_vals[j_idx];
right = (s[row] - a) / dk_vals[j_idx];
if (dk_vals[j_idx] >= 0){
lower = MAX(lower, left);
upper = MIN(upper, right);
} else {
lower = MAX(lower, right);
upper = MIN(upper, left);
}
}
beta[j] = gsl_ran_flat(random, lower, upper);
}
}
/* compute ln(a + b) safely, given ln(a) and ln(b). */
double safe_sum(double ln_a, double ln_b)
{
if (isnormal(ln_a) && isnormal(ln_b))
return ln_a < ln_b
? ln_b + gsl_sf_log(gsl_sf_exp(ln_a - ln_b) + 1.0)
: ln_a + gsl_sf_log(gsl_sf_exp(ln_b - ln_a) + 1.0);
else if (isnormal(ln_a))
return ln_a;
else
return ln_b;
}
// -----------------------------------------------------------------
static double error2(double x, void *pars) {
double al = ((error2_pars_type*)pars)->alpha;
double hv = h(x, ((error2_pars_type*)pars)->epsilon,
((error2_pars_type*)pars)->order,
((error2_pars_type*)pars)->c);
// A**B = exp[B log A]
double num_pow = al + 1.0, num_arg = 1.0 + x;
double den_pow = (3.0 + al) / 2.0, den_arg = 1.0 - (x * x);
double num = gsl_sf_exp(num_pow * gsl_sf_log(num_arg));
double den = gsl_sf_exp(den_pow * gsl_sf_log(den_arg));
return (hv * hv * hv * hv * num / den);
}
/*******************************************************************************
* gencluster: recursivily calls itself and returns a set of lattice points.
******************************************************************************/
int
gencluster(lattice_site * lattice, settings conf, int loc_id , int * update_list, int ** bonds, gsl_vector * base, double beta)
{
int i,update_count = 0;
double exp_factor,s1n,s2n;
int nid;
for(i = 0 ; i < 2*conf.spacedims ; i++)
{
nid = lattice[loc_id].neighbors[i]; /* Neighbor ID */
//Continue on if the point has already been added
// or if bond has already been checked.
if(update_list[nid] == 1 || bonds[loc_id][nid] != 0)
continue;
gsl_blas_ddot(lattice[loc_id].spin,base,&s1n);
gsl_blas_ddot(lattice[nid].spin,base,&s2n);
exp_factor = -2.0*s1n*s2n*beta;
if(exp_factor > -10 && gsl_rng_uniform(conf.rng) < 1-gsl_sf_exp(exp_factor))
{
update_list[nid] = 1; /* Set to be flipped */
update_count += 1;
bonds[loc_id][nid] = 1; /* Prevent link from being checked again */
bonds[nid][loc_id] = 1;
update_count += gencluster(lattice,conf,nid,update_list,bonds,base,beta);
}
else
{
bonds[loc_id][nid] = -1; /* If not added keep this link from being made again */
bonds[nid][loc_id] = -1;
}
}
return(update_count);
}
const double exp(const double x) {
double res =
#ifdef USE_GSL_EXP
gsl_sf_exp(x);
#else
std::exp(x);
#endif
return res;
}
// 2014-11-26 calculateExp, may be we should delete?
gsl_vector *
CRebuildGraph::calculateExp(const gsl_vector_complex *eval){
CFuncTrace lFuncTrace(false,"calculateExp");
int order = (int)eval->size;
lFuncTrace.trace(CTrace::TRACE_DEBUG,"Ordre for Expo %d",order);
gsl_vector *evalexp = gsl_vector_alloc (order);
for ( int i = 0; i < order; i++){
gsl_complex eval_i
= gsl_vector_complex_get (eval, i);
// printf ("eigenvalue = %g + %gi\n",
// GSL_REAL(eval_i), GSL_IMAG(eval_i));
gsl_vector_set(evalexp,i,gsl_sf_exp(GSL_REAL(eval_i)));
printf("W exp %g\n",gsl_sf_exp(GSL_REAL(eval_i)));
}
return evalexp;
}
double max_to_avg_ratio(struct wpoint **points, unsigned npoints)
{
struct wpoint **pp, **pe = points + npoints;
double ln_total = NAN, maxval = -DBL_MAX;
for (pp = points; pp != pe; ++pp)
{
ln_total = safe_sum(ln_total, (*pp)->ln_o);
maxval = max(maxval, (*pp)->o);
}
return maxval / (gsl_sf_exp(ln_total) / (double)npoints);
}
// ../src/lcao_wavefunction/lcao_wavefunction__gf_overlap_integral.cpp ----------------- //
//
// File author: Humberto Jr.
//
// Date: 10/2013
//
// Description: Given two unormalized GF exponents, alpha and beta, centered at atom A
// and atom B, respectively; and also the distance, d, between A and B;
// this function returns the minimal overlap integral, S = <A|B>.
//
// References: A. Szabo and N. Ostlund; Modern Quantum Chemistry - Introduction to
// Advanced Electronic Sctructure.
//
// ------------------------------------------------------------------------------------- //
//
//
//
inline double gf_overlap_integral(const double &alpha, // The gf exponent at atom A.
const double &beta, // The gf exponent at atom B.
const double &d) // The A-B distance.
{
//
// A. Szabo and N. Ostlund;
// Modern Quantum Chemistry - Introduction to Advanced Electronic Sctructure;
// Appendix A;
// pag. 412;
// equation (A.9):
return std::pow(M_PI/(alpha + beta), 1.5)*gsl_sf_exp(-alpha*beta*gsl_pow_2(d)/(alpha + beta));
};
void sample_prior_aux_laplace_multilambda(const gsl_rng *random, double *beta,
int dk_rows, int *dk_rowbreaks, int *dk_cols, double *deltak,
double *lambda, double *s)
{
int i;
mat_dot_vec(dk_rows, dk_rowbreaks, dk_cols, deltak, beta, s);
vec_abs(dk_rows, s);
for(i = 0; i < dk_rows; i++){
s[i] = -gsl_sf_log(lex_ran_flat (random, 0.0, gsl_sf_exp(-lambda[i] * s[i]))) / lambda[i];
}
}
/* Acceptance of new_site depends on the sign at the lattice site and
* a probabilistic factor
*/
inline bool Lattice::cluster_try_add(bool positive, Phi phi, Site new_site) {
if ((get_phi(new_site) > 0) != positive)
return false;
if (cluster.find(new_site) != cluster.end())
return false;
const RR probability =
1 - gsl_sf_exp(-2 * phi * get_phi(new_site));
if (random() < probability) {
cluster.insert(new_site);
cluster_queue.push_back(new_site);
return true;
}
return false;
}
inline void Lattice::step_Metropolis(const PhiXY& phi) {
const double phi_2 = phi.value * phi.value;
const double newphi = phi.value + random_phi();
const double newphi_2 = newphi * newphi;
// Calculate energy difference
const double delta =
(phi.value - newphi) * (phi.next_x + phi.next_y + phi.prev_x + phi.prev_y)
+
mu2_tilde * (newphi_2 - phi_2)
+
lambda_tilde * (newphi_2 * newphi_2 - phi_2 * phi_2);
// Flip if difference <= 0 or probabilistic acceptance
if (delta <= 0 || random() < gsl_sf_exp(-delta))
phi.value = newphi;
}
// print out the CDF given a number of points.
// normalize to the given constant
void print_cdf(struct wpoint **points, unsigned npoints,
double total_mass,
struct wpoint *first_point, // needed to give each point an index
const char *dist_name,
FILE *cdf_fh)
{
unsigned dim;
char fmt[] = "%s\t%c\t%20.18le\t%u\t%20.18le\t%20.18le\t%20.18le\t%s\n";
char base[] = "ACGT";
struct wpoint *s, **sp, **se = points + npoints;
double sum, ln_z = gsl_sf_log(total_mass);
double ln_sum, max_ln_step = -INFINITY;
for (dim = 0; dim != NUCS; ++dim)
{
cmp_dim = dim;
qsort(points, npoints, sizeof(struct wpoints *), pcmp5);
ln_sum = NAN;
sum = 0;
for (sp = points; sp != se; ++sp)
{
s = *sp;
max_ln_step = max(max_ln_step, s->ln_o - ln_z);
/* ln_sum = safe_sum(ln_sum, s->ln_o - gsl_sf_log(s->num_samples)); */
sum += s->o / (double)s->num_samples;
fprintf(cdf_fh, fmt,
dist_name,
base[dim],
s->x[dim],
(unsigned)(s - first_point),
/* gsl_sf_exp(ln_sum - ln_z), */
sum / total_mass,
s->ln_d,
s->ln_o,
s->dist);
}
}
fprintf(stderr, "%s, max_ln_step = %g, max_step = %g\n", dist_name, max_ln_step, gsl_sf_exp(max_ln_step));
}
void sample_prior_aux_doublepareto(const gsl_rng *random, double *beta,
int dk_rows, int *dk_rowbreaks, int *dk_cols, double *deltak,
double lambda, double dp_hyperparameter, double *s)
{
int i;
double z;
double dp_exponent;
dp_exponent = -(dp_hyperparameter+1);
mat_dot_vec(dk_rows, dk_rowbreaks, dk_cols, deltak, beta, s);
vec_abs(dk_rows, s);
for(i = 0; i < dk_rows; i++){
/* Lambda as an inverse scale parameter */
z = pow(1. + lambda * s[i] / dp_hyperparameter, dp_exponent);
s[i] = dp_hyperparameter / lambda * (gsl_sf_exp(gsl_sf_log(lex_ran_flat(random, 0, z)) / dp_exponent) - 1);
/* Lambda as a scale parameter
z = pow(1. + s[i] / (dp_hyperparameter * lambda), -dp_hyperparameter - 1.);
s[i] = dp_hyperparameter * lambda * (gsl_sf_exp(-gsl_sf_log(lex_ran_flat(random, 0, z)) / (dp_hyperparameter + 1.0)) - 1);
*/
}
}
inline double gf_overlaping(const double &a, // The m gf exponent.
const double &b, // The n gf exponent.
const double &c) // The i-j atomic distance.
{
return gsl_sf_exp(-a*b*gsl_pow_2(c)/(a + b))*std::pow(M_PI/(a + b), 1.5);
};
void bayes_gfl_poisson_doublepareto (int n, int *obs,
int dk_rows, int *dk_rowbreaks, int *dk_cols, double *deltak,
double lambda_hyperparam_a, double lambda_hyperparam_b,
double lam_walk_stdev, double lam0, double dp_hyperparameter,
long iterations, long burn, long thin,
double **beta_samples, double *lambda_samples)
{
int i;
double *s;
double *beta;
int **coefs;
int *coef_breaks;
long iteration;
int sample_idx;
double ymean;
const gsl_rng_type *T;
gsl_rng *random;
double lambda;
gsl_rng_env_setup();
T = gsl_rng_default;
random = gsl_rng_alloc (T);
s = (double *) malloc(dk_rows * sizeof(double));
coefs = (int **) malloc(n * sizeof(int*));
coef_breaks = (int *) malloc(n * sizeof(int));
beta = (double *) malloc(n * sizeof(double));
lambda = lam0;
/* Cache a lookup table to map from deltak column to the set of rows with
non-zero entries for that column */
calc_coefs(n, dk_rows, dk_rowbreaks, dk_cols, coefs, coef_breaks);
/* Set all beta values to the mean to start */
ymean = gsl_sf_log(vec_mean_int(n, obs));
for (i = 0; i < n; i++){ beta[i] = ymean; }
/* Run the Gibbs sampler */
for (iteration = 0, sample_idx = 0; iteration < iterations; iteration++)
{
/* Sample the lambda penalty weight on the double Pareto prior */
lambda = sample_lambda_doublepareto(random, beta,
dk_rows, dk_rowbreaks, dk_cols, deltak,
lambda_hyperparam_a, lambda_hyperparam_b,
lambda, dp_hyperparameter, lam_walk_stdev);
/* Sample each of the auxillary variables (one per row of Dk) */
sample_prior_aux_doublepareto(random, beta, dk_rows, dk_rowbreaks, dk_cols, deltak, lambda, dp_hyperparameter, s);
/* Sample from the Poisson likelihood */
sample_likelihood_poisson(random, n, obs, dk_rowbreaks, dk_cols, deltak, s, coefs, coef_breaks, beta);
/* Add the sample */
if (iteration >= burn && (iteration % thin) == 0){
lambda_samples[sample_idx] = lambda;
for(i = 0; i < n; i++){ beta_samples[sample_idx][i] = gsl_sf_exp(beta[i]); }
sample_idx++;
}
}
free(s);
free(beta);
for (i = 0; i < n; i++){ free(coefs[i]); }
free(coefs);
free(coef_breaks);
gsl_rng_free(random);
}
void empirical_bayes_gfl_binomial_laplace_gamma (int n, int *trials, int *successes,
int dk_rows, int *dk_rowbreaks, int *dk_cols, double *deltak,
double lambda,
long iterations, long burn, long thin,
double **beta_samples, double *lambda_samples)
{
int i;
double *s;
double *beta;
double *tau;
int **coefs;
int *coef_breaks;
long iteration;
int sample_idx;
double ymean;
const gsl_rng_type *T;
gsl_rng *random;
gsl_rng_env_setup();
T = gsl_rng_default;
random = gsl_rng_alloc (T);
s = (double *) malloc(dk_rows * sizeof(double));
coefs = (int **) malloc(n * sizeof(int*));
coef_breaks = (int *) malloc(n * sizeof(int));
beta = (double *) malloc(n * sizeof(double));
tau = (double *) malloc(dk_rows * sizeof(double));
/* Cache a lookup table to map from deltak column to the set of rows with
non-zero entries for that column */
calc_coefs(n, dk_rows, dk_rowbreaks, dk_cols, coefs, coef_breaks);
/* Set all beta values to the mean to start */
ymean = 0;
for (i = 0; i < n; i++){ if (successes[i] > 0) {ymean += trials[i] / (double)successes[i];} }
ymean = ymean > 0 ? -gsl_sf_log(ymean / (double)n) : 0;
for (i = 0; i < n; i++){ beta[i] = ymean; }
/* Set tau to 1 to start */
for (i = 0; i < dk_rows; i++){ tau[i] = 1.0; }
/* Run the Gibbs sampler */
for (iteration = 0, sample_idx = 0; iteration < iterations; iteration++)
{
/* Sample the local laplace penalty tau */
sample_tau_laplace_gamma(random, beta, dk_rows, dk_rowbreaks, dk_cols, deltak, lambda, 1.0, tau);
/* Sample each of the auxillary variables (one per row of Dk) */
sample_prior_aux_laplace_multilambda(random, beta, dk_rows, dk_rowbreaks, dk_cols, deltak, tau, s);
/* Sample from the binomial likelihood */
sample_likelihood_binomial(random, n, trials, successes, dk_rowbreaks, dk_cols, deltak, s, coefs, coef_breaks, beta);
/* Add the sample */
if (iteration >= burn && (iteration % thin) == 0){
lambda_samples[sample_idx] = lambda;
for(i = 0; i < n; i++){ beta_samples[sample_idx][i] = 1.0 / (1.0 + gsl_sf_exp(-CLAMP(beta[i], BINOMIAL_BETA_MIN, BINOMIAL_BETA_MAX))); }
sample_idx++;
}
}
free(s);
free(beta);
free(tau);
for (i = 0; i < n; i++){ free(coefs[i]); }
free(coefs);
free(coef_breaks);
gsl_rng_free(random);
}
/**
* C++ version of gsl_sf_exp().
* Exponential function
* @param x A real number
* @return The function value
*/
inline double exp( double const x ){ return gsl_sf_exp( x ); }
//--------------------------------------------------------------------------------------------------
double exp_kernel( const double& h, const double& sigma, const double& theta ) {
return sigma * gsl_sf_exp( -h / theta );
}
//--------------------------------------------------------------------------------------------------
double gaussian_kernel( const double& h, const double& sigma, const double& theta ) {
return sigma * gsl_sf_exp( -h * h / theta );
}
/** ****************************************************************************************************
***** 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);
}
/** ****************************************************************************************************
***** 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;*/
}
