void
gsl_complex_arctan (complex_t const *a, complex_t *res)
{ /* z = arctan(a) */
gnm_float R = GSL_REAL (a), I = GSL_IMAG (a);
if (I == 0) {
complex_init (res, gnm_atan (R), 0);
} else {
/* FIXME: This is a naive implementation which does not fully
* take into account cancellation errors, overflow, underflow
* etc. It would benefit from the Hull et al treatment. */
gnm_float r = gnm_hypot (R, I);
gnm_float imag;
gnm_float u = 2 * I / (1 + r * r);
/* FIXME: the following cross-over should be optimized but 0.1
* seems to work ok */
if (gnm_abs (u) < 0.1) {
imag = 0.25 * (gnm_log1p (u) - gnm_log1p (-u));
} else {
gnm_float A = gnm_hypot (R, I + 1);
gnm_float B = gnm_hypot (R, I - 1);
imag = 0.5 * gnm_log (A / B);
}
if (R == 0) {
if (I > 1) {
complex_init (res, M_PI_2gnum, imag);
} else if (I < -1) {
complex_init (res, -M_PI_2gnum, imag);
} else {
complex_init (res, 0, imag);
}
} else {
complex_init (res, 0.5 * gnm_atan2 (2 * R,
((1 + r) * (1 - r))),
imag);
}
}
}
void
gsl_complex_arccos (complex_t const *a, complex_t *res)
{ /* z = arccos(a) */
gnm_float R = GSL_REAL (a), I = GSL_IMAG (a);
if (I == 0) {
gsl_complex_arccos_real (R, res);
} else {
gnm_float x = gnm_abs (R);
gnm_float y = gnm_abs (I);
gnm_float r = gnm_hypot (x + 1, y);
gnm_float s = gnm_hypot (x - 1, y);
gnm_float A = 0.5 * (r + s);
gnm_float B = x / A;
gnm_float y2 = y * y;
gnm_float real, imag;
const gnm_float A_crossover = 1.5;
const gnm_float B_crossover = 0.6417;
if (B <= B_crossover) {
real = gnm_acos (B);
} else {
if (x <= 1) {
gnm_float D = 0.5 * (A + x) *
(y2 / (r + x + 1) + (s + (1 - x)));
real = gnm_atan (gnm_sqrt (D) / x);
} else {
gnm_float Apx = A + x;
gnm_float D = 0.5 * (Apx / (r + x + 1) + Apx /
(s + (x - 1)));
real = gnm_atan ((y * gnm_sqrt (D)) / x);
}
}
if (A <= A_crossover) {
gnm_float Am1;
if (x < 1) {
Am1 = 0.5 * (y2 / (r + (x + 1)) + y2 /
(s + (1 - x)));
} else {
Am1 = 0.5 * (y2 / (r + (x + 1)) +
(s + (x - 1)));
}
imag = gnm_log1p (Am1 + gnm_sqrt (Am1 * (A + 1)));
} else {
imag = gnm_log (A + gnm_sqrt (A * A - 1));
}
complex_init (res, (R >= 0) ? real : M_PIgnum - real, (I >= 0) ?
-imag : imag);
}
}
gnm_float gnm_lbeta(gnm_float a, gnm_float b)
{
gnm_float corr, p, q;
p = q = a;
if(b < p) p = b;/* := min(a,b) */
if(b > q) q = b;/* := max(a,b) */
#ifdef IEEE_754
if(gnm_isnan(a) || gnm_isnan(b))
return a + b;
#endif
/* both arguments must be >= 0 */
if (p < 0)
ML_ERR_return_NAN
else if (p == 0) {
return gnm_pinf;
}
else if (!gnm_finite(q)) {
return gnm_ninf;
}
if (p >= 10) {
/* p and q are big. */
corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q);
return gnm_log(q) * -0.5 + M_LN_SQRT_2PI + corr
+ (p - 0.5) * gnm_log(p / (p + q)) + q * gnm_log1p(-p / (p + q));
}
else if (q >= 10) {
/* p is small, but q is big. */
corr = lgammacor(q) - lgammacor(p + q);
return gnm_lgamma(p) + corr + p - p * gnm_log(p + q)
+ (q - 0.5) * gnm_log1p(-p / (p + q));
}
else
/* p and q are small: p <= q < 10. */
return gnm_lgamma (p) + gnm_lgamma (q) - gnm_lgamma (p + q);
}
gnm_float
qgumbel (gnm_float p, gnm_float mu, gnm_float beta, gboolean lower_tail, gboolean log_p)
{
if (!(beta > 0) ||
gnm_isnan (mu) || gnm_isnan (beta) || gnm_isnan (p) ||
(log_p ? p > 0 : (p < 0 || p > 1)))
return gnm_nan;
if (log_p) {
if (!lower_tail)
p = swap_log_tail (p);
} else {
if (lower_tail)
p = gnm_log (p);
else
p = gnm_log1p (-p);
}
/* We're now in the log_p, lower_tail case. */
return mu - beta * gnm_log (-p);
}
gnm_float
pochhammer (gnm_float x, gnm_float n)
{
gnm_float rn, rx, lr;
GnmQuad m1, m2;
int e1, e2;
if (gnm_isnan (x) || gnm_isnan (n))
return gnm_nan;
if (n == 0)
return 1;
rx = gnm_floor (x);
rn = gnm_floor (n);
/*
* Use naive multiplication when n is a small integer.
* We don't want to use this if x is also an integer
* (but we might do so below if x is insanely large).
*/
if (n == rn && x != rx && n >= 0 && n < 40)
return pochhammer_naive (x, (int)n);
if (!qfactf (x + n - 1, &m1, &e1) &&
!qfactf (x - 1, &m2, &e2)) {
void *state = gnm_quad_start ();
int de = e1 - e2;
GnmQuad qr;
gnm_float r;
gnm_quad_div (&qr, &m1, &m2);
r = gnm_quad_value (&qr);
gnm_quad_end (state);
return gnm_ldexp (r, de);
}
if (x == rx && x <= 0) {
if (n != rn)
return 0;
if (x == 0)
return (n > 0)
? 0
: ((gnm_fmod (-n, 2) == 0 ? +1 : -1) /
gnm_fact (-n));
if (n > -x)
return gnm_nan;
}
/*
* We have left the common cases. One of x+n and x is
* insanely big, possibly both.
*/
if (gnm_abs (x) < 1)
return gnm_pinf;
if (n < 0)
return 1 / pochhammer (x + n, -n);
if (n == rn && n >= 0 && n < 100)
return pochhammer_naive (x, (int)n);
if (gnm_abs (n) < 1) {
/* x is big. */
void *state = gnm_quad_start ();
GnmQuad qr;
gnm_float r;
pochhammer_small_n (x, n, &qr);
r = gnm_quad_value (&qr);
gnm_quad_end (state);
return r;
}
/* Panic mode. */
g_printerr ("x=%.20g n=%.20g\n", x, n);
lr = ((x - 0.5) * gnm_log1p (n / x) +
n * gnm_log (x + n) -
n +
(lgammacor (x + n) - lgammacor (x)));
return gnm_exp (lr);
}
gnm_float
pst (gnm_float x, gnm_float n, gnm_float shape, gboolean lower_tail, gboolean log_p)
{
gnm_float p;
if (n <= 0 || gnm_isnan (x) || gnm_isnan (n) || gnm_isnan (shape))
return gnm_nan;
if (shape == 0.)
return pt (x, n, lower_tail, log_p);
if (n > 100) {
/* Approximation */
return psnorm (x, shape, 0.0, 1.0, lower_tail, log_p);
}
/* Flip to a lower-tail problem. */
if (!lower_tail) {
x = -x;
shape = -shape;
lower_tail = !lower_tail;
}
/* Generic fallback. */
if (log_p)
gnm_log (pst (x, n, shape, TRUE, FALSE));
if (n != gnm_floor (n)) {
/* We would need numerical integration for this. */
return gnm_nan;
}
/*
* Use recurrence formula from "Recurrent relations for
* distributions of a skew-t and a linear combination of order
* statistics form a bivariate-t", Computational Statistics
* and Data Analysis volume 52, 2009 by Jamallizadeh,
* Khosravi, Balakrishnan.
*
* This brings us down to n==1 or n==2 for which explicit formulas
* are available.
*/
p = 0;
while (n > 2) {
double a, lb, c, d, pv, v = n - 1;
d = v == 2
? M_LN2gnum - gnm_log (M_PIgnum) + gnm_log (3) / 2
: (0.5 + M_LN2gnum / 2 - gnm_log (M_PIgnum) / 2 +
v / 2 * (gnm_log1p (-1 / (v - 1)) + gnm_log (v + 1)) -
0.5 * (gnm_log (v - 2) + gnm_log (v + 1)) +
stirlerr (v / 2 - 1) -
stirlerr ((v - 1) / 2));
a = v + 1 + x * x;
lb = (d - gnm_log (a) * v / 2);
c = pt (gnm_sqrt (v) * shape * x / gnm_sqrt (a), v, TRUE, FALSE);
pv = x * gnm_exp (lb) * c;
p += pv;
n -= 2;
x *= gnm_sqrt ((v - 1) / (v + 1));
}
g_return_val_if_fail (n == 1 || n == 2, gnm_nan);
if (n == 1) {
gnm_float p1;
p1 = (gnm_atan (x) + gnm_acos (shape / gnm_sqrt ((1 + shape * shape) * (1 + x * x)))) / M_PIgnum;
p += p1;
} else if (n == 2) {
gnm_float p2, f;
f = x / gnm_sqrt (2 + x * x);
p2 = (gnm_atan_mpihalf (shape) + f * gnm_atan_mpihalf (-shape * f)) / -M_PIgnum;
p += p2;
} else {
return gnm_nan;
}
/*
* Negatives can occur due to rounding errors and hopefully for no
* other reason.
*/
p = CLAMP (p, 0.0, 1.0);
return p;
}
