double compute_daem_free_energy_l0(void) {
double l0 = 0.0;
double smooth_sum;
SW_INS_PTR ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->smooth + 1.0);
ptr = ptr->next;
}
l0 += lngamma(smooth_sum);
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->inside_h);
ptr = ptr->next;
}
l0 -= lngamma(smooth_sum) / itemp;
ptr = occ_switches[i];
while (ptr != NULL) {
l0 += lngamma(ptr->inside_h) / itemp;
l0 -= lngamma(ptr->smooth + 1.0);
ptr = ptr->next;
}
}
return l0;
}
/* Computes the probability density function
*
* @param x Value
*/
double StudentDistribution::pdf(double x)
{
// If ndf == 1, this is a Cauchy distribution
if( ndf == 1 )
{
return ( 1.0 / ( PI * ( 1.0 + x*x ) ) );
}
// If ndf == 2, we use a simpler equation
if( ndf == 2 )
{
double temp( 2.0 + x*x );
return ( 1.0 / ( std::sqrt( temp * temp * temp ) ) );
}
double nu( static_cast<double>(ndf) );
// Let's compute some terms
double t1( 0.5*nu );
double t2( t1 + 0.5 );
double t3( std::log( std::sqrt(nu*PI) ) );
return ( std::exp( lngamma(t2) - t2 * std::log(1.0 + x*x/nu)
- t3 - lngamma(t1) ) );
} // End of method 'StudentDistribution::pdf()'
double lnfactorial(double n)
{
static double a[101];
int N = (int) n;
if (N <= 1) return 0.0;
if (N <= 100) return a[N] ? a[N] : (a[N]=lngamma(N+1.0));
else return lngamma(N+1.0);
}
double compute_cs(double likelihood)
{
double cs;
double l0, l1, l2;
int i;
SW_INS_PTR ptr;
double smooth_sum;
/* Compute BD score using the expectations: */
l0 = 0.0;
for (i = 0; i < occ_switch_tab_size; i++) {
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->smooth + 1.0);
ptr = ptr->next;
}
l0 += lngamma(smooth_sum);
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->total_expect + ptr->smooth + 1.0);
ptr = ptr->next;
}
l0 -= lngamma(smooth_sum);
ptr = occ_switches[i];
while (ptr != NULL) {
l0 += lngamma(ptr->total_expect + ptr->smooth + 1.0);
l0 -= lngamma(ptr->smooth + 1.0);
ptr = ptr->next;
}
}
/* Compute the likelihood of complete data using the expectations: */
l1 = 0.0;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
while (ptr != NULL) {
l1 += ptr->total_expect * log(ptr->inside);
ptr = ptr->next;
}
}
/* Get the log-likelihood: */
l2 = likelihood;
cs = l0 - l1 + l2;
return cs;
}
static double compute_rerank_score(void)
{
int i,s;
V_ENT_PTR v_ent;
EG_PATH_PTR path_ptr = NULL;
int k;
SW_INS_PTR sw_ins_ptr;
double score = 0.0;
double alpha_sum0,alpha_sum1;
for (i = 0; i < occ_switch_tab_size; i++) {
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
sw_ins_ptr->count = 0;
sw_ins_ptr = sw_ins_ptr->next;
}
}
for (s = 0; s < n_viterbi_egraph_size; s++) {
v_ent = n_viterbi_egraphs[s];
path_ptr = v_ent->path_ptr;
if (path_ptr == NULL) continue;
for (k = 0; k < path_ptr->sws_len; k++) {
path_ptr->sws[k]->count++;
}
}
score = 0.0;
for (i = 0; i < occ_switch_tab_size; i++) {
alpha_sum0 = 0.0;
alpha_sum1 = 0.0;
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
alpha_sum0 += sw_ins_ptr->inside_h;
alpha_sum1 += sw_ins_ptr->count + sw_ins_ptr->inside_h;
sw_ins_ptr = sw_ins_ptr->next;
}
score += lngamma(alpha_sum0) - lngamma(alpha_sum1);
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
score += lngamma(sw_ins_ptr->count + sw_ins_ptr->inside_h);
score -= lngamma(sw_ins_ptr->inside_h);
sw_ins_ptr = sw_ins_ptr->next;
}
}
return score;
}
double ibeta(double a, double b, double x)
{
double bt;
if (x < 0.0 || x > 1.0 || a <= 0.0 || b <= 0.0) return 0;
if (x == 0.0 || x == 1.0) bt=0.0;
else
bt=exp(lngamma(a+b)-lngamma(a)-lngamma(b)+a*log(x)+b*log(1.0-x));
if (x < (a+1.0)/(a+b+2.0))
return bt*betacf(a,b,x)/a;
else
return 1.0-bt*betacf(b,a,1.0-x)/b;
}
value gamma_CAML_lngamma( value v_x )
{
CAMLparam1( v_x );
CAMLlocal1( v_lng );
v_lng = caml_copy_double( lngamma( Double_val( v_x ) ) );
CAMLreturn( v_lng );
}
void test02 ( )
/******************************************************************************/
/*
Purpose:
TEST02 demonstrates the use of LNGAMMA.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
20 November 2010
Author:
John Burkardt
*/
{
double fx;
double fx2;
int ier;
int n_data;
double x;
printf ( "\n" );
printf ( "TEST02:\n" );
printf ( " LNGAMMA computes the logarithm of the \n" );
printf ( " Gamma function. We compare the result\n" );
printf ( " to tabulated values.\n" );
printf ( "\n" );
printf ( " X " );
printf ( "FX FX2\n" );
printf ( " " );
printf ( "(Tabulated) (LNGAMMA) DIFF\n" );
printf ( "\n" );
n_data = 0;
for ( ; ; )
{
gamma_log_values ( &n_data, &x, &fx );
if ( n_data == 0 )
{
break;
}
fx2 = lngamma ( x, &ier );
printf ( " %24.16f %24.16f %24.16f %10.4e\n",
x, fx, fx2, fabs ( fx - fx2 ) );
}
return;
}
/** [chi_pp p v]
* Finds the percentage point [p] of the chi squared distribution of [v] degrees
* of freedom. The gamma is related to this distribution by the define below.
*
* Algorithm AS91: The Percentage Points of the chi^2 Distribution
* (translated to C, and removed goto's ~nrl) */
double chi_pp( double p, double v ){
double ch,s1,s2,s3,s4,s5,s6;
double e,aa,xx,c,g,x,p1,a,q,p2,t,ig,b;
assert( v > 0.0 );
if (p < 0.000002 || p > 0.999998)
failwith("Chi^2 Percentage Points incorrect.1");
e = 0.5e-6; /** error term **/
aa= 0.6931471805;
xx = 0.5 * v;
c = xx - 1.0;
g = lngamma( xx );
if( v < -1.24 * log(p) ){
ch = pow(p * xx * exp ( g + xx * aa), 1.0/xx);
if( ch - e < 0 ) return ch;
} else if( v > 0.32) {
x = point_normal( p );
p1 = 0.222222 / v;
ch = v * pow( x * sqrt( p1 ) + 1 - p1, 3.0) ;
if (ch > 2.2 * v + 6)
ch = -2.0 * (log(1-p) - c*log(0.5*ch)+g);
} else {
ch = 0.4;
a = log (1 - p);
do{
q = ch;
p1 = 1 + ch * (4.67 + ch);
p2 = ch * (6.73 + ch * (6.66 + ch));
t = -0.5 + (4.67 + 2*ch)/p1 - (6.73 + ch*(13.32 + 3*ch))/p2;
ch = ch - (1- exp( a + g + 0.5*ch+c*aa) * p2/p1)/t;
} while( fabs( q/ch - 1) - 0.01 > 0.0 );
}
do{
q = ch;
p1 = .5*ch;
ig = gammap( p1, xx );
if (ig < 0){ failwith("Chi^2 Percentage Points incorrect.2"); }
p2 = p - ig;
t = p2 * exp( xx*aa + g + p1 - c*log(ch));
b = t / ch;
a = (0.5*t) - (b*c);
/* Seven terms of the Taylor series */
s1 = (210 + a*(140 + a*(105 + a*(84 + a*(70 + 60*a))))) / 420.0;
s2 = (420 + a*(735 + a*(966 + a*(1141 + 1278*a)))) / 2520.0;
s3 = (210 + a*(462 + a*(707 + 932*a))) / 2520.0;
s4 = (252 + a*(672 + 1182*a) + c*(294 + a*(889 + 1740*a))) / 5040.0;
s5 = ( 84 + 264*a + c*(175 + 606*a)) / 2520.0;
s6 = (120 + c*(346 + 127*c)) / 5040.0;
ch+= t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6))))));
} while( fabs(q / ch - 1.0) > e);
return (ch);
}
/*************************************************************************
Returns nodes/weights for Gauss-Laguerre quadrature on [0,+inf) with
weight function W(x)=Power(x,Alpha)*Exp(-x)
INPUT PARAMETERS:
N - number of nodes, >=1
Alpha - power-law coefficient, Alpha>-1
OUTPUT PARAMETERS:
Info - error code:
* -4 an error was detected when calculating
weights/nodes. Alpha is too close to -1 to
obtain weights/nodes with high enough accuracy
or, may be, N is too large. Try to use
multiple precision version.
* -3 internal eigenproblem solver hasn't converged
* -1 incorrect N/Alpha was passed
* +1 OK
X - array[0..N-1] - array of quadrature nodes,
in ascending order.
W - array[0..N-1] - array of quadrature weights.
-- ALGLIB --
Copyright 12.05.2009 by Bochkanov Sergey
*************************************************************************/
void gqgenerategausslaguerre(int n,
double alpha,
int& info,
ap::real_1d_array& x,
ap::real_1d_array& w)
{
ap::real_1d_array a;
ap::real_1d_array b;
double t;
int i;
double s;
if( n<1||ap::fp_less_eq(alpha,-1) )
{
info = -1;
return;
}
a.setlength(n);
b.setlength(n);
a(0) = alpha+1;
t = lngamma(alpha+1, s);
if( ap::fp_greater_eq(t,log(ap::maxrealnumber)) )
{
info = -4;
return;
}
b(0) = exp(t);
if( n>1 )
{
for(i = 1; i <= n-1; i++)
{
a(i) = 2*i+alpha+1;
b(i) = i*(i+alpha);
}
}
gqgeneraterec(a, b, b(0), n, info, x, w);
//
// test basic properties to detect errors
//
if( info>0 )
{
if( ap::fp_less(x(0),0) )
{
info = -4;
}
for(i = 0; i <= n-2; i++)
{
if( ap::fp_greater_eq(x(i),x(i+1)) )
{
info = -4;
}
}
}
}
double factorial(double n)
{
static int ntop=4;
static double a[33]={1.0,1.0,2.0,6.0,24.0};
int j;
if (n < 0) return 0;
if (n > 32) return exp(lngamma(n+1.0));
while (ntop<(int)n) {
j=ntop++;
a[ntop]=a[j]*ntop;
}
return a[(int)n];
}
double gammaCDF(double a, double x) {
double gln, p;
if (x <= 0.0 || a <= 0.0)
return 0.0;
else if (a > LARGE_A)
return gnorm(a, x);
else {
gln = lngamma(a);
if (x < (a + 1.0))
return gser(a, x, gln);
else
return (1.0 - gcf(a, x, gln));
}
}
/**
* Retuns the incomplete gamma function evaluated by its series representation
* also, ln gamma in gln.
*
* "Numerical Recipes in C", Section 6.2
*/
void gser(double *gam,double a,double x,double *gln)
{
double sum,del,ap;
*gln = lngamma ( a );
if (x <= 0.0 ) { *gam = 0.0; return; }
ap = a;
del = sum = 1.0 / a;
for(;;) {
++ap;
del *= x/ap;
sum += del;
if (fabs(del) < fabs(sum)*EPSILON){
*gam = sum * exp(-x+a*log(x)-(*gln));
break;
}
}
}
/*************************************************************************
Incomplete gamma integral
The function is defined by
x
-
1 | | -t a-1
igam(a,x) = ----- | e t dt.
- | |
| (a) -
0
In this implementation both arguments must be positive.
The integral is evaluated by either a power series or
continued fraction expansion, depending on the relative
values of a and x.
ACCURACY:
Relative error:
arithmetic domain # trials peak rms
IEEE 0,30 200000 3.6e-14 2.9e-15
IEEE 0,100 300000 9.9e-14 1.5e-14
Cephes Math Library Release 2.8: June, 2000
Copyright 1985, 1987, 2000 by Stephen L. Moshier
*************************************************************************/
double incompletegamma(double a, double x)
{
double result;
double igammaepsilon;
double ans;
double ax;
double c;
double r;
double tmp;
igammaepsilon = 0.000000000000001;
if( ap::fp_less_eq(x,0)||ap::fp_less_eq(a,0) )
{
result = 0;
return result;
}
if( ap::fp_greater(x,1)&&ap::fp_greater(x,a) )
{
result = 1-incompletegammac(a, x);
return result;
}
ax = a*log(x)-x-lngamma(a, tmp);
if( ap::fp_less(ax,-709.78271289338399) )
{
result = 0;
return result;
}
ax = exp(ax);
r = a;
c = 1;
ans = 1;
do
{
r = r+1;
c = c*x/r;
ans = ans+c;
}
while(ap::fp_greater(c/ans,igammaepsilon));
result = ans*ax/a;
return result;
}
/**
* Returns the incomplete gamma function evaluated by its continued fraction
* also, ln gamma in gln.
*
* "Numerical Recipes in C", Section 6.2
*/
void gcf( double *gam,double a,double x,double *gln )
{
int i;
double an,b,c,d,del,h;
*gln = lngamma( a );
b = x + 1.0 - a;
c = 1.0 / FABMIN;
d = 1.0 / b;
h=d;
for(i=1;;i++){
an = -i*(i-a);
b += 2.0;
d = an*d+b;
if ( fabs(d) < FABMIN ){ d=FABMIN; }
c = b+an/c;
if ( fabs(c) < FABMIN ){ c=FABMIN; }
d = 1.0 / d;
del = d*c;
h *= del;
if (fabs(del-1.0) <= EPSILON){ break; }
}
*gam = exp(-x+a*log(x)-(*gln))*h;
}
void gcf(double *gammcf, double a, double x, double *gln)
{
int i;
double an,b,c,d,del,h;
*gln=lngamma(a);
b=x+1.0-a;
c=1.0/FPMIN;
d=1.0/b;
h=d;
for (i=1;i<=MAXIT;i++) {
an = -i*(i-a);
b += 2.0;
d=an*d+b;
if (fabs(d) < FPMIN) d=FPMIN;
c=b+an/c;
if (fabs(c) < FPMIN) c=FPMIN;
d=1.0/d;
del=d*c;
h *= del;
if (fabs(del-1.0) < EPS) break;
}
*gammcf=exp(-x+a*log(x)-(*gln))*h;
}
void gser(double *gamser, double a, double x, double *gln)
{
int n;
double sum,del,ap;
*gln=lngamma(a);
if (x <= 0.0) {
*gamser=0.0;
return;
} else {
ap=a;
del=sum=1.0/a;
for (n=1;n<=MAXIT;n++) {
++ap;
del *= x/ap;
sum += del;
if (fabs(del) < fabs(sum)*EPS) {
*gamser=sum*exp(-x+a*log(x)-(*gln));
return;
}
}
return;
}
}
bool testgamma(bool silent)
{
bool result;
double threshold;
double v;
double s;
bool waserrors;
bool gammaerrors;
bool lngammaerrors;
gammaerrors = false;
lngammaerrors = false;
waserrors = false;
threshold = 100*ap::machineepsilon;
//
//
//
gammaerrors = gammaerrors||fabs(gamma(0.5)-sqrt(ap::pi()))>threshold;
gammaerrors = gammaerrors||fabs(gamma(1.5)-0.5*sqrt(ap::pi()))>threshold;
v = lngamma(0.5, s);
lngammaerrors = lngammaerrors||fabs(v-log(sqrt(ap::pi())))>threshold||s!=1;
v = lngamma(1.5, s);
lngammaerrors = lngammaerrors||fabs(v-log(0.5*sqrt(ap::pi())))>threshold||s!=1;
//
// report
//
waserrors = gammaerrors||lngammaerrors;
if( !silent )
{
printf("TESTING GAMMA FUNCTION\n");
printf("GAMMA: ");
if( gammaerrors )
{
printf("FAILED\n");
}
else
{
printf("OK\n");
}
printf("LN GAMMA: ");
if( lngammaerrors )
{
printf("FAILED\n");
}
else
{
printf("OK\n");
}
if( waserrors )
{
printf("TEST FAILED\n");
}
else
{
printf("TEST PASSED\n");
}
printf("\n\n");
}
//
// end
//
result = !waserrors;
return result;
}
/**
* Computes ln(|Gamma(x)|).
*/
double lngamma(double x) {
/* Constants for [0.5,1.5) -------------------------------------------*/
const double D1 = -5.772156649015328605195174e-01;
const double P1[] = {
+4.945235359296727046734888e+00, +2.018112620856775083915565e+02,
+2.290838373831346393026739e+03, +1.131967205903380828685045e+04,
+2.855724635671635335736389e+04, +3.848496228443793359990269e+04,
+2.637748787624195437963534e+04, +7.225813979700288197698961e+03
};
const double Q1[] = {
+6.748212550303777196073036e+01, +1.113332393857199323513008e+03,
+7.738757056935398733233834e+03, +2.763987074403340708898585e+04,
+5.499310206226157329794414e+04, +6.161122180066002127833352e+04,
+3.635127591501940507276287e+04, +8.785536302431013170870835e+03
};
/* Constants for [1.5,4.0) -------------------------------------------*/
const double D2 = +4.227843350984671393993777e-01;
const double P2[] = {
+4.974607845568932035012064e+00, +5.424138599891070494101986e+02,
+1.550693864978364947665077e+04, +1.847932904445632425417223e+05,
+1.088204769468828767498470e+06, +3.338152967987029735917223e+06,
+5.106661678927352456275255e+06, +3.074109054850539556250927e+06
};
const double Q2[] = {
+1.830328399370592604055942e+02, +7.765049321445005871323047e+03,
+1.331903827966074194402448e+05, +1.136705821321969608938755e+06,
+5.267964117437946917577538e+06, +1.346701454311101692290052e+07,
+1.782736530353274213975932e+07, +9.533095591844353613395747e+06
};
/* Constants for [4.0,12.0) ------------------------------------------*/
const double D4 = +1.791759469228055000094023e+00;
const double P4[] = {
+1.474502166059939948905062e+04, +2.426813369486704502836312e+06,
+1.214755574045093227939592e+08, +2.663432449630976949898078e+09,
+2.940378956634553899906876e+10, +1.702665737765398868392998e+11,
+4.926125793377430887588120e+11, +5.606251856223951465078242e+11
};
const double Q4[] = {
+2.690530175870899333379843e+03, +6.393885654300092398984238e+05,
+4.135599930241388052042842e+07, +1.120872109616147941376570e+09,
+1.488613728678813811542398e+10, +1.016803586272438228077304e+11,
+3.417476345507377132798597e+11, +4.463158187419713286462081e+11
};
/* Constants for [12.0,Infinity) -------------------------------------*/
const double C[] = {
-2.955065359477124231624146e-02, +6.410256410256410034009811e-03,
-1.917526917526917633674555e-03, +8.417508417508417139715760e-04,
-5.952380952380952917890600e-04, +7.936507936507936501052685e-04,
-2.777777777777777883788657e-03, +8.333333333333332870740406e-02
};
/*--------------------------------------------------------------------*/
const double EPS = 2.22e-16;
const double P68 = 87.0 / 128.0;
const double BIG = 2.25e+76;
/*--------------------------------------------------------------------*/
double p, q, y;
int i, n;
if (x != x) /* NaN */
return x;
else if (0 * x != 0) /* Infinity */
return HUGE_VAL;
else if (x <= 0.0) {
q = modf(-2.0 * x, &p);
n = (int)(p);
q = sin(PI_2 * (n % 2 == 0 ? q : 1.0 - q));
return log(PI / q) - lngamma(1.0 - x);
} else if (x < EPS)
return -log(x);
else if (x < 0.5) {
p = 0.0;
q = 1.0;
y = x;
for (i = 0; i < 8; i++) {
p = p * y + P1[i];
q = q * y + Q1[i];
}
return x * (D1 + y * (p / q)) - log(x);
} else if (x < P68) {
p = 0.0;
q = 1.0;
y = x - 1.0;
for (i = 0; i < 8; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
return y * (D2 + y * (p / q)) - log(x);
} else if (x < 1.5) {
p = 0.0;
q = 1.0;
y = x - 1.0;
for (i = 0; i < 8; i++) {
p = p * y + P1[i];
q = q * y + Q1[i];
}
return y * (D1 + y * (p / q));
} else if (x < 4.0) {
p = 0.0;
q = 1.0;
y = x - 2.0;
for (i = 0; i < 8; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
return y * (D2 + y * (p / q));
} else if (x < 12.0) {
p = 0.0;
q = -1.0;
y = x - 4.0;
for (i = 0; i < 8; i++) {
p = p * y + P4[i];
q = q * y + Q4[i];
}
return D4 + y * (p / q);
} else if (x < BIG) {
p = 0.0;
q = log(x);
y = 1.0 / (x * x);
for (i = 0; i < 8; i++) {
p = p * y + C[i];
}
return p / x + LN_SQRT2PI - 0.5 * q + x * (q - 1.0);
} else {
q = log(x);
return LN_SQRT2PI - 0.5 * q + x * (q - 1.0);
}
/*--------------------------------------------------------------------*/
}
/*************************************************************************
Inverse of complemented imcomplete gamma integral
Given p, the function finds x such that
igamc( a, x ) = p.
Starting with the approximate value
3
x = a t
where
t = 1 - d - ndtri(p) sqrt(d)
and
d = 1/9a,
the routine performs up to 10 Newton iterations to find the
root of igamc(a,x) - p = 0.
ACCURACY:
Tested at random a, p in the intervals indicated.
a p Relative error:
arithmetic domain domain # trials peak rms
IEEE 0.5,100 0,0.5 100000 1.0e-14 1.7e-15
IEEE 0.01,0.5 0,0.5 100000 9.0e-14 3.4e-15
IEEE 0.5,10000 0,0.5 20000 2.3e-13 3.8e-14
Cephes Math Library Release 2.8: June, 2000
Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier
*************************************************************************/
double invincompletegammac(double a, double y0)
{
double result;
double igammaepsilon;
double iinvgammabignumber;
double x0;
double x1;
double x;
double yl;
double yh;
double y;
double d;
double lgm;
double dithresh;
int i;
int dir;
double tmp;
igammaepsilon = 0.000000000000001;
iinvgammabignumber = 4503599627370496.0;
x0 = iinvgammabignumber;
yl = 0;
x1 = 0;
yh = 1;
dithresh = 5*igammaepsilon;
d = 1/(9*a);
y = 1-d-invnormaldistribution(y0)*sqrt(d);
x = a*y*y*y;
lgm = lngamma(a, tmp);
i = 0;
while(i<10)
{
if( ap::fp_greater(x,x0)||ap::fp_less(x,x1) )
{
d = 0.0625;
break;
}
y = incompletegammac(a, x);
if( ap::fp_less(y,yl)||ap::fp_greater(y,yh) )
{
d = 0.0625;
break;
}
if( ap::fp_less(y,y0) )
{
x0 = x;
yl = y;
}
else
{
x1 = x;
yh = y;
}
d = (a-1)*log(x)-x-lgm;
if( ap::fp_less(d,-709.78271289338399) )
{
d = 0.0625;
break;
}
d = -exp(d);
d = (y-y0)/d;
if( ap::fp_less(fabs(d/x),igammaepsilon) )
{
result = x;
return result;
}
x = x-d;
i = i+1;
}
if( ap::fp_eq(x0,iinvgammabignumber) )
{
if( ap::fp_less_eq(x,0) )
{
x = 1;
}
while(ap::fp_eq(x0,iinvgammabignumber))
{
x = (1+d)*x;
y = incompletegammac(a, x);
if( ap::fp_less(y,y0) )
{
x0 = x;
yl = y;
break;
}
d = d+d;
}
}
d = 0.5;
dir = 0;
i = 0;
while(i<400)
{
x = x1+d*(x0-x1);
y = incompletegammac(a, x);
lgm = (x0-x1)/(x1+x0);
if( ap::fp_less(fabs(lgm),dithresh) )
{
break;
}
lgm = (y-y0)/y0;
if( ap::fp_less(fabs(lgm),dithresh) )
{
break;
}
if( ap::fp_less_eq(x,0.0) )
{
break;
}
if( ap::fp_greater_eq(y,y0) )
{
x1 = x;
yh = y;
if( dir<0 )
{
dir = 0;
d = 0.5;
}
else
{
if( dir>1 )
{
d = 0.5*d+0.5;
}
else
{
d = (y0-yl)/(yh-yl);
}
}
dir = dir+1;
}
else
{
x0 = x;
yl = y;
if( dir>0 )
{
dir = 0;
d = 0.5;
}
else
{
if( dir<-1 )
{
d = 0.5*d;
}
else
{
d = (y0-yl)/(yh-yl);
}
}
dir = dir-1;
}
i = i+1;
}
result = x;
return result;
}
/*************************************************************************
Complemented incomplete gamma integral
The function is defined by
igamc(a,x) = 1 - igam(a,x)
inf.
-
1 | | -t a-1
= ----- | e t dt.
- | |
| (a) -
x
In this implementation both arguments must be positive.
The integral is evaluated by either a power series or
continued fraction expansion, depending on the relative
values of a and x.
ACCURACY:
Tested at random a, x.
a x Relative error:
arithmetic domain domain # trials peak rms
IEEE 0.5,100 0,100 200000 1.9e-14 1.7e-15
IEEE 0.01,0.5 0,100 200000 1.4e-13 1.6e-15
Cephes Math Library Release 2.8: June, 2000
Copyright 1985, 1987, 2000 by Stephen L. Moshier
*************************************************************************/
double incompletegammac(double a, double x)
{
double result;
double igammaepsilon;
double igammabignumber;
double igammabignumberinv;
double ans;
double ax;
double c;
double yc;
double r;
double t;
double y;
double z;
double pk;
double pkm1;
double pkm2;
double qk;
double qkm1;
double qkm2;
double tmp;
igammaepsilon = 0.000000000000001;
igammabignumber = 4503599627370496.0;
igammabignumberinv = 2.22044604925031308085*0.0000000000000001;
if( ap::fp_less_eq(x,0)||ap::fp_less_eq(a,0) )
{
result = 1;
return result;
}
if( ap::fp_less(x,1)||ap::fp_less(x,a) )
{
result = 1-incompletegamma(a, x);
return result;
}
ax = a*log(x)-x-lngamma(a, tmp);
if( ap::fp_less(ax,-709.78271289338399) )
{
result = 0;
return result;
}
ax = exp(ax);
y = 1-a;
z = x+y+1;
c = 0;
pkm2 = 1;
qkm2 = x;
pkm1 = x+1;
qkm1 = z*x;
ans = pkm1/qkm1;
do
{
c = c+1;
y = y+1;
z = z+2;
yc = y*c;
pk = pkm1*z-pkm2*yc;
qk = qkm1*z-qkm2*yc;
if( ap::fp_neq(qk,0) )
{
r = pk/qk;
t = fabs((ans-r)/r);
ans = r;
}
else
{
t = 1;
}
pkm2 = pkm1;
pkm1 = pk;
qkm2 = qkm1;
qkm1 = qk;
if( ap::fp_greater(fabs(pk),igammabignumber) )
{
pkm2 = pkm2*igammabignumberinv;
pkm1 = pkm1*igammabignumberinv;
qkm2 = qkm2*igammabignumberinv;
qkm1 = qkm1*igammabignumberinv;
}
}
while(ap::fp_greater(t,igammaepsilon));
result = ans*ax;
return result;
}
double beta(double z, double w)
{
return exp(lngamma(z)+lngamma(w)-lngamma(z+w));
}
double gammad(double x, double p) {
//! ALGORITHM AS239 APPL. STATIST. (1988) VOL. 37, NO. 3
//! Computation of the Incomplete Gamma Integral
//! Auxiliary functions required: ALNORM = algorithm AS66 (included) & LNGAMMA
//! Converted to be compatible with ELF90 by Alan Miller
//! N.B. The return parameter IFAULT has been removed as ELF90 allows only
//! one output parameter from functions. An error message is issued instead.
double gamma_prob;
double pn1, pn2, pn3, pn4, pn5, pn6, tol = 1.e-14, oflo = 1.e+37;
double xbig = 1.e+8, arg, c, rn, a, b, one = 1.0, zero = 0.0, an;
double two = 2.0, elimit = -88.0, plimit = 1000.0, three = 3.0;
double nine = 9;
gamma_prob = zero;
if (p <= zero || x < EPSILON) {
return 0.0;
}
// Use a normal approximation if P > PLIMIT
if (p > plimit) {
pn1 = three * sqrt(p) * (pow(x/p,one/three) + one / (nine * p) - one);
return alnorm(pn1, false);
}
// If X is extremely large compared to P then set gamma_prob = 1
if (x > xbig) {
return one;
}
if (x <= one || x < p) {
//! Use Pearson's series expansion.
//! (Note that P is not large enough to force overflow in LNGAMMA)
arg = p * log(x) - x - lngamma(p + one);
c = one;
gamma_prob = one;
a = p;
do {
a = a + one;
c = c * x / a;
gamma_prob = gamma_prob + c;
} while (c >= tol);
arg = arg + log(gamma_prob);
gamma_prob = zero;
if (arg >= elimit) {
gamma_prob = exp(arg);
}
} else {
//! Use a continued fraction expansion
arg = p * log(x) - x - lngamma(p);
a = one - p;
b = a + x + one;
c = zero;
pn1 = one;
pn2 = x;
pn3 = x + one;
pn4 = x * b;
gamma_prob = pn3 / pn4;
do {
a = a + one;
b = b + two;
c = c + one;
an = a * c;
pn5 = b * pn3 - an * pn1;
pn6 = b * pn4 - an * pn2;
if (fabs(pn6) > zero) {
rn = pn5 / pn6;
if(fabs(gamma_prob - rn) <= MIN(tol, tol * rn))
break;
gamma_prob = rn;
}
pn1 = pn3;
pn2 = pn4;
pn3 = pn5;
pn4 = pn6;
if (fabs(pn5) >= oflo) {
// ! Re-scale terms in continued fraction if terms are large
pn1 = pn1 / oflo;
pn2 = pn2 / oflo;
pn3 = pn3 / oflo;
pn4 = pn4 / oflo;
}
} while (true);
arg = arg + log(gamma_prob);
gamma_prob = one;
if (arg >= elimit) {
gamma_prob = one - exp(arg);
}
}
return gamma_prob;
}
/** [lngamma_pdf r alpha beta]
* Return the probability density function of the gamma distribution using ln
* gamma. Since, exp(b*r)*gamma(a) = exp(b*r)*e(lngam(a)) = exp(b*r+lngam(a)) */
double lngamma_pdf(const double r, const double alpha, const double beta)
{
return (pow(beta,alpha)*pow(r, alpha-1)) / (exp(beta*r + lngamma(alpha)) );
}
/*************************************************************************
Natural logarithm of gamma function
Input parameters:
X - argument
Result:
logarithm of the absolute value of the Gamma(X).
Output parameters:
SgnGam - sign(Gamma(X))
Domain:
0 < X < 2.55e305
-2.55e305 < X < 0, X is not an integer.
ACCURACY:
arithmetic domain # trials peak rms
IEEE 0, 3 28000 5.4e-16 1.1e-16
IEEE 2.718, 2.556e305 40000 3.5e-16 8.3e-17
The error criterion was relative when the function magnitude
was greater than one but absolute when it was less than one.
The following test used the relative error criterion, though
at certain points the relative error could be much higher than
indicated.
IEEE -200, -4 10000 4.8e-16 1.3e-16
Cephes Math Library Release 2.8: June, 2000
Copyright 1984, 1987, 1989, 1992, 2000 by Stephen L. Moshier
Translated to AlgoPascal by Bochkanov Sergey (2005, 2006, 2007).
*************************************************************************/
double lngamma(double x, double& sgngam)
{
#ifndef ALGLIB_INTERCEPTS_SPECFUNCS
double result;
double a;
double b;
double c;
double p;
double q;
double u;
double w;
double z;
int i;
double logpi;
double ls2pi;
double tmp;
sgngam = 1;
logpi = 1.14472988584940017414;
ls2pi = 0.91893853320467274178;
if( ap::fp_less(x,-34.0) )
{
q = -x;
w = lngamma(q, tmp);
p = ap::ifloor(q);
i = ap::round(p);
if( i%2==0 )
{
sgngam = -1;
}
else
{
sgngam = 1;
}
z = q-p;
if( ap::fp_greater(z,0.5) )
{
p = p+1;
z = p-q;
}
z = q*sin(ap::pi()*z);
result = logpi-log(z)-w;
return result;
}
if( ap::fp_less(x,13) )
{
z = 1;
p = 0;
u = x;
while(ap::fp_greater_eq(u,3))
{
p = p-1;
u = x+p;
z = z*u;
}
while(ap::fp_less(u,2))
{
z = z/u;
p = p+1;
u = x+p;
}
if( ap::fp_less(z,0) )
{
sgngam = -1;
z = -z;
}
else
{
sgngam = 1;
}
if( ap::fp_eq(u,2) )
{
result = log(z);
return result;
}
p = p-2;
x = x+p;
b = -1378.25152569120859100;
b = -38801.6315134637840924+x*b;
b = -331612.992738871184744+x*b;
b = -1162370.97492762307383+x*b;
b = -1721737.00820839662146+x*b;
b = -853555.664245765465627+x*b;
c = 1;
c = -351.815701436523470549+x*c;
c = -17064.2106651881159223+x*c;
c = -220528.590553854454839+x*c;
c = -1139334.44367982507207+x*c;
c = -2532523.07177582951285+x*c;
c = -2018891.41433532773231+x*c;
p = x*b/c;
result = log(z)+p;
return result;
}
q = (x-0.5)*log(x)-x+ls2pi;
if( ap::fp_greater(x,100000000) )
{
result = q;
return result;
}
p = 1/(x*x);
if( ap::fp_greater_eq(x,1000.0) )
{
q = q+((7.9365079365079365079365*0.0001*p-2.7777777777777777777778*0.001)*p+0.0833333333333333333333)/x;
}
else
{
a = 8.11614167470508450300*0.0001;
a = -5.95061904284301438324*0.0001+p*a;
a = 7.93650340457716943945*0.0001+p*a;
a = -2.77777777730099687205*0.001+p*a;
a = 8.33333333333331927722*0.01+p*a;
q = q+a/x;
}
result = q;
return result;
#else
return _i_lngamma(x, sgngam);
#endif
}
// ripped from GSL (see above). Compute probability of getting a value
// k from a Poisson distribution with mean mu:
double poisson(const unsigned int k, const double mu)
{
double lf = lngamma(k+1);
return exp(log(mu) * k - lf - mu);
}
/*************************************************************************
Returns nodes/weights for Gauss-Jacobi quadrature on [-1,1] with weight
function W(x)=Power(1-x,Alpha)*Power(1+x,Beta).
INPUT PARAMETERS:
N - number of nodes, >=1
Alpha - power-law coefficient, Alpha>-1
Beta - power-law coefficient, Beta>-1
OUTPUT PARAMETERS:
Info - error code:
* -4 an error was detected when calculating
weights/nodes. Alpha or Beta are too close
to -1 to obtain weights/nodes with high enough
accuracy, or, may be, N is too large. Try to
use multiple precision version.
* -3 internal eigenproblem solver hasn't converged
* -1 incorrect N/Alpha/Beta was passed
* +1 OK
X - array[0..N-1] - array of quadrature nodes,
in ascending order.
W - array[0..N-1] - array of quadrature weights.
-- ALGLIB --
Copyright 12.05.2009 by Bochkanov Sergey
*************************************************************************/
void gqgenerategaussjacobi(int n,
double alpha,
double beta,
int& info,
ap::real_1d_array& x,
ap::real_1d_array& w)
{
ap::real_1d_array a;
ap::real_1d_array b;
double alpha2;
double beta2;
double apb;
double t;
int i;
double s;
if( n<1||ap::fp_less_eq(alpha,-1)||ap::fp_less_eq(beta,-1) )
{
info = -1;
return;
}
a.setlength(n);
b.setlength(n);
apb = alpha+beta;
a(0) = (beta-alpha)/(apb+2);
t = (apb+1)*log(double(2))+lngamma(alpha+1, s)+lngamma(beta+1, s)-lngamma(apb+2, s);
if( ap::fp_greater(t,log(ap::maxrealnumber)) )
{
info = -4;
return;
}
b(0) = exp(t);
if( n>1 )
{
alpha2 = ap::sqr(alpha);
beta2 = ap::sqr(beta);
a(1) = (beta2-alpha2)/((apb+2)*(apb+4));
b(1) = 4*(alpha+1)*(beta+1)/((apb+3)*ap::sqr(apb+2));
for(i = 2; i <= n-1; i++)
{
a(i) = 0.25*(beta2-alpha2)/(i*i*(1+0.5*apb/i)*(1+0.5*(apb+2)/i));
b(i) = 0.25*(1+alpha/i)*(1+beta/i)*(1+apb/i)/((1+0.5*(apb+1)/i)*(1+0.5*(apb-1)/i)*ap::sqr(1+0.5*apb/i));
}
}
gqgeneraterec(a, b, b(0), n, info, x, w);
//
// test basic properties to detect errors
//
if( info>0 )
{
if( ap::fp_less(x(0),-1)||ap::fp_greater(x(n-1),+1) )
{
info = -4;
}
for(i = 0; i <= n-2; i++)
{
if( ap::fp_greater_eq(x(i),x(i+1)) )
{
info = -4;
}
}
}
}
