コード例 #1
0
ファイル: dgamma.c プロジェクト: Vladimir84/rcc
double dgamma(double x, double shape, double scale, int give_log)
{
    double pr;
#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(shape) || ISNAN(scale))
        return x + shape + scale;
#endif
    if (shape <= 0 || scale <= 0) ML_ERR_return_NAN;
    if (x < 0)
	return R_D__0;
    if (x == 0) {
	if (shape < 1) return ML_POSINF;
	if (shape > 1) return R_D__0;
	/* else */
	return give_log ? -log(scale) : 1 / scale;
    }

    if (shape < 1) {
	pr = dpois_raw(shape, x/scale, give_log);
	return give_log ?  pr + log(shape/x) : pr*shape/x;
    }
    /* else  shape >= 1 */
    pr = dpois_raw(shape-1, x/scale, give_log);
    return give_log ? pr - log(scale) : pr/scale;
}
コード例 #2
0
ファイル: dnchisq.c プロジェクト: Vladimir84/rcc
double dnchisq(double x, double df, double lambda, int give_log)
{
    const double eps = 5e-15;

    double i, lambda2, term, sum, q, mid, dfmid, imax, errorbound;

#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(df) || ISNAN(lambda))
	return x + df + lambda;
#endif
    if (lambda < 0 || df <= 0) ML_ERR_return_NAN;

    if (!R_FINITE(df) || !R_FINITE(lambda))
	ML_ERR_return_NAN;

    if(x < 0) return R_D__0;
    if(x == 0 && df < 2.)
	return ML_POSINF;
    if(lambda == 0)
	return dchisq(x, df, give_log);

    lambda2 = 0.5 * lambda;

    /* find max element of sum */
    imax = ceil((-(2+df) +sqrt((2-df) * (2-df) + 4 * lambda * x))/4);
    if (imax < 0) imax = 0;
    dfmid = df + 2 * imax;
    mid = dpois_raw(imax, lambda2, FALSE) * dchisq(x, dfmid, FALSE);

    sum = mid;
    /* upper tail */
    term = mid;
    i = imax;
    df = dfmid;
    do {
	i++;
	q = x * lambda2 / i / df;
	df += 2;
	term = q * term;
	sum += term;
	errorbound = term * q / (1-q);
    } while (errorbound > eps || q >= 1);
    /* lower tail */
    term = mid;
    df = dfmid;
    i = imax;
    while ( i ){
	df -= 2;
	q = i * df / x / lambda2;
	i--;
	term = q * term;
	sum += term;
	errorbound = term * q / (1-q);
	if (errorbound <= eps && q < 1) break;
    }
    return R_D_val(sum);
}
コード例 #3
0
ファイル: pgamma.c プロジェクト: FatManCoding/r-source
/*
 * Abramowitz and Stegun 6.5.29 [right]
 */
static double
pgamma_smallx (double x, double alph, int lower_tail, int log_p)
{
    double sum = 0, c = alph, n = 0, term;

#ifdef DEBUG_p
    REprintf (" pg_smallx(x=%.12g, alph=%.12g): ", x, alph);
#endif

    /*
     * Relative to 6.5.29 all terms have been multiplied by alph
     * and the first, thus being 1, is omitted.
     */

    do {
	n++;
	c *= -x / n;
	term = c / (alph + n);
	sum += term;
    } while (fabs (term) > DBL_EPSILON * fabs (sum));

#ifdef DEBUG_p
    REprintf ("%5.0f terms --> conv.sum=%g;", n, sum);
#endif
    if (lower_tail) {
	double f1 = log_p ? log1p (sum) : 1 + sum;
	double f2;
	if (alph > 1) {
	    f2 = dpois_raw (alph, x, log_p);
	    f2 = log_p ? f2 + x : f2 * exp (x);
	} else if (log_p)
	    f2 = alph * log (x) - lgamma1p (alph);
	else
	    f2 = pow (x, alph) / exp (lgamma1p (alph));
#ifdef DEBUG_p
    REprintf (" (f1,f2)= (%g,%g)\n", f1,f2);
#endif
	return log_p ? f1 + f2 : f1 * f2;
    } else {
	double lf2 = alph * log (x) - lgamma1p (alph);
#ifdef DEBUG_p
	REprintf (" 1:%.14g  2:%.14g\n", alph * log (x), lgamma1p (alph));
	REprintf (" sum=%.14g  log(1+sum)=%.14g	 lf2=%.14g\n",
		  sum, log1p (sum), lf2);
#endif
	if (log_p)
	    return R_Log1_Exp (log1p (sum) + lf2);
	else {
	    double f1m1 = sum;
	    double f2m1 = expm1 (lf2);
	    return -(f1m1 + f2m1 + f1m1 * f2m1);
	}
    }
} /* pgamma_smallx() */
コード例 #4
0
ファイル: dgamma.cpp プロジェクト: MarkEdmondson1234/Boom
double dgamma(double x, double shape, double scale, int give_log)
{
#ifndef D_non_pois
    double pr;
#endif
#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(shape) || ISNAN(scale))
        return x + shape + scale;
#endif
    if (shape <= 0 || scale <= 0) ML_ERR_return_NAN;
    if (x < 0)
        return R_D__0;
    if (x == 0) {
      //        if (shape < 1) ML_ERR_return_NAN;
      if(shape < 1) return BOOM::infinity();
      if(shape > 1) return R_D__0;
      /* else */
      return give_log ? -log(scale) : 1 / scale;
    }

#ifdef D_non_pois

    x /= scale;
    return give_log ?
           ((shape - 1) * log(x) - lgammafn(shape) - x) - log(scale) :
        exp((shape - 1) * log(x) - lgammafn(shape) - x) / scale;

#else /* new dpois() based code */

    if (shape < 1) {
        pr = dpois_raw(shape, x/scale, give_log);
        return give_log ?  pr + log(shape/x) : pr*shape/x;
    }
    /* else  shape >= 1 */
    pr = dpois_raw(shape-1, x/scale, give_log);
    return give_log ? pr - log(scale) : pr/scale;
#endif
}
コード例 #5
0
ファイル: pgamma.c プロジェクト: FatManCoding/r-source
/* dpois_wrap (x_P_1,  lambda, g_log) ==
 *   dpois (x_P_1 - 1, lambda, g_log) :=  exp(-L)  L^k / gamma(k+1) ,  k := x_P_1 - 1
*/
static double
dpois_wrap (double x_plus_1, double lambda, int give_log)
{
#ifdef DEBUG_p
    REprintf (" dpois_wrap(x+1=%.14g, lambda=%.14g, log=%d)\n",
	      x_plus_1, lambda, give_log);
#endif
    if (!R_FINITE(lambda))
	return R_D__0;
    if (x_plus_1 > 1)
	return dpois_raw (x_plus_1 - 1, lambda, give_log);
    if (lambda > fabs(x_plus_1 - 1) * M_cutoff)
	return R_D_exp(-lambda - lgammafn(x_plus_1));
    else {
	double d = dpois_raw (x_plus_1, lambda, give_log);
#ifdef DEBUG_p
	REprintf ("  -> d=dpois_raw(..)=%.14g\n", d);
#endif
	return give_log
	    ? d + log (x_plus_1 / lambda)
	    : d * (x_plus_1 / lambda);
    }
}
コード例 #6
0
ファイル: dpois.c プロジェクト: ahma88/magro
double dpois(NMATH_STATE *state, double x, double lambda, int give_log)
{
    if(isnan(x) || isnan(lambda))
        return x + lambda;

    if (lambda < 0) return NAN;
    R_D_nonint_check(x);
    if (x < 0 || !isfinite(x))
	return R_D__0;

    x = R_D_forceint(x);

    return( dpois_raw(state, x,lambda,give_log) );
}
コード例 #7
0
ファイル: dpois.c プロジェクト: 6e441f9c/julia
double dpois(double x, double lambda, int give_log)
{
#ifdef IEEE_754
    if(ISNAN(x) || ISNAN(lambda))
        return x + lambda;
#endif

    if (lambda < 0) ML_ERR_return_NAN;
    R_D_nonint_check(x);
    if (x < 0 || !R_FINITE(x))
	return R_D__0;

    x = R_D_forceint(x);

    return( dpois_raw(x,lambda,give_log) );
}
コード例 #8
0
ファイル: dnbinom.c プロジェクト: Bgods/r-source
double dnbinom_mu(double x, double size, double mu, int give_log)
{
    /* originally, just set  prob :=  size / (size + mu)  and called dbinom_raw(),
     * but that suffers from cancellation when   mu << size  */

#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(size) || ISNAN(mu))
        return x + size + mu;
#endif

    if (mu < 0 || size < 0) ML_ERR_return_NAN;
    R_D_nonint_check(x);
    if (x < 0 || !R_FINITE(x)) return R_D__0;

    /* limiting case as size approaches zero is point mass at zero,
     * even if mu is kept constant. limit distribution does not
     * have mean mu, though.
     */
    if (x == 0 && size == 0) return R_D__1;
    x = R_forceint(x);
    if(!R_FINITE(size)) // limit case: Poisson
	return(dpois_raw(x, mu, give_log));

    if(x == 0)/* be accurate, both for n << mu, and n >> mu :*/
	return R_D_exp(size * (size < mu ? log(size/(size+mu)) : log1p(- mu/(size+mu))));
    if(x < 1e-10 * size) { /* don't use dbinom_raw() but MM's formula: */
	/* FIXME --- 1e-8 shows problem; rather use algdiv() from ./toms708.c */
	double p = (size < mu ? log(size/(1 + size/mu)) : log(mu / (1 + mu/size)));
	return R_D_exp(x * p - mu - lgamma(x+1) +
		       log1p(x*(x-1)/(2*size)));
    } else {
	/* no unnecessary cancellation inside dbinom_raw, when
	 * x_ = size and n_ = x+size are so close that n_ - x_ loses accuracy */
	double p = ((double)size)/(size+x),
	    ans = dbinom_raw(size, x+size, size/(size+mu), mu/(size+mu), give_log);
	return((give_log) ? log(p) + ans : p * ans);
    }
}
コード例 #9
0
ファイル: dnchisq.c プロジェクト: Bgods/r-source
double dnchisq(double x, double df, double ncp, int give_log)
{
    const static double eps = 5e-15;

    double i, ncp2, q, mid, dfmid, imax;
    LDOUBLE sum, term;

#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(df) || ISNAN(ncp))
	return x + df + ncp;
#endif

    if (!R_FINITE(df) || !R_FINITE(ncp) || ncp < 0 || df < 0)
    	ML_ERR_return_NAN;

    if(x < 0) return R_D__0;
    if(x == 0 && df < 2.)
	return ML_POSINF;
    if(ncp == 0)
	return (df > 0) ? dchisq(x, df, give_log) : R_D__0;
    if(x == ML_POSINF) return R_D__0;

    ncp2 = 0.5 * ncp;

    /* find max element of sum */
    imax = ceil((-(2+df) +sqrt((2-df) * (2-df) + 4 * ncp * x))/4);
    if (imax < 0) imax = 0;
    if(R_FINITE(imax)) {
	dfmid = df + 2 * imax;
	mid = dpois_raw(imax, ncp2, FALSE) * dchisq(x, dfmid, FALSE);
    } else /* imax = Inf */
	mid = 0;

    if(mid == 0) {
	/* underflow to 0 -- maybe numerically correct; maybe can be more accurate,
	 * particularly when  give_log = TRUE */
	/* Use  central-chisq approximation formula when appropriate;
	 * ((FIXME: the optimal cutoff also depends on (x,df);  use always here? )) */
	if(give_log || ncp > 1000.) {
	    double nl = df + ncp, ic = nl/(nl + ncp);/* = "1/(1+b)" Abramowitz & St.*/
	    return dchisq(x*ic, nl*ic, give_log);
	} else
	    return R_D__0;
    }

    sum = mid;

    /* errorbound := term * q / (1-q)  now subsumed in while() / if() below: */

    /* upper tail */
    term = mid; df = dfmid; i = imax;
    double x2 = x * ncp2;
    do {
	i++;
	q = x2 / i / df;
	df += 2;
	term *= q;
	sum += term;
    } while (q >= 1 || term * q > (1-q)*eps || term > 1e-10*sum);
    /* lower tail */
    term = mid; df = dfmid; i = imax;
    while (i != 0) {
	df -= 2;
	q = i * df / x2;
	i--;
	term *= q;
	sum += term;
	if (q < 1 && term * q <= (1-q)*eps) break;
    }
    return R_D_val((double) sum);
}