Example #1
0
double lchoose(double n, double k)
{
    double k0 = k;
    k = floor(k + 0.5);
#ifdef IEEE_754
    /* NaNs propagated correctly */
    if(ISNAN(n) || ISNAN(k)) return n + k;
#endif
    if (fabs(k - k0) > 1e-7)
	MATHLIB_WARNING2(_("'k' (%.2f) must be integer, rounded to %.0f"), k0, k);
    if (k < 2) {
	if (k <	 0) return ML_NEGINF;
	if (k == 0) return 0.;
	/* else: k == 1 */
	return log(fabs(n));
    }
    /* else: k >= 2 */
    if (n < 0) {
	return lchoose(-n+ k-1, k);
    }
    else if (R_IS_INT(n)) {
	if(n < k) return ML_NEGINF;
	/* k <= n :*/
	if(n - k < 2) return lchoose(n, n-k); /* <- Symmetry */
	/* else: n >= k+2 */
	return lfastchoose(n, k);
    }
    /* else non-integer n >= 0 : */
    if (n < k-1) {
	int s;
	return lfastchoose2(n, k, &s);
    }
    return lfastchoose(n, k);
}
Example #2
0
double psigamma(double x, double deriv)
{
    /* n-th derivative of psi(x);  e.g., psigamma(x,0) == digamma(x) */
    double ans;
    int nz, ierr, k, n;

    if(ISNAN(x))
	return x;
    deriv = floor(deriv + 0.5);
    n = (int)deriv;
    if(n > n_max) {
	MATHLIB_WARNING2(_("deriv = %d > %d (= n_max)"), n, n_max);
	return ML_NAN;
    }
    dpsifn(x, n, 1, 1, &ans, &nz, &ierr);
    if(ierr != 0) {
	errno = EDOM;
	return ML_NAN;
    }
    /* ans ==  A := (-1)^(n+1) / gamma(n+1) * psi(n, x) */
    ans = -ans; /* = (-1)^(0+1) * gamma(0+1) * A */
    for(k = 1; k <= n; k++)
	ans *= (-k);/* = (-1)^(k+1) * gamma(k+1) * A */
    return ans;/* = psi(n, x) */
}
Example #3
0
/* modified version of bessel_k that accepts a work array instead of
   allocating one. */
double bessel_k_ex(double x, double alpha, double expo, double *bk)
{
    long nb, ncalc, ize;

#ifdef IEEE_754
    /* NaNs propagated correctly */
    if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
    if (x < 0) {
	ML_ERROR(ME_RANGE, "bessel_k");
	return ML_NAN;
    }
    ize = (long)expo;
    if(alpha < 0)
	alpha = -alpha;
    nb = 1+ (long)floor(alpha);/* nb-1 <= |alpha| < nb */
    alpha -= (double)(nb-1);
    K_bessel(&x, &alpha, &nb, &ize, bk, &ncalc);
    if(ncalc != nb) {/* error input */
      if(ncalc < 0)
	MATHLIB_WARNING4(_("bessel_k(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
			 x, ncalc, nb, alpha);
      else
	MATHLIB_WARNING2(_("bessel_k(%g,nu=%g): precision lost in result\n"),
			 x, alpha+(double)nb-1);
    }
    x = bk[nb-1];
    return x;
}
Example #4
0
/* modified version of bessel_j that accepts a work array instead of
   allocating one. */
double bessel_j_ex(double x, double alpha, double *bj)
{
    long nb, ncalc;
    double na;

#ifdef IEEE_754
    /* NaNs propagated correctly */
    if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
    if (x < 0) {
	ML_ERROR(ME_RANGE, "bessel_j");
	return ML_NAN;
    }
    na = floor(alpha);
    if (alpha < 0) {
	/* Using Abramowitz & Stegun  9.1.2
	 * this may not be quite optimal (CPU and accuracy wise) */
	return(bessel_j_ex(x, -alpha, bj) * cos(M_PI * alpha) +
	       ((alpha == na) ? 0 :
		bessel_y_ex(x, -alpha, bj) * sin(M_PI * alpha)));
    }
    nb = 1 + (long)na; /* nb-1 <= alpha < nb */
    alpha -= (nb-1);
    J_bessel(&x, &alpha, &nb, bj, &ncalc);
    if(ncalc != nb) {/* error input */
      if(ncalc < 0)
	MATHLIB_WARNING4(_("bessel_j(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
			 x, ncalc, nb, alpha);
      else
	MATHLIB_WARNING2(_("bessel_j(%g,nu=%g): precision lost in result\n"),
			 x, alpha+nb-1);
    }
    x = bj[nb-1];
    return x;
}
Example #5
0
// unused now from R
double bessel_j(double x, double alpha)
{
    int nb, ncalc;
    double na, *bj;
#ifndef MATHLIB_STANDALONE
    const void *vmax;
#endif

#ifdef IEEE_754
    /* NaNs propagated correctly */
    if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
    if (x < 0) {
	ML_ERROR(ME_RANGE, "bessel_j");
	return ML_NAN;
    }
    na = floor(alpha);
    if (alpha < 0) {
	/* Using Abramowitz & Stegun  9.1.2
	 * this may not be quite optimal (CPU and accuracy wise) */
	return(((alpha - na == 0.5) ? 0 : bessel_j(x, -alpha) * cospi(alpha)) +
	       ((alpha      == na ) ? 0 : bessel_y(x, -alpha) * sinpi(alpha)));
    }
    else if (alpha > 1e7) {
	MATHLIB_WARNING("besselJ(x, nu): nu=%g too large for bessel_j() algorithm", alpha);
	return ML_NAN;
    }
    nb = 1 + (int)na; /* nb-1 <= alpha < nb */
    alpha -= (double)(nb-1);
#ifdef MATHLIB_STANDALONE
    bj = (double *) calloc(nb, sizeof(double));
#ifndef _RENJIN
    if (!bj) MATHLIB_ERROR("%s", _("bessel_j allocation error"));
#endif
#else
    vmax = vmaxget();
    bj = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
    J_bessel(&x, &alpha, &nb, bj, &ncalc);
    if(ncalc != nb) {/* error input */
      if(ncalc < 0)
	MATHLIB_WARNING4(_("bessel_j(%g): ncalc (=%d) != nb (=%d); alpha=%g. Arg. out of range?\n"),
			 x, ncalc, nb, alpha);
      else
	MATHLIB_WARNING2(_("bessel_j(%g,nu=%g): precision lost in result\n"),
			 x, alpha+(double)nb-1);
    }
    x = bj[nb-1];
#ifdef MATHLIB_STANDALONE
    free(bj);
#else
    vmaxset(vmax);
#endif
    return x;
}
double bessel_y(double x, double alpha)
{
    long nb, ncalc;
    double na, *by;
#ifndef MATHLIB_STANDALONE
    const void *vmax;
#endif

#ifdef IEEE_754
    /* NaNs propagated correctly */
    if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
    if (x < 0) {
	ML_ERROR(ME_RANGE, "bessel_y");
	return ML_NAN;
    }
    na = floor(alpha);
    if (alpha < 0) {
	/* Using Abramowitz & Stegun  9.1.2
	 * this may not be quite optimal (CPU and accuracy wise) */
	return(bessel_y(x, -alpha) * cos(M_PI * alpha) -
	       ((alpha == na) ? 0 :
		bessel_j(x, -alpha) * sin(M_PI * alpha)));
    }
    nb = 1+ (long)na;/* nb-1 <= alpha < nb */
    alpha -= (nb-1);
#ifdef MATHLIB_STANDALONE
    by = (double *) calloc(nb, sizeof(double));
    if (!by) MATHLIB_ERROR("%s", _("bessel_y allocation error"));
#else
    vmax = vmaxget();
    by = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
    Y_bessel(&x, &alpha, &nb, by, &ncalc);
    if(ncalc != nb) {/* error input */
	if(ncalc == -1)
	    return ML_POSINF;
	else if(ncalc < -1)
	    MATHLIB_WARNING4(_("bessel_y(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
			     x, ncalc, nb, alpha);
	else /* ncalc >= 0 */
	    MATHLIB_WARNING2(_("bessel_y(%g,nu=%g): precision lost in result\n"),
			     x, alpha+nb-1);
    }
    x = by[nb-1];
#ifdef MATHLIB_STANDALONE
    free(by);
#else
    vmaxset(vmax);
#endif
    return x;
}
Example #7
0
double bessel_k(double x, double alpha, double expo)
{
    long nb, ncalc, ize;
    double *bk;
#ifndef MATHLIB_STANDALONE
    const void *vmax;
#endif

#ifdef IEEE_754
    /* NaNs propagated correctly */
    if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
    if (x < 0) {
	ML_ERROR(ME_RANGE, "bessel_k");
	return ML_NAN;
    }
    ize = (long)expo;
    if(alpha < 0)
	alpha = -alpha;
    nb = 1+ (long)floor(alpha);/* nb-1 <= |alpha| < nb */
    alpha -= (double)(nb-1);
#ifdef MATHLIB_STANDALONE
    bk = (double *) calloc(nb, sizeof(double));
    if (!bk) MATHLIB_ERROR("%s", _("bessel_k allocation error"));
#else
    vmax = vmaxget();
    bk = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
    K_bessel(&x, &alpha, &nb, &ize, bk, &ncalc);
    if(ncalc != nb) {/* error input */
      if(ncalc < 0)
	MATHLIB_WARNING4(_("bessel_k(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
			 x, ncalc, nb, alpha);
      else
	MATHLIB_WARNING2(_("bessel_k(%g,nu=%g): precision lost in result\n"),
			 x, alpha+(double)nb-1);
    }
    x = bk[nb-1];
#ifdef MATHLIB_STANDALONE
    free(bk);
#else
    vmaxset(vmax);
#endif
    return x;
}
Example #8
0
/* 30 is somewhat arbitrary: it is on the *safe* side:
 * both speed and precision are clearly improved for k < 30.
*/
double choose(double n, double k)
{
    double r, k0 = k;
    k = R_forceint(k);
#ifdef IEEE_754
    /* NaNs propagated correctly */
    if(ISNAN(n) || ISNAN(k)) return n + k;
#endif
#ifndef MATHLIB_STANDALONE
    R_CheckStack();
#endif
    if (fabs(k - k0) > 1e-7)
	MATHLIB_WARNING2(_("'k' (%.2f) must be integer, rounded to %.0f"), k0, k);
    if (k < k_small_max) {
	int j;
	if(n-k < k && n >= 0 && R_IS_INT(n)) k = n-k; /* <- Symmetry */
	if (k <	 0) return 0.;
	if (k == 0) return 1.;
	/* else: k >= 1 */
	r = n;
	for(j = 2; j <= k; j++)
	    r *= (n-j+1)/j;
	return R_IS_INT(n) ? R_forceint(r) : r;
	/* might have got rounding errors */
    }
    /* else: k >= k_small_max */
    if (n < 0) {
	r = choose(-n+ k-1, k);
	if (ODD(k)) r = -r;
	return r;
    }
    else if (R_IS_INT(n)) {
	n = R_forceint(n);
	if(n < k) return 0.;
	if(n - k < k_small_max) return choose(n, n-k); /* <- Symmetry */
	return R_forceint(exp(lfastchoose(n, k)));
    }
    /* else non-integer n >= 0 : */
    if (n < k-1) {
	int s_choose;
	r = lfastchoose2(n, k, /* -> */ &s_choose);
	return s_choose * exp(r);
    }
    return exp(lfastchoose(n, k));
}
Example #9
0
/* Called from R: modified version of bessel_j(), accepting a work array
 * instead of allocating one. */
double bessel_j_ex(double x, double alpha, double *bj)
{
    int nb, ncalc;
    double na;

#ifdef IEEE_754
    /* NaNs propagated correctly */
    if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
    if (x < 0) {
	ML_ERROR(ME_RANGE, "bessel_j");
	return ML_NAN;
    }
    na = floor(alpha);
    if (alpha < 0) {
	/* Using Abramowitz & Stegun  9.1.2
	 * this may not be quite optimal (CPU and accuracy wise) */
	return(((alpha - na == 0.5) ? 0 : bessel_j_ex(x, -alpha, bj) * cospi(alpha)) +
	       ((alpha      == na ) ? 0 : bessel_y_ex(x, -alpha, bj) * sinpi(alpha)));
    }
    else if (alpha > 1e7) {
	MATHLIB_WARNING("besselJ(x, nu): nu=%g too large for bessel_j() algorithm", alpha);
	return ML_NAN;
    }
    nb = 1 + (int)na; /* nb-1 <= alpha < nb */
    alpha -= (double)(nb-1); // ==> alpha' in [0, 1)
    J_bessel(&x, &alpha, &nb, bj, &ncalc);
    if(ncalc != nb) {/* error input */
      if(ncalc < 0)
	MATHLIB_WARNING4(_("bessel_j(%g): ncalc (=%d) != nb (=%d); alpha=%g. Arg. out of range?\n"),
			 x, ncalc, nb, alpha);
      else
	MATHLIB_WARNING2(_("bessel_j(%g,nu=%g): precision lost in result\n"),
			 x, alpha+(double)nb-1);
    }
    x = bj[nb-1];
    return x;
}
Example #10
0
double attribute_hidden
pnchisq_raw(double x, double f, double theta,
	    double errmax, double reltol, int itrmax, Rboolean lower_tail)
{
    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;

    static const double _dbl_min_exp = M_LN2 * DBL_MIN_EXP;
    /*= -708.3964 for IEEE double precision */

    if (x <= 0.) {
	if(x == 0. && f == 0.)
	    return lower_tail ? exp(-0.5*theta) : -expm1(-0.5*theta);
	/* x < 0  or {x==0, f > 0} */
	return lower_tail ? 0. : 1.;
    }
    if(!R_FINITE(x))	return lower_tail ? 1. : 0.;

    /* 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 sum = 0, sum2 = 0, lambda = 0.5*theta, 
	    pr = EXP(-lambda); // does this need a feature test?
	double ans;
	int i;
	/* we need to renormalize here: the result could be very close to 1 */
	for(i = 0; i < 110;  pr *= lambda/++i) {
	    sum2 += pr;
	    sum += pr * pchisq(x, f+2*i, lower_tail, FALSE);
	    if (sum2 >= 1-1e-15) break;
	}
	ans = (double) (sum/sum2);
	return ans;
    }


#ifdef DEBUG_pnch
    REprintf("pnchisq(x=%g, f=%g, theta=%g): ",x,f,theta);
#endif
    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)) - 0.5 * log(2*M_PI*(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) {
	if (x > f + theta +  5* sqrt( 2*(f + 2*theta))) {
	    /* x > E[X] + 5* sigma(X) */
	    return lower_tail ? 1. : 0.; /* FIXME: We 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
	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
	    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
                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
    return (double) (lower_tail ? ans : 1 - ans);
}
Example #11
0
double pnchisq_raw(double x, double f, double theta,
		   double errmax, double reltol, int itrmax)
{
    double ans, lam, u, v, x2, f2, t, term, bound, f_x_2n, f_2n, lt;
    double lu = -1., l_lam = -1., l_x = -1.; /* initialized for -Wall */
    int n;
    Rboolean lamSml, tSml, is_r, is_b, is_it;

    static const double _dbl_min_exp = M_LN2 * DBL_MIN_EXP;
    /*= -708.3964 for IEEE double precision */

    if (x <= 0.)	return 0.;
    if(!R_FINITE(x))	return 1.;

#ifdef DEBUG_pnch
    REprintf("pnchisq(x=%g, f=%g, theta=%g): ",x,f,theta);
#endif
    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) <         /* other 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)) - 0.5 * log(2*M_PI*(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) {
	if (x > f + theta +  5* sqrt( 2*(f + 2*theta))) {
	    /* x > E[X] + 5* sigma(X) */
	    return 1.; /* better than 0 --- but definitely "FIXME" */
	} /* else */
	l_x = log(x);
	ans = term = t = 0.;
    }
    else {
	t = exp(lt);
#ifdef DEBUG_pnch
 	REprintf(", t=exp(lt)= %g\n", t);
#endif
	ans = term = v * t;
    }

    for (n = 1, f_2n = f + 2., f_x_2n += 2.;  ; n++, f_2n += 2, f_x_2n += 2) {
#ifdef DEBUG_pnch
	REprintf("\n _OL_: n=%d",n);
#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 = t * x / f_x_2n;
#ifdef DEBUG_pnch
	    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
                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 = 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
    return (ans);
}
Example #12
0
// Returns both qbeta() and its "mirror" 1-qbeta(). Useful notably when qbeta() ~= 1
attribute_hidden void
qbeta_raw(double alpha, double p, double q, int lower_tail, int log_p,
	  int swap_01, // {TRUE, NA, FALSE}: if NA, algorithm decides swap_tail
	  double log_q_cut, /* if == Inf: return log(qbeta(..));
			       otherwise, if finite: the bound for
			       switching to log(x)-scale; see use_log_x */
	  int n_N,  // number of "unconstrained" Newton steps before switching to constrained
	  double *qb) // = qb[0:1] = { qbeta(), 1 - qbeta() }
{
    Rboolean
	swap_choose = (swap_01 == MLOGICAL_NA),
	swap_tail,
	log_, give_log_q = (log_q_cut == ML_POSINF),
	use_log_x = give_log_q, // or u < log_q_cut  below
	warned = FALSE, add_N_step = TRUE;
    int i_pb, i_inn;
    double a, la, logbeta, g, h, pp, p_, qq, r, s, t, w, y = -1.;
    volatile double u, xinbta;

    // Assuming p >= 0, q >= 0  here ...

    // Deal with boundary cases here:
    if(alpha == R_DT_0) {
#define return_q_0						\
	if(give_log_q) { qb[0] = ML_NEGINF; qb[1] = 0; }	\
	else {           qb[0] = 0;         qb[1] = 1; }	\
	return

	return_q_0;
    }
    if(alpha == R_DT_1) {
#define return_q_1						\
	if(give_log_q) { qb[0] = 0; qb[1] = ML_NEGINF; }	\
	else {           qb[0] = 1; qb[1] = 0;         }	\
	return

	return_q_1;
    }

    // check alpha {*before* transformation which may all accuracy}:
    if((log_p && alpha > 0) ||
       (!log_p && (alpha < 0 || alpha > 1))) { // alpha is outside
	R_ifDEBUG_printf("qbeta(alpha=%g, %g, %g, .., log_p=%d): %s%s\n",
			 alpha, p,q, log_p, "alpha not in ",
			 log_p ? "[-Inf, 0]" : "[0,1]");
	// ML_ERR_return_NAN :
	ML_ERROR(ME_DOMAIN, "");
	qb[0] = qb[1] = ML_NAN; return;
    }

    //  p==0, q==0, p = Inf, q = Inf  <==> treat as one- or two-point mass
    if(p == 0 || q == 0 || !R_FINITE(p) || !R_FINITE(q)) {
	// We know 0 < T(alpha) < 1 : pbeta() is constant and trivial in {0, 1/2, 1}
	R_ifDEBUG_printf(
	    "qbeta(%g, %g, %g, lower_t=%d, log_p=%d): (p,q)-boundary: trivial\n",
	    alpha, p,q, lower_tail, log_p);
	if(p == 0 && q == 0) { // point mass 1/2 at each of {0,1} :
	    if(alpha < R_D_half) { return_q_0; }
	    if(alpha > R_D_half) { return_q_1; }
	    // else:  alpha == "1/2"
#define return_q_half					\
	    if(give_log_q) qb[0] = qb[1] = -M_LN2;	\
	    else	   qb[0] = qb[1] = 0.5;		\
	    return

	    return_q_half;
	} else if (p == 0 || p/q == 0) { // point mass 1 at 0 - "flipped around"
	    return_q_0;
	} else if (q == 0 || q/p == 0) { // point mass 1 at 0 - "flipped around"
	    return_q_1;
	}
	// else:  p = q = Inf : point mass 1 at 1/2
	return_q_half;
    }

    /* initialize */
    p_ = R_DT_qIv(alpha);/* lower_tail prob (in any case) */
    // Conceptually,  0 < p_ < 1  (but can be 0 or 1 because of cancellation!)
    logbeta = lbeta(p, q);

    swap_tail = (swap_choose) ? (p_ > 0.5) : swap_01;
    // change tail; default (swap_01 = NA): afterwards 0 < a <= 1/2
    if(swap_tail) { /* change tail, swap  p <-> q :*/
	a = R_DT_CIv(alpha); // = 1 - p_ < 1/2
	/* la := log(a), but without numerical cancellation: */
	la = R_DT_Clog(alpha);
	pp = q; qq = p;
    }
    else {
	a = p_;
	la = R_DT_log(alpha);
	pp = p; qq = q;
    }

    /* calculate the initial approximation */

    /* Desired accuracy for Newton iterations (below) should depend on  (a,p)
     * This is from Remark .. on AS 109, adapted.
     * However, it's not clear if this is "optimal" for IEEE double prec.

     * acu = fmax2(acu_min, pow(10., -25. - 5./(pp * pp) - 1./(a * a)));

     * NEW: 'acu' accuracy NOT for squared adjustment, but simple;
     * ---- i.e.,  "new acu" = sqrt(old acu)
    */
    double acu = fmax2(acu_min, pow(10., -13. - 2.5/(pp * pp) - 0.5/(a * a)));
    // try to catch  "extreme left tail" early
    double tx, u0 = (la + log(pp) + logbeta) / pp; // = log(x_0)
    static const double
	log_eps_c = M_LN2 * (1. - DBL_MANT_DIG);// = log(DBL_EPSILON) = -36.04..
    r = pp*(1.-qq)/(pp+1.);

    t = 0.2;
    // FIXME: Factor 0.2 is a bit arbitrary;  '1' is clearly much too much.

    R_ifDEBUG_printf(
	"qbeta(%g, %g, %g, lower_t=%d, log_p=%d):%s\n"
	"  swap_tail=%d, la=%g, u0=%g (bnd: %g (%g)) ",
	alpha, p,q, lower_tail, log_p,
	(log_p && (p_ == 0. || p_ == 1.)) ? (p_==0.?" p_=0":" p_=1") : "",
	swap_tail, la, u0,
	(t*log_eps_c - log(fabs(pp*(1.-qq)*(2.-qq)/(2.*(pp+2.)))))/2.,
	 t*log_eps_c - log(fabs(r))
	);

    if(M_LN2 * DBL_MIN_EXP < u0 && // cannot allow exp(u0) = 0 ==> exp(u1) = exp(u0) = 0
       u0 < -0.01 && // (must: u0 < 0, but too close to 0 <==> x = exp(u0) = 0.99..)
       // qq <= 2 && // <--- "arbitrary"
       // u0 <  t*log_eps_c - log(fabs(r)) &&
       u0 < (t*log_eps_c - log(fabs(pp*(1.-qq)*(2.-qq)/(2.*(pp+2.)))))/2.)
    {
// TODO: maybe jump here from below, when initial u "fails" ?
// L_tail_u:
	// MM's one-step correction (cheaper than 1 Newton!)
	r = r*exp(u0);// = r*x0
	if(r > -1.) {
	    u = u0 - log1p(r)/pp;
	    R_ifDEBUG_printf("u1-u0=%9.3g --> choosing u = u1\n", u-u0);
	} else {
	    u = u0;
	    R_ifDEBUG_printf("cannot cheaply improve u0\n");
	}
	tx = xinbta = exp(u);
	use_log_x = TRUE; // or (u < log_q_cut)  ??
	goto L_Newton;
    }

    // y := y_\alpha in AS 64 := Hastings(1955) approximation of qnorm(1 - a) :
    r = sqrt(-2 * la);
    y = r - (const1 + const2 * r) / (1. + (const3 + const4 * r) * r);

    if (pp > 1 && qq > 1) { // use  Carter(1947), see AS 109, remark '5.'
	r = (y * y - 3.) / 6.;
	s = 1. / (pp + pp - 1.);
	t = 1. / (qq + qq - 1.);
	h = 2. / (s + t);
	w = y * sqrt(h + r) / h - (t - s) * (r + 5. / 6. - 2. / (3. * h));
	R_ifDEBUG_printf("p,q > 1 => w=%g", w);
	if(w > 300) { // exp(w+w) is huge or overflows
	    t = w+w + log(qq) - log(pp); // = argument of log1pexp(.)
	    u = // log(xinbta) = - log1p(qq/pp * exp(w+w)) = -log(1 + exp(t))
		(t <= 18) ? -log1p(exp(t)) : -t - exp(-t);
	    xinbta = exp(u);
	} else {
	    xinbta = pp / (pp + qq * exp(w + w));
	    u = // log(xinbta)
		- log1p(qq/pp * exp(w+w));
	}
    } else { // use the original AS 64 proposal, Scheffé-Tukey (1944) and Wilson-Hilferty
	r = qq + qq;
	/* A slightly more stable version of  t := \chi^2_{alpha} of AS 64
	 * t = 1. / (9. * qq); t = r * R_pow_di(1. - t + y * sqrt(t), 3);  */
	t = 1. / (3. * sqrt(qq));
	t = r * R_pow_di(1. + t*(-t + y), 3);// = \chi^2_{alpha} of AS 64
	s = 4. * pp + r - 2.;// 4p + 2q - 2 = numerator of new t = (...) / chi^2
	R_ifDEBUG_printf("min(p,q) <= 1: t=%g", t);
	if (t == 0 || (t < 0. && s >= t)) { // cannot use chisq approx
	    // x0 = 1 - { (1-a)*q*B(p,q) } ^{1/q}    {AS 65}
	    // xinbta = 1. - exp((log(1-a)+ log(qq) + logbeta) / qq);
	    double l1ma;/* := log(1-a), directly from alpha (as 'la' above):
			 * FIXME: not worth it? log1p(-a) always the same ?? */
	    if(swap_tail)
		l1ma = R_DT_log(alpha);
	    else
		l1ma = R_DT_Clog(alpha);
	    R_ifDEBUG_printf(" t <= 0 : log1p(-a)=%.15g, better l1ma=%.15g\n", log1p(-a), l1ma);
	    double xx = (l1ma + log(qq) + logbeta) / qq;
	    if(xx <= 0.) {
		xinbta = -expm1(xx);
		u = R_Log1_Exp (xx);// =  log(xinbta) = log(1 - exp(...A...))
	    } else { // xx > 0 ==> 1 - e^xx < 0 .. is nonsense
		R_ifDEBUG_printf(" xx=%g > 0: xinbta:= 1-e^xx < 0\n", xx);
		xinbta = 0; u = ML_NEGINF; /// FIXME can do better?
	    }
	} else {
	    t = s / t;
	    R_ifDEBUG_printf(" t > 0 or s < t < 0:  new t = %g ( > 1 ?)\n", t);
	    if (t <= 1.) { // cannot use chisq, either
		u = (la + log(pp) + logbeta) / pp;
		xinbta = exp(u);
	    } else { // (1+x0)/(1-x0) = t,  solved for x0 :
		xinbta = 1. - 2. / (t + 1.);
		u = log1p(-2. / (t + 1.));
	    }
	}
    }

    // Problem: If initial u is completely wrong, we make a wrong decision here
    if(swap_choose &&
       (( swap_tail && u >= -exp(  log_q_cut)) || // ==> "swap back"
	(!swap_tail && u >= -exp(4*log_q_cut) && pp / qq < 1000.))) { // ==> "swap now" (much less easily)
	// "revert swap" -- and use_log_x
	swap_tail = !swap_tail;
	R_ifDEBUG_printf(" u = %g (e^u = xinbta = %.16g) ==> ", u, xinbta);
	if(swap_tail) {
	    a = R_DT_CIv(alpha); // needed ?
	    la = R_DT_Clog(alpha);
	    pp = q; qq = p;
	}
	else {
	    a = p_;
	    la = R_DT_log(alpha);
	    pp = p; qq = q;
	}
	R_ifDEBUG_printf("\"%s\"; la = %g\n",
			 (swap_tail ? "swap now" : "swap back"), la);
	// we could redo computations above, but this should be stable
	u = R_Log1_Exp(u);
	xinbta = exp(u);

/* Careful: "swap now"  should not fail if
   1) the above initial xinbta is "completely wrong"
   2) The correction step can go outside (u_n > 0 ==>  e^u > 1 is illegal)
   e.g., for
	qbeta(0.2066, 0.143891, 0.05)
*/
    }

    if(!use_log_x)
	use_log_x = (u < log_q_cut);//(per default) <==> xinbta = e^u < 4.54e-5
    Rboolean
	bad_u = !R_FINITE(u),
	bad_init = bad_u || xinbta > p_hi;

    R_ifDEBUG_printf(" -> u = %g, e^u = xinbta = %.16g, (Newton acu=%g%s)\n",
	     u, xinbta, acu,
	     (bad_u ? ", ** bad u **" :
	      (use_log_x ? ", on u = log(x) scale" : "")));

    double u_n = 1.; // -Wall
    tx = xinbta; // keeping "original initial x" (for now)

    if(bad_u || u < log_q_cut) { /* e.g.
		    qbeta(0.21, .001, 0.05)
		    try "left border" quickly, i.e.,
		    try at smallest positive number: */
	w = pbeta_raw(DBL_very_MIN, pp, qq, TRUE, log_p);
	if(w > (log_p ? la : a)) {
	    R_ifDEBUG_printf(" quantile is left of smallest positive number; \"convergence\"\n");
	    if(log_p || fabs(w - a) < fabs(0 - a)) { // DBL_very_MIN is better than 0
		tx   = DBL_very_MIN;
		u_n  = DBL_log_v_MIN;// = log(DBL_very_MIN)
	    } else {
		tx   = 0.;
		u_n  = ML_NEGINF;
	    }
	    use_log_x = log_p; add_N_step = FALSE; goto L_return;
	}
	else {
	    R_ifDEBUG_printf(" pbeta(smallest pos.) = %g <= %g  --> continuing\n",
		     w, (log_p ? la : a));
	    if(u  < DBL_log_v_MIN) {
		u = DBL_log_v_MIN;// = log(DBL_very_MIN)
		xinbta = DBL_very_MIN;
	    }
	}
    }


    /* Sometimes the approximation is negative (and == 0 is also not "ok") */
    if (bad_init && !(use_log_x && tx > 0)) {
	if(u == ML_NEGINF) {
	    R_ifDEBUG_printf("  u = -Inf;");
	    u = M_LN2 * DBL_MIN_EXP;
	    xinbta = DBL_MIN;
	} else {
	    R_ifDEBUG_printf(" bad_init: u=%g, xinbta=%g;", u,xinbta);
	    xinbta = (xinbta > 1.1) // i.e. "way off"
		? 0.5 // otherwise, keep the respective boundary:
		: ((xinbta < p_lo) ? exp(u) : p_hi);
	    if(bad_u)
		u = log(xinbta);
	    // otherwise: not changing "potentially better" u than the above
	}
	R_ifDEBUG_printf(" -> (partly)new u=%g, xinbta=%g\n", u,xinbta);
    }

L_Newton:
    /* --------------------------------------------------------------------

     * Solve for x by a modified Newton-Raphson method, using pbeta_raw()
     */
    r = 1 - pp;
    t = 1 - qq;
    double wprev = 0., prev = 1., adj = 1.; // -Wall

    if(use_log_x) { // find  log(xinbta) -- work in  u := log(x) scale
	// if(bad_init && tx > 0) xinbta = tx;// may have been better

	for (i_pb=0; i_pb < 1000; i_pb++) {
	    // using log_p == TRUE  unconditionally here
	    // FIXME: if exp(u) = xinbta underflows to 0, like different formula pbeta_log(u, *)
	    y = pbeta_raw(xinbta, pp, qq, /*lower_tail = */ TRUE, TRUE);

	    /* w := Newton step size for   L(u) = log F(e^u)  =!= 0;   u := log(x)
	     *   =  (L(.) - la) / L'(.);  L'(u)= (F'(e^u) * e^u ) / F(e^u)
	     *   =  (L(.) - la)*F(.) / {F'(e^u) * e^u } =
	     *   =  (L(.) - la) * e^L(.) * e^{-log F'(e^u) - u}
	     *   =  ( y   - la) * e^{ y - u -log F'(e^u)}
		and  -log F'(x)= -log f(x) =  + logbeta + (1-p) log(x) + (1-q) log(1-x)
			       = logbeta + (1-p) u + (1-q) log(1-e^u)
	     */
	    w = (y == ML_NEGINF) // y = -Inf  well possible: we are on log scale!
		? 0. : (y - la) * exp(y - u + logbeta + r * u + t * R_Log1_Exp(u));
	    if(!R_FINITE(w))
		break;
	    if (i_pb >= n_N && w * wprev <= 0.)
		prev = fmax2(fabs(adj),fpu);
	    R_ifDEBUG_printf("N(i=%2d): u=%#20.16g, pb(e^u)=%#12.6g, w=%#15.9g, %s prev=%11g,",
			     i_pb, u, y, w, (w * wprev <= 0.) ? "new" : "old", prev);
	    g = 1;
	    for (i_inn=0; i_inn < 1000; i_inn++) {
		adj = g * w;
		// take full Newton steps at the beginning; only then safe guard:
		if (i_pb < n_N || fabs(adj) < prev) {
		    u_n = u - adj; // u_{n+1} = u_n - g*w
		    if (u_n <= 0.) { // <==> 0 <  xinbta := e^u  <= 1
			if (prev <= acu || fabs(w) <= acu) {
			    /* R_ifDEBUG_printf(" -adj=%g, %s <= acu  ==> convergence\n", */
			    /*	 -adj, (prev <= acu) ? "prev" : "|w|"); */
			    R_ifDEBUG_printf(" it{in}=%d, -adj=%g, %s <= acu  ==> convergence\n",
					     i_inn, -adj, (prev <= acu) ? "prev" : "|w|");
			    goto L_converged;
			}
			// if (u_n != ML_NEGINF && u_n != 1)
			break;
		    }
		}
		g /= 3;
	    }
	    // (cancellation in (u_n -u) => may differ from adj:
	    double D = fmin2(fabs(adj), fabs(u_n - u));
	    /* R_ifDEBUG_printf(" delta(u)=%g\n", u_n - u); */
	    R_ifDEBUG_printf(" it{in}=%d, delta(u)=%9.3g, D/|.|=%.3g\n",
			     i_inn, u_n - u, D/fabs(u_n + u));
	    if (D <= 4e-16 * fabs(u_n + u))
		goto L_converged;
	    u = u_n;
	    xinbta = exp(u);
	    wprev = w;
	} // for(i )

    } else

    for (i_pb=0; i_pb < 1000; i_pb++) {
	y = pbeta_raw(xinbta, pp, qq, /*lower_tail = */ TRUE, log_p);
	// delta{y} :   d_y = y - (log_p ? la : a);
#ifdef IEEE_754
	if(!R_FINITE(y) && !(log_p && y == ML_NEGINF))// y = -Inf  is ok if(log_p)
#else
	if (errno)
#endif
	{ // ML_ERR_return_NAN :
	    ML_ERROR(ME_DOMAIN, "");
	    qb[0] = qb[1] = ML_NAN; return;
	}


	/* w := Newton step size  (F(.) - a) / F'(.)  or,
	 * --   log: (lF - la) / (F' / F) = exp(lF) * (lF - la) / F'
	 */
	w = log_p
	    ? (y - la) * exp(y + logbeta + r * log(xinbta) + t * log1p(-xinbta))
	    : (y - a)  * exp(    logbeta + r * log(xinbta) + t * log1p(-xinbta));
	if (i_pb >= n_N && w * wprev <= 0.)
	    prev = fmax2(fabs(adj),fpu);
	R_ifDEBUG_printf("N(i=%2d): x0=%#17.15g, pb(x0)=%#17.15g, w=%#17.15g, %s prev=%g,",
			 i_pb, xinbta, y, w, (w * wprev <= 0.) ? "new" : "old", prev);
	g = 1;
	for (i_inn=0; i_inn < 1000;i_inn++) {
	    adj = g * w;
	    // take full Newton steps at the beginning; only then safe guard:
	    if (i_pb < n_N || fabs(adj) < prev) {
		tx = xinbta - adj; // x_{n+1} = x_n - g*w
		if (0. <= tx && tx <= 1.) {
		    if (prev <= acu || fabs(w) <= acu) {
			R_ifDEBUG_printf(" it{in}=%d, delta(x)=%g, %s <= acu  ==> convergence\n",
					 i_inn, -adj, (prev <= acu) ? "prev" : "|w|");
			goto L_converged;
		    }
		    if (tx != 0. && tx != 1)
			break;
		}
	    }
	    g /= 3;
	}
	R_ifDEBUG_printf(" it{in}=%d, delta(x)=%g\n", i_inn, tx - xinbta);
	if (fabs(tx - xinbta) <= 4e-16 * (tx + xinbta)) // "<=" : (.) == 0
	    goto L_converged;
	xinbta = tx;
	if(tx == 0) // "we have lost"
	    break;
	wprev = w;
    }

    /*-- NOT converged: Iteration count --*/
    warned = TRUE;
    ML_ERROR(ME_PRECISION, "qbeta");

L_converged:
    log_ = log_p || use_log_x; // only for printing
    R_ifDEBUG_printf(" %s: Final delta(y) = %g%s\n",
	     warned ? "_NO_ convergence" : "converged",
	     y - (log_ ? la : a), (log_ ? " (log_)" : ""));
    if((log_ && y == ML_NEGINF) || (!log_ && y == 0)) {
	// stuck at left, try if smallest positive number is "better"
	w = pbeta_raw(DBL_very_MIN, pp, qq, TRUE, log_);
	if(log_ || fabs(w - a) <= fabs(y - a)) {
	    tx  = DBL_very_MIN;
	    u_n = DBL_log_v_MIN;// = log(DBL_very_MIN)
	}
	add_N_step = FALSE; // not trying to do better anymore
    }
    else if(!warned && (log_ ? fabs(y - la) > 3 : fabs(y - a) > 1e-4)) {
	if(!(log_ && y == ML_NEGINF &&
	    // e.g. qbeta(-1e-10, .2, .03, log=TRUE) cannot get accurate ==> do NOT warn
	     pbeta_raw(DBL_1__eps, // = 1 - eps
		       pp, qq, TRUE, TRUE) > la + 2))
	    MATHLIB_WARNING2( // low accuracy for more platform independent output:
    "qbeta(a, *) =: x0 with |pbeta(x0,*%s) - alpha| = %.5g is not accurate",
	    (log_ ? ", log_" : ""), fabs(y - (log_ ? la : a)));
    }
L_return:
    if(give_log_q) { // ==> use_log_x , too
	if(!use_log_x) // (see if claim above is true)
	    MATHLIB_WARNING(
		"qbeta() L_return, u_n=%g;  give_log_q=TRUE but use_log_x=FALSE -- please report!",
		u_n);
	double r = R_Log1_Exp(u_n);
	if(swap_tail) {
	    qb[0] = r;	 qb[1] = u_n;
	} else {
	    qb[0] = u_n; qb[1] = r;
	}
    } else {
	if(use_log_x) {
	    if(add_N_step) {
		/* add one last Newton step on original x scale, e.g., for
		   qbeta(2^-98, 0.125, 2^-96) */
		xinbta = exp(u_n);
		y = pbeta_raw(xinbta, pp, qq, /*lower_tail = */ TRUE, log_p);
		w = log_p
		    ? (y - la) * exp(y + logbeta + r * log(xinbta) + t * log1p(-xinbta))
		    : (y - a)  * exp(    logbeta + r * log(xinbta) + t * log1p(-xinbta));
		tx = xinbta - w;
		R_ifDEBUG_printf(
		    "Final Newton correction(non-log scale): xinbta=%.16g, y=%g, w=%g. => new tx=%.16g\n",
		    xinbta, y, w, tx);
	    } else {
		if(swap_tail) {
		    qb[0] = -expm1(u_n); qb[1] =  exp  (u_n);
		} else {
		    qb[0] =  exp  (u_n); qb[1] = -expm1(u_n);
		}
		return;
	    }
	}
	if(swap_tail) {
	    qb[0] = 1 - tx;	qb[1] = tx;
	} else {
	    qb[0] = tx;	qb[1] = 1 - tx;
	}
    }
    return;
}
Example #13
0
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);
}