double lchoose(double n, double k)
{
double k0 = k;
k = floor(k + 0.5);
#ifdef IEEE_754
/* NaNs propagated correctly */
if(ISNAN(n) || ISNAN(k)) return n + k;
#endif
if (fabs(k - k0) > 1e-7)
MATHLIB_WARNING2(_("'k' (%.2f) must be integer, rounded to %.0f"), k0, k);
if (k < 2) {
if (k < 0) return ML_NEGINF;
if (k == 0) return 0.;
/* else: k == 1 */
return log(fabs(n));
}
/* else: k >= 2 */
if (n < 0) {
return lchoose(-n+ k-1, k);
}
else if (R_IS_INT(n)) {
if(n < k) return ML_NEGINF;
/* k <= n :*/
if(n - k < 2) return lchoose(n, n-k); /* <- Symmetry */
/* else: n >= k+2 */
return lfastchoose(n, k);
}
/* else non-integer n >= 0 : */
if (n < k-1) {
int s;
return lfastchoose2(n, k, &s);
}
return lfastchoose(n, k);
}
void empiricalBootConcProb(double *data, int *nSite, int *nObs, int *blockSize,
double *concProb){
const double normCst = lchoose(*nObs, *blockSize);
const int nPair = *nSite * (*nSite - 1) / 2;
#pragma omp parallel for
for (int currentPair=0;currentPair<nPair;currentPair++){
int i, j;
getSiteIndex(currentPair, *nSite, &i, &j);
// For each pair compute the estimator
concProb[currentPair] = 0;
for (int k=0;k<*nObs;k++){
int d = 0;
for (int l=0;l<*nObs;l++)
d += (data[l + i * *nObs] < data[k + i * *nObs]) && (data[l + j * *nObs] < data[k + j * *nObs]);
concProb[currentPair] += exp(lchoose(d, *blockSize - 1) - normCst);
}
}
return;
}
double lchoose(double n, double k)
{
k = floor(k + 0.5);
#ifdef IEEE_754
/* NaNs propagated correctly */
if(ISNAN(n) || ISNAN(k)) return n + k;
#endif
if (k < 2) {
if (k < 0) return ML_NEGINF;
if (k == 0) return 0.;
/* else: k == 1 */
return log(n);
}
/* else: k >= 2 */
if (n < 0) {
if (ODD(k)) return ML_NAN;/* log( <negative> ) */
return lchoose(-n+ k-1, k);
}
else if (R_IS_INT(n)) {
if(n < k) return ML_NEGINF;
if(n - k < 2) return lchoose(n, n-k); /* <- Symmetry */
return lfastchoose(n, k);
}
/* else non-integer n >= 0 : */
if (n < k-1) {
int s;
if (fmod(floor(n-k+1), 2.) == 0) /* choose() < 0 */
return ML_NAN;
return lfastchoose2(n, k, &s);
}
return lfastchoose(n, k);
}
double dwilcox(double x, double m, double n, int give_log)
{
double d;
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(m) || ISNAN(n))
return(x + m + n);
#endif
m = R_forceint(m);
n = R_forceint(n);
if (m <= 0 || n <= 0)
ML_ERR_return_NAN;
if (fabs(x - R_forceint(x)) > 1e-7)
return(R_D__0);
x = R_forceint(x);
if ((x < 0) || (x > m * n))
return(R_D__0);
int mm = (int) m, nn = (int) n, xx = (int) x;
w_init_maybe(mm, nn);
d = give_log ?
log(cwilcox(xx, mm, nn)) - lchoose(m + n, n) :
cwilcox(xx, mm, nn) / choose(m + n, n);
return(d);
}
void zpprob(double *x1, double *x2, double *n1, double *n2, int *ln, double *th, double *ans){
int i;
for(i=0;i<= *ln; i++){
ans[i] = exp(lchoose(*n1,x1[i])+lchoose(*n2,x2[i])+(x1[i]+x2[i])*log(*th)+(*n1+ *n2-x1[i]-x2[i])*log(1- *th));
}
}
