double GammaqtlQ (double prob, double k, double theta)
{ /* --- quantile of Gamma distribution */
int n = 0; /* loop variable */
double x, f, a, d, dx, dp; /* buffers */
assert((k > 0) && (theta > 0) /* check the function arguments */
&& (prob >= 0) && (prob <= 1));
if (prob <= 0.0) return INFINITY;
if (prob >= 1.0) return 0; /* handle limiting values */
if (prob < 0.05) x = logGamma(k) -log(prob);
else if (prob > 0.95) x = exp(logGamma(k) +log1p(-prob) /k);
else { /* distinguish three prob. ranges */
f = unitqtlQ(prob); a = sqrt(k);
x = (f >= -a) ? a *f +k : k;
} /* compute initial approximation */
do { /* Lagrange's interpolation */
dp = prob -GammacdfQ(x, k, 1);
if ((dp == 0) || (++n > 33)) break;
f = Gammapdf(x, k, 1);
a = 2 *fabs(dp/x);
a = dx = -dp /((a > f) ? a : f);
d = -0.25 *((k-1)/x -1) *a*a;
if (fabs(d) < fabs(a)) dx += d;
if (x +dx > 0) x += dx;
else x /= 2;
} while (fabs(a) > 1e-10 *x);
if (fabs(dp) > EPS_QTL *prob) return -1;
return x *theta; /* check for convergence and */
} /* GammaqtlQ() */ /* return the computed quantile */
double GammaQ (double n, double x)
{ /* --- regularized Gamma function Q */
assert((n > 0) && (x >= 0)); /* check the function arguments */
if (x <= 0) return 1; /* treat x = 0 as a special case */
if (x < n+1) return 1 -series(n, x) *exp(n *log(x) -x -logGamma(n));
return cfrac(n, x) *exp(n *log(x) -x -logGamma(n));
} /* GammaQ() */
double re_fetinfo (SUPP supp, SUPP body, SUPP head, SUPP base)
{ /* --- Fisher's exact test (info.) */
SUPP rest, n; /* counter for rest cases, buffer */
double com; /* common probability term */
double cut; /* cutoff value for information gain */
double sum; /* probability sum of conting. tables */
if ((head <= 0) || (head >= base)
|| (body <= 0) || (body >= base))
return 1; /* check for non-vanishing marginals */
rest = base -head -body; /* compute number of rest cases */
if (rest < 0) { /* if rest cases are less than supp, */
supp -= rest = -rest; /* exchange rows and exchange columns */
body = base -body; head = base -head;
} /* complement/exchange the marginals */
if (head < body) { /* ensure that body <= head */
n = head; head = body; body = n; }
com = logGamma((double)( head+1))
+ logGamma((double)( body+1))
+ logGamma((double)(base-head+1))
+ logGamma((double)(base-body+1))
- logGamma((double)(base+1));/* compute common probability term */
cut = re_info(supp, body, head, base) *(1.0-DBL_EPSILON);
for (sum = 0, supp = 0; supp <= body; supp++) {
if (re_info(supp, body, head, base) >= cut)
sum += exp(com -logGamma((double)(body-supp+1))
-logGamma((double)(head-supp+1))
-logGamma((double) (supp+1))
-logGamma((double)(rest+supp+1)));
} /* sum probs. of less extreme tables */
return sum; /* return computed probability */
} /* re_fetinfo() */
double Gammapdf (double x, double k, double theta)
{ /* --- probability density function */
assert((k > 0) && (theta > 0));
if (x < 0) return 0; /* support is non-negative x */
if (x <= 0) return (k == 1) ? 1/theta : 0;
if (k == 1) return exp(-x/theta) /theta;
return exp ((k-1) *log(x/theta) -x/theta -logGamma(k)) /theta;
} /* Gammapdf() */
double Gamma (double n)
{ /* --- compute Gamma(n) = (n-1)! */
assert(n > 0); /* check the function argument */
if (facts[0] <= 0) init(); /* initialize the tables */
if (n < MAXFACT +1 +4 *EPSILON) {
if (fabs( n -floor( n)) < 4 *EPSILON)
return facts[(int)floor(n)-1];
if (fabs(2*n -floor(2*n)) < 4 *EPSILON)
return halfs[(int)floor(n)];
} /* try to get the value from a table */
return exp(logGamma(n)); /* compute through natural logarithm */
} /* Gamma() */
double gammaSeries(double x, double a){
int n, maxit = 100;
double eps = 0.0000003;
double sum = 1.0 / a, ap = a, gln = logGamma(a), del = sum;
for (n = 1; n <= maxit; n++) {
ap++;
del = del * x / ap;
sum = sum + del;
if (fabs(del) < fabs(sum) * eps) break;
}
return sum * exp(-x + a * log(x) - gln);
}
int main (int argc, char *argv[])
{ /* --- main function */
double x; /* argument */
if (argc != 2) { /* if wrong number of arguments given */
printf("usage: %s x\n", argv[0]);
printf("compute (logarithm of) Gamma function\n");
return 0; /* print a usage message */
} /* and abort the program */
x = atof(argv[1]); /* get argument */
if (x <= 0) { printf("%s: x must be > 0\n", argv[0]); return -1; }
printf(" Gamma(%.16g) = % .20g\n", x, Gamma(x));
printf("ln(Gamma(%.16g)) = % .20g\n", x, logGamma(x));
return 0; /* compute and print Gamma function */
} /* main() */
double gammaCF(double x, double a){
int n, maxit = 100;
double eps = 0.0000003;
double gln = logGamma(a), g = 0, gold = 0, a0 = 1, a1 = x, b0 = 0, b1 = 1, fac = 1;
double an, ana, anf;
for (n = 1; n <= maxit; n++) {
an = 1.0 * n;
ana = an - a;
a0 = (a1 + a0 * ana) * fac;
b0 = (b1 + b0 * ana) * fac;
anf = an * fac;
a1 = x * a0 + anf * a1;
b1 = x * b0 + anf * b1;
if (a1 != 0) {
fac = 1.0 / a1;
g = b1 * fac;
if (fabs((g - gold) / g) < eps)
break;
gold = g;
}
}
return exp(-x + a * log(x) - gln) * g;
}
double re_fetsupp (SUPP supp, SUPP body, SUPP head, SUPP base)
{ /* --- Fisher's exact test (support) */
SUPP rest, n; /* counter for rest cases, buffer */
double com; /* common probability term */
double sum; /* probability sum of conting. tables */
if ((head <= 0) || (head >= base)
|| (body <= 0) || (body >= base))
return 1; /* check for non-vanishing marginals */
rest = base -head -body; /* compute number of rest cases */
if (rest < 0) { /* if rest cases are less than supp, */
supp -= rest = -rest; /* exchange rows and exchange columns */
body = base -body; head = base -head;
} /* complement/exchange the marginals */
if (head < body) { /* ensure that body <= head */
n = head; head = body; body = n; }
com = logGamma((double)( head+1))
+ logGamma((double)( body+1))
+ logGamma((double)(base-head+1))
+ logGamma((double)(base-body+1))
- logGamma((double)(base+1));/* compute common probability term */
if (supp <= body -supp) { /* if fewer lesser support values */
for (sum = 1.0; --supp >= 0; )
sum -= exp(com -logGamma((double)(body-supp+1))
-logGamma((double)(head-supp+1))
-logGamma((double)( supp+1))
-logGamma((double)(rest+supp+1))); }
else { /* if fewer greater support values */
for (sum = 0.0; supp <= body; supp++)
sum += exp(com -logGamma((double)(body-supp+1))
-logGamma((double)(head-supp+1))
-logGamma((double)( supp+1))
-logGamma((double)(rest+supp+1)));
} /* sum the table probabilities */
return sum; /* return computed probability */
} /* re_fetsupp() */
double re_fetchi2 (SUPP supp, SUPP body, SUPP head, SUPP base)
{ /* --- Fisher's exact test (chi^2) */
SUPP rest, n; /* counter for rest cases, buffer */
double com; /* common probability term */
double exs; /* expected support value */
double sum; /* probability sum of conting. tables */
if ((head <= 0) || (head >= base)
|| (body <= 0) || (body >= base))
return 1; /* check for non-vanishing marginals */
rest = base -head -body; /* compute number of rest cases */
if (rest < 0) { /* if rest cases are less than supp, */
supp -= rest = -rest; /* exchange rows and exchange columns */
body = base -body; head = base -head;
} /* complement/exchange the marginals */
if (head < body) { /* ensure that body <= head */
n = head; head = body; body = n; }
com = logGamma((double)( head+1))
+ logGamma((double)( body+1))
+ logGamma((double)(base-head+1))
+ logGamma((double)(base-body+1))
- logGamma((double)(base+1));/* compute common probability term */
exs = (double)head *(double)body /(double)base;
if ((double)supp < exs)
{ n = (SUPP)ceil (exs+(exs-(double)supp)); }
else { n = supp; supp = (SUPP)floor(exs-((double)supp-exs)); }
if (n > body) n = body+1; /* compute the range of values and */
if (supp < 0) supp = -1; /* clamp it to the possible maximum */
if (n-supp-4 < supp+body-n) { /* if fewer less extreme tables */
for (sum = 1; ++supp < n;){ /* traverse the less extreme tables */
sum -= exp(com -logGamma((double)(body-supp+1))
-logGamma((double)(head-supp+1))
-logGamma((double)( supp+1))
-logGamma((double)(rest+supp+1)));
} } /* sum the probability of the tables */
else { /* if fewer more extreme tables */
for (sum = 0; supp >= 0; supp--) {
sum += exp(com -logGamma((double)(body-supp+1))
-logGamma((double)(head-supp+1))
-logGamma((double)( supp+1))
-logGamma((double)(rest+supp+1)));
} /* traverse the more extreme tables */
for (supp = n; supp <= body; supp++) {
sum += exp(com -logGamma((double)(body-supp+1))
-logGamma((double)(head-supp+1))
-logGamma((double)( supp+1))
-logGamma((double)(rest+supp+1)));
} /* sum the probability of the tables */
} /* (upper and lower table ranges) */
return sum; /* return computed probability */
} /* re_fetchi2() */
double re_fetprob (SUPP supp, SUPP body, SUPP head, SUPP base)
{ /* --- Fisher's exact test (prob.) */
SUPP rest, n; /* counter for rest cases, buffer */
double com; /* common probability term */
double cut, p; /* (cutoff value for) probability */
double sum; /* probability sum of conting. tables */
if ((head <= 0) || (head >= base)
|| (body <= 0) || (body >= base))
return 1; /* check for non-vanishing marginals */
rest = base -head -body; /* compute number of rest cases */
if (rest < 0) { /* if rest cases are less than supp, */
supp -= rest = -rest; /* exchange rows and exchange columns */
body = base -body; head = base -head;
} /* complement/exchange the marginals */
if (head < body) { /* ensure that body <= head */
n = head; head = body; body = n; }
com = logGamma((double)( head+1))
+ logGamma((double)( body+1))
+ logGamma((double)(base-head+1))
+ logGamma((double)(base-body+1))
- logGamma((double)(base+1));/* compute common probability term */
cut = com /* and log of the cutoff probability */
- logGamma((double)(body-supp+1))
- logGamma((double)(head-supp+1))
- logGamma((double)( supp+1))
- logGamma((double)(rest+supp+1));
cut *= 1.0-DBL_EPSILON; /* adapt for roundoff errors */
/* cut must be multiplied with a value < 1 in order to increase it, */
/* because it is the logarithm of a probability and hence negative. */
for (sum = 0, supp = 0; supp <= body; supp++) {
p = com /* traverse the contingency tables */
- logGamma((double)(body-supp+1))
- logGamma((double)(head-supp+1))
- logGamma((double)( supp+1))
- logGamma((double)(rest+supp+1));
if (p <= cut) sum += exp(p);/* sum probabilities greater */
} /* than the cutoff probability */
return sum; /* return computed probability */
} /* re_fetprob() */
