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);
}
}
static gnm_float
gnm_atan_mpihalf (gnm_float x)
{
if (x > 0)
return gnm_acot (-x);
else
return gnm_atan (x) - (M_PIgnum / 2);
}
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);
}
}
}
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;
}
