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); }
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); }