https://github.com/MoorjaniLab/DATES_v4010
Raw File
Tip revision: e034dc0d6fe8d41a828796f07791d50011b6bb04 authored by MoorjaniLab on 09 May 2022, 23:55:41 UTC
Add files via upload
Tip revision: e034dc0
gslfit.c
#include <stdio.h>
#include <string.h>
#include <unistd.h>
#include <math.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>

#include <nicklib.h>
#include <getpars.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_multimin.h>
#include <gsl/gsl_errno.h>
#include "qpsubs.h"

#define WVERSION   "100"
#define MAXSTR  512

extern int gsldetails;
extern double gslprecision;

double scorexp (double *www) ;
static int xnexp;
static double *xvexp;
static double *www;

gsl_multimin_fminimizer *s = NULL;
static gsl_vector *ss, *x;
gsl_multimin_function minex_func;

double fjunk2 (const gsl_vector *v, void *params);
static double fff (double *a, int n);

double p2s (double p) 
{
  if (p==0.0) return -1.0e20 ;
  if (p==1.0) return 1.0e20 ;
  return log(p/(1-p)) ;
}

double s2p (double s) 
{
  double r ;
  r = exp(s) ; 
  return  r/(1+r) ;
}


int
gslsetup (int nexp, double *vexp)
{
  int k;
  const gsl_multimin_fminimizer_type *T = gsl_multimin_fminimizer_nmsimplex2;

  if (nexp == 0)
    return 0;
  xnexp = nexp;
  ZALLOC (xvexp, nexp, double);
  copyarr (vexp, xvexp, nexp);
  ZALLOC (www,  nexp, double);


  minex_func.n = nexp;
  minex_func.f = fjunk2;
  minex_func.params = NULL;

  x = gsl_vector_alloc (nexp);
  for (k = 0; k < nexp; ++k) {
    gsl_vector_set (x, k, s2p(vexp[k]));
  }

  /* Set initial step sizes to 0.01 */
  ss = gsl_vector_alloc (nexp);
  gsl_vector_set_all (ss, 0.01);

  /* Initialize method and iterate */

  s = gsl_multimin_fminimizer_alloc (T, nexp);
  gsl_multimin_fminimizer_set (s, &minex_func, x, ss);

  gsl_set_error_handler_off ();

//  gsldetails = YES ;  
  printf ("gslsetup called\n");
  
  return 1;
}


double
gslopt (double *wpars)
{
  size_t iter = 0, k;
  int status;
  double size;
  double q = 999999;
  double qbest = 1.0e40;

  /* Starting point */


  for (k = 0; k < xnexp; ++k) {
    gsl_vector_set (x, k, s2p(wpars[k]));
  }
  gsl_multimin_fminimizer_set (s, &minex_func, x, ss);

  gsl_set_error_handler_off ();

  do {
    iter++;
    status = gsl_multimin_fminimizer_iterate (s);

    if (status)
      break;

    size = gsl_multimin_fminimizer_size (s);
    status = gsl_multimin_test_size (size, gslprecision);
    q = s->fval;
    if (gsldetails)
      printf ("gslopt: %3d %12.6f\n", (int) iter, q);
    if (q < qbest) {
      if (gsldetails)
	printf ("+++ new best\n");
      qbest = q;
      for (k = 0; k < xnexp; ++k) {
	wpars[k] = gsl_vector_get (s->x, k);
      }
    }
  }
  while (status == GSL_CONTINUE && iter < 10000);

  printf ("gslans: %4d %12.6f\n", (int) iter, q);
  fff (wpars, xnexp);
  printmat (wpars, 1, xnexp);

  fflush (stdout);
  return q;
}

double
fff (double *a, int n)
// make a cononical; return penalty
{
  double penalty = 0;
  int k;
  double xx, y, yy;

  for (k = 0; k < n; ++k) {
    yy = xx = a[k];
    if ((xx >= 0) && (xx <= 1))
      continue;
    if (xx < 0) {
      yy = -yy;
    }
    if (yy > 1) {
      yy = 2.0 * modf (0.5 * yy, &y);   // periodicity is 2
      if (yy > 1)
        yy = 2 - yy;
    }
    y = yy - xx;
    penalty += y * y;
    a[k] = xx = yy;
  }
  return penalty;
}


double
fjunk2 (const gsl_vector * v, void *params)
{
  double xx;
  double q;
  int k, t = 0;
  double *tt;
  double penalty = 0;

  ZALLOC (tt, xnexp, double);
  for (k = 0; k < xnexp; ++k) {
    tt[k] = gsl_vector_get (v, k);
  }
  penalty = fff (tt, xnexp);

  t = 0;
  for (k = 0; k < xnexp; ++k) {
    xx = tt[k];
    www[k] = xx ;     
  }
  q = scorexp(www) ;
  q += 10 * penalty;
  if (gsldetails) {
    printf ("zzfjunk2 %12.6f\n", q);
    printmat (tt, 1, xnexp);
  }
  free (tt);
  return q;
}
back to top