Ejemplo n.º 1
0
double dbinom_raw(double x, double n, double p, double q, int give_log)
{
    double lf, lc;

    if (p == 0) return((x == 0) ? R_D__1 : R_D__0);
    if (q == 0) return((x == n) ? R_D__1 : R_D__0);

    if (x == 0) {
	if(n == 0) return R_D__1;
	lc = (p < 0.1) ? -bd0(n,n*q) - n*p : n*log(q);
	return( R_D_exp(lc) );
    }
    if (x == n) {
	lc = (q < 0.1) ? -bd0(n,n*p) - n*q : n*log(p);
	return( R_D_exp(lc) );
    }
    if (x < 0 || x > n) return( R_D__0 );

    /* n*p or n*q can underflow to zero if n and p or q are small.  This
       used to occur in dbeta, and gives NaN as from R 2.3.0.  */
    lc = stirlerr(n) - stirlerr(x) - stirlerr(n-x) - bd0(x,n*p) - bd0(n-x,n*q);

    /* f = (M_2PI*x*(n-x))/n; could overflow or underflow */
    /* Upto R 2.7.1:
     * lf = log(M_2PI) + log(x) + log(n-x) - log(n);
     * -- following is much better for  x << n : */
    lf = M_LN_2PI + log(x) + log1p(- x/n);

    return R_D_exp(lc - 0.5*lf);
}
Ejemplo n.º 2
0
	double dbinom(int x, int n, double p)
	{
		assert((p>=0) && (p<=1));
		assert(n>=0);
		assert((x>=0) && (x<=n));
		if (p==0.0) return x==0 ? 1.0 : 0.0;
		if (p==1.0) return x==n ? 1.0 : 0.0;
		if (x==0) return exp(n*log(1-p));
		if (x==n) return exp(n*log(p));
		double lc = stirlerr(n) - stirlerr(x) - stirlerr(n-x) - bd0(x, n*p) - bd0(n-x, n*(1-p));
		return exp(lc)*sqrt(n/(PI2*x*(n-x)));
	}
Ejemplo n.º 3
0
static lua_Number dbinom_raw (lua_Number x, lua_Number n, lua_Number p,
    lua_Number q) {
  lua_Number f, lc;
  if (p == 0) return (x == 0) ? 1 : 0;
  if (q == 0) return (x == n) ? 1 : 0;
  if (x == 0)
    return exp((p < 0.1) ? -bd0(n, n * q) - n * p : n * log(q));
  if (x == n)
    return exp((q < 0.1) ? -bd0(n, n * p) - n * q : n * log(p));
  if ((x < 0) || (x > n)) return 0;
  lc = stirlerr(n) - stirlerr(x) - stirlerr(n - x)
    - bd0(x, n * p) - bd0(n - x, n * q);
  f = (2 * M_PI * x * (n - x)) / n;
  return exp(lc) / sqrt(f);
}
Ejemplo n.º 4
0
double dt(double x, double n, int give_log)
{
#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(n))
	return x + n;
#endif
    if (n <= 0) ML_ERR_return_NAN;
    if(!R_FINITE(x))
	return R_D__0;
    if(!R_FINITE(n))
	return dnorm(x, 0., 1., give_log);

    double u, ax, t = -bd0(n/2.,(n+1)/2.) + stirlerr((n+1)/2.) - stirlerr(n/2.),
	x2n = x*x/n, // in  [0, Inf]
	l_x2n; // := log(sqrt(1 + x2n)) = log(1 + x2n)/2
    Rboolean lrg_x2n =  (x2n > 1./DBL_EPSILON);
    if (lrg_x2n) { // large x^2/n :
	ax = fabs(x);
	l_x2n = log(ax) - log(n)/2.; // = log(x2n)/2 = 1/2 * log(x^2 / n)
	u = //  log(1 + x2n) * n/2 =  n * log(1 + x2n)/2 =
	    n * l_x2n;
    }
    else if (x2n > 0.2) {
	l_x2n = log(1 + x2n)/2.;
	u = n * l_x2n;
    } else {
	l_x2n = log1p(x2n)/2.;
	u = -bd0(n/2.,(n+x*x)/2.) + x*x/2.;
    }

    //old: return  R_D_fexp(M_2PI*(1+x2n), t-u);

    // R_D_fexp(f,x) :=  (give_log ? -0.5*log(f)+(x) : exp(x)/sqrt(f))
    // f = 2pi*(1+x2n)
    //  ==> 0.5*log(f) = log(2pi)/2 + log(1+x2n)/2 = log(2pi)/2 + l_x2n
    //	     1/sqrt(f) = 1/sqrt(2pi * (1+ x^2 / n))
    //		       = 1/sqrt(2pi)/(|x|/sqrt(n)*sqrt(1+1/x2n))
    //		       = M_1_SQRT_2PI * sqrt(n)/ (|x|*sqrt(1+1/x2n))
    if(give_log)
	return t-u - (M_LN_SQRT_2PI + l_x2n);

    // else :  if(lrg_x2n) : sqrt(1 + 1/x2n) ='= sqrt(1) = 1
    double I_sqrt_ = (lrg_x2n ? sqrt(n)/ax : exp(-l_x2n));
    return exp(t-u) * M_1_SQRT_2PI * I_sqrt_;
}
Ejemplo n.º 5
0
Archivo: dpois.c Proyecto: ahma88/magro
double dpois_raw(NMATH_STATE *state, double x, double lambda, int give_log)
{
    /*       x >= 0 ; integer for dpois(), but not e.g. for pgamma()!
        lambda >= 0
    */
    if (lambda == 0) return( (x == 0) ? R_D__1 : R_D__0 );
    if (!isfinite(lambda)) return R_D__0;
    if (x < 0) return( R_D__0 );
    if (x <= lambda * DBL_MIN) return(R_D_exp(-lambda) );
    if (lambda < x * DBL_MIN) return(R_D_exp(-lambda + x*log(lambda) -lgammafn(state, x+1)));
    return(R_D_fexp( M_PI*2.0*x, -stirlerr(state,x)-bd0(x,lambda) ));
}
Ejemplo n.º 6
0
double attribute_hidden dpois_raw(double x, double lambda, int give_log)
{
    /*       x >= 0 ; integer for dpois(), but not e.g. for pgamma()!
        lambda >= 0
    */
    if (lambda == 0) return( (x == 0) ? R_D__1 : R_D__0 );
    if (!R_FINITE(lambda)) return R_D__0;
    if (x < 0) return( R_D__0 );
    if (x <= lambda * DBL_MIN) return(R_D_exp(-lambda) );
    if (lambda < x * DBL_MIN) return(R_D_exp(-lambda + x*log(lambda) -lgammafn(x+1)));
    return(R_D_fexp( M_2PI*x, -stirlerr(x)-bd0(x,lambda) ));
}
Ejemplo n.º 7
0
Archivo: gamma.c Proyecto: csilles/cxxr
double gammafn(double x)
{
    const static double gamcs[42] = {
	+.8571195590989331421920062399942e-2,
	+.4415381324841006757191315771652e-2,
	+.5685043681599363378632664588789e-1,
	-.4219835396418560501012500186624e-2,
	+.1326808181212460220584006796352e-2,
	-.1893024529798880432523947023886e-3,
	+.3606925327441245256578082217225e-4,
	-.6056761904460864218485548290365e-5,
	+.1055829546302283344731823509093e-5,
	-.1811967365542384048291855891166e-6,
	+.3117724964715322277790254593169e-7,
	-.5354219639019687140874081024347e-8,
	+.9193275519859588946887786825940e-9,
	-.1577941280288339761767423273953e-9,
	+.2707980622934954543266540433089e-10,
	-.4646818653825730144081661058933e-11,
	+.7973350192007419656460767175359e-12,
	-.1368078209830916025799499172309e-12,
	+.2347319486563800657233471771688e-13,
	-.4027432614949066932766570534699e-14,
	+.6910051747372100912138336975257e-15,
	-.1185584500221992907052387126192e-15,
	+.2034148542496373955201026051932e-16,
	-.3490054341717405849274012949108e-17,
	+.5987993856485305567135051066026e-18,
	-.1027378057872228074490069778431e-18,
	+.1762702816060529824942759660748e-19,
	-.3024320653735306260958772112042e-20,
	+.5188914660218397839717833550506e-21,
	-.8902770842456576692449251601066e-22,
	+.1527474068493342602274596891306e-22,
	-.2620731256187362900257328332799e-23,
	+.4496464047830538670331046570666e-24,
	-.7714712731336877911703901525333e-25,
	+.1323635453126044036486572714666e-25,
	-.2270999412942928816702313813333e-26,
	+.3896418998003991449320816639999e-27,
	-.6685198115125953327792127999999e-28,
	+.1146998663140024384347613866666e-28,
	-.1967938586345134677295103999999e-29,
	+.3376448816585338090334890666666e-30,
	-.5793070335782135784625493333333e-31
    };

    int i, n;
    double y;
    double sinpiy, value;

#ifdef NOMORE_FOR_THREADS
    static int ngam = 0;
    static double xmin = 0, xmax = 0., xsml = 0., dxrel = 0.;

    /* Initialize machine dependent constants, the first time gamma() is called.
	FIXME for threads ! */
    if (ngam == 0) {
	ngam = chebyshev_init(gamcs, 42, DBL_EPSILON/20);/*was .1*d1mach(3)*/
	gammalims(&xmin, &xmax);/*-> ./gammalims.c */
	xsml = exp(fmax2(log(DBL_MIN), -log(DBL_MAX)) + 0.01);
	/*   = exp(.01)*DBL_MIN = 2.247e-308 for IEEE */
	dxrel = sqrt(DBL_EPSILON);/*was sqrt(d1mach(4)) */
    }
#else
/* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 :
 * (xmin, xmax) are non-trivial, see ./gammalims.c
 * xsml = exp(.01)*DBL_MIN
 * dxrel = sqrt(DBL_EPSILON) = 2 ^ -26
*/
# define ngam 22
# define xmin -170.5674972726612
# define xmax  171.61447887182298
# define xsml 2.2474362225598545e-308
# define dxrel 1.490116119384765696e-8
#endif

    if(ISNAN(x)) return x;

    /* If the argument is exactly zero or a negative integer
     * then return NaN. */
    if (x == 0 || (x < 0 && x == (long)x)) {
	ML_ERROR(ME_DOMAIN, "gammafn");
	return ML_NAN;
    }

    y = fabs(x);

    if (y <= 10) {

	/* Compute gamma(x) for -10 <= x <= 10
	 * Reduce the interval and find gamma(1 + y) for 0 <= y < 1
	 * first of all. */

	n = (int) x;
	if(x < 0) --n;
	y = x - n;/* n = floor(x)  ==>	y in [ 0, 1 ) */
	--n;
	value = chebyshev_eval(y * 2 - 1, gamcs, ngam) + .9375;
	if (n == 0)
	    return value;/* x = 1.dddd = 1+y */

	if (n < 0) {
	    /* compute gamma(x) for -10 <= x < 1 */

	    /* exact 0 or "-n" checked already above */

	    /* The answer is less than half precision */
	    /* because x too near a negative integer. */
	    if (x < -0.5 && fabs(x - (int)(x - 0.5) / x) < dxrel) {
		ML_ERROR(ME_PRECISION, "gammafn");
	    }

	    /* The argument is so close to 0 that the result would overflow. */
	    if (y < xsml) {
		ML_ERROR(ME_RANGE, "gammafn");
		if(x > 0) return ML_POSINF;
		else return ML_NEGINF;
	    }

	    n = -n;

	    for (i = 0; i < n; i++) {
		value /= (x + i);
	    }
	    return value;
	}
	else {
	    /* gamma(x) for 2 <= x <= 10 */

	    for (i = 1; i <= n; i++) {
		value *= (y + i);
	    }
	    return value;
	}
    }
    else {
	/* gamma(x) for	 y = |x| > 10. */

	if (x > xmax) {			/* Overflow */
	    ML_ERROR(ME_RANGE, "gammafn");
	    return ML_POSINF;
	}

	if (x < xmin) {			/* Underflow */
	    ML_ERROR(ME_UNDERFLOW, "gammafn");
	    return 0.;
	}

	if(y <= 50 && y == (int)y) { /* compute (n - 1)! */
	    value = 1.;
	    for (i = 2; i < y; i++) value *= i;
	}
	else { /* normal case */
	    value = exp((y - 0.5) * log(y) - y + M_LN_SQRT_2PI +
			((2*y == (int)2*y)? stirlerr(y) : lgammacor(y)));
	}
	if (x > 0)
	    return value;

	if (fabs((x - (int)(x - 0.5))/x) < dxrel){

	    /* The answer is less than half precision because */
	    /* the argument is too near a negative integer. */

	    ML_ERROR(ME_PRECISION, "gammafn");
	}

	sinpiy = sin(M_PI * y);
	if (sinpiy == 0) {		/* Negative integer arg - overflow */
	    ML_ERROR(ME_RANGE, "gammafn");
	    return ML_POSINF;
	}

	return -M_PI / (y * sinpiy * value);
    }
}
Ejemplo n.º 8
0
	double dpois(int x, double lb)
	{
		if (lb==0.0) return x==0 ? 1.0 : 0.0;
		if (x==0) return exp(-lb);
		return exp(-stirlerr(x)-bd0(x,lb))/sqrt(PI2*x);
	}
Ejemplo n.º 9
0
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;
}