double psignrank(double x, double n, int lower_tail, int log_p)
{
int i;
double f, p;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n))
return(x + n);
#endif
if (!R_FINITE(n)) ML_ERR_return_NAN;
n = floor(n + 0.5);
if (n <= 0) ML_ERR_return_NAN;
x = floor(x + 1e-7);
if (x < 0.0)
return(R_DT_0);
if (x >= n * (n + 1) / 2)
return(R_DT_1);
w_init_maybe(n);
f = exp(- n * M_LN2);
p = 0;
if (x <= (n * (n + 1) / 4)) {
for (i = 0; i <= x; i++)
p += csignrank(i, n) * f;
}
else {
x = n * (n + 1) / 2 - x;
for (i = 0; i < x; i++)
p += csignrank(i, n) * f;
lower_tail = !lower_tail; /* p = 1 - p; */
}
return(R_DT_val(p));
} /* psignrank() */
double pnchisq(double x, double f, double theta, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(f) || ISNAN(theta))
return x + f + theta;
if (!R_FINITE(f) || !R_FINITE(theta))
ML_ERR_return_NAN;
#endif
if (f < 0. || theta < 0.) ML_ERR_return_NAN;
return (R_DT_val(pnchisq_raw(x, f, theta, 1e-12, 8*DBL_EPSILON, 1000000)));
}
double punif(double x, double a, double b, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(a) || ISNAN(b))
return x + a + b;
#endif
if (b <= a) ML_ERR_return_NAN;
if (x <= a)
return R_DT_0;
if (x >= b)
return R_DT_1;
return R_DT_val((x - a) / (b - a));
}
double pcauchy(double x, double location, double scale,
int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(location) || ISNAN(scale))
return x + location + scale;
#endif
if (scale <= 0) ML_ERR_return_NAN;
x = (x - location) / scale;
if (ISNAN(x)) ML_ERR_return_NAN;
#ifdef IEEE_754
if(!R_FINITE(x)) {
if(x < 0) return R_DT_0;
else return R_DT_1;
}
#endif
return R_DT_val(0.5 + atan(x) / M_PI);
}
/* args have the same meaning as R function pwilcox */
double pwilcox(double q, double m, double n, int lower_tail, int log_p)
{
int i;
double c, p;
#ifdef IEEE_754
if (ISNAN(q) || ISNAN(m) || ISNAN(n))
return(q + m + n);
#endif
if (!R_FINITE(m) || !R_FINITE(n))
ML_ERR_return_NAN;
m = R_forceint(m);
n = R_forceint(n);
if (m <= 0 || n <= 0)
ML_ERR_return_NAN;
q = floor(q + 1e-7);
if (q < 0.0)
return(R_DT_0);
if (q >= m * n)
return(R_DT_1);
int mm = (int) m, nn = (int) n;
w_init_maybe(mm, nn);
c = choose(m + n, n);
p = 0;
/* Use summation of probs over the shorter range */
if (q <= (m * n / 2)) {
for (i = 0; i <= q; i++)
p += cwilcox(i, mm, nn) / c;
}
else {
q = m * n - q;
for (i = 0; i < q; i++)
p += cwilcox(i, mm, nn) / c;
lower_tail = !lower_tail; /* p = 1 - p; */
}
return(R_DT_val(p));
} /* pwilcox */
double ptukey(double q, double rr, double cc, double df,
int lower_tail, int log_p)
{
/* function ptukey() [was qprob() ]:
q = value of studentized range
rr = no. of rows or groups
cc = no. of columns or treatments
df = degrees of freedom of error term
ir[0] = error flag = 1 if wprob probability > 1
ir[1] = error flag = 1 if qprob probability > 1
qprob = returned probability integral over [0, q]
The program will not terminate if ir[0] or ir[1] are raised.
All references in wprob to Abramowitz and Stegun
are from the following reference:
Abramowitz, Milton and Stegun, Irene A.
Handbook of Mathematical Functions.
New York: Dover publications, Inc. (1970).
All constants taken from this text are
given to 25 significant digits.
nlegq = order of legendre quadrature
ihalfq = int ((nlegq + 1) / 2)
eps = max. allowable value of integral
eps1 & eps2 = values below which there is
no contribution to integral.
d.f. <= dhaf: integral is divided into ulen1 length intervals. else
d.f. <= dquar: integral is divided into ulen2 length intervals. else
d.f. <= deigh: integral is divided into ulen3 length intervals. else
d.f. <= dlarg: integral is divided into ulen4 length intervals.
d.f. > dlarg: the range is used to calculate integral.
M_LN2 = log(2)
xlegq = legendre 16-point nodes
alegq = legendre 16-point coefficients
The coefficients and nodes for the legendre quadrature used in
qprob and wprob were calculated using the algorithms found in:
Stroud, A. H. and Secrest, D.
Gaussian Quadrature Formulas.
Englewood Cliffs,
New Jersey: Prentice-Hall, Inc, 1966.
All values matched the tables (provided in same reference)
to 30 significant digits.
f(x) = .5 + erf(x / sqrt(2)) / 2 for x > 0
f(x) = erfc( -x / sqrt(2)) / 2 for x < 0
where f(x) is standard normal c. d. f.
if degrees of freedom large, approximate integral
with range distribution.
*/
#define nlegq 16
#define ihalfq 8
/* const double eps = 1.0; not used if = 1 */
const static double eps1 = -30.0;
const static double eps2 = 1.0e-14;
const static double dhaf = 100.0;
const static double dquar = 800.0;
const static double deigh = 5000.0;
const static double dlarg = 25000.0;
const static double ulen1 = 1.0;
const static double ulen2 = 0.5;
const static double ulen3 = 0.25;
const static double ulen4 = 0.125;
const static double xlegq[ihalfq] = {
0.989400934991649932596154173450,
0.944575023073232576077988415535,
0.865631202387831743880467897712,
0.755404408355003033895101194847,
0.617876244402643748446671764049,
0.458016777657227386342419442984,
0.281603550779258913230460501460,
0.950125098376374401853193354250e-1
};
const static double alegq[ihalfq] = {
0.271524594117540948517805724560e-1,
0.622535239386478928628438369944e-1,
0.951585116824927848099251076022e-1,
0.124628971255533872052476282192,
0.149595988816576732081501730547,
0.169156519395002538189312079030,
0.182603415044923588866763667969,
0.189450610455068496285396723208
};
double ans, f2, f21, f2lf, ff4, otsum, qsqz, rotsum, t1, twa1, ulen, wprb;
int i, j, jj;
#ifdef IEEE_754
if (ISNAN(q) || ISNAN(rr) || ISNAN(cc) || ISNAN(df))
ML_ERR_return_NAN;
#endif
if (q <= 0)
return R_DT_0;
/* df must be > 1 */
/* there must be at least two values */
if (df < 2 || rr < 1 || cc < 2) ML_ERR_return_NAN;
if(!R_FINITE(q))
return R_DT_1;
if (df > dlarg)
return R_DT_val(wprob(q, rr, cc));
/* calculate leading constant */
f2 = df * 0.5;
/* lgammafn(u) = log(gamma(u)) */
f2lf = ((f2 * log(df)) - (df * M_LN2)) - lgammafn(f2);
f21 = f2 - 1.0;
/* integral is divided into unit, half-unit, quarter-unit, or */
/* eighth-unit length intervals depending on the value of the */
/* degrees of freedom. */
ff4 = df * 0.25;
if (df <= dhaf) ulen = ulen1;
else if (df <= dquar) ulen = ulen2;
else if (df <= deigh) ulen = ulen3;
else ulen = ulen4;
f2lf += log(ulen);
/* integrate over each subinterval */
ans = 0.0;
for (i = 1; i <= 50; i++) {
otsum = 0.0;
/* legendre quadrature with order = nlegq */
/* nodes (stored in xlegq) are symmetric around zero. */
twa1 = (2 * i - 1) * ulen;
for (jj = 1; jj <= nlegq; jj++) {
if (ihalfq < jj) {
j = jj - ihalfq - 1;
t1 = (f2lf + (f21 * log(twa1 + (xlegq[j] * ulen))))
- (((xlegq[j] * ulen) + twa1) * ff4);
} else {
j = jj - 1;
t1 = (f2lf + (f21 * log(twa1 - (xlegq[j] * ulen))))
+ (((xlegq[j] * ulen) - twa1) * ff4);
}
/* if exp(t1) < 9e-14, then doesn't contribute to integral */
if (t1 >= eps1) {
if (ihalfq < jj) {
qsqz = q * sqrt(((xlegq[j] * ulen) + twa1) * 0.5);
} else {
qsqz = q * sqrt(((-(xlegq[j] * ulen)) + twa1) * 0.5);
}
/* call wprob to find integral of range portion */
wprb = wprob(qsqz, rr, cc);
rotsum = (wprb * alegq[j]) * exp(t1);
otsum += rotsum;
}
/* end legendre integral for interval i */
/* L200: */
}
/* if integral for interval i < 1e-14, then stop.
* However, in order to avoid small area under left tail,
* at least 1 / ulen intervals are calculated.
*/
if (i * ulen >= 1.0 && otsum <= eps2)
break;
/* end of interval i */
/* L330: */
ans += otsum;
}
if(otsum > eps2) { /* not converged */
ML_ERROR(ME_PRECISION, "ptukey");
}
if (ans > 1.)
ans = 1.;
return R_DT_val(ans);
}
double pnt(double t, double df, double delta, int lower_tail, int log_p)
{
double a, albeta, b, del, errbd, geven, godd,
lambda, p, q, rxb, s, tnc, tt, x, xeven, xodd;
int it, negdel;
/* note - itrmax and errmax may be changed to suit one's needs. */
const int itrmax = 1000;
const double errmax = 1.e-12;
if (df <= 0.) ML_ERR_return_NAN;
if(!R_FINITE(t))
return (t < 0) ? R_DT_0 : R_DT_1;
if (t >= 0.) {
negdel = false; tt = t; del = delta;
}
else {
negdel = true; tt = -t; del = -delta;
}
if (df > 4e5 || del*del > 2*M_LN2*(-(numeric_limits<double>::min_exponent))) {
/*-- 2nd part: if del > 37.62, then p=0 below
FIXME: test should depend on `df', `tt' AND `del' ! */
/* Approx. from Abramowitz & Stegun 26.7.10 (p.949) */
s = 1./(4.*df);
return pnorm(tt*(1. - s), del, sqrt(1. + tt*tt*2.*s),
lower_tail != negdel, log_p);
}
/* initialize twin series */
/* Guenther, J. (1978). Statist. Computn. Simuln. vol.6, 199. */
x = t * t;
x = x / (x + df);/* in [0,1) */
if (x > 0.) {/* <==> t != 0 */
lambda = del * del;
p = .5 * exp(-.5 * lambda);
if(p == 0.) { /* underflow! */
/*========== really use an other algorithm for this case !!! */
ML_ERROR(ME_UNDERFLOW);
report_error("|delta| too large."); /* |delta| too large */
}
q = M_SQRT_2dPI * p * del;
s = .5 - p;
a = .5;
b = .5 * df;
rxb = pow(1. - x, b);
albeta = M_LN_SQRT_PI + lgammafn(b) - lgammafn(.5 + b);
xodd = pbeta(x, a, b, /*lower*/true, /*log_p*/false);
godd = 2. * rxb * exp(a * log(x) - albeta);
xeven = 1. - rxb;
geven = b * x * rxb;
tnc = p * xodd + q * xeven;
/* repeat until convergence or iteration limit */
for(it = 1; it <= itrmax; it++) {
a += 1.;
xodd -= godd;
xeven -= geven;
godd *= x * (a + b - 1.) / a;
geven *= x * (a + b - .5) / (a + .5);
p *= lambda / (2 * it);
q *= lambda / (2 * it + 1);
tnc += p * xodd + q * xeven;
s -= p;
if(s <= 0.) { /* happens e.g. for (t,df,delta)=(40,10,38.5), after 799 it.*/
ML_ERROR(ME_PRECISION);
goto finis;
}
errbd = 2. * s * (xodd - godd);
if(errbd < errmax) goto finis;/*convergence*/
}
/* non-convergence:*/
ML_ERROR(ME_PRECISION);
}
else { /* x = t = 0 */
tnc = 0.;
}
finis:
tnc += pnorm(- del, 0., 1., /*lower*/true, /*log_p*/false);
lower_tail = lower_tail != negdel; /* xor */
return R_DT_val(tnc);
}
double attribute_hidden
pnchisq_raw(double x, double f, double theta /* = ncp */,
double errmax, double reltol, int itrmax,
Rboolean lower_tail, Rboolean log_p)
{
double lam, x2, f2, term, bound, f_x_2n, f_2n;
double l_lam = -1., l_x = -1.; /* initialized for -Wall */
int n;
Rboolean lamSml, tSml, is_r, is_b, is_it;
LDOUBLE ans, u, v, t, lt, lu =-1;
if (x <= 0.) {
if(x == 0. && f == 0.) {
#define _L (-0.5 * theta) // = -lambda
return lower_tail ? R_D_exp(_L) : (log_p ? R_Log1_Exp(_L) : -expm1(_L));
}
/* x < 0 or {x==0, f > 0} */
return R_DT_0;
}
if(!R_FINITE(x)) return R_DT_1;
/* This is principally for use from qnchisq */
#ifndef MATHLIB_STANDALONE
R_CheckUserInterrupt();
#endif
if(theta < 80) { /* use 110 for Inf, as ppois(110, 80/2, lower.tail=FALSE) is 2e-20 */
LDOUBLE ans;
int i;
// Have pgamma(x,s) < x^s / Gamma(s+1) (< and ~= for small x)
// ==> pchisq(x, f) = pgamma(x, f/2, 2) = pgamma(x/2, f/2)
// < (x/2)^(f/2) / Gamma(f/2+1) < eps
// <==> f/2 * log(x/2) - log(Gamma(f/2+1)) < log(eps) ( ~= -708.3964 )
// <==> log(x/2) < 2/f*(log(Gamma(f/2+1)) + log(eps))
// <==> log(x) < log(2) + 2/f*(log(Gamma(f/2+1)) + log(eps))
if(lower_tail && f > 0. &&
log(x) < M_LN2 + 2/f*(lgamma(f/2. + 1) + _dbl_min_exp)) {
// all pchisq(x, f+2*i, lower_tail, FALSE), i=0,...,110 would underflow to 0.
// ==> work in log scale
double lambda = 0.5 * theta;
double sum, sum2, pr = -lambda;
sum = sum2 = ML_NEGINF;
/* we need to renormalize here: the result could be very close to 1 */
for(i = 0; i < 110; pr += log(lambda) - log(++i)) {
sum2 = logspace_add(sum2, pr);
sum = logspace_add(sum, pr + pchisq(x, f+2*i, lower_tail, TRUE));
if (sum2 >= -1e-15) /*<=> EXP(sum2) >= 1-1e-15 */ break;
}
ans = sum - sum2;
#ifdef DEBUG_pnch
REprintf("pnchisq(x=%g, f=%g, th.=%g); th. < 80, logspace: i=%d, ans=(sum=%g)-(sum2=%g)\n",
x,f,theta, i, (double)sum, (double)sum2);
#endif
return (double) (log_p ? ans : EXP(ans));
}
else {
LDOUBLE lambda = 0.5 * theta;
LDOUBLE sum = 0, sum2 = 0, pr = EXP(-lambda); // does this need a feature test?
/* we need to renormalize here: the result could be very close to 1 */
for(i = 0; i < 110; pr *= lambda/++i) {
// pr == exp(-lambda) lambda^i / i! == dpois(i, lambda)
sum2 += pr;
// pchisq(*, i, *) is strictly decreasing to 0 for lower_tail=TRUE
// and strictly increasing to 1 for lower_tail=FALSE
sum += pr * pchisq(x, f+2*i, lower_tail, FALSE);
if (sum2 >= 1-1e-15) break;
}
ans = sum/sum2;
#ifdef DEBUG_pnch
REprintf("pnchisq(x=%g, f=%g, theta=%g); theta < 80: i=%d, sum=%g, sum2=%g\n",
x,f,theta, i, (double)sum, (double)sum2);
#endif
return (double) (log_p ? LOG(ans) : ans);
}
} // if(theta < 80)
// else: theta == ncp >= 80 --------------------------------------------
#ifdef DEBUG_pnch
REprintf("pnchisq(x=%g, f=%g, theta=%g >= 80): ",x,f,theta);
#endif
// Series expansion ------- FIXME: log_p=TRUE, lower_tail=FALSE only applied at end
lam = .5 * theta;
lamSml = (-lam < _dbl_min_exp);
if(lamSml) {
/* MATHLIB_ERROR(
"non centrality parameter (= %g) too large for current algorithm",
theta) */
u = 0;
lu = -lam;/* == ln(u) */
l_lam = log(lam);
} else {
u = exp(-lam);
}
/* evaluate the first term */
v = u;
x2 = .5 * x;
f2 = .5 * f;
f_x_2n = f - x;
#ifdef DEBUG_pnch
REprintf("-- v=exp(-th/2)=%g, x/2= %g, f/2= %g\n",v,x2,f2);
#endif
if(f2 * DBL_EPSILON > 0.125 && /* very large f and x ~= f: probably needs */
FABS(t = x2 - f2) < /* another algorithm anyway */
sqrt(DBL_EPSILON) * f2) {
/* evade cancellation error */
/* t = exp((1 - t)*(2 - t/(f2 + 1))) / sqrt(2*M_PI*(f2 + 1));*/
lt = (1 - t)*(2 - t/(f2 + 1)) - M_LN_SQRT_2PI - 0.5 * log(f2 + 1);
#ifdef DEBUG_pnch
REprintf(" (case I) ==> ");
#endif
}
else {
/* Usual case 2: careful not to overflow .. : */
lt = f2*log(x2) -x2 - lgammafn(f2 + 1);
}
#ifdef DEBUG_pnch
REprintf(" lt= %g", lt);
#endif
tSml = (lt < _dbl_min_exp);
if(tSml) {
#ifdef DEBUG_pnch
REprintf(" is very small\n");
#endif
if (x > f + theta + 5* sqrt( 2*(f + 2*theta))) {
/* x > E[X] + 5* sigma(X) */
return R_DT_1; /* FIXME: could be more accurate than 0. */
} /* else */
l_x = log(x);
ans = term = 0.; t = 0;
}
else {
t = EXP(lt);
#ifdef DEBUG_pnch
REprintf(", t=exp(lt)= %g\n", t);
#endif
ans = term = (double) (v * t);
}
for (n = 1, f_2n = f + 2., f_x_2n += 2.; ; n++, f_2n += 2, f_x_2n += 2) {
#ifdef DEBUG_pnch_n
REprintf("\n _OL_: n=%d",n);
#endif
#ifndef MATHLIB_STANDALONE
if(n % 1000) R_CheckUserInterrupt();
#endif
/* f_2n === f + 2*n
* f_x_2n === f - x + 2*n > 0 <==> (f+2n) > x */
if (f_x_2n > 0) {
/* find the error bound and check for convergence */
bound = (double) (t * x / f_x_2n);
#ifdef DEBUG_pnch_n
REprintf("\n L10: n=%d; term= %g; bound= %g",n,term,bound);
#endif
is_r = is_it = FALSE;
/* convergence only if BOTH absolute and relative error < 'bnd' */
if (((is_b = (bound <= errmax)) &&
(is_r = (term <= reltol * ans))) || (is_it = (n > itrmax)))
{
#ifdef DEBUG_pnch
REprintf("BREAK n=%d %s; bound= %g %s, rel.err= %g %s\n",
n, (is_it ? "> itrmax" : ""),
bound, (is_b ? "<= errmax" : ""),
term/ans, (is_r ? "<= reltol" : ""));
#endif
break; /* out completely */
}
}
/* evaluate the next term of the */
/* expansion and then the partial sum */
if(lamSml) {
lu += l_lam - log(n); /* u = u* lam / n */
if(lu >= _dbl_min_exp) {
/* no underflow anymore ==> change regime */
#ifdef DEBUG_pnch_n
REprintf(" n=%d; nomore underflow in u = exp(lu) ==> change\n",
n);
#endif
v = u = EXP(lu); /* the first non-0 'u' */
lamSml = FALSE;
}
} else {
u *= lam / n;
v += u;
}
if(tSml) {
lt += l_x - log(f_2n);/* t <- t * (x / f2n) */
if(lt >= _dbl_min_exp) {
/* no underflow anymore ==> change regime */
#ifdef DEBUG_pnch
REprintf(" n=%d; nomore underflow in t = exp(lt) ==> change\n", n);
#endif
t = EXP(lt); /* the first non-0 't' */
tSml = FALSE;
}
} else {
t *= x / f_2n;
}
if(!lamSml && !tSml) {
term = (double) (v * t);
ans += term;
}
} /* for(n ...) */
if (is_it) {
MATHLIB_WARNING2(_("pnchisq(x=%g, ..): not converged in %d iter."),
x, itrmax);
}
#ifdef DEBUG_pnch
REprintf("\n == L_End: n=%d; term= %g; bound=%g\n",n,term,bound);
#endif
double dans = (double) ans;
return R_DT_val(dans);
}
/* args have the same meaning as R function pwilcox */
double PWilcox::pwilcox(double q, double m, double n, bool lower_tail) {
try {
int i;
double c, p;
bool log_p = false;
double*** w;
if (isnan(m) || isnan(n))
{
return 0;
}
m = floor(m + 0.5);
n = floor(n + 0.5);
if (m <= 0 || n <= 0) {
return 0;
}
q = floor(q + 1e-7);
if (q < 0.0)
return(R_DT_0);
if (q >= m * n)
return(R_DT_1);
int mm = (int) m, nn = (int) n;
if (mout->control_pressed) {
return 0;
}
//w_init_maybe(mm, nn);
/********************************************/
int thisi;
if (mm > nn) {
thisi = nn;
nn = mm;
mm = thisi;
}
mm = max(mm, 50);
nn = max(nn, 50);
w = (double ***) calloc((size_t) mm + 1, sizeof(double **));
for (thisi = 0; thisi <= mm; thisi++) {
w[thisi] = (double **) calloc((size_t) nn + 1, sizeof(double *));
}
allocated_m = m;
allocated_n = n;
/********************************************/
c = choose(m + n, n);
p = 0;
/* Use summation of probs over the shorter range */
if (q <= (m * n / 2)) {
for (i = 0; i <= q; i++)
p += cwilcox(i, m, n, w) / c;
}
else {
q = m * n - q;
for (i = 0; i < q; i++) {
p += cwilcox(i, m, n, w) / c;
}
lower_tail = !lower_tail; /* p = 1 - p; */
}
//free w
/********************************************/
for (int i = allocated_m; i >= 0; i--) {
for (int j = allocated_n; j >= 0; j--) {
if (w[i][j] != 0)
free((void *) w[i][j]);
}
free((void *) w[i]);
}
free((void *) w);
w = 0;
allocated_m = allocated_n = 0;
/********************************************/
return(R_DT_val(p));
}
catch(exception& e) {
mout->errorOut(e, "PWilcox", "pwilcox");
exit(1);
}
} /* pwilcox */