/* R file: pgamma.c
*
* Asymptotic expansion to calculate the probability that Poisson variate * has value <= x.
* Various assertions about this are made (without proof) at http://members.aol.com/iandjmsmith/PoissonApprox.htm
*/
private static double ppois_asymp(double x, double lambda, bool lower_tail, bool log_p)
{
double elfb, elfb_term;
double res12, res1_term, res1_ig, res2_term, res2_ig;
double dfm, pt_, s2pt, f, np;
int i;
dfm = lambda - x;
/* If lambda is large, the distribution is highly concentrated
* about lambda. So representation error in x or lambda can lead
* to arbitrarily large values of pt_ and hence divergence of the
* coefficients of this approximation.
*/
pt_ = -log1pmx(dfm / x);
s2pt = Math.Sqrt(2 * x * pt_);
if (dfm < 0)
{
s2pt = -s2pt;
}
res12 = 0;
res1_ig = res1_term = Math.Sqrt(x);
res2_ig = res2_term = s2pt;
for (i = 1; i < 8; i++)
{
res12 += res1_ig * coefs_a4ppois_asymp[i];
res12 += res2_ig * coefs_b4ppois_asymp[i];
res1_term *= pt_ / i;
res2_term *= 2 * pt_ / (2 * i + 1);
res1_ig = res1_ig / x + res1_term;
res2_ig = res2_ig / x + res2_term;
}
elfb = x;
elfb_term = 1;
for (i = 1; i < 8; i++)
{
elfb += elfb_term * coefs_b4ppois_asymp[i];
elfb_term /= x;
}
if (!lower_tail)
{
elfb = -elfb;
}
f = res12 / elfb;
np = NormalDistribution.PNorm(s2pt, 0.0, 1.0, !lower_tail, log_p);
if (log_p)
{
double n_d_over_p = dpnorm(s2pt, !lower_tail, np);
return(np + log1p(f * n_d_over_p));
}
else
{
double nd = NormalDistribution.DNorm(s2pt, 0.0, 1.0, log_p);
return(np + f * nd);
}
} /* ppois_asymp() */
internal static double poisson_rand(double mu)
{
glblCount++;
/* Local Vars [initialize some for -Wall]: */
//double del;
difmuk = 0.0; E = 0.0; fk = 0.0;
//double fx, fy, g, px, py, t;
u = 0.0;
//double v, x;
pois = -1.0;
//int k, kflag;
//bool big_mu;
bool directToStepF = false;
new_big_mu = false;
big_mu = mu >= 10.0;
if (big_mu)
{
new_big_mu = false;
}
if (!(big_mu && mu == muprev))
{/* maybe compute new persistent par.s */
if (big_mu)
{
new_big_mu = true;
/* Case A. (recalculation of s,d,l because mu has changed):
* The poisson probabilities pk exceed the discrete normal
* probabilities fk whenever k >= m(mu).
*/
muprev = mu;
s = Math.Sqrt(mu);
d = 6.0 * mu * mu;
big_l = Math.Floor(mu - 1.1484);
/* = an upper bound to m(mu) for all mu >= 10.*/
}
else
{ /* Small mu ( < 10) -- not using normal approx. */
/* Case B. (start new table and calculate p0 if necessary) */
/*muprev = 0.;-* such that next time, mu != muprev ..*/
if (mu != muprev)
{
muprev = mu;
m = Math.Max(1, (int)mu);
l = 0; /* pp[] is already ok up to pp[l] */
q = p0 = p = Math.Exp(-mu);
}
for (;;)
{
/* Step U. uniform sample for inversion method */
u = UniformDistribution.RUnif();
if (u <= p0)
{
return(0.0);
}
/* Step T. table comparison until the end pp[l] of the
* pp-table of cumulative poisson probabilities
* (0.458 > ~= pp[9](= 0.45792971447) for mu=10 ) */
if (l != 0)
{
for (k = (u <= 0.458) ? 1 : Math.Min(l, m); k <= l; k++)
{
if (u <= pp[k])
{
return((double)k);
}
}
if (l == 35) /* u > pp[35] */
{
continue;
}
}
/* Step C. creation of new poisson
* probabilities p[l..] and their cumulatives q =: pp[k] */
l++;
for (k = l; k <= 35; k++)
{
p *= mu / k;
q += p;
pp[k] = q;
if (u <= q)
{
l = k;
return((double)k);
}
}
l = 35;
} /* end(repeat) */
} /* mu < 10 */
} /* end {initialize persistent vars} */
/* Only if mu >= 10 : ----------------------- */
/* Step N. normal sample */
g = mu + s * NormalDistribution.RNorm();/* norm_rand() ~ N(0,1), standard normal */
if (g >= 0.0)
{
pois = Math.Floor(g);
/* Step I. immediate acceptance if pois is large enough */
if (pois >= big_l)
{
return(pois);
}
/* Step S. squeeze acceptance */
fk = pois;
difmuk = mu - fk;
u = UniformDistribution.RUnif(); /* ~ U(0,1) - sample */
if (d * u >= difmuk * difmuk * difmuk)
{
return(pois);
}
}
/* Step P. preparations for steps Q and H.
* (recalculations of parameters if necessary) */
if (new_big_mu || mu != muprev2)
{
/* Careful! muprev2 is not always == muprev
* because one might have exited in step I or S
*/
muprev2 = mu;
omega = RVaria.M_1_SQRT_2PI / s;
/* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite
* approximations to the discrete normal probabilities fk. */
b1 = one_24 / mu;
b2 = 0.3 * b1 * b1;
c3 = one_7 * b1 * b2;
c2 = b2 - 15.0 * c3;
c1 = b1 - 6.0 * b2 + 45.0 * c3;
c0 = 1.0 - b1 + 3.0 * b2 - 15.0 * c3;
c = 0.1069 / mu; /* guarantees majorization by the 'hat'-function. */
}
if (g >= 0.0)
{
/* 'Subroutine' F is called (kflag=0 for correct return) */
kflag = 0;
//goto Step_F;
//F(mu);
directToStepF = true;
countDirectToStepF++;
}
for (;;)
{
if (!directToStepF)
{
/* Step E. Exponential Sample */
E = ExponentialDistribution.RExp(); /* ~ Exp(1) (standard exponential) */
/* sample t from the laplace 'hat'
* (if t <= -0.6744 then pk < fk for all mu >= 10.) */
u = 2 * UniformDistribution.RUnif() - 1.0;
t = 1.8 + RVaria.fsign(E, u);
}
if ((t > -0.6744) || directToStepF)
{
if (!directToStepF)
{
pois = Math.Floor(mu + s * t);
fk = pois;
difmuk = mu - fk;
kflag = 1;
}
/* 'subroutine' F is called (kflag=1 for correct return) */
F(mu);
directToStepF = false;
//Step_F: /* 'subroutine' F : calculation of px,py,fx,fy. */
// if (pois < 10)
// { /* use factorials from table fact[] */
// px = -mu;
// py = Math.Pow(mu, pois) / fact[(int)pois];
// }
// else
// {
// /* Case pois >= 10 uses polynomial approximation
// a0-a7 for accuracy when advisable */
// del = one_12 / fk;
// del = del * (1.0 - 4.8 * del * del);
// v = difmuk / fk;
// if (Math.Abs(v) <= 0.25)
// px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) *
// v + a3) * v + a2) * v + a1) * v + a0)
// - del;
// else /* |v| > 1/4 */
// px = fk * Math.Log(1.0 + v) - difmuk - del;
// py = R.M_1_SQRT_2PI / Math.Sqrt(fk);
// }
// x = (0.5 - difmuk) / s;
// x *= x;/* x^2 */
// fx = -0.5 * x;
// fy = omega * (((c3 * x + c2) * x + c1) * x + c0);
if (kflag > 0)
{
/* Step H. Hat acceptance (E is repeated on rejection) */
if (c * Math.Abs(u) <= py * Math.Exp(px + E) - fy * Math.Exp(fx + E))
{
break;
}
}
else
/* Step Q. Quotient acceptance (rare case) */
if (fy - u * fy <= py * Math.Exp(px - fx))
{
break;
}
}/* t > -.67.. */
}
return(pois);
}
private static double gamma_rand(double shape, double scale)
{
// On a et scale sont fini, a>=0 et scale>0
//if (!R_FINITE(a) || !R_FINITE(scale) || a < 0.0 || scale <= 0.0)
//{
// if (scale == 0.0) return 0.0;
// return double.NaN; //ML_ERR_return_NAN;
//}
/* State variables [FIXME for threading!] :*/
double aa = 0.0;
double aaa = 0.0;
double s = 0, s2 = 0, d = 0; /* no. 1 (step 1) */
double q0 = 0, b = 0, si = 0, c = 0; /* no. 2 (step 4) */
double e, p, q, r, t, u, v, w, x, ret_val;
if (shape < 1.0)
{ /* GS algorithm for parameters a < 1 */
if (shape == 0.0)
{
return(0.0);
}
e = 1.0 + exp_m1 * shape;
for (;;)
{
p = e * UniformDistribution.RUnif();
if (p >= 1.0)
{
x = -Math.Log((e - p) / shape);
if (ExponentialDistribution.RExp() >= (1.0 - shape) * Math.Log(x))
{
break;
}
}
else
{
x = Math.Exp(Math.Log(p) / shape);
if (ExponentialDistribution.RExp() >= x)
{
break;
}
}
}
return(scale * x);
}
/* --- a >= 1 : GD algorithm --- */
/* Step 1: Recalculations of s2, s, d if a has changed */
if (shape != aa)
{
aa = shape;
s2 = shape - 0.5;
s = Math.Sqrt(s2);
d = sqrt32 - s * 12.0;
}
/* Step 2: t = standard normal deviate,
* x = (s,1/2) -normal deviate. */
/* immediate acceptance (i) */
t = NormalDistribution.RNorm();
x = s + 0.5 * t;
ret_val = x * x;
if (t >= 0.0)
{
return(scale * ret_val);
}
/* Step 3: u = 0,1 - uniform sample. squeeze acceptance (s) */
u = UniformDistribution.RUnif();
if (d * u <= t * t * t)
{
return(scale * ret_val);
}
/* Step 4: recalculations of q0, b, si, c if necessary */
if (shape != aaa)
{
aaa = shape;
r = 1.0 / shape;
q0 = ((((((q7 * r + q6) * r + q5) * r + q4) * r + q3) * r
+ q2) * r + q1) * r;
/* Approximation depending on size of parameter a */
/* The constants in the expressions for b, si and c */
/* were established by numerical experiments */
if (shape <= 3.686)
{
b = 0.463 + s + 0.178 * s2;
si = 1.235;
c = 0.195 / s - 0.079 + 0.16 * s;
}
else if (shape <= 13.022)
{
b = 1.654 + 0.0076 * s2;
si = 1.68 / s + 0.275;
c = 0.062 / s + 0.024;
}
else
{
b = 1.77;
si = 0.75;
c = 0.1515 / s;
}
}
/* Step 5: no quotient test if x not positive */
if (x > 0.0)
{
/* Step 6: calculation of v and quotient q */
v = t / (s + s);
if (Math.Abs(v) <= 0.25)
{
q = q0 + 0.5 * t * t * ((((((a7 * v + a6) * v + a5) * v + a4) * v
+ a3) * v + a2) * v + a1) * v;
}
else
{
q = q0 - s * t + 0.25 * t * t + (s2 + s2) * Math.Log(1.0 + v);
}
/* Step 7: quotient acceptance (q) */
if (Math.Log(1.0 - u) <= q)
{
return(scale * ret_val);
}
}
while (true)
{
/* Step 8: e = standard exponential deviate
* u = 0,1 -uniform deviate
* t = (b,si)-double exponential (laplace) sample */
e = ExponentialDistribution.RExp();
u = UniformDistribution.RUnif();
u = u + u - 1.0;
if (u < 0.0)
{
t = b - si * e;
}
else
{
t = b + si * e;
}
/* Step 9: rejection if t < tau(1) = -0.71874483771719 */
if (t >= -0.71874483771719)
{
/* Step 10: calculation of v and quotient q */
v = t / (s + s);
if (Math.Abs(v) <= 0.25)
{
q = q0 + 0.5 * t * t *
((((((a7 * v + a6) * v + a5) * v + a4) * v + a3) * v
+ a2) * v + a1) * v;
}
else
{
q = q0 - s * t + 0.25 * t * t + (s2 + s2) * Math.Log(1.0 + v);
}
/* Step 11: hat acceptance (h) */
/* (if q not positive go to step 8) */
if (q > 0.0)
{
w = expm1(q);
/* ^^^^^ original code had approximation with rel.err < 2e-7 */
/* if t is rejected sample again at step 8 */
if (c * Math.Abs(u) <= w * Math.Exp(e - 0.5 * t * t))
{
break;
}
}
}
} /* repeat .. until `t' is accepted */
x = s + 0.5 * t;
return(scale * x * x);
}
private static double qchisq_appr(
double p,
double nu,
double g /* = log Gamma(nu/2) */,
bool lower_tail,
bool log_p,
double tol /* EPS1 */)
{
double alpha, a, c, ch, p1;
double p2, q, t, x;
/* test arguments and initialise */
if (double.IsNaN(p) || double.IsNaN(nu))
{
return(p + nu);
}
if ((log_p && (p > 0)) ||
(!log_p && (p < 0 || p > 1)))
{
return(double.NaN); //ML_ERR_return_NAN
}
//R_Q_P01_check(p);
if (nu <= 0)
{
return(double.NaN); //ML_ERR_return_NAN;
}
alpha = 0.5 * nu; /* = [pq]gamma() shape */
c = alpha - 1;
//p1 = (lower_tail ? (log_p ? (p) : Math.Log(p)) : ((p) > -M_LN2 ? Math.Log(-expm1(p)) : log1p(-Math.Exp(p))));
p1 = (lower_tail ? (log_p ? (p) : Math.Log(p)) : (log_p ? ((p) > -M_LN2 ? Math.Log(-expm1(p)) : log1p(-Math.Exp(p))) : log1p(-p)));
if (nu < (-1.24 * p1))
{ /* for small chi-squared */
/* Math.Log(alpha) + g = Math.Log(alpha) + Math.Log(gamma(alpha)) =
* = Math.Log(alpha*gamma(alpha)) = lgamma(alpha+1) suffers from
* catastrophic cancellation when alpha << 1
*/
double lgam1pa = (alpha < 0.5) ? GammaDistribution.lgamma1p(alpha) : (Math.Log(alpha) + g);
ch = Math.Exp((lgam1pa + p1) / alpha + M_LN2);
}
else if (nu > 0.32)
{ /* using Wilson and Hilferty estimate */
x = NormalDistribution.QNorm(p, 0, 1, lower_tail, log_p);
p1 = 2.0 / (9 * nu);
ch = nu * Math.Pow(x * Math.Sqrt(p1) + 1 - p1, 3);
/* approximation for p tending to 1: */
if (ch > 2.2 * nu + 6)
{
ch = -2 * (R_DT_Clog(p, lower_tail, log_p) - c * Math.Log(0.5 * ch) + g);
}
}
else
{ /* "small nu" : 1.24*(-Math.Math.Log(p)) <= nu <= 0.32 */
ch = 0.4;
a = R_DT_Clog(p, lower_tail, log_p) + g + c * M_LN2;
do
{
q = ch;
p1 = 1.0 / (1 + ch * (C7 + ch));
p2 = ch * (C9 + ch * (C8 + ch));
t = -0.5 + (C7 + 2 * ch) * p1 - (C9 + ch * (C10 + 3 * ch)) / p2;
ch -= (1 - Math.Exp(a + 0.5 * ch) * p2 * p1) / t;
} while (Math.Abs(q - ch) > tol * Math.Abs(ch));
}
return(ch);
}
