double logspace_add_safe(double log_x, double log_y) { // An interface to R's C function logspace_add // Computes log(exp(log_x) + exp(log_y)) if(log_x == -INFINITY && log_y == -INFINITY) { return(-INFINITY); } else { return(logspace_add(log_x, log_y)); } }
double logspace_sum (double* logx, int n) { if(n == 0) return ML_NEGINF; // = log( sum(<empty>) ) if(n == 1) return logx[0]; if(n == 2) return logspace_add(logx[0], logx[1]); // else (n >= 3) : int i; // Mx := max_i log(x_i) double Mx = logx[0]; for(i = 1; i < n; i++) if(Mx < logx[i]) Mx = logx[i]; LDOUBLE s = (LDOUBLE) 0.; for(i = 0; i < n; i++) s += EXP(logx[i] - Mx); return Mx + (double) LOG(s); }
SEXP logspace_sum_matrix_rows_C(SEXP Xp, SEXP N_rowp, SEXP N_colp) { int i, j, n_row = *INTEGER(N_rowp), n_col = *INTEGER(N_colp); SEXP retval = PROTECT(allocVector(REALSXP, n_row)); double *dblptr = REAL(retval), *X = REAL(Xp); for(i = 0; i < n_row; i++) { *(dblptr + i) = *(X + i); } for(j = 1; j < n_col; j++) { for(i = 0; i < n_row; i++) { if(!(*(dblptr + i) == R_NegInf && *(X + i + j*n_row) == R_NegInf)) *(dblptr + i) = logspace_add(*(dblptr + i), *(X + i + j*n_row)); } } UNPROTECT(1); return retval; }
SEXP logspace_add_C(SEXP log_x, SEXP log_y) { // An interface to R's C function logspace_add // Computes log(exp(log_x) + exp(log_y)) SEXP retval; retval = PROTECT(allocVector(REALSXP, 1)); double lx = *(REAL(log_x)), ly = *(REAL(log_y)); if(lx == R_NegInf && ly == R_NegInf) { // Rprintf("Both = -Infty\n"); *(REAL(retval)) = R_NegInf; } else { *(REAL(retval)) = logspace_add(lx, ly); } UNPROTECT(1); return retval; }
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); }