gnm_float
qst (gnm_float p, gnm_float n, gnm_float shape,
gboolean lower_tail, gboolean log_p)
{
gnm_float x0;
gnm_float params[2];
if (n <= 0 || gnm_isnan (p) || gnm_isnan (n) || gnm_isnan (shape))
return gnm_nan;
if (shape == 0.)
return qt (p, n, lower_tail, log_p);
if (!log_p && p > 0.9) {
/* We're far into the tail. Flip. */
p = 1 - p;
lower_tail = !lower_tail;
}
x0 = 0.0;
params[0] = n;
params[1] = shape;
return pfuncinverter (p, params, lower_tail, log_p,
gnm_ninf, gnm_pinf, x0,
pst1, dst1);
}
gnm_float
qsnorm (gnm_float p, gnm_float shape, gnm_float location, gnm_float scale,
gboolean lower_tail, gboolean log_p)
{
gnm_float x0;
gnm_float params[3];
if (gnm_isnan (p) || gnm_isnan (shape) || gnm_isnan (location) || gnm_isnan (scale))
return gnm_nan;
if (shape == 0.)
return qnorm (p, location, scale, lower_tail, log_p);
if (!log_p && p > 0.9) {
/* We're far into the tail. Flip. */
p = 1 - p;
lower_tail = !lower_tail;
}
x0 = 0.0;
params[0] = shape;
params[1] = location;
params[2] = scale;
return pfuncinverter (p, params, lower_tail, log_p,
gnm_ninf, gnm_pinf, x0,
psnorm1, dsnorm1);
}
gnm_float
dgumbel (gnm_float x, gnm_float mu, gnm_float beta, gboolean give_log)
{
gnm_float z, lp;
if (!(beta > 0) || gnm_isnan (mu) || gnm_isnan (beta) || gnm_isnan (x))
return gnm_nan;
z = (x - mu) / beta;
lp = -(z + gnm_exp (-z));
return give_log ? lp - gnm_log (beta) : gnm_exp (lp) / beta;
}
gnm_float
dsnorm (gnm_float x, gnm_float shape, gnm_float location, gnm_float scale, gboolean give_log)
{
if (gnm_isnan (x) || gnm_isnan (shape) || gnm_isnan (location) || gnm_isnan (scale))
return gnm_nan;
if (shape == 0.)
return dnorm (x, location, scale, give_log);
else if (give_log)
return M_LN2gnum + dnorm (x, location, scale, TRUE) + pnorm (shape * x, shape * location, scale, TRUE, TRUE);
else
return 2 * dnorm (x, location, scale, FALSE) * pnorm (shape * x, location/shape, scale, TRUE, FALSE);
}
gnm_float
psnorm (gnm_float x, gnm_float shape, gnm_float location, gnm_float scale, gboolean lower_tail, gboolean log_p)
{
gnm_float result, h;
if (gnm_isnan (x) || gnm_isnan (shape) ||
gnm_isnan (location) || gnm_isnan (scale))
return gnm_nan;
if (shape == 0.)
return pnorm (x, location, scale, lower_tail, log_p);
/* Normalize */
h = (x - location) / scale;
/* Flip to a lower-tail problem. */
if (!lower_tail) {
h = -h;
shape = -shape;
lower_tail = !lower_tail;
}
if (gnm_abs (shape) < 10) {
gnm_float s = pnorm (h, 0, 1, lower_tail, FALSE);
gnm_float t = 2 * gnm_owent (h, shape);
result = s - t;
} else {
/*
* Make use of this result for Owen's T:
*
* T(h,a) = .5N(h) + .5N(ha) - N(h)N(ha) - T(ha,1/a)
*/
gnm_float s = pnorm (h * shape, 0, 1, TRUE, FALSE);
gnm_float u = gnm_erf (h / M_SQRT2gnum);
gnm_float t = 2 * gnm_owent (h * shape, 1 / shape);
result = s * u + t;
}
/*
* Negatives can occur due to rounding errors and hopefully for no
* other reason.
*/
result= CLAMP (result, 0.0, 1.0);
if (log_p)
return gnm_log (result);
else
return result;
}
gnm_float
pgumbel (gnm_float x, gnm_float mu, gnm_float beta, gboolean lower_tail, gboolean log_p)
{
gnm_float z, lp;
if (!(beta > 0) || gnm_isnan (mu) || gnm_isnan (beta) || gnm_isnan (x))
return gnm_nan;
z = (x - mu) / beta;
lp = -gnm_exp (-z);
if (lower_tail)
return log_p ? lp : gnm_exp (lp);
else
return log_p ? swap_log_tail (lp) : 0 - gnm_expm1 (lp);
}
gnm_float
dst (gnm_float x, gnm_float n, gnm_float shape, gboolean give_log)
{
if (n <= 0 || gnm_isnan (x) || gnm_isnan (n) || gnm_isnan (shape))
return gnm_nan;
if (shape == 0.)
return dt (x, n, give_log);
else {
gnm_float pdf = dt (x, n, give_log);
gnm_float cdf = pt (shape * x * gnm_sqrt ((n + 1)/(x * x + n)),
n + 1, TRUE, give_log);
return give_log ? (M_LN2gnum + pdf + cdf) : (2. * pdf * cdf);
}
}
/* 0: ok, 1: overflow, 2: nan */
static int
qbetaf (gnm_float a, gnm_float b, GnmQuad *mant, int *exp2)
{
GnmQuad ma, mb, mab;
int ea, eb, eab;
gnm_float ab = a + b;
if (gnm_isnan (ab) ||
(a <= 0 && a == gnm_floor (a)) ||
(b <= 0 && b == gnm_floor (b)))
return 2;
if (ab <= 0 && ab == gnm_floor (ab)) {
gnm_quad_init (mant, 0);
*exp2 = 0;
return 0;
}
if (!qgammaf (a, &ma, &ea) &&
!qgammaf (b, &mb, &eb) &&
!qgammaf (ab, &mab, &eab)) {
void *state = gnm_quad_start ();
gnm_quad_mul (&ma, &ma, &mb);
gnm_quad_div (mant, &ma, &mab);
gnm_quad_end (state);
*exp2 = ea + eb - eab;
return 0;
} else
return 1;
}
double
lgamma_r (double x, int *signp)
{
*signp = +1;
if (gnm_isnan (x))
return gnm_nan;
if (x > 0) {
gnm_float f = 1;
while (x < 10) {
f *= x;
x++;
}
return (M_LN_SQRT_2PI + (x - 0.5) * gnm_log(x) -
x + lgammacor(x)) - gnm_log (f);
} else {
gnm_float axm2 = gnm_fmod (-x, 2.0);
gnm_float y = gnm_sinpi (axm2) / M_PIgnum;
*signp = axm2 > 1.0 ? +1 : -1;
return y == 0
? gnm_nan
: - gnm_log (gnm_abs (y)) - lgamma1p (-x);
}
}
gnm_float
qcauchy (gnm_float p, gnm_float location, gnm_float scale,
gboolean lower_tail, gboolean log_p)
{
if (gnm_isnan(p) || gnm_isnan(location) || gnm_isnan(scale))
return p + location + scale;
R_Q_P01_check(p);
if (scale < 0 || !gnm_finite(scale)) ML_ERR_return_NAN;
if (log_p) {
if (p > -1)
/* The "0" here is important for the p=0 case: */
lower_tail = !lower_tail, p = 0 - gnm_expm1 (p);
else
p = gnm_exp (p);
}
if (lower_tail) scale = -scale;
return location + scale / gnm_tan(M_PIgnum * p);
}
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 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);
}
/* 0: ok, 1: overflow, 2: nan */
static int
qgammaf (gnm_float x, GnmQuad *mant, int *exp2)
{
if (x < -1.5 || x > 0.5)
return qfactf (x - 1, mant, exp2);
else if (gnm_isnan (x) || x == 0)
return 2;
else {
void *state = gnm_quad_start ();
GnmQuad qx;
qfactf (x, mant, exp2);
gnm_quad_init (&qx, x);
gnm_quad_div (mant, mant, &qx);
rescale_mant_exp (mant, exp2);
gnm_quad_end (state);
return 0;
}
}
/* 0: ok, 1: overflow, 2: nan */
int
qfactf (gnm_float x, GnmQuad *mant, int *exp2)
{
void *state;
gboolean res = 0;
if (gnm_isnan (x))
return 2;
if (x >= G_MAXINT / 2)
return 1;
if (x == gnm_floor (x)) {
/* Integer or infinite. */
if (x < 0)
return 2;
if (!qfacti ((int)x, mant, exp2))
return 0;
}
state = gnm_quad_start ();
if (x < -1) {
if (qfactf (-x - 1, mant, exp2))
res = 1;
else {
GnmQuad b;
gnm_quad_init (&b, -x);
gnm_quad_sinpi (&b, &b);
gnm_quad_mul (&b, &b, mant);
gnm_quad_div (mant, &gnm_quad_pi, &b);
*exp2 = -*exp2;
}
} else if (x >= QFACTI_LIMIT - 0.5) {
/*
* Let y = x + 1 = m * 2^e; c = sqrt(2Pi).
*
* G(y) = c * y^(y-1/2) * exp(-y) * E(y)
* = c * (y/e)^y / sqrt(y) * E(y)
*/
GnmQuad y, f1, f2, f3, f4;
gnm_float ef2;
gboolean debug = FALSE;
if (debug) g_printerr ("x=%.20g\n", x);
gnm_quad_init (&y, x + 1);
*exp2 = 0;
/* sqrt(2Pi) */
gnm_quad_sqrt (&f1, &gnm_quad_2pi);
if (debug) g_printerr ("f1=%.20g\n", gnm_quad_value (&f1));
/* (y/e)^y */
gnm_quad_div (&f2, &y, &gnm_quad_e);
gnm_quad_pow (&f2, &ef2, &f2, &y);
if (ef2 > G_MAXINT || ef2 < G_MININT)
res = 1;
else
*exp2 += (int)ef2;
if (debug) g_printerr ("f2=%.20g\n", gnm_quad_value (&f2));
/* sqrt(y) */
gnm_quad_sqrt (&f3, &y);
if (debug) g_printerr ("f3=%.20g\n", gnm_quad_value (&f3));
/* E(x) */
gamma_error_factor (&f4, &y);
if (debug) g_printerr ("f4=%.20g\n", gnm_quad_value (&f4));
gnm_quad_mul (mant, &f1, &f2);
gnm_quad_div (mant, mant, &f3);
gnm_quad_mul (mant, mant, &f4);
if (debug) g_printerr ("G(x+1)=%.20g * 2^%d %s\n", gnm_quad_value (mant), *exp2, res ? "overflow" : "");
} else {
GnmQuad s, qx, mFw;
gnm_float w, f;
int eFw;
/*
* w integer, |f|<=0.5, x=w+f.
*
* Do this before we do the stepping below which would kill
* up to 4 bits of accuracy of f.
*/
w = gnm_floor (x + 0.5);
f = x - w;
gnm_quad_init (&qx, x);
gnm_quad_init (&s, 1);
while (w < 20) {
gnm_quad_add (&qx, &qx, &gnm_quad_one);
w++;
gnm_quad_mul (&s, &s, &qx);
}
if (qfacti ((int)w, &mFw, &eFw)) {
res = 1;
} else {
GnmQuad r;
pochhammer_small_n (w + 1, f, &r);
gnm_quad_mul (mant, &mFw, &r);
gnm_quad_div (mant, mant, &s);
*exp2 = eFw;
}
}
if (res == 0)
rescale_mant_exp (mant, exp2);
gnm_quad_end (state);
return res;
}
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;
}
