double pf(double x, double df1, double df2, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df1) || ISNAN(df2))
return x + df2 + df1;
#endif
if (df1 <= 0. || df2 <= 0.) ML_ERR_return_NAN;
R_P_bounds_01(x, 0., ML_POSINF);
/* move to pchisq for very large values - was 'df1 > 4e5' in 2.0.x,
now only needed for df1 = Inf or df2 = Inf {since pbeta(0,*)=0} : */
if (df2 == ML_POSINF) {
if (df1 == ML_POSINF) {
if(x < 1.) return R_DT_0;
if(x == 1.) return (log_p ? -M_LN2 : 0.5);
if(x > 1.) return R_DT_1;
}
return pchisq(x * df1, df1, lower_tail, log_p);
}
if (df1 == ML_POSINF)/* was "fudge" 'df1 > 4e5' in 2.0.x */
return pchisq(df2 / x , df2, !lower_tail, log_p);
/* Avoid squeezing pbeta's first parameter against 1 : */
if (df1 * x > df2)
x = pbeta(df2 / (df2 + df1 * x), df2 / 2., df1 / 2.,
!lower_tail, log_p);
else
x = pbeta(df1 * x / (df2 + df1 * x), df1 / 2., df2 / 2.,
lower_tail, log_p);
return ML_VALID(x) ? x : ML_NAN;
}
double levinvparalogis(double limit, double shape, double scale, double order,
int give_log)
{
double u, tmp1, tmp2, tmp3;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape * shape)
return R_PosInf;
tmp1 = order / shape;
tmp2 = shape + tmp1;
tmp3 = 1.0 - tmp1;
u = exp(-log1pexp(shape * (log(scale) - log(limit))));
return R_pow(scale, order) * gammafn(tmp2) * gammafn(tmp3)
* pbeta(u, tmp2, tmp3, 1, 0) / gammafn(shape)
+ ACT_DLIM__0(limit, order) * (0.5 - R_pow(u, shape) + 0.5);
}
void bigI_nu(unsigned ndim, const double *x, void *fdata, unsigned fdim, double *fval)
{
double nu = *((double *) fdata);
double xmax;
xmax=nu/(nu+(*x)*(*x));
fval[0]=pbeta(xmax,nu/2,0.5,1,0);
}
double inverseF(int df1, int df2, double alfa){
double prob=0.0, minF=0.0, maxF=100.0, halfway=50.0, absdiff=1.0;
int count=0;
while ((absdiff>0.001)&&(count<100)){
count++;
halfway= (maxF+minF)/2.0;
prob = pbeta(df2/(df2+df1*halfway), df2/2.0, df1/2.0, 1, 0);
if (prob<alfa) maxF= halfway;
else minF= halfway;
absdiff= fabs(prob-alfa);
}
return halfway;
}
double inverseF(int df1, int df2, double alfa, int verbose) {
double prob=0.0, minF=0.0, maxF=100.0, halfway=50.0, absdiff=1.0;
int count=0;
while ((absdiff>0.001)&&(count<100)) {
debug_trace("INFO df1:%d df2:%d alpha:%f\n", df1, df2, alfa);
count++;
halfway= (maxF+minF)/2.0;
prob = pbeta(df2/(df2+df1*halfway), df2/2.0, df1/2.0, 1, 0);
debug_trace("(%f, %f, %f) prob=%f\n", df2/(df2+df1*halfway), df2/2.0, df1/2.0, prob);
if (prob<alfa) maxF= halfway;
else minF= halfway;
absdiff= fabs(prob-alfa);
}
if(verbose) Rprintf("INFO: Prob=%.3f Alfa=%f\n", prob, alfa);
return halfway;
}
double pbinom(double x, double n, double p, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n) || ISNAN(p))
return x + n + p;
if (!R_FINITE(n) || !R_FINITE(p)) ML_ERR_return_NAN;
#endif
if(R_D_nonint(n)) ML_ERR_return_NAN;
n = R_D_forceint(n);
if(n <= 0 || p < 0 || p > 1) ML_ERR_return_NAN;
x = floor(x + 1e-7);
if (x < 0.0) return R_DT_0;
if (n <= x) return R_DT_1;
return pbeta(p, x + 1, n - x, !lower_tail, log_p);
}
double pnbinom(double x, double size, double prob, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(size) || ISNAN(prob))
return x + size + prob;
if(!R_FINITE(size) || !R_FINITE(prob)) ML_ERR_return_NAN;
#endif
if (size < 0 || prob <= 0 || prob > 1) ML_ERR_return_NAN;
/* limiting case: point mass at zero */
if (size == 0)
return (x >= 0) ? R_DT_1 : R_DT_0;
if (x < 0) return R_DT_0;
if (!R_FINITE(x)) return R_DT_1;
x = floor(x + 1e-7);
return pbeta(prob, size, x + 1, lower_tail, log_p);
}
//**********************************************************************************************************************
vector<string> ChimeraPerseusCommand::setParameters(){
try {
CommandParameter pfasta("fasta", "InputTypes", "", "", "none", "none", "none",false,true); parameters.push_back(pfasta);
CommandParameter pname("name", "InputTypes", "", "", "none", "none", "none",false,true); parameters.push_back(pname);
CommandParameter pgroup("group", "InputTypes", "", "", "none", "none", "none",false,false); parameters.push_back(pgroup);
CommandParameter pprocessors("processors", "Number", "", "1", "", "", "",false,false); parameters.push_back(pprocessors);
CommandParameter pinputdir("inputdir", "String", "", "", "", "", "",false,false); parameters.push_back(pinputdir);
CommandParameter poutputdir("outputdir", "String", "", "", "", "", "",false,false); parameters.push_back(poutputdir);
CommandParameter pcutoff("cutoff", "Number", "", "0.5", "", "", "",false,false); parameters.push_back(pcutoff);
CommandParameter palpha("alpha", "Number", "", "-5.54", "", "", "",false,false); parameters.push_back(palpha);
CommandParameter pbeta("beta", "Number", "", "0.33", "", "", "",false,false); parameters.push_back(pbeta);
vector<string> myArray;
for (int i = 0; i < parameters.size(); i++) { myArray.push_back(parameters[i].name); }
return myArray;
}
catch(exception& e) {
m->errorOut(e, "ChimeraPerseusCommand", "setParameters");
exit(1);
}
}
double pbinom(double x, double n, double p, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n) || ISNAN(p))
return x + n + p;
if (!R_FINITE(n) || !R_FINITE(p)) ML_ERR_return_NAN;
#endif
if(R_nonint(n)) {
MATHLIB_WARNING(_("non-integer n = %f"), n);
ML_ERR_return_NAN;
}
n = R_forceint(n);
/* PR#8560: n=0 is a valid value */
if(n < 0 || p < 0 || p > 1) ML_ERR_return_NAN;
if (x < 0) return R_DT_0;
x = floor(x + 1e-7);
if (n <= x) return R_DT_1;
return pbeta(p, x + 1, n - x, !lower_tail, log_p);
}
double pt(double x, double n, int lower_tail, int log_p)
{
/* return P[ T <= x ] where
* T ~ t_{n} (t distrib. with n degrees of freedom).
* --> ./pnt.c for NON-central
*/
double val;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n))
return x + n;
#endif
if (n <= 0.0) ML_ERR_return_NAN;
if(!R_FINITE(x))
return (x < 0) ? R_DT_0 : R_DT_1;
if(!R_FINITE(n))
return pnorm(x, 0.0, 1.0, lower_tail, log_p);
if (n > 4e5) { /*-- Fixme(?): test should depend on `n' AND `x' ! */
/* Approx. from Abramowitz & Stegun 26.7.8 (p.949) */
val = 1./(4.*n);
return pnorm(x*(1. - val)/sqrt(1. + x*x*2.*val), 0.0, 1.0,
lower_tail, log_p);
}
val = pbeta(n / (n + x * x), n / 2.0, 0.5, /*lower_tail*/1, log_p);
/* Use "1 - v" if lower_tail and x > 0 (but not both):*/
if(x <= 0.)
lower_tail = !lower_tail;
if(log_p) {
if(lower_tail) return log1p(-0.5*exp(val));
else return val - M_LN2; /* = log(.5* pbeta(....)) */
}
else {
val /= 2.;
return R_D_Cval(val);
}
}
double pf(double x, double n1, double n2, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n1) || ISNAN(n2))
return x + n2 + n1;
#endif
if (n1 <= 0. || n2 <= 0.) ML_ERR_return_NAN;
if (x <= 0.)
return R_DT_0;
/* fudge the extreme DF cases -- pbeta doesn't do this well */
if (n2 > 4e5)
return pchisq(x * n1, n1, lower_tail, log_p);
if (n1 > 4e5)
return pchisq(n2 / x , n2, !lower_tail, log_p);
x = pbeta(n2 / (n2 + n1 * x), n2 / 2.0, n1 / 2.0,
!lower_tail, log_p);
return ML_VALID(x) ? x : numeric_limits<double>::quiet_NaN();
}
double F77_SUB(cdfbetas)(double *x, double *a, double *b, int *lower_tail, int *give_log)
{
return pbeta(*x, *a, *b, *lower_tail, *give_log);
}
/*
Given prob, x, a and b, this function returns the corresponding
noncentrality parameter of the noncentral beta distribution.
I.e. the following equation
I_x(a, b, lambda) = prob
is solved for lambda with Newton iteration.
This function works just fine when supplied with meaningful input
data (and from practically meaningful range) but may easily crash
if not. Please be nice.
*/
double ncbeta(double prob, double x, double a, double b) {
double ql;
double qu;
double c;
double d;
double p;
double lambda;
double lambda_new;
double k;
double f;
double g;
double mu;
double eps;
double eps2;
int itr_cnt;
lambda_new = guess(prob, x, 2.0*a, 2.0*b);
/* FIXME: are these tolerances OK ? */
eps = 1.0e-7;
eps2 = 1.0e-6;
itr_cnt = 0;
do {
lambda = lambda_new;
mu = lambda/2.0;
ql = qpois(eps, mu, 1, 0);
qu = qpois(eps, mu, 0, 0);
k = qu;
c = pbeta(x, a+k, b, 1, 0);
d = x*(1.0-x)/(a+k-1.0)*dbeta(x, a+k-1, b, 0);
p = dpois(k, mu, 0);
f=p*c;
p = k/mu*p;
g = p*d;
for (k = qu-1; k >= ql; --k) {
c=c+d;
d=(a+k)/(x*(a+k+b-1))*d;
f=f+p*c;
p=k/mu*p;
g=g+p*d;
}
/* Newton step */
lambda_new = lambda+2.0*(f-prob)/g;
++itr_cnt;
}
while ((fabs(lambda_new-lambda) > eps2*lambda_new)&&(itr_cnt<=10));
/* FIXME: how this error is handled properly in R ? */
if (itr_cnt == 11) {
fprintf( stderr, "Newton iteration failed in ncbeta()!\n");
exit(127);
}
return lambda_new;
}
void data::runPermutationExtended(string fout, vector < int > nPermutations) {
//0. Prepare genotypes
vector < double > genotype_sd = vector < double > (genotype_count, 0.0);
vector < double > phenotype_sd = vector < double > (phenotype_count, 0.0);
if (covariate_count > 0) {
LOG.println("\nCorrecting genotypes for covariates");
covariate_engine->residualize(genotype_orig);
}
for (int g = 0 ; g < genotype_count ; g ++) genotype_sd[g] = RunningStat(genotype_orig[g]).StandardDeviation();
normalize(genotype_orig);
//1. Loop over phenotypes
ofile fdo (fout);
for (int p = 0 ; p < phenotype_count ; p ++) {
LOG.println("\nProcessing gene [" + phenotype_id[p] + "]");
//1.1. Enumerate all genotype-phenotype pairs within cis-window
vector < int > targetGenotypes, targetDistances;
for (int g = 0 ; g < genotype_count ; g ++) {
int cisdistance;
int startdistance = genotype_pos[g] - phenotype_start[p];
int enddistance = genotype_end[g] - phenotype_start[p];
// for INVs ignore the span and define the cisdistance
// as the distance from the breakpoints to the phenotype_start
if (genotype_vartype[g].compare("INV") == 0) {
if (abs(startdistance) <= abs(enddistance))
cisdistance = startdistance;
else
cisdistance = enddistance;
}
// for the variants with span (DEL, DUP, MEI), cisdistance is zero
// if the phenotype_start falls within the span, and the distance to
// the closest edge otherwise
// BNDs get processed here as well, but their END coordinate is the
// same as the START coordinate.
else {
if (startdistance < 0 && enddistance > 0) { // if gene is within SV, then cis distance is 0
cisdistance = 0;
}
else if (startdistance >= 0)
cisdistance = startdistance;
else
cisdistance = enddistance;
}
if (abs(cisdistance) <= cis_window) {
targetGenotypes.push_back(g);
targetDistances.push_back(cisdistance);
}
}
LOG.println(" * Number of variants in cis = " + sutils::int2str(targetGenotypes.size()));
//1.2. Copy original data
vector < float > phenotype_curr = phenotype_orig[p];
if (covariate_count > 0) covariate_engine->residualize(phenotype_curr);
phenotype_sd[p] = RunningStat(phenotype_curr).StandardDeviation();
normalize(phenotype_curr);
//1.3. Nominal pass: scan cis-window & compute statistics
double bestCorr = 0.0;
vector < double > targetCorrelations;
int bestDistance = ___LI___, bestIndex = -1;
for (int g = 0 ; g < targetGenotypes.size() ; g ++) {
double corr = getCorrelation(genotype_orig[targetGenotypes[g]], phenotype_curr);
targetCorrelations.push_back(corr);
if (abs(targetCorrelations[g]) > abs(bestCorr) || (abs(targetCorrelations[g]) == abs(bestCorr) && abs(targetDistances[g]) < bestDistance)) {
bestCorr = targetCorrelations[g];
bestDistance = targetDistances[g];
bestIndex = targetGenotypes[g];
}
}
if (targetGenotypes.size() > 0) LOG.println(" * Best correlation = " + sutils::double2str(bestCorr, 4));
//1.4. Permutation pass:
bool done = false;
int countPermutations = 0, nBetterCorrelation = 0;
vector < double > permCorr;
do {
double bestCperm = 0.0;
phenotype_curr = phenotype_orig[p];
random_shuffle(phenotype_curr.begin(), phenotype_curr.end());
if (covariate_count > 0) covariate_engine->residualize(phenotype_curr);
normalize(phenotype_curr);
for (int g = 0 ; g < targetGenotypes.size() ; g ++) {
double corr = getCorrelation(genotype_orig[targetGenotypes[g]], phenotype_curr);
if (abs(corr) > abs(bestCperm)) bestCperm = corr;
}
if (abs(bestCperm) >= abs(bestCorr)) nBetterCorrelation++;
permCorr.push_back(bestCperm);
countPermutations++;
if (nPermutations.size() == 1 && countPermutations >= nPermutations[0]) done = true;
if (nPermutations.size() == 2 && (nBetterCorrelation >= nPermutations[0] || countPermutations >= nPermutations[1])) done = true;
if (nPermutations.size() == 3 && (countPermutations >= nPermutations[0]) && (nBetterCorrelation >= nPermutations[1] || countPermutations >= nPermutations[2])) done = true;
} while (!done);
if (targetGenotypes.size() > 0) LOG.println(" * Number of permutations = " + sutils::int2str(nBetterCorrelation) + " / " + sutils::int2str(countPermutations));
//1.5. Calculate effective DFs & Beta distribution parameters
vector < double > permPvalues;
double true_df = sample_count - 2 - ((covariate_count>0)?covariate_engine->nCovariates():0);
double mean = 0.0, variance = 0.0, beta_shape1 = 1.0, beta_shape2 = 1.0;
if (targetGenotypes.size() > 0) {
//Estimate number of degrees of freedom
if (putils::variance(permCorr, putils::mean(permCorr)) != 0.0) {
learnDF(permCorr, true_df);
//LOG.println(" * Effective degree of freedom = " + sutils::double2str(true_df, 4));
}
//Compute mean and variance of p-values
for (int c = 0 ; c < permCorr.size() ; c ++) permPvalues.push_back(getPvalue(permCorr[c], true_df));
for (int pv = 0 ; pv < permPvalues.size() ; pv++) mean += permPvalues[pv];
mean /= permPvalues.size();
for (int pv = 0 ; pv < permPvalues.size() ; pv++) variance += (permPvalues[pv] - mean) * (permPvalues[pv] - mean);
variance /= (permPvalues.size() - 1);
//Estimate shape1 & shape2
if (targetGenotypes.size() > 1 && mean != 1.0) {
beta_shape1 = mean * (mean * (1 - mean ) / variance - 1);
beta_shape2 = beta_shape1 * (1 / mean - 1);
if (targetGenotypes.size() > 10) mleBeta(permPvalues, beta_shape1, beta_shape2); //ML estimate if more than 10 variant in cis
}
LOG.println(" * Beta distribution parameters = " + sutils::double2str(beta_shape1, 4) + " " + sutils::double2str(beta_shape2, 4));
}
//1.6. Writing results
if (targetGenotypes.size() > 0 && bestIndex >= 0) {
for (int g = 0 ; g < targetGenotypes.size() ; g ++) {
fdo << phenotype_id[p] << " " << targetGenotypes.size();
fdo << " " << beta_shape1 << " " << beta_shape2 << " " << true_df;
double pval_fdo = getPvalue(targetCorrelations[g], true_df);
double pval_nom = getPvalue(targetCorrelations[g], sample_count - 2 - ((covariate_count>0)?covariate_engine->nCovariates():0));
double pval_slope = getSlope(targetCorrelations[g], phenotype_sd[p], genotype_sd[bestIndex]);
fdo << " " << genotype_id[targetGenotypes[g]];
fdo << " " << targetDistances[g];
fdo << " " << pval_nom;
fdo << " " << pval_slope;
fdo << " " << (nBetterCorrelation + 1) * 1.0 / (countPermutations + 1.0);
fdo << " " << pbeta(pval_fdo, beta_shape1, beta_shape2, 1, 0);
fdo << endl;
}
}
else fdo << phenotype_id[p] << " NA NA NA NA NA NA NA NA NA" << endl;
LOG.println(" * Progress = " + sutils::double2str((p+1) * 100.0 / phenotype_count, 1) + "%");
}
fdo.close();
}
double pnt(double t, double df, double delta, int lower_tail, int log_p)
{
double a, albeta, b, del, errbd, geven, godd,
lambda, p, q, rxb, s, tnc, tt, x, xeven, xodd;
int it, negdel;
/* note - itrmax and errmax may be changed to suit one's needs. */
const int itrmax = 1000;
const double errmax = 1.e-12;
if (df <= 0.) ML_ERR_return_NAN;
if(!R_FINITE(t))
return (t < 0) ? R_DT_0 : R_DT_1;
if (t >= 0.) {
negdel = false; tt = t; del = delta;
}
else {
negdel = true; tt = -t; del = -delta;
}
if (df > 4e5 || del*del > 2*M_LN2*(-(numeric_limits<double>::min_exponent))) {
/*-- 2nd part: if del > 37.62, then p=0 below
FIXME: test should depend on `df', `tt' AND `del' ! */
/* Approx. from Abramowitz & Stegun 26.7.10 (p.949) */
s = 1./(4.*df);
return pnorm(tt*(1. - s), del, sqrt(1. + tt*tt*2.*s),
lower_tail != negdel, log_p);
}
/* initialize twin series */
/* Guenther, J. (1978). Statist. Computn. Simuln. vol.6, 199. */
x = t * t;
x = x / (x + df);/* in [0,1) */
if (x > 0.) {/* <==> t != 0 */
lambda = del * del;
p = .5 * exp(-.5 * lambda);
if(p == 0.) { /* underflow! */
/*========== really use an other algorithm for this case !!! */
ML_ERROR(ME_UNDERFLOW);
report_error("|delta| too large."); /* |delta| too large */
}
q = M_SQRT_2dPI * p * del;
s = .5 - p;
a = .5;
b = .5 * df;
rxb = pow(1. - x, b);
albeta = M_LN_SQRT_PI + lgammafn(b) - lgammafn(.5 + b);
xodd = pbeta(x, a, b, /*lower*/true, /*log_p*/false);
godd = 2. * rxb * exp(a * log(x) - albeta);
xeven = 1. - rxb;
geven = b * x * rxb;
tnc = p * xodd + q * xeven;
/* repeat until convergence or iteration limit */
for(it = 1; it <= itrmax; it++) {
a += 1.;
xodd -= godd;
xeven -= geven;
godd *= x * (a + b - 1.) / a;
geven *= x * (a + b - .5) / (a + .5);
p *= lambda / (2 * it);
q *= lambda / (2 * it + 1);
tnc += p * xodd + q * xeven;
s -= p;
if(s <= 0.) { /* happens e.g. for (t,df,delta)=(40,10,38.5), after 799 it.*/
ML_ERROR(ME_PRECISION);
goto finis;
}
errbd = 2. * s * (xodd - godd);
if(errbd < errmax) goto finis;/*convergence*/
}
/* non-convergence:*/
ML_ERROR(ME_PRECISION);
}
else { /* x = t = 0 */
tnc = 0.;
}
finis:
tnc += pnorm(- del, 0., 1., /*lower*/true, /*log_p*/false);
lower_tail = lower_tail != negdel; /* xor */
return R_DT_val(tnc);
}
template <typename float_t> float_t pf(float_t x, float_t num, float_t den)
{
return 1 - pbeta(num/(den + num*x), den/2, num/2);
}
//function to calculate l[P'(D|M)] for a given distribution of bases
double lPDM_mod_fn(int *z, int ind, double pstar)
{
/*'z' is a pointer to a vector of length 5, where the
first 4 elements correspond to each base (with the consensus
as the fourth element z[3]). The final element is
S-z[3]=sum(z[0:2])
'ind' denotes which model (from 0:9) is to be calculated
'pstar' is the overall mutation rate*/
double lPDM = 0.0;
/* switch(ind)*/
/* {*/
/* //Null p1=p2=p3=p3*/
/* case 0 :lPDM=z[4]*log(pstar/3.0)+z[3]*log(1.0-pstar);*/
/* break;*/
/* //Alt that one free pi is different: e.g. p1!=p2=p3 etc. but mutation rate constrained to p**/
/* case 1 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[0])+lfactorial(z[1]+z[2])-lfactorial(z[4]+1)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* case 2 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[1])+lfactorial(z[0]+z[2])-lfactorial(z[4]+1)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* case 3 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[2])+lfactorial(z[0]+z[1])-lfactorial(z[4]+1)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* //Alt that all pis are different but mutation rate constrained to p**/
/* case 4 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])-lfactorial(z[4]+2)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* //Alt that pis are uniform but not constrained to sum to p**/
/* case 5 :lPDM=-z[4]*log(3.0)+lfactorial(z[4])+lfactorial(z[3])-lfactorial(z[3]+z[4]+1);*/
/* break;*/
/* //Alt that one free pi is different: e.g. p1!=p2=p3 etc.*/
/* case 6 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[1]+z[2])+lfactorial(z[0])+lfactorial(z[3])-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* case 7 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[0]+z[2])+lfactorial(z[1])+lfactorial(z[3])-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* case 8 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[0]+z[1])+lfactorial(z[2])+lfactorial(z[3])-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* //Alt that all pis are different*/
/* case 9 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])+lfactorial(z[3])-log(z[4]+2)-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* }*/
int i;
double z1[5];
for(i=0;i<5;i++) z1[i]=(double) z[i];
switch(ind)
{
//Null p1=p2=p3=p/3 where p<=p*
case 0 :lPDM=-z1[4]*log(3.0)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that one free pi is different: e.g. p1!=p2=p3 etc. but mutation rate constrained to be <= p*
case 1 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[0])+lfactorial(z[1]+z[2])-lfactorial(z[4]+1)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 2 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[1])+lfactorial(z[0]+z[2])-lfactorial(z[4]+1)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 3 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[2])+lfactorial(z[0]+z[1])-lfactorial(z[4]+1)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that all pis are different but mutation rate constrained to be <= p*
case 4 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])-lfactorial(z[4]+2)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt p1=p2=p3=p/3 where p>p*
case 5 :lPDM=-z1[4]*log(3.0)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that one free pi is different: e.g. p1!=p2=p3 etc. but mutation rate constrained to be > p*
case 6 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[0])+lfactorial(z[1]+z[2])-lfactorial(z[4]+1)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 7 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[1])+lfactorial(z[0]+z[2])-lfactorial(z[4]+1)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 8 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[2])+lfactorial(z[0]+z[1])-lfactorial(z[4]+1)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that all pis are different but mutation rate constrained to be > p*
case 9 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])-lfactorial(z[4]+2)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
}
return lPDM;
}
void binom_bayes(int *x,
int *n,
double *a,
double *b,
double *alpha,
double *lcl,
double* ucl,
int *len,
int *maxit,
double *tol,
int *error) {
int i, j, first, down;
double lcl_x, ucl_x, lcl_y, ucl_y;
double y1, y2, y3;
double px1, px2, sig;
double mode, xx;
double x1, x2;
double lx1, lx2, ux1, ux2;
double p[3];
for(j = 0; j < len[0]; j++) {
lcl_x = lcl[j];
ucl_x = ucl[j];
lcl_y = dbeta(lcl_x, a[j], b[j], NCP);
ucl_y = dbeta(ucl_x, a[j], b[j], NCP);
y3 = fmax(lcl_y, ucl_y);
y1 = 0;
mode = (a[j] - 1)/(a[j] + b[j] - 2);
first = (lcl_y < ucl_y ? 0 : 1);
x1 = first ? mode : 0;
x2 = first ? 1 : mode;
p[0] = y3;
p[1] = a[j];
p[2] = b[j];
xx = zeroin(dbeta_shift, x1, x2, p, tol[0], maxit[0]);
if(first) {
ucl_x = xx;
} else {
lcl_x = xx;
}
px1 = pbeta(lcl_x, a[j], b[j], LOWER_TAIL, LOG_P);
px2 = pbeta(ucl_x, a[j], b[j], UPPER_TAIL, LOG_P);
sig = px1 + px2;
down = 0;
i = 0;
while(fabs(sig - 2 * alpha[j]) > tol[0] && i < maxit[0]) {
y2 = (y1 + y3) * 0.5;
if(down) {
if(dbeta(lcl_x, a[j], b[j], 0) < y2)
lcl_x = mode;
lx1 = 0;
lx2 = lcl_x;
if(dbeta(ucl_x, a[j], b[j], 0) < y2)
ucl_x = mode;
ux1 = ucl_x;
ux2 = 1;
} else {
if(dbeta(lcl_x, a[j], b[j], 0) > y2)
lcl_x = 0;
lx1 = lcl_x;
lx2 = mode;
if(dbeta(ucl_x, a[j], b[j], 0) > y2)
ucl_x = 1;
ux1 = mode;
ux2 = ucl_x;
}
p[0] = y2;
lcl_x = zeroin(dbeta_shift, lx1, lx2, p, tol[0], maxit[0]);
ucl_x = zeroin(dbeta_shift, ux1, ux2, p, tol[0], maxit[0]);
px1 = pbeta(lcl_x, a[j], b[j], LOWER_TAIL, LOG_P);
px2 = pbeta(ucl_x, a[j], b[j], UPPER_TAIL, LOG_P);
sig = px1 + px2;
if(sig > 2 * alpha[j]) {
down = 0;
y3 = y2;
} else {
down = 1;
y1 = y2;
}
i++;
}
error[j] = (i >= maxit[0] ? 1 : 0);
lcl[j] = lcl_x;
ucl[j] = ucl_x;
}
}
