double Norma(int a, int b, int k) //log((b-a-1)choose(k-1))
{
if (a==b)
return 0;
double Res = (lgammafn(b-a)-lgammafn(k)-lgammafn(b-a-k+1));
return Res;
}
/* mathematically the same:
less stable typically, but useful if n-k+1 < 0 : */
static
double lfastchoose2(double n, double k, int *s_choose)
{
double r;
r = lgammafn_sign(n - k + 1., s_choose);
return lgammafn(n + 1.) - lgammafn(k + 1.) - r;
}
double multilik(double * prob, int * samp, int n,
int full, int debug) {
int i;
double lik;
int tot;
lik=0.0;
for (i=0; i<n; i++) {
if (!(prob[i]==0 && samp[i]==0)) {
lik -= (double)samp[i]*log(prob[i]);
if (debug==1)
Rprintf("mlik: %d %f %f %f\n",i,lik,samp[i],log(prob[i]));
}
}
if (full) {
for (i=0,tot=0; i<n; i++) {
lik += lgammafn((double)samp[i]+1.0);
tot += samp[i];
}
lik -= lgammafn((double)tot+1.0);
}
if (debug==1)
Rprintf("full mlik: %f\n",lik);
return(lik);
}
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
// Computing the Marginal pseudo-likelihood
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
void log_mpl( int *node, int mb_node[], int *size_node, double *log_mpl_node, double S[],
double S_mb_node[], int *n, int *p )
{
int size_node_fa = *size_node + 1, dim = *p, dim1 = dim + 1;
double det_S_mb_node, det_S_fa_node;
if( *size_node > 0 )
{
// S_mb_node = S[ mb_node, mb_node ]
sub_matrix_upper( &S[0], &S_mb_node[0], &mb_node[0], size_node, &dim );
if( *size_node > 1 )
determinant( &S_mb_node[0], &det_S_mb_node, size_node );
else
det_S_mb_node = S[ mb_node[0] * dim1 ];
// fa_node = c( mb_node, node )
mb_node[ *size_node ] = *node;
// S_fa_node = S[fa_node, fa_node]
sub_matrix_upper( &S[0], &S_mb_node[0], &mb_node[0], &size_node_fa, &dim );
//det_S_fa_node = det( S_fa_node )
determinant( &S_mb_node[0], &det_S_fa_node, &size_node_fa );
//*log_mpl_node = lgammafn( 0.5 * ( *n + *size_node ) ) - lgammafn( 0.5 * size_node_fa ) - ( 2 * *size_node + 1 ) * log( *n ) * 0.5 - ( *n - 1 ) * ( log( det_S_fa_node ) - log( det_S_mb_node ) ) * 0.5;
*log_mpl_node = lgammafn( 0.5 * ( *n + *size_node ) ) - lgammafn( 0.5 * size_node_fa ) -
*size_node * log( static_cast<double>( *n ) ) - ( *n - 1 ) * ( log( det_S_fa_node ) - log( det_S_mb_node ) ) * 0.5;
}else{
det_S_fa_node = S[ *node * dim1 ];
//*log_mpl_node = lgammafn( 0.5 * *n ) - lgammafn( 0.5 ) - log( *n ) * 0.5 - ( *n - 1 ) * ( log( det_S_fa_node ) ) * 0.5;
*log_mpl_node = lgammafn( 0.5 * *n ) - lgammafn( 0.5 ) - ( *n - 1 ) * ( log( det_S_fa_node ) ) * 0.5;
}
}
double compute_logConst_pairbeta (double alpha, int dim)
{
double lK = log(2) + lgammafn(dim-2) - log(dim) - log(dim-1)+
lgammafn(alpha * dim +1) -
(lgammafn(2*alpha +1) + lgammafn(alpha *(dim -2))) ;
return(lK) ;
}
double LogBinNeg::operator()(int a, int b)
{
if (a==b)
return 0;
int S = LesObs.SumInSegment(a,b);
double L = LesObs.LogFactorialInSegment(a,b);
int n = b-a;
double Res = lgammafn(beta+n*phi)+lgammafn(S+alpha)-lgammafn(alpha)-lgammafn(beta) +lgammafn(alpha+beta)-lgammafn(beta+alpha+n*phi+S)-L;
return Res;
}
double LogPoisson::operator()(int a, int b)
{
if (a==b)
return 0;
int S = LesObs.SumInSegment(a,b);
double L = LesObs.LogFactorialInSegment(a,b);
int n = b-a;
double Res = lgammafn(S+alpha)-(S+alpha)*log((double)(n)+beta)-L+alpha*log(beta)-lgammafn(alpha);
return Res;
}
static double unNorm_logPairbetaFun(double alpha, double beta_ij, double xi,
double xj, int dim)
{
double A1 = (2*alpha - 1) * log(xi +xj);
double A2 = ((dim - 2) * alpha - dim +2) * log( 1 - xi - xj );
double A3 = lgammafn(2*beta_ij) - 2*lgammafn(beta_ij);
double A4 = (beta_ij-1) * (log( xi) + log(xj) - 2*log(xi+xj) ) ;
return(A1 + A2 + A3 + A4 ) ;
}
double loghyperg1F1_laplace(double a, double b, double x)
{
double mode,mode1, mode2, lprec, prec, logy;
/* int u^(a-1) (1-u)^(b-1) exp(-x u) du assuming that x >= 0 */
prec = 0.0;
logy = 0.0;
if ( x <= 0.0) {
if (x < 0.0) {
x = -x;
logy = -lgammafn(b) - lgammafn(a) + lgammafn(a+b);
// mode = (2.0 - 2.0* a + b - x - sqrt(pow(b, 2.0) - 2.0*b*x + x*(4.0*(a-1.0)+x)))/
// (2*(a - 1.0 - b));
mode1 = .5*(-a + b + x - sqrt( 4.*a*b + pow(a - b - x, 2.0)))/a;
mode1 = 1.0/(1.0 + mode1);
mode2 = .5*(-a + b + x + sqrt( 4.*a*b + pow(a - b -x, 2.0)))/a;
mode2 = 1.0/(1.0 + mode2);
if (a*log(mode1) + b*log(1.0 - mode1) - x*mode1 >
a*log(mode2) + b*log(1.0 - mode2) - x*mode2) mode = mode1;
else mode = mode2;
// Rprintf("mode 1 %lf, mode %lf\n", mode1, mode2);
if (mode < 0) {
mode = 0.0;
warning("1F1 Laplace approximation on boundary\n");
}
else{
/* prec = a*mode*(1.0 - mode) + (1.0-mode)*(1.0 - mode)*b +
x*pow(1.0-mode, 3.0) - x*mode*(1.0 -
mode)*(1.0-mode); */
prec = (1.0-mode)*((a + b - x)*pow(mode,2) + (1.0-mode)*mode*(a + b + x));
if (prec > 0) {
lprec = log(prec);
logy += a*log(mode) + b*log(1.0 - mode) - x*mode;
logy += -0.5*lprec + M_LN_SQRT_2PI;
}
else {prec = 0.0;}
}
// Rprintf("mode %lf prec %lf, Lap 1F1(%lf, %lf, %lf) = %lf\n", mode, prec, a,b,x, logy);
}
else {logy = 0.0;}
}
else {
logy = x + loghyperg1F1_laplace(b - a, a, -x);
}
return(logy);
}
/* posterior wishart probability for the BGe score. */
SEXP wpost(SEXP x, SEXP imaginary, SEXP phi_coef) {
int i = 0, n = LENGTH(x);
double mu = 0, phi = 0, tau = 0, rho = 0;
double oldtau = 0, oldmu = 0, logk = 0, logscale = 0, mscore = 0;
double *res = NULL, *xx = REAL(x), *c = REAL(phi_coef);
int *iss = INTEGER(imaginary);
SEXP result;
/* allocate and initialize result to zero. */
PROTECT(result = allocVector(REALSXP, 1));
res = REAL(result);
*res = 0;
/* compute the mean and the variance of the data. */
for (i = 0; i < n; i++)
mu += xx[i];
mu /= n;
for (i = 0; i < n; i++)
phi += (xx[i] - mu) * (xx[i] - mu);
phi = phi / (n - 1) * (*c) ;
/* set tau and rho. */
tau = rho = *iss;
for (i = 0; i < n; i++) {
logscale = log(phi) + log1p(1.0/tau);
logk = lgammafn(0.5 * (1.0 + rho)) - lgammafn(rho * 0.5);
logk -= 0.5 * (logscale + log(M_PI));
mscore = logk - 0.5 * (rho + 1) * log1p( (xx[i] - mu) * (xx[i] - mu) / exp(logscale) );
*res += mscore;
oldtau = tau;
oldmu = mu;
tau++;
rho++;
mu = (oldtau * mu + xx[i]) / tau;
phi += (xx[i] - mu) * xx[i] + (oldmu - mu) * oldtau * oldmu;
}/*FOR*/
UNPROTECT(1);
return result;
}/*WPOST*/
double stirlerr(double n)
{
#define S0 0.083333333333333333333 /* 1/12 */
#define S1 0.00277777777777777777778 /* 1/360 */
#define S2 0.00079365079365079365079365 /* 1/1260 */
#define S3 0.000595238095238095238095238 /* 1/1680 */
#define S4 0.0008417508417508417508417508/* 1/1188 */
/*
error for 0, 0.5, 1.0, 1.5, ..., 14.5, 15.0.
*/
const double sferr_halves[31] = {
0.0, /* n=0 - wrong, place holder only */
0.1534264097200273452913848, /* 0.5 */
0.0810614667953272582196702, /* 1.0 */
0.0548141210519176538961390, /* 1.5 */
0.0413406959554092940938221, /* 2.0 */
0.03316287351993628748511048, /* 2.5 */
0.02767792568499833914878929, /* 3.0 */
0.02374616365629749597132920, /* 3.5 */
0.02079067210376509311152277, /* 4.0 */
0.01848845053267318523077934, /* 4.5 */
0.01664469118982119216319487, /* 5.0 */
0.01513497322191737887351255, /* 5.5 */
0.01387612882307074799874573, /* 6.0 */
0.01281046524292022692424986, /* 6.5 */
0.01189670994589177009505572, /* 7.0 */
0.01110455975820691732662991, /* 7.5 */
0.010411265261972096497478567, /* 8.0 */
0.009799416126158803298389475, /* 8.5 */
0.009255462182712732917728637, /* 9.0 */
0.008768700134139385462952823, /* 9.5 */
0.008330563433362871256469318, /* 10.0 */
0.007934114564314020547248100, /* 10.5 */
0.007573675487951840794972024, /* 11.0 */
0.007244554301320383179543912, /* 11.5 */
0.006942840107209529865664152, /* 12.0 */
0.006665247032707682442354394, /* 12.5 */
0.006408994188004207068439631, /* 13.0 */
0.006171712263039457647532867, /* 13.5 */
0.005951370112758847735624416, /* 14.0 */
0.005746216513010115682023589, /* 14.5 */
0.005554733551962801371038690 /* 15.0 */
};
double nn;
if (n <= 15.0) {
nn = n + n;
if (nn == (int)nn) return(sferr_halves[(int)nn]);
return(lgammafn(n + 1.) - (n + 0.5)*log(n) + n - M_LN_SQRT_2PI);
}
nn = n*n;
if (n>500) return((S0-S1/nn)/n);
if (n> 80) return((S0-(S1-S2/nn)/nn)/n);
if (n> 35) return((S0-(S1-(S2-S3/nn)/nn)/nn)/n);
/* 15 < n <= 35 : */
return((S0-(S1-(S2-(S3-S4/nn)/nn)/nn)/nn)/n);
}
double lmultiProb (int * k, double * lp, int m) {
double x = 0;
for (int i = 0; i < m; i++) {
x += k[i] * lp[i] - lgammafn(1. + k[i]);
}
return x;
}
void rnb(double* mu, double* r, double* x, int* ny, double* y, double* ex, int* acceptr, double* rvar, double* a, double* b, double* r_r)
{
int i;
double u;
double rnew;
double temp;
double lr;
/*a,b: Parameter of Gamma(a,b)-Prior of r*/
GetRNGstate();
u=runif(0,1);
PutRNGstate();
/*Proposal forr r: truncated normal*/
rnew = rnorm(*r,*rvar);
while (rnew < 0){ /*| rnew > 100){*/
rnew = rnorm(*r,*rvar);
}
/*Calculation of acceptance probability*/
temp=0;
for (i=0; i < *ny; i++){
temp+=((lgammafn(y[i]+rnew)+lgammafn(*r))-(lgammafn(y[i]+ *r)+lgammafn(rnew))+rnew*log(rnew/(mu[i]+rnew))-(*r)*log(*r/(mu[i]+*r))+y[i]*log((mu[i]+*r)/(mu[i]+rnew)));
}
/*Prior for r*/
temp = temp + (*a-1)*log((rnew)/(*r)) - *b * ((rnew)-(*r));
/*Proposal Ratio for gamma proposal for r*/
/*temp=temp+((*r)-(rnew))/ *rvar*(log(*rvar)-1)+log(gammafn((*r)/ *rvar)/gammafn((rnew)/ *rvar))-((*r)/ *rvar-1)*log((rnew))+((rnew)/ *rvar-1)*log((*r));*/
lr = (temp<0)*temp;
if ((log(u) < lr) | (lr >= 0)){
*r = rnew;
*acceptr = *acceptr+1;
} else {
*r = *r;
}
r_r[0] = *r;
r_r[1] = *acceptr;
}
// FIXME: Use a .Call() and then vectorize in both main args (p, nu)
void qchisq_appr_v(double *P, int *n, double *nu, double *tol,
logical *lower_tail, logical *log_p,
/* result: */ double *q)
{
double g = lgammafn(0.5* *nu);
for(int i = 0; i < *n; i++)
q[i] = qchisq_appr(P[i], *nu, g, *lower_tail, *log_p, *tol);
return;
}
double KL_Dirichlets(double *w, const double *v, int K) { // second one happens to be prior in VB application; thus const. Don't really understand how to use const.
/* Kullback-Leibler divergence between two Dirichlets with parameters w_1,...,w_K and v_1,...,v_K
Rezek & Roberts et al. variational Bayes HMM book chapter
http://www.robots.ox.ac.uk/~irezek/Outgoing/Papers/varhmm.ps.gz */
double d=0.0, sumw=0.0, sumv=0.0 ;
int k ;
for(k = 0 ; k < K ; ++k, ++w, ++v) {
sumw += *w ;
sumv += *v ;
d += lgammafn(*v) - lgammafn(*w) + (*w - *v) * DIGAMMA(*w) ;
}
d += lgammafn(sumw) - lgammafn(sumv) - (sumw - sumv) * DIGAMMA(sumw) ;
return d ;
}
double *compute_ddirimix(double *mu, double *nu, double *x,
double *w, int dim, int nmu, int nx,
int take_logs)
/* Returns the densities themselves (not the log) as a vector*/
{
double *density = calloc(nx+1, sizeof(double));
if (!density) return NULL;
int m, i, j, ix;
double log_const, log_dens;
int isOnSimplex;
double oneOut = 0;
for (m = 0; m < nmu; m++)
{
log_const = lgammafn(nu[m]);
for (i = dim * m; i < dim * (m + 1); i++)
log_const -= lgammafn(mu[i] * nu[m]);
for (ix = 0; ix < nx; ix++)
{
isOnSimplex = is_on_simplex(x + ix * dim, dim) ;
if( ! isOnSimplex)
{
density[ix]= take_logs ? ZERO_BMAMEVT : 0 ;
oneOut = 1;
}
else
{
log_dens = 0;
for (j = 0; j < dim; j++)
{
log_dens +=
(mu[j + dim * m] * nu[m] - 1) * log(x[j + ix * dim]);
}
density[ix] += w[m] * exp(log_const + log_dens);
}
}
}
density[nx] = oneOut;
return density;
}
double LogGaussienne::operator()(int a, int b)
{
if (a==b)
return 0;
double M = LesObs.MeanInSegment(a,b);
double V = LesObs.VarInSegment(a,b);
int n = b-a;
double theta = 2/(n*V+s0+n*n0*(M-mu0)*(M-mu0)/(n+n0));
double Res = lgammafn((n+nu0)/2)+(log(n0)-log(n+n0))/2+(n+nu0)/2*log(theta)+nu0/2*log(s0/2)-lgammafn(nu0/2)-n/2*log(2*M_PI);
return Res;
}
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) ));
}
void comp_adjfactor
(double cut_dpoi[1], int no_qf[1], int no_lmd[1],
double qf[], double lmd[], double adjfactor[1] )
{
double dpoi_low, dpoi_up, adjfactor_lmd[no_lmd[0]], lambda,
sum_dpois [no_qf[0]]; // sumalldpoi;
int m, l, l_low, l_up, L_md, L_low, L_up, L_max;
L_max = no_qf[0] - 1;
for(l = 0; l <= L_max; l++) sum_dpois [l] = 0;
for(m = 0; m < no_lmd[0]; m ++)
{
lambda = lmd[m];
//determine lower and upper starting l
L_md = floor (lambda);
L_low = imin2 (L_md, L_max);
L_up = L_low + 1;
dpoi_low = exp (-lambda+ L_low * log(lambda)- lgammafn (L_low + 1) );
dpoi_up = dpoi_low * lambda / L_up;
// summing poisson weight in lower tail
for (l_low = L_low; l_low >= 0; l_low --)
{
if (dpoi_low > cut_dpoi[0])
{
sum_dpois[l_low] += dpoi_low;
dpoi_low /= lambda/l_low;
}
else break;
}
if (L_up > L_max) continue;
// summing poisson weight in upper tail
for (l_up = L_up; l_up <= L_max; l_up ++)
{
if (dpoi_up > cut_dpoi[0])
{
sum_dpois[l_up] += dpoi_up;
dpoi_up *= lambda/(l_up+1);
}
else break;
}
}
adjfactor [0] = 0;
// sumalldpoi = 0;
for(l = 0; l <= L_max; l++) {
adjfactor [0] += qf [l] * sum_dpois[l];
// sumalldpoi += sum_dpois [l];
}
adjfactor [0] /= no_lmd[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) ));
}
double ddirimix_point(double *mu, double *nu, double *x,
double *w, int dim, int nmu,
int take_logs)
/* Returns the density itself (not the log) */
{
double density=0;
int m, i, j ;
double log_const, log_dens;
int isOnSimplex;
isOnSimplex = is_on_simplex(x, dim) ;
if( ! isOnSimplex)
{
density = take_logs ? ZERO_BMAMEVT : 0 ;
return density ;
}
for (m = 0; m < nmu; m++)
{
log_const = lgammafn(nu[m]);
for (i = dim * m; i < dim * (m + 1); i++)
log_const -= lgammafn(mu[i] * nu[m]);
/*
for (ix = 0; ix < nx; ix++)
{*/
log_dens = 0;
for (j = 0; j < dim; j++)
{
log_dens +=
(mu[j + dim * m] * nu[m] - 1) * log(x[j]);
}
density += w[m] * exp(log_const + log_dens);
}
/*}*/
return density;
}
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
}
double gammaHyperObjectiveFn(int n, double * par, void * ex) {
const double s(par[0]);
if (s <= 0.0)
return INFINITY;
double * input = static_cast<double *>(ex);
const double sum_log_x(input[0]);
const double sum_x(input[1]);
const double P(input[2]);
const double l_s(input[3]);
const double l_l(input[4]);
double out = s * (-l_s + sum_log_x) - P * lgammafn(s) - P * s +
P * s * log(P * s / (l_l + sum_x));
return(- out);
}
double robust_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept, int Laplace ) {
double n, p, logmarglik;
n = REAL(getListElement(hyperparams, "n"))[0];
p = (double) pmodel;
logmarglik = loglik_mle + M_LN_SQRT_2PI - 0.5* logdet_Iintercept;
if (p >= 1.0) {
logmarglik += -log(2.0) + 0.5 *(log(n + 1.0) - log(p + 1.0))
+ lgammafn((p+1.0)/2.0)
- .5*(p + 1.0)*log(W/2.0) +
pgamma((p + 1.0)/(n + 1.0), 0.5*(p+1.0), 2.0/W, 1, 1);
}
return(logmarglik);
}
double TG_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept, int Laplace ) {
double a,p, logmarglik;
a = REAL(getListElement(hyperparams, "alpha"))[0];
p = (double) pmodel;
logmarglik = loglik_mle + M_LN_SQRT_2PI - 0.5* logdet_Iintercept;
if (pmodel >= 1.0) {
logmarglik += -log(2.0) + log(a)
+ lgammafn((a + p)/2.0)
- .5*(a + p)*log(W/2.0)
+ pgamma(1.0, .5*(a + p), 2.0/W, 1, 1);
}
return(logmarglik);
}
double lbeta(double a, double b)
{
double corr, p, q;
#ifdef IEEE_754
if(ISNAN(a) || ISNAN(b))
return a + b;
#endif
p = q = a;
if(b < p) p = b;/* := min(a,b) */
if(b > q) q = b;/* := max(a,b) */
/* both arguments must be >= 0 */
if (p < 0)
ML_ERR_return_NAN
else if (p == 0) {
return ML_POSINF;
}
else if (!R_FINITE(q)) { /* q == +Inf */
return ML_NEGINF;
}
if (p >= 10) {
/* p and q are big. */
corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q);
return log(q) * -0.5 + M_LN_SQRT_2PI + corr
+ (p - 0.5) * log(p / (p + q)) + q * log1p(-p / (p + q));
}
else if (q >= 10) {
/* p is small, but q is big. */
corr = lgammacor(q) - lgammacor(p + q);
return lgammafn(p) + corr + p - p * log(p + q)
+ (q - 0.5) * log1p(-p / (p + q));
}
else {
/* p and q are small: p <= q < 10. */
/* R change for very small args */
if (p < 1e-306) return lgamma(p) + (lgamma(q) - lgamma(p+q));
else return log(gammafn(p) * (gammafn(q) / gammafn(p + q)));
}
}
double lbeta(NMATH_STATE *state, double a, double b)
{
double corr, p, q;
p = q = a;
if(b < p) p = b;/* := min(a,b) */
if(b > q) q = b;/* := max(a,b) */
#ifdef IEEE_754
if(ISNAN(a) || ISNAN(b))
return a + b;
#endif
/* both arguments must be >= 0 */
if (p < 0) return NAN;
else if (p == 0) {
return POSINF;
}
else if (!isfinite(q)) {
return NEGINF;
}
if (p >= 10) {
/* p and q are big. */
corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q);
return log(q) * -0.5 + M_LN_SQRT_2PI + corr
+ (p - 0.5) * log(p / (p + q)) + q * log1p(-p / (p + q));
}
else if (q >= 10) {
/* p is small, but q is big. */
corr = lgammacor(q) - lgammacor(p + q);
return lgammafn(state, p) + corr + p - p * log(p + q)
+ (q - 0.5) * log1p(-p / (p + q));
}
else
/* p and q are small: p <= q < 10. */
return log(gammafn(state, p) * (gammafn(state, q) / gammafn(state, p + q)));
}
/* 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);
}
}
void F77_CALL(flgamma)(double *x,double *y){
*y=lgammafn(*x);}
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);
}
