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 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); }
static gnm_float gnm_owent (gnm_float h, gnm_float a) { gnm_float weight[10] = { GNM_const(0.0666713443086881375935688098933), GNM_const(0.149451349150580593145776339658), GNM_const(0.219086362515982043995534934228), GNM_const(0.269266719309996355091226921569), GNM_const(0.295524224714752870173892994651), GNM_const(0.295524224714752870173892994651), GNM_const(0.269266719309996355091226921569), GNM_const(0.219086362515982043995534934228), GNM_const(0.149451349150580593145776339658), GNM_const(0.0666713443086881375935688098933) }; gnm_float xtab[10] = {GNM_const(0.026093471482828279922035987916), GNM_const(0.134936633311015489267903311577), GNM_const(0.320590431700975593765672634885), GNM_const(0.566604605870752809200734056834), GNM_const(0.85112566101836878911517399887), GNM_const(1.148874338981631210884826001130), GNM_const(1.433395394129247190799265943166), GNM_const(1.679409568299024406234327365115), GNM_const(1.865063366688984510732096688423), GNM_const(1.973906528517171720077964012084) }; gnm_float hs, h2, as, rt; int i; if (fabs(h) < LIM1) return atan(a) * TWOPI_INVERSE; if (fabs(h) > LIM2 || fabs(a) < LIM1) return 0.0; hs = -0.5 * h * h; h2 = a; as = a * a; if (log(1.0 + as) - hs * as >= LIM3) { gnm_float h1 = 0.5 * a; as *= 0.25; for (;;) { gnm_float rt = as + 1.0; h2 = h1 + (hs * as + LIM3 - log(rt)) / (2.0 * h1 * (1.0 / rt - hs)); as = h2 * h2; if (fabs(h2 - h1) < LIM4) break; h1 = h2; } } rt = 0.0; for (i = 0; i < 10; i++) { gnm_float x = 0.5 * h2 * xtab[i], tmp = 1.0 + x * x; rt += weight[i] * gnm_exp (hs * tmp) / tmp; } return 0.5 * rt * h2 * TWOPI_INVERSE; }
static gnm_float lgammacor(gnm_float x) { static const gnm_float algmcs[15] = { GNM_const(+.1666389480451863247205729650822e+0), GNM_const(-.1384948176067563840732986059135e-4), GNM_const(+.9810825646924729426157171547487e-8), GNM_const(-.1809129475572494194263306266719e-10), GNM_const(+.6221098041892605227126015543416e-13), GNM_const(-.3399615005417721944303330599666e-15), GNM_const(+.2683181998482698748957538846666e-17), GNM_const(-.2868042435334643284144622399999e-19), GNM_const(+.3962837061046434803679306666666e-21), GNM_const(-.6831888753985766870111999999999e-23), GNM_const(+.1429227355942498147573333333333e-24), GNM_const(-.3547598158101070547199999999999e-26), GNM_const(+.1025680058010470912000000000000e-27), GNM_const(-.3401102254316748799999999999999e-29), GNM_const(+.1276642195630062933333333333333e-30) }; gnm_float tmp; #ifdef NOMORE_FOR_THREADS static int nalgm = 0; static gnm_float xbig = 0, xmax = 0; /* Initialize machine dependent constants, the first time gamma() is called. FIXME for threads ! */ if (nalgm == 0) { /* For IEEE gnm_float precision : nalgm = 5 */ nalgm = chebyshev_init(algmcs, 15, GNM_EPSILON/2);/*was d1mach(3)*/ xbig = 1 / gnm_sqrt(GNM_EPSILON/2); /* ~ 94906265.6 for IEEE gnm_float */ xmax = gnm_exp(fmin2(gnm_log(GNM_MAX / 12), -gnm_log(12 * GNM_MIN))); /* = GNM_MAX / 48 ~= 3.745e306 for IEEE gnm_float */ } #else /* For IEEE gnm_float precision GNM_EPSILON = 2^-52 = GNM_const(2.220446049250313e-16) : * xbig = 2 ^ 26.5 * xmax = GNM_MAX / 48 = 2^1020 / 3 */ # define nalgm 5 # define xbig GNM_const(94906265.62425156) # define xmax GNM_const(3.745194030963158e306) #endif if (x < 10) ML_ERR_return_NAN else if (x >= xmax) { ML_ERROR(ME_UNDERFLOW); return ML_UNDERFLOW; } else if (x < xbig) { tmp = 10 / x; return chebyshev_eval(tmp * tmp * 2 - 1, algmcs, nalgm) / x; } else return 1 / (x * 12); }
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 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; }