void
test_f (const gsl_min_fminimizer_type * T,
const char * description, gsl_function *f,
double lower_bound, double middle, double upper_bound,
double correct_minimum)
{
int status;
size_t iterations = 0;
double m, a, b;
double x_lower, x_upper;
gsl_min_fminimizer * s;
x_lower = lower_bound;
x_upper = upper_bound;
s = gsl_min_fminimizer_alloc (T) ;
gsl_min_fminimizer_set (s, f, middle, x_lower, x_upper) ;
do
{
iterations++ ;
status = gsl_min_fminimizer_iterate (s);
m = gsl_min_fminimizer_x_minimum(s);
a = gsl_min_fminimizer_x_lower(s);
b = gsl_min_fminimizer_x_upper(s);
#ifdef DEBUG
printf("%.12f %.18f %.12f %.18f %.12f %.18f status=%d\n",
a, GSL_FN_EVAL(f, a), m, GSL_FN_EVAL(f, m), b, GSL_FN_EVAL(f, b), status);
#endif
if (a > b)
gsl_test (GSL_FAILURE, "interval is invalid (%g,%g)", a, b);
if (m < a || m > b)
gsl_test (GSL_FAILURE, "m lies outside interval %g (%g,%g)", m, a, b);
if (status) break ;
status = gsl_min_test_interval (a, b, EPSABS, EPSREL);
}
while (status == GSL_CONTINUE && iterations < MAX_ITERATIONS);
gsl_test (status, "%s, %s (%g obs vs %g expected) ",
gsl_min_fminimizer_name(s), description,
gsl_min_fminimizer_x_minimum(s), correct_minimum);
/* check the validity of the returned result */
if (!WITHIN_TOL (m, correct_minimum, EPSREL, EPSABS))
{
gsl_test (GSL_FAILURE, "incorrect precision (%g obs vs %g expected)",
m, correct_minimum);
}
gsl_min_fminimizer_free (s);
}
/**
* The Brent minimization algorithm combines a parabolic interpolation with the golden section algorithm.
* This produces a fast algorithm which is still robust. The outline of the algorithm can be summarized as
* follows: on each iteration Brent's method approximates the function using an interpolating parabola
* through three existing points. The minimum of the parabola is taken as a guess for the minimum.
* If it lies within the bounds of the current interval then the interpolating point is accepted,
* and used to generate a smaller interval. If the interpolating point is not accepted then the
* algorithm falls back to an ordinary golden section step. The full details of Brent's method
* include some additional checks to improve convergence.
*
* @author Sharmila Prasad (8/15/2011)
*
* @param x_lower - x_lower interval
* @param x_upper - x_upper interval
* @param Func - gsl_function, high-level driver for the algorithm
* Continuous function of one variable for the minimizers to operate on
* @param x_minimum - x_minimum calculated parabola min value
* @return double - status
*/
int Photometry::brentminimizer(double x_lower, double x_upper, gsl_function *Func,
double & x_minimum, double tolerance) {
int status;
int iter=0, max_iter=100;
const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
//double m_expected = M_PI;
T = gsl_min_fminimizer_brent;
s = gsl_min_fminimizer_alloc(T);
// This function sets, or resets, an existing minimizer s to use the function Func and
// the initial search interval [x_lower, x_upper], with a guess for the location of
// the minimum x_minimum. If the interval given does not contain a minimum, then
// the function returns an error code of GSL_EINVAL.
gsl_min_fminimizer_set(s, Func, x_minimum, x_lower, x_upper);
do {
iter++;
status = gsl_min_fminimizer_iterate(s);
x_minimum = gsl_min_fminimizer_x_minimum(s);
x_lower = gsl_min_fminimizer_x_lower(s);
x_upper = gsl_min_fminimizer_x_upper(s);
status = gsl_min_test_interval(x_lower, x_upper, tolerance, 0.0);
} while(status == GSL_CONTINUE && iter < max_iter);
// This function frees all the memory associated with the minimizer s.
gsl_min_fminimizer_free(s);
return status;
}
CAMLprim value ml_gsl_min_fminimizer_free(value s)
{
remove_global_root(&(Mparams_val(s)->closure));
stat_free(Mparams_val(s));
gsl_min_fminimizer_free(Minimizer_val(s));
return Val_unit;
}
int
main (void)
{
int status;
int iter = 0, max_iter = 100;
const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
double m = 2.0, m_expected = M_PI;
double a = 0.0, b = 6.0;
gsl_function F;
F.function = &fn1;
F.params = 0;
T = gsl_min_fminimizer_brent;
s = gsl_min_fminimizer_alloc (T);
gsl_min_fminimizer_set (s, &F, m, a, b);
printf ("using %s method\n",
gsl_min_fminimizer_name (s));
printf ("%5s [%9s, %9s] %9s %10s %9s\n",
"iter", "lower", "upper", "min",
"err", "err(est)");
printf ("%5d [%.7f, %.7f] %.7f %+.7f %.7f\n",
iter, a, b,
m, m - m_expected, b - a);
do
{
iter++;
status = gsl_min_fminimizer_iterate (s);
m = gsl_min_fminimizer_x_minimum (s);
a = gsl_min_fminimizer_x_lower (s);
b = gsl_min_fminimizer_x_upper (s);
status
= gsl_min_test_interval (a, b, 0.001, 0.0);
if (status == GSL_SUCCESS)
printf ("Converged:\n");
printf ("%5d [%.7f, %.7f] "
"%.7f %+.7f %.7f\n",
iter, a, b,
m, m - m_expected, b - a);
}
while (status == GSL_CONTINUE && iter < max_iter);
gsl_min_fminimizer_free (s);
return status;
}
/*=============================================================================
* MINIMIZATION
*=============================================================================*/
double minimize(double a,double b, double m){
int status;
int iter = 0, max_iter = 100;
const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
double epsabs= 0.005; //eps of solution
double epsrel= 0.0; //eps of solution
gsl_function F;
F.function = &min_func;
F.params = 0;
T = gsl_min_fminimizer_brent;
s = gsl_min_fminimizer_alloc (T);
gsl_min_fminimizer_set (s, &F, m, a, b);
printf ("using %s method\n",
gsl_min_fminimizer_name (s));
printf ("%5s [%9s, %9s] %9s %9s\n",
"iter", "lower", "upper", "min",
"err(est)");
printf ("%5d [%.7f, %.7f] %.7f %.7f\n",
iter, a, b,
m, b - a);
do
{
iter++;
status = gsl_min_fminimizer_iterate (s);
m = gsl_min_fminimizer_x_minimum (s);
a = gsl_min_fminimizer_x_lower (s);
b = gsl_min_fminimizer_x_upper (s);
status
= gsl_min_test_interval (a, b, epsabs, epsrel);
if (status == GSL_SUCCESS)
printf ("Converged:\n");
printf ("%5d [%.7f, %.7f] "
"%.7f %.7f\n",
iter, a, b,
m, b - a);
}
while (status == GSL_CONTINUE && iter < max_iter);
gsl_min_fminimizer_free (s);
return m;
}
void
test_f_e (const gsl_min_fminimizer_type * T,
const char * description, gsl_function *f,
double lower_bound, double middle, double upper_bound,
double correct_minimum)
{
int status;
size_t iterations = 0;
double x_lower, x_upper;
double a, b;
gsl_min_fminimizer * s;
x_lower = lower_bound;
x_upper = upper_bound;
s = gsl_min_fminimizer_alloc (T) ;
status = gsl_min_fminimizer_set (s, f, middle, x_lower, x_upper) ;
if (status != GSL_SUCCESS)
{
gsl_min_fminimizer_free (s) ;
gsl_test (status == GSL_SUCCESS, "%s, %s", T->name, description);
return ;
}
do
{
iterations++ ;
gsl_min_fminimizer_iterate (s);
a = gsl_min_fminimizer_x_lower(s);
b = gsl_min_fminimizer_x_upper(s);
status = gsl_min_test_interval (a, b, EPSABS, EPSREL);
}
while (status == GSL_CONTINUE && iterations < MAX_ITERATIONS);
gsl_test (!status, "%s, %s", gsl_min_fminimizer_name(s), description,
gsl_min_fminimizer_x_minimum(s) - correct_minimum);
gsl_min_fminimizer_free (s);
}
double iteractive_max(Params *params,double a, double b) {
const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
gsl_function F;
int status;
int iter = 0, max_iter = 100;
double m=(a+b)/2.0;
printf("a=%lg b=%lg\n",a,b);
printf("f(a)=%lg f(b)=%lg f((a+b)/2)=%lg\n",max_fun(a,params),max_fun(b,params),max_fun((a+b)/2.0,params));
F.function = &max_fun;
F.params = (void*)params;
T = gsl_min_fminimizer_brent;
s = gsl_min_fminimizer_alloc (T);
gsl_min_fminimizer_set (s, &F, m, a, b);
printf ("using %s method\n",gsl_min_fminimizer_name (s));
fflush(stdout);
printf("Start Interactions\n");
fflush(stdout);
do
{
iter++;
status = gsl_min_fminimizer_iterate (s);
m = gsl_min_fminimizer_x_minimum (s);
a = gsl_min_fminimizer_x_lower (s);
b = gsl_min_fminimizer_x_upper (s);
status = gsl_min_test_interval (a, b, 0.001, 0.0);
if (status == GSL_SUCCESS)
printf ("Converged:\n");
printf ("%5d [%.7f, %.7f] "
"%.7f %.7f\n",
iter, a, b,
m, b - a);
}
while (status == GSL_CONTINUE && iter < max_iter);
gsl_min_fminimizer_free (s);
return m;
}
/*
-------------------------------------------------------------------------
* This function frees the memory allocated using XLALInitFContactWorkSpace.
* ------------------------------------------------------------------------*/
void XLALFreeFContactWorkSpace( fContactWorkSpace *workSpace )
{
if ( !workSpace )
XLAL_ERROR_VOID( XLAL_EFAULT );
/* Free all the allocated memory */
if (workSpace->tmpA) XLAL_CALLGSL( gsl_matrix_free( workSpace->tmpA ));
if (workSpace->tmpB) XLAL_CALLGSL( gsl_matrix_free( workSpace->tmpB ));
if (workSpace->C) XLAL_CALLGSL( gsl_matrix_free( workSpace->C ));
if (workSpace->p1) XLAL_CALLGSL( gsl_permutation_free( workSpace->p1 ));
if (workSpace->tmpV) XLAL_CALLGSL( gsl_vector_free( workSpace->tmpV ));
if (workSpace->r_AB) XLAL_CALLGSL( gsl_vector_free( workSpace->r_AB ));
if (workSpace->s) XLAL_CALLGSL( gsl_min_fminimizer_free( workSpace->s ));
LALFree( workSpace );
return;
}
int main ()
{
int status;
int iter = 0, max_iter = 100; /*Max. number of iterations*/
const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
double m = 0.7; /* Starting point for the search*/
double a = -4.0, b = 1.0; /* The interval in which the minimum lies*/
gsl_function F;
F.function = &fn_1; /* Function to Minimize*/
F.params = 0;
T = gsl_min_fminimizer_goldensection; /*Set the minimization algorithm - Uses Golden Section*/
s = gsl_min_fminimizer_alloc (T); /* Initialize the minimizer*/
gsl_min_fminimizer_set (s, &F, m, a, b); /*Set up the minimizer*/
printf ("Using %s method\n", gsl_min_fminimizer_name (s));
printf ("%5s [%9s, %9s] %9s \n","iter", "lower", "upper", "min", "err", "err(est)");
printf ("%5d [%.7f, %.7f] %.7f \n", iter, a, b, m);
/* Set up the iterative minimization procedure*/
do
{
iter++;
status = gsl_min_fminimizer_iterate(s);
m = gsl_min_fminimizer_x_minimum (s);
a = gsl_min_fminimizer_x_lower (s);
b = gsl_min_fminimizer_x_upper (s);
status = gsl_min_test_interval (a, b, 0.001, 0.0);
if (status == GSL_SUCCESS)
printf ("Converged:\n");
printf ("%5d [%.7f, %.7f] %.7f\n",iter, a, b, m);
} while (status == GSL_CONTINUE && iter < max_iter);
gsl_min_fminimizer_free (s);
return status;
}
void FC_FUNC_(oct_1dminimize, OCT_1DMINIMIZE)(double *a, double *b, double *m, func1 f, int *status)
{
int iter = 0;
int max_iter = 100;
const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
gsl_function F;
param_f1_t p;
p.func = f;
F.function = &fn1;
F.params = (void *) &p;
T = gsl_min_fminimizer_brent;
s = gsl_min_fminimizer_alloc (T);
*status = gsl_min_fminimizer_set (s, &F, *m, *a, *b);
gsl_set_error_handler_off();
do
{
iter++;
*status = gsl_min_fminimizer_iterate (s);
*m = gsl_min_fminimizer_x_minimum (s);
*a = gsl_min_fminimizer_x_lower (s);
*b = gsl_min_fminimizer_x_upper (s);
*status = gsl_min_test_interval (*a, *b, 0.00001, 0.0);
/*if (*status == GSL_SUCCESS) printf ("Converged:\n");*/
/*printf ("%5d [%.7f, %.7f] %.7f \n", iter, *a, *b,*m);*/
}
while (*status == GSL_CONTINUE && iter < max_iter);
gsl_min_fminimizer_free(s);
}
/* this function minimizes the one-dimensional function, starting at point
x0, in the interval [x_min, x_max]. */
int f_min (double x_min, double x0, double x_max, double *minimum, struct f_min_params *par) {
size_t iter;
int status;
double x_lo, x_hi;
gsl_function func;
/* allocates the memory for the minimizer */
gsl_min_fminimizer *s = gsl_min_fminimizer_alloc (par->type);
/* defines the function to minimize and to be handed to the minimizer */
func.function = par->func;
func.params = par->func_p;
/* initializes the minimizer */
gsl_min_fminimizer_set (s, &func, x0, x_min, x_max);
/* iterate */
iter = 0;
do {
iter++;
status = gsl_min_fminimizer_iterate (s);
/* check interval for convergence */
x_lo = gsl_min_fminimizer_x_lower (s);
x_hi = gsl_min_fminimizer_x_upper (s);
status = gsl_min_test_interval (x_lo, x_hi, par->eps_abs, par->eps_rel);
if (par->verbose)
printf ("iter %lu: x_lo = %f x_hi = %f\n", iter, x_lo, x_hi);
} while (status==GSL_CONTINUE && iter<par->max_iter);
/* get the value of the minimum and free the memory */
*minimum = gsl_min_fminimizer_x_minimum (s);
gsl_min_fminimizer_free (s);
return status;
}
Minimizer::~Minimizer() { gsl_min_fminimizer_free(s); }
void shearlayerkcrit_driver(char *input_file_name)
{
PARAMS_STRUCT *params;
GRID_STRUCT *grid;
ROTATION_STRUCT *rotation;
COMPRESSED_MATRIX *matrix;
ARPACK_CONTROL *arpack_params;
RESULTS_STRUCT *results;
OUTPUT_CONTROL *output_control;
double shear_width, shear_radius, E;
//Parameters needed for the root-finding routine
int status;
int iter=0, max_iter=50;
const gsl_root_fsolver_type *Troot;
const gsl_min_fminimizer_type *Tmin;
gsl_root_fsolver *sroot;
gsl_min_fminimizer *smin;
double k_low, k_high, k_guess;
double k_min = NAN;
double k_max = NAN;
double k_peak = NAN;
double gr_peak;
double errabs, errrel;
double width_prefactor;
gsl_function F;
struct FUNCTION_PARAMS function_params;
//Get the physical parameters for the computation
params = malloc(sizeof(PARAMS_STRUCT));
probgen(input_file_name, params);
//Set up the grid, based on the physical parameters
grid = gridgen(params);
//Set up the rotation profile of a shear layer. Derive the width
//from the Ekman number, E=\nu/\Omega r^2, width = rE^(1/4)
//Use r = (r2-r1) and Omega = (Omega1-Omega2)/2.
shear_radius = get_dparam("shear_radius", input_file_name);
/*
width_prefactor = get_dparam("width_prefactor", input_file_name);
E = params->nu/(0.5*fabs(params->omega1 - params->omega2) *
pow((params->r2-params->r1),2));
shear_width = width_prefactor*(params->r2-params->r1)*pow(E, 0.25);
printf("Using shear layer width %g cm\n", shear_width);
*/
shear_width = get_dparam("shear_width", input_file_name);
rotation = shearlayer(params, grid, shear_width, shear_radius);
//Set up the matrix structure for the computations.
matrix = create_matrix(5*grid->numcells);
//Setup the ARPACK parameters
arpack_params = setup_arpack(input_file_name);
//Setup the output control structure
output_control = malloc(sizeof(OUTPUT_CONTROL));
//Pull the error params from the input file to decide when
//we have converged
errabs = get_dparam("errabs", input_file_name);
errrel = get_dparam("errrel", input_file_name);
//Put pointers to all of our control structures in function_params
function_params.params = params;
function_params.grid = grid;
function_params.rotation = rotation;
function_params.matrix = matrix;
function_params.arpack_params = arpack_params;
//Assign the evaluation function and params structure to
//the gsl_function
F.function = &mindampingrate;
F.params = &function_params;
gsl_set_error_handler(&err_handler);
/* Now we find the peak of the growth rate, by minimizing the
damping rate. We set what we hope are reasonable numbers
for the bounds and initial guess.
*/
k_low = 0.01;
k_high = 1000;
k_guess = params->k;
Tmin = gsl_min_fminimizer_brent;
smin = gsl_min_fminimizer_alloc(Tmin);
status = gsl_min_fminimizer_set(smin, &F, k_guess, k_low, k_high);
//Make sure that we didn't thrown an error on initialization
if (status == GSL_SUCCESS) {
//Now iterate!
iter = 0;
do
{
iter++;
status = gsl_min_fminimizer_iterate(smin);
//Make sure that we didn't thrown an error in the iteration routine
if (status != GSL_SUCCESS) {
fprintf(stderr, "Aborted attempt to find k_peak.\n");
break;
}
params->k = gsl_min_fminimizer_x_minimum(smin);
k_low = gsl_min_fminimizer_x_lower(smin);
k_high = gsl_min_fminimizer_x_upper(smin);
status = gsl_min_test_interval(k_low, k_high, errabs, errrel);
if(status == GSL_SUCCESS && params->VERBOSE) {
printf("Converged with k_peak=%g\n", params->k);
}
}
while (status == GSL_CONTINUE && iter < max_iter);
//Save the peak growth rate for printing later, then free the solver
gr_peak = -gsl_min_fminimizer_f_minimum(smin);
} else {
fprintf(stderr, "Aborted attempt to find k_peak.\n");
}
gsl_min_fminimizer_free(smin);
//Check to make sure we converged. If not, don't save the results.
if (status == GSL_SUCCESS) {
k_peak = params->k;
//Make sure everything is set up correctly for normal run
params->kva = params->k*params->va;
free(grid->r);
free(grid->x);
free(grid->r2inv);
free(grid);
grid = gridgen(params);
//Now do a normal run with the chosen k
arpack_params->sigma = find_sigma(matrix, params, grid, rotation,
arpack_params);
results = eigensolve(matrix, params, grid, rotation, arpack_params);
//Setup the structures needed to output the data files, and write them.
get_sparam("basefilename", input_file_name, output_control->basefilename);
strcat(output_control->basefilename, "_kpeak");
wnetcdf(params, grid, rotation, output_control, arpack_params, results);
free(results->lambda);
free(results->z);
free(results->residual);
free(results);
}
/* Now do a root finding search for k_min. */
/*
//Set up the root solver.
Troot = gsl_root_fsolver_brent;
sroot = gsl_root_fsolver_alloc(Troot);
//Set the initial bounds for the search. We're searching for k_min,
//so search from 0 up to k_peak.
k_low = 0;
k_high = k_peak;
status = gsl_root_fsolver_set(sroot, &F, k_low, k_high);
//Make sure that we didn't thrown an error on initialization
if (status == GSL_SUCCESS) {
//Now iterate!
iter = 0;
do
{
iter++;
status = gsl_root_fsolver_iterate(sroot);
//Make sure that we didn't thrown an error in the iteration routine
if (status != GSL_SUCCESS) {
fprintf(stderr, "Aborted attempt to find k_min.\n");
break;
}
params->k = gsl_root_fsolver_root(sroot);
k_low = gsl_root_fsolver_x_lower(sroot);
k_high = gsl_root_fsolver_x_upper(sroot);
status = gsl_root_test_interval(k_low, k_high, errabs, errrel);
if(status == GSL_SUCCESS && params->VERBOSE) {
printf("Converged with k_min=%g\n", params->k);
}
}
while (status == GSL_CONTINUE && iter < max_iter);
} else {
fprintf(stderr, "Aborted attempt to find k_min.\n");
}
gsl_root_fsolver_free (sroot);
//Check to make sure we converged. If not, don't save the results.
if (status == GSL_SUCCESS) {
k_min = params->k;
//Make sure everything is set up correctly for the normal run
params->kva = params->k*params->va;
free(grid->r);
free(grid->x);
free(grid->r2inv);
free(grid);
grid = gridgen(params);
//Now do a normal run with the chosen k
arpack_params->sigma = find_sigma(matrix, params, grid, rotation,
arpack_params);
results = eigensolve(matrix, params, grid, rotation, arpack_params);
//Set the new file name, and write the output
get_sparam("basefilename", input_file_name, output_control->basefilename);
strcat(output_control->basefilename, "_kmin");
wnetcdf(params, grid, rotation, output_control, arpack_params, results);
free(results->lambda);
free(results->z);
free(results->residual);
free(results);
}
*/
/* Now move on to solving for k_max. */
Troot = gsl_root_fsolver_brent;
sroot = gsl_root_fsolver_alloc(Troot);
//Set the initial bounds for the search. We're searching for k_max,
//so search from k_peak to a large number
k_low = k_peak;
k_high = 10000;
status = gsl_root_fsolver_set(sroot, &F, k_low, k_high);
//Make sure that we didn't thrown an error on initialization
if (status == GSL_SUCCESS) {
//Now iterate!
iter = 0;
do
{
iter++;
status = gsl_root_fsolver_iterate(sroot);
//Make sure that we didn't thrown an error in the iteration routine
if (status != GSL_SUCCESS) {
fprintf(stderr, "Aborted attempt to find k_max.\n");
break;
}
params->k = gsl_root_fsolver_root(sroot);
k_low = gsl_root_fsolver_x_lower(sroot);
k_high = gsl_root_fsolver_x_upper(sroot);
status = gsl_root_test_interval(k_low, k_high, errabs, errrel);
if(status == GSL_SUCCESS && params->VERBOSE) {
printf("Converged with k_max=%g\n", params->k);
}
}
while (status == GSL_CONTINUE && iter < max_iter);
} else {
fprintf(stderr, "Aborted attempt to find k_max.\n");
}
gsl_root_fsolver_free (sroot);
//Check to make sure we converged. If not, don't save the results.
if (status == GSL_SUCCESS) {
k_max = params->k;
//Make sure everything is set up correctly for the normal run
params->kva = params->k*params->va;
free(grid->r);
free(grid->x);
free(grid->r2inv);
free(grid);
grid = gridgen(params);
//Now do a normal run with the chosen k
arpack_params->sigma = find_sigma(matrix, params, grid, rotation,
arpack_params);
results = eigensolve(matrix, params, grid, rotation, arpack_params);
//Set the new file name, and write the output
get_sparam("basefilename", input_file_name, output_control->basefilename);
strcat(output_control->basefilename, "_kmax");
wnetcdf(params, grid, rotation, output_control, arpack_params, results);
free(results->lambda);
free(results->z);
free(results->residual);
free(results);
}
printf("Found k_min = %g, k_peak = %g, k_max = %g\n", k_min, k_peak, k_max);
printf("Peak growth rate: %g\n", gr_peak);
free(matrix->A);
free(matrix->B);
free(matrix->Bb);
free(matrix);
free(params);
free(grid->r);
free(grid->x);
free(grid->r2inv);
free(grid);
free(rotation->omega);
free(rotation);
free(output_control);
return;
}
/** ****************************************************************************************************
***** 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;*/
}
REAL8 XLALMinimizeEThincaParameterOverTravelTime( REAL8 travelTime,
EThincaMinimizer *minimizer,
INT4 exttrig
)
{
REAL8 ethinca;
/* If colocated detectors or known sky position, just return the e-thinca parameter */
if (travelTime == 0.0 || exttrig )
{
ethinca = minimizeEThincaParameterOverTimeDiff( travelTime, minimizer );
if ( XLAL_IS_REAL8_FAIL_NAN(ethinca) )
{
XLAL_ERROR_REAL8( XLAL_EFUNC );
}
return ethinca;
}
else
{
gsl_function F;
INT4 min_status;
INT4 iter = 0;
const INT4 max_iter = 100;
REAL8 epsilon = 1.0 / 16384.0;
REAL8 m = 0.0;
REAL8 a = - travelTime, b = travelTime; /* Upper and lower bounds */
REAL8 minEThinca, maxEThinca;
REAL8 midEThinca;
gsl_min_fminimizer *s = gsl_min_fminimizer_alloc( minimizer->workSpace->T );
if ( !s )
{
XLAL_ERROR_REAL8( XLAL_ENOMEM );
}
F.function = &minimizeEThincaParameterOverTimeDiff;
F.params = minimizer;
/* Calculate e-thinca parameter at start, end and mid points */
minEThinca = minimizeEThincaParameterOverTimeDiff( a, minimizer );
maxEThinca = minimizeEThincaParameterOverTimeDiff( b, minimizer );
midEThinca = minimizeEThincaParameterOverTimeDiff( m, minimizer );
if ( XLAL_IS_REAL8_FAIL_NAN(minEThinca) || XLAL_IS_REAL8_FAIL_NAN(maxEThinca)
|| XLAL_IS_REAL8_FAIL_NAN(midEThinca) )
{
gsl_min_fminimizer_free( s );
XLAL_ERROR_REAL8( XLAL_EFUNC );
}
/* Check we have contained a minimum. Otherwise take appropriate action */
if ( midEThinca >= minEThinca || midEThinca >= maxEThinca )
{
REAL8 testEThinca; /* To contain the lowest end-point */
if ( minEThinca < maxEThinca )
{
testEThinca = minEThinca;
m = a + 2.0 * epsilon;
}
else
{
testEThinca = maxEThinca;
m = b - 2.0 * epsilon;
}
midEThinca = minimizeEThincaParameterOverTimeDiff( m, minimizer );
if ( XLAL_IS_REAL8_FAIL_NAN(midEThinca) )
{
gsl_min_fminimizer_free( s );
XLAL_ERROR_REAL8( XLAL_EFUNC );
}
/* If we still don't have the minimum return the lowest end-point */
if ( midEThinca >= testEThinca )
{
gsl_min_fminimizer_free( s );
return testEThinca;
}
}
/* Set up the GSL minimizer */
XLAL_CALLGSL( min_status = gsl_min_fminimizer_set_with_values(s, &F,
m, midEThinca, a, minEThinca, b, maxEThinca) );
if ( min_status != GSL_SUCCESS )
{
gsl_min_fminimizer_free( s );
XLAL_ERROR_REAL8( XLAL_EFUNC );
}
/* Loop to perform the minimization */
do
{
iter++;
XLAL_CALLGSL( min_status = gsl_min_fminimizer_iterate (s) );
if (min_status != GSL_SUCCESS )
{
gsl_min_fminimizer_free( s );
XLAL_ERROR_REAL8( XLAL_EFUNC );
}
m = gsl_min_fminimizer_x_minimum (s);
a = gsl_min_fminimizer_x_lower (s);
b = gsl_min_fminimizer_x_upper (s);
XLAL_CALLGSL( min_status = gsl_min_test_interval (a, b, epsilon, 0.0) );
if (min_status != GSL_CONTINUE && min_status != GSL_SUCCESS )
{
gsl_min_fminimizer_free( s );
XLAL_ERROR_REAL8( XLAL_EFUNC );
}
}
while ( min_status == GSL_CONTINUE && iter < max_iter );
/* End of minimization routine */
/* Throw an error if max iterations would have been exceeded */
if ( iter == max_iter && min_status == GSL_CONTINUE )
{
gsl_min_fminimizer_free( s );
XLAL_ERROR_REAL8( XLAL_EMAXITER );
}
/* Get the minimum e-thinca param, and free memory for minimizer */
ethinca = gsl_min_fminimizer_f_minimum( s );
gsl_min_fminimizer_free( s );
XLALPrintInfo( "%s: Number of iterations = %d\n", __func__, iter);
}
/* Return the required e-thinca value */
return ethinca;
}
void find_periodic_solution_one_dim(double vz_init, double th_init, struct_all_ode *sao) {
struct_state_ode sx;
int nb_jump, ij, iq;
double t_max = 2;
double vth_init, vth_min, vth_max, vth_tolabs, deltaf;
int status;
int iter = 0, max_iter = 100;
const gsl_min_fminimizer_type *T;
gsl_min_fminimizer *s;
gsl_function F;
// init the function to minimize
vth_init = 0 * M_PI / 180;
vth_min = -200 * M_PI / 180;
vth_max = 200 * M_PI / 180;
vth_tolabs = 0.001 * M_PI / 180;
// find vth init such as to obtain a periodic solution
if (sao == NULL) {
sao = new_all_ode(sao, NULL);
}
sao->eps_rel = 1e-6;
sao->eps_abs = 1e-6;
sao->h = 1e-6;
sao->hmax = 1;
sao->mode = MODE_FLY;
sao->x[INDX_PH] = 0 * M_PI / 180;
sao->x[INDX_TH] = th_init;
sao->x[INDX_X] = 0;
sao->x[INDX_Z] = 0;
sao->x[INDX_R] = sao->r0;
sao->x[INDX_VPH] = 0 * M_PI / 180;
sao->x[INDX_VTH] = 0;
sao->x[INDX_VR] = 0; // vr for flying model
sao->x[INDX_ROOT] = 0;
// trajectoire periodique => pas de perte d'energie a l'aterrisage,
// vx =-vz.tan(theta) est imposee par vz et theta
// le seul parametre permettant de fixer la periodicite est vtheta
sao->x[INDX_TH] = th_init;
sao->x[INDX_VX] = -vz_init * sin(th_init) / cos(th_init);
sao->x[INDX_VZ] = vz_init;
sx.NX = sao->NX;
memcpy(sx.x, sao->x, sx.NX * sizeof (double));
sx.mode = sao->mode;
sx.time_s = 0;
sx.NX = sao->NX;
sao->initial_state = sx;
F.function = &get_delta_x_on_period_one_dim;
F.params = (void *) sao;
T = gsl_min_fminimizer_brent;
s = gsl_min_fminimizer_alloc(T);
gsl_min_fminimizer_set(s, &F, vth_init, vth_min, vth_max);
do {
iter++;
status = gsl_min_fminimizer_iterate(s);
vth_init = gsl_min_fminimizer_x_minimum(s);
vth_min = gsl_min_fminimizer_x_lower(s);
vth_max = gsl_min_fminimizer_x_upper(s);
status
= gsl_min_test_interval(vth_min, vth_max, vth_tolabs, 0.0);
if (status == GSL_SUCCESS) {
deltaf = get_delta_x_on_period_one_dim(vth_init, sao);
printf("Converged, delta f= %.5e:\n", deltaf);
printf("%5d [%.7f, %.7f] "
"%.7f delta=%.7f\n",
iter, vth_min, vth_max,
vth_init, vth_max - vth_min);
}
} while (status == GSL_CONTINUE && iter < max_iter);
gsl_min_fminimizer_free(s);
memcpy(sao->x, sao->initial_state.x, sao->NX * sizeof (double));
sao->time_second = 0;
sao->mode = sx.mode;
/*
sao->print_values_fly_to_sol = 1;
printf("--- initial state at time t= %e ----------\n", sao->final_state.time_s);
print_state(sao->initial_state.x, NULL);
print_energies(sao, sao->initial_state.x);
printf("--- final state at time t= %e ----------\n", sao->final_state.time_s);
print_state(sao->final_state.x, NULL);
print_energies(sao, sao->final_state.x);*/
}
bool PairMatchingCut::Get_CDA_FromCalculation( EventClass &E, int t, int a, double &z, double &cda, int &iterations)
{
//=====================================================================//
double z1,z2;
//------------------------------------------------------------------//
// Find the range where to look for the CDA //
//------------------------------------------------------------------//
if( E.dcmin[t] < E.dcmin[a])
{
z1 = E.geo->dc(std::min(E.dcmax[t], E.dcmin[a])).center().z();
z2 = E.geo->dc(std::max(E.dcmax[t], E.dcmin[a])).center().z();
}
else
{
z1 = E.geo->dc(std::min(E.dcmax[a], E.dcmin[t])).center().z();
z2 = E.geo->dc(std::max(E.dcmax[a], E.dcmin[t])).center().z();
}
z1 = z1 -0.2;
z2 = z2 +0.2;
// L corresponding to the maximum frequency:
// L1 --> omega1, L2 --> omega2, omega_max = w1 + w2 --> Lmin
double lmin = fabs(E.wavelen[t])*fabs(E.wavelen[a])/(fabs(E.wavelen[t])+fabs(E.wavelen[a]));
// cout<<" In Get_CDA_FromCalculation 2 lmin ="<<lmin<<endl;
// cout<<" In Get_CDA_FromCalculation 2 wavelen ="<<E.wavelen[t]<<" "<<E.wavelen[a]<<endl;
// cout<<" In Get_CDA_FromCalculation 2 ptot ="<<E.ptot[t]<<" "<<E.costh[a]<<endl;
//------------------------------------------------------------------//
// Sample the distance to isolate local minima //
// First decide about the number of points in the sample //
//------------------------------------------------------------------//
int nsample = int(12*(1.+fabs(z1-z2)/lmin));
TrackDistanceUV distance(E, t, a, z1, z2);
vector<double> dd(nsample);
for(int i = 0; i<nsample; i++) {
double z = z1 + (z2-z1)*i/double(nsample-1);
dd[i] = distance(z);
}
double A,M,B;
vector<MinBracket> brackets;
for(int i=1; i<nsample-1; i++) {
if( (dd[i] < dd[i-1]) && (dd[i] <= dd[i+1]) ) {
A = z1 + (z2-z1)*(i-1)/double(nsample-1);
M = z1 + (z2-z1)*i/double(nsample-1);
B = z1 + (z2-z1)*(i+1)/double(nsample-1);
brackets.push_back(MinBracket(A,M,B));
}
}
//------------------------------------------------------------------//
// Check the ends of the search interval //
//------------------------------------------------------------------//
// cout<<" In Get_CDA_FromCalculation 3"<<endl;
// The distance of approach
vector<double> Alldist;
// Position of minimal distance of approach
vector<double> Allz;
vector<int> Alliter;
if(dd[0] <= dd[1]) {
double ztest = z1 + std::min(z2-z1, tolerance_abs);
double ftest = distance(ztest);
if( (ftest <= dd[0]) && (ftest <= dd[1])) {
//std::cerr<<" z1 bracket"<<std::endl;
brackets.push_back(MinBracket(z1,ztest, z1 + (z2-z1)/double(nsample-1)));
}
else {
//std::cerr<<" z1 min"<<std::endl;
// Extract the distances of approach here
Alldist.push_back(dd[0]);
// Position of minimal distance of approach
Allz.push_back(z1);
Alliter.push_back(0);
}
}
if(dd[nsample-1] <= dd[nsample-2]) {
double ztest = z2 - std::min(z2-z1, tolerance_abs);
double ftest = distance(ztest);
if( (ftest <= dd[nsample-1]) && (ftest <= dd[nsample-2])) {
//std::cerr<<" z2 bracket"<<std::endl;
brackets.push_back(MinBracket(z1 + (z2-z1)*(nsample-2)/double(nsample-1), ztest, z2));
}
else {
//std::cerr<<" z2 min"<<std::endl;
// Extract the distances of approach here
Alldist.push_back(dd[nsample-1]);
// Position of minimal distance of approach
Allz.push_back(z2);
Alliter.push_back(0);
}
}
// cout<<" In Get_CDA_FromCalculation 4 brackets size ="<<brackets.size()<<endl;
//------------------------------------------------------------------//
// Loop over the brackets and for each one of them, find a minimum. //
//------------------------------------------------------------------//
for(unsigned i=0; i<brackets.size(); i++) {
//std::cerr<<"Bracket{"<<brackets[i].a<<", "<<brackets[i].m<<", "<<brackets[i].b<<std::endl;
const gsl_min_fminimizer_type *T = gsl_min_fminimizer_brent;
gsl_min_fminimizer *s = gsl_min_fminimizer_alloc (T);
gsl_function F;
F.function = &TrackDistanceUV::fwrapper;
F.params = &distance;
gsl_min_fminimizer_set(s, &F, brackets[i].m, brackets[i].a, brackets[i].b);
int iter=0;
while(1)
{
iter++;
int status;
if(GSL_SUCCESS != (status = gsl_min_fminimizer_iterate (s)) )
{
gsl_min_fminimizer_free(s);
Log->warn("PairMatchingCut: Get_CDA_FromCalculation(): failure from gsl_min_fminimizer_iterate(): status==%i", status);
return false;
}
M = gsl_min_fminimizer_x_minimum (s);
A = gsl_min_fminimizer_x_lower (s);
B = gsl_min_fminimizer_x_upper (s);
status = gsl_min_test_interval (A, B, tolerance_abs, tolerance_rel);
if (status == GSL_SUCCESS) {
//printf ("Converged:\n");
//printf ("%5d [%.7f, %.7f] %.7f %.7f\n", iter, a, b, m, b - a);
// Extract the distances of approach here
Alldist.push_back(gsl_min_fminimizer_f_minimum(s));
// Position of minimal distance of approach
Allz.push_back(M);
Alliter.push_back(iter);
break;
}
else if(status == GSL_CONTINUE) {
if(iter>max_iter) {
gsl_min_fminimizer_free(s);
Log->warn("PairMatchingCut: Get_CDA_FromCalculation(): exceeded max_iter=");
return false;
}
}
else {
gsl_min_fminimizer_free(s);
Log->warn("PairMatchingCut: Get_CDA_FromCalculation(); failure from gsl_min_test_interval(): status=");
return false;
}
} // while(1) minimize
gsl_min_fminimizer_free(s);
} // for(brackets)
// cout<<" In Get_CDA_FromCalculation 5 Alldist size ="<<Alldist.size()<<endl;
//------------------------------------------------------------------//
// The CDA is the minimum of all the distances of approach //
//------------------------------------------------------------------//
int MinIndex = -1;
cda = 500.;
z = 1000.;
iterations = 0;
// cout<<" In Get_CDA_FromCalculation 6 cda = "<<cda<<endl;
for (int i = 0; i < Alldist.size(); i++)
{
// cout<<" In Get_CDA_FromCalculation 6.1 AllDist[0] = "<<Alldist[0]<<endl;
if ( Alldist[i] < cda )
{
MinIndex = i;
cda = Alldist[i];
// cout<<" In Get_CDA_FromCalculation 6.2 cda = "<<cda<<endl;
}
}
if (MinIndex == -1)
{
Log->warn("PairMatchingCut: Get_CDA_FromCalculation(); The cda could not be found.");
cda = 500; // Safer with a large number since we cut on the small cda.
return false;
}
else
{
z = Allz[MinIndex];
iterations = Alliter[MinIndex];
}
// cout<<" In Get_CDA_FromCalculation 7 cda = "<<cda<<endl;
return true;
}
/** ****************************************************************************************************
***** 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);
}
