double Pp::distToroidal(int *i, int *j)
{
if(*i==*j) return 0.0;
if(*i>*j) return distToroidal(j, i);
return sqrt(
pow( fmin2( xlim[1]-xlim[0]-fabs(getX(i)-getX(j)) , fabs(getX(i)-getX(j)) ) , 2) +
pow( fmin2( ylim[1]-ylim[0]-fabs(getY(i)-getY(j)) , fabs(getY(i)-getY(j)) ) ,2) );
}
double Pp::computeEdgeDistance(int *i){
double bx,by,bz;
bx = fmin2(getX(i)-xlim[0], xlim[1]-getX(i));
by = fmin2(getY(i)-ylim[0], ylim[1]-getY(i));
bx = fmin2(bx,by);
if(dim==3) {
bz = fmin2(getZ(i)-zlim[0], zlim[1]-getZ(i));
bx = fmin2(bx, bz);
}
return bx;
}
double pnchisq(double x, double df, double ncp, int lower_tail, int log_p)
{
double ans;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(ncp))
return x + df + ncp;
if (!R_FINITE(df) || !R_FINITE(ncp))
ML_ERR_return_NAN;
#endif
if (df < 0. || ncp < 0.) ML_ERR_return_NAN;
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, lower_tail, log_p);
if(ncp >= 80) {
if(lower_tail) {
ans = fmin2(ans, R_D__1); /* e.g., pchisq(555, 1.01, ncp = 80) */
} else { /* !lower_tail */
/* since we computed the other tail cancellation is likely */
if(ans < (log_p ? (-10. * M_LN10) : 1e-10)) ML_ERROR(ME_PRECISION, "pnchisq");
if(!log_p) ans = fmax2(ans, 0.0); /* Precaution PR#7099 */
}
}
if (!log_p || ans < -1e-8)
return ans;
else { // log_p && ans > -1e-8
// prob. = exp(ans) is near one: we can do better using the other tail
#ifdef DEBUG_pnch
REprintf(" pnchisq_raw(*, log_p): ans=%g => 2nd call, other tail\n", ans);
#endif
// FIXME: (sum,sum2) will be the same (=> return them as well and reuse here ?)
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, !lower_tail, FALSE);
return log1p(-ans);
}
}
double pnchisq(double x, double df, double ncp, int lower_tail, int log_p)
{
double ans;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(ncp))
return x + df + ncp;
if (!R_FINITE(df) || !R_FINITE(ncp))
ML_ERR_return_NAN;
#endif
if (df < 0. || ncp < 0.) ML_ERR_return_NAN;
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, lower_tail);
if(ncp >= 80) {
if(lower_tail) {
ans = fmin2(ans, 1.0); /* e.g., pchisq(555, 1.01, ncp = 80) */
} else { /* !lower_tail */
/* since we computed the other tail cancellation is likely */
if(ans < 1e-10) ML_ERROR(ME_PRECISION, "pnchisq");
ans = fmax2(ans, 0.0); /* Precaution PR#7099 */
}
}
if (!log_p) return ans;
/* if ans is near one, we can do better using the other tail */
if (ncp >= 80 || ans < 1 - 1e-8) return log(ans);
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, !lower_tail);
return log1p(-ans);
}
static double
do_search(double y, double *z, double p, double n, double pr, double incr)
{
if(*z >= p) {
/* search to the left */
#ifdef DEBUG_qbinom
REprintf("\tnew z=%7g >= p = %7g --> search to left (y--) ..\n", z,p);
#endif
for(;;) {
double newz;
if(y == 0 ||
(newz = pbinom(y - incr, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) < p)
return y;
y = fmax2(0, y - incr);
*z = newz;
}
}
else { /* search to the right */
#ifdef DEBUG_qbinom
REprintf("\tnew z=%7g < p = %7g --> search to right (y++) ..\n", z,p);
#endif
for(;;) {
y = fmin2(y + incr, n);
if(y == n ||
(*z = pbinom(y, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) >= p)
return y;
}
}
}
double qnt(double p, double df, double ncp, int lower_tail, int log_p)
{
const static double accu = 1e-13;
const static double Eps = 1e-11; /* must be > accu */
double ux, lx, nx, pp;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(df) || ISNAN(ncp))
return p + df + ncp;
#endif
if (!R_FINITE(df)) ML_ERR_return_NAN;
/* Was
* df = floor(df + 0.5);
* if (df < 1 || ncp < 0) ML_ERR_return_NAN;
*/
if (df <= 0.0) ML_ERR_return_NAN;
if(ncp == 0.0 && df >= 1.0) return qt(p, df, lower_tail, log_p);
R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
p = R_DT_qIv(p);
/* Invert pnt(.) :
* 1. finding an upper and lower bound */
if(p > 1 - DBL_EPSILON) return ML_POSINF;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(ux = fmax2(1., ncp);
ux < DBL_MAX && pnt(ux, df, ncp, TRUE, FALSE) < pp;
ux *= 2);
pp = p * (1 - Eps);
for(lx = fmin2(-1., -ncp);
lx > -DBL_MAX && pnt(lx, df, ncp, TRUE, FALSE) > pp;
lx *= 2);
/* 2. interval (lx,ux) halving : */
do {
nx = 0.5 * (lx + ux);
if (pnt(nx, df, ncp, TRUE, FALSE) > p) ux = nx; else lx = nx;
}
while ((ux - lx) / fabs(nx) > accu);
return 0.5 * (lx + ux);
}
static gnm_float lgammacor(gnm_float x)
{
static const gnm_float algmcs[15] = {
GNM_const(+.1666389480451863247205729650822e+0),
GNM_const(-.1384948176067563840732986059135e-4),
GNM_const(+.9810825646924729426157171547487e-8),
GNM_const(-.1809129475572494194263306266719e-10),
GNM_const(+.6221098041892605227126015543416e-13),
GNM_const(-.3399615005417721944303330599666e-15),
GNM_const(+.2683181998482698748957538846666e-17),
GNM_const(-.2868042435334643284144622399999e-19),
GNM_const(+.3962837061046434803679306666666e-21),
GNM_const(-.6831888753985766870111999999999e-23),
GNM_const(+.1429227355942498147573333333333e-24),
GNM_const(-.3547598158101070547199999999999e-26),
GNM_const(+.1025680058010470912000000000000e-27),
GNM_const(-.3401102254316748799999999999999e-29),
GNM_const(+.1276642195630062933333333333333e-30)
};
gnm_float tmp;
#ifdef NOMORE_FOR_THREADS
static int nalgm = 0;
static gnm_float xbig = 0, xmax = 0;
/* Initialize machine dependent constants, the first time gamma() is called.
FIXME for threads ! */
if (nalgm == 0) {
/* For IEEE gnm_float precision : nalgm = 5 */
nalgm = chebyshev_init(algmcs, 15, GNM_EPSILON/2);/*was d1mach(3)*/
xbig = 1 / gnm_sqrt(GNM_EPSILON/2); /* ~ 94906265.6 for IEEE gnm_float */
xmax = gnm_exp(fmin2(gnm_log(GNM_MAX / 12), -gnm_log(12 * GNM_MIN)));
/* = GNM_MAX / 48 ~= 3.745e306 for IEEE gnm_float */
}
#else
/* For IEEE gnm_float precision GNM_EPSILON = 2^-52 = GNM_const(2.220446049250313e-16) :
* xbig = 2 ^ 26.5
* xmax = GNM_MAX / 48 = 2^1020 / 3 */
# define nalgm 5
# define xbig GNM_const(94906265.62425156)
# define xmax GNM_const(3.745194030963158e306)
#endif
if (x < 10)
ML_ERR_return_NAN
else if (x >= xmax) {
ML_ERROR(ME_UNDERFLOW);
return ML_UNDERFLOW;
}
else if (x < xbig) {
tmp = 10 / x;
return chebyshev_eval(tmp * tmp * 2 - 1, algmcs, nalgm) / x;
}
else return 1 / (x * 12);
}
/* Do two lines intersect ?
* Algorithm from Paul Bourke
* (http://www.swin.edu.au/astronomy/pbourke/geometry/lineline2d/index.html)
*/
int linesIntersect(double x1, double x2, double x3, double x4,
double y1, double y2, double y3, double y4)
{
double result = 0;
double denom = (y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1);
double ua = ((x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3));
/* If the lines are parallel ...
*/
if (denom == 0) {
/* If the lines are coincident ...
*/
if (ua == 0) {
/* If the lines are vertical ...
*/
if (x1 == x2) {
/* Compare y-values
*/
if (!((y1 < y3 && fmax2(y1, y2) < fmin2(y3, y4)) ||
(y3 < y1 && fmax2(y3, y4) < fmin2(y1, y2))))
result = 1;
} else {
/* Compare x-values
*/
if (!((x1 < x3 && fmax2(x1, x2) < fmin2(x3, x4)) ||
(x3 < x1 && fmax2(x3, x4) < fmin2(x1, x2))))
result = 1;
}
}
}
/* ... otherwise, calculate where the lines intersect ...
*/
else {
double ub = ((x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3));
ua = ua/denom;
ub = ub/denom;
/* Check for overlap
*/
if ((ua > 0 && ua < 1) && (ub > 0 && ub < 1))
result = 1;
}
return (int) result;
}
/**
* update the proposal standard deviations
*
* @param p the number of parameters to be tuned
* @param acc pointer to the acceptance rate in the M-H update
* @param mh_sd pointer to the vector of proposal standard deviations
* @param mark pointer to the vector of marks
*
*/
static R_INLINE void tune_var(int p, double *acc, double *mh_sd, int *mark) {
double acc_bd;
for (int j = 0; j < p; j++){
acc_bd = fmin2(fmax2(acc[j], 0.01), 0.99); /* bound the empirical acceptance */
if (acc[j] < (MH_ACC_TAR - MH_ACC_TOL))
mh_sd[j] /= 2 - acc_bd/MH_ACC_TAR;
else if (acc[j] > (MH_ACC_TAR - MH_ACC_TOL))
mh_sd[j] *= 2 - (1 - acc_bd)/(1 - MH_ACC_TAR);
else mark[j]++;
}
}
double integral2D (int fn, int m, int c, double gsbval[], int cc, double traps[],
double mask[], int n1, int n2, int kk, int mm, double ex[]) {
double ax=1e20;
double bx=-1e20;
double epsabs = 0.0001;
double epsrel = 0.0001;
double result = 0;
double abserr = 0;
int neval = 0;
int ier = 0;
int limit = 100;
int lenw = 400;
int last = 0;
int iwork[100];
double work[400];
int k;
int ns;
int reportier = 0;
/* limits from bounding box of this polygon */
ns = n2-n1+1;
for (k=0; k<ns; k++) {
ax = fmin2(ax, traps[k+n1]);
bx = fmax2(bx, traps[k+n1]);
}
/* pass parameters etc. through pointer */
ex[0] = gsbval[c];
ex[1] = gsbval[cc + c];
ex[2] = gsbval[2*cc + c];
ex[3] = fn;
ex[4] = mask[m];
ex[5] = mask[m+mm];
ex[6] = 0;
ex[7] = 0;
ex[8] = 0;
ex[9] = ns;
/* also pass polygon vertices */
for (k=0; k<ns; k++) {
ex[k+10] = traps[k+n1]; /* x */
ex[k+ns+10] = traps[k+n1+kk]; /* y */
}
Rdqags(fx, ex, &ax, &bx, &epsabs, &epsrel, &result, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
if ((ier != 0) & (reportier))
Rprintf("ier error code in integral2D %5d\n", ier);
return (result);
}
double attribute_hidden
pnbeta2(double x, double o_x, double a, double b, double ncp,
/* o_x == 1 - x but maybe more accurate */
int lower_tail, int log_p)
{
long double ans = pnbeta_raw(x, o_x, a,b, ncp);
/* return R_DT_val(ans), but we want to warn about cancellation here */
if (lower_tail) return (double) (log_p ? logl(ans) : ans);
else {
if(ans > 1 - 1e-10) ML_ERROR(ME_PRECISION, "pnbeta");
ans = fmin2(ans, 1.0); /* Precaution */
return (double) (log_p ? log1p((double)-ans) : (1. - ans));
}
}
/*===============================================================*/
void integral2Dtest
(int *fn, int *m, int *c, double *gsbval, int *cc, double *traps,
double *mask, int *n1, int *n2, int *kk, int *mm, double *result)
{
double *ex;
double ax=1e20;
double bx=-1e20;
double res;
double epsabs = 0.0001;
double epsrel = 0.0001;
double abserr = 0;
int neval = 0;
int ier = 0;
int limit = 100;
int lenw = 400;
int last = 0;
int iwork[100];
double work[400];
int k;
int ns;
/* limits from bounding box of this polygon */
ns = *n2 - *n1 + 1;
for (k=0; k<ns; k++) {
ax = fmin2(ax, traps[k+ns]);
bx = fmax2(bx, traps[k+ns]);
}
ex = (double *) R_alloc(10 + 2 * *kk, sizeof(double));
ex[0] = gsbval[*c]; /* 1.0? */
ex[1] = gsbval[*cc + *c];
ex[2] = gsbval[2* *cc + *c];
ex[3] = *fn;
ex[4] = mask[*m];
ex[5] = mask[*m+ *mm];
ex[6] = 0;
ex[7] = 0;
ex[8] = 0;
ex[9] = ns;
for (k=0; k<ns; k++) {
ex[k+10] = traps[k+ *n1];
ex[k+ns+10] = traps[k+ *n1 + *kk];
}
Rdqags(fx, ex, &ax, &bx, &epsabs, &epsrel, &res, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
*result = res;
}
SEXP pvaluecombine( SEXP RpVec, SEXP Rmethod ) {
int k = length(RpVec);
const char * method = CHAR(STRING_ELT(Rmethod, 0));
SEXP Rcmbdpvalue = PROTECT(allocVector(REALSXP, 1));
memset(REAL(Rcmbdpvalue), 0.0, sizeof(double));
double * cmbdpvalue = REAL(Rcmbdpvalue);
if (!strcmp(method, "fisher")) {
for (int i=0; i<k; i++) {
*cmbdpvalue += log(REAL(RpVec)[i]);
}
*cmbdpvalue = 1 - pchisq(-2 * *cmbdpvalue, 2*k, 1, 0);
} else if (!strcmp(method, "normal") || !strcmp(method, "stouffer")) {
for (int i=0; i<k; i++) {
*cmbdpvalue += qnorm(REAL(RpVec)[i], 0.0, 1.0, 1, 0);
}
*cmbdpvalue = *cmbdpvalue / sqrt(k);
*cmbdpvalue = pnorm(*cmbdpvalue, 0.0, 1.0, 1, 0);
} else if (!strcmp(method, "min") || !strcmp(method, "tippett")) {
*cmbdpvalue = REAL(RpVec)[0];
for (int i=1; i<k; i++) {
*cmbdpvalue = fmin2(*cmbdpvalue, REAL(RpVec)[i]);
}
*cmbdpvalue = 1 - pow(1-*cmbdpvalue, k);
} else if (!strcmp(method, "max")) {
*cmbdpvalue = REAL(RpVec)[0];
for (int i=1; i<k; i++) {
*cmbdpvalue = fmax2(*cmbdpvalue, REAL(RpVec)[i]);
}
*cmbdpvalue = pow(*cmbdpvalue, k);
} else if (!strcmp(method, "sum")) {
for (int i=0; i<k; i++) {
*cmbdpvalue += REAL(RpVec)[i];
}
if (k <= 30) {
*cmbdpvalue = pConvolveUniform(*cmbdpvalue, (double)k);
} else {
*cmbdpvalue = pnorm(*cmbdpvalue, (double)k/2.0, sqrt((double)k/12.0), 1, 0);
}
} else {
*cmbdpvalue = 3.1415926;
}
// return
UNPROTECT(1);
return(Rcmbdpvalue);
}
double bncoef(int n, double *ban)
{
int k, n_1 = n-1;
double sup = 0.;// sup := max_k ban[k]
for(k = 1; k < n; ++k)
if (sup < ban[k])
sup = ban[k];
double cf = 0.;
for (k = 0; k < n; ) {
int kearl = (k > 0) ? k : 1,
kafte = (++k < n) ? k : n_1;
double syze = fmin2(ban[kearl], ban[kafte]);
cf += (1. - syze / sup);
}
return cf / n;
} /* bncoef */
//the max and min of the diagonal elements of a p by p matrix v
void absrng_(double * v, int* p, double * vmin, double * vmax)
{
int m = *p,i;
double tmp;
tmp= fabs(v[0]);
vmin[0] = tmp;
vmax[0] = tmp;
if(m==1) return;
for(i=1;i< m;i++)
{
tmp = fabs(v[i*m+i]);
vmin[0] = fmin2(tmp,vmin[0]);
vmax[0] = fmax2(tmp,vmax[0]);
}
return;
}
//Function to compute bivariate negbin PMF for one pair (x,y):
double do_dbinegbin(double x, double y, double nu0, double nu1, double nu2, double p0, double p1,
double p2, int give_log, int add_carefully){
double out, phold;
if(nu0==0){
out = dnbinom(x,nu1,p1,1) + dnbinom(y,nu2,p2,1);
return( give_log==1 ? out : exp(out) );
}
out = phold = 0;
double u;
double umax = fmin2(x,y);
double parray[21] = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0};
for(u=0;u<=umax;u++){
phold = exp(dnbinom(x-u,nu1,p1,1)+dnbinom(y-u,nu2,p2,1)+dnbinom(u,nu0,p0,1));
carefulprobsum(phold, parray, add_carefully);
R_CheckUserInterrupt();
}
out = carefulprobsum_fin(parray,add_carefully);
out = ((give_log==1) ? log(out) : out);
return(out);
}
double qnbeta(double p, double a, double b, double ncp,
int lower_tail, int log_p)
{
const static double accu = 1e-15;
const static double Eps = 1e-14; /* must be > accu */
double ux, lx, nx, pp;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(a) || ISNAN(b) || ISNAN(ncp))
return p + a + b + ncp;
#endif
if (!R_FINITE(a)) ML_ERR_return_NAN;
if (ncp < 0. || a <= 0. || b <= 0.) ML_ERR_return_NAN;
R_Q_P01_boundaries(p, 0, 1);
p = R_DT_qIv(p);
/* Invert pnbeta(.) :
* 1. finding an upper and lower bound */
if(p > 1 - DBL_EPSILON) return 1.0;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(ux = 0.5;
ux < 1 - DBL_EPSILON && pnbeta(ux, a, b, ncp, TRUE, FALSE) < pp;
ux = 0.5*(1+ux));
pp = p * (1 - Eps);
for(lx = 0.5;
lx > DBL_MIN && pnbeta(lx, a, b, ncp, TRUE, FALSE) > pp;
lx *= 0.5);
/* 2. interval (lx,ux) halving : */
do {
nx = 0.5 * (lx + ux);
if (pnbeta(nx, a, b, ncp, TRUE, FALSE) > p) ux = nx; else lx = nx;
}
while ((ux - lx) / nx > accu);
return 0.5 * (ux + lx);
}
/* sample W via MH for 2x2 table */
void rMH(
double *W, /* previous draws */
double *XY, /* X_i and Y_i */
double W1min, /* lower bound for W1 */
double W1max, /* upper bound for W1 */
double *mu, /* mean vector for normal */
double **InvSigma, /* Inverse covariance matrix for normal */
int n_dim) /* dimension of parameters */
{
int j;
double dens1, dens2, ratio;
double *Sample = doubleArray(n_dim);
double *vtemp = doubleArray(n_dim);
double *vtemp1 = doubleArray(n_dim);
/* sample W_1 from unif(W1min, W1max) */
Sample[0] = runif(W1min, W1max);
Sample[1] = XY[1]/(1-XY[0])-Sample[0]*XY[0]/(1-XY[0]);
for (j = 0; j < n_dim; j++) {
vtemp[j] = log(Sample[j])-log(1-Sample[j]);
vtemp1[j] = log(W[j])-log(1-W[j]);
}
/* acceptance ratio */
dens1 = dMVN(vtemp, mu, InvSigma, n_dim, 1) -
log(Sample[0])-log(Sample[1])-log(1-Sample[0])-log(1-Sample[1]);
dens2 = dMVN(vtemp1, mu, InvSigma, n_dim, 1) -
log(W[0])-log(W[1])-log(1-W[0])-log(1-W[1]);
ratio = fmin2(1, exp(dens1-dens2));
/* accept */
if (unif_rand() < ratio)
for (j=0; j<n_dim; j++)
W[j]=Sample[j];
free(Sample);
free(vtemp);
free(vtemp1);
}
double hypot(double a, double b)
{
double p, r, s, t, tmp, u;
if(ISNAN(a) || ISNAN(b)) /* propagate Na(N)s: */
return
#ifdef IEEE_754
a + b;
#else
ML_NAN;
#endif
if (!R_FINITE(a) || !R_FINITE(b)) {
return ML_POSINF;
}
p = fmax2(fabs(a), fabs(b));
if (p != 0.0) {
/* r = (min(|a|,|b|) / p) ^2 */
tmp = fmin2(fabs(a), fabs(b))/p;
r = tmp * tmp;
for(;;) {
t = 4.0 + r;
/* This was a test of 4.0 + r == 4.0, but optimizing
compilers nowadays infinite loop on that. */
if(fabs(r) < 2*DBL_EPSILON) break;
s = r / t;
u = 1. + 2. * s;
p *= u ;
/* r = (s / u)^2 * r */
tmp = s / u;
r *= tmp * tmp;
}
}
return p;
}
static void
bound(double *x, double *dx, double *s,
double *ds, double *z, double *dz, double *w,
double *dw, int *n, double *beta, double *deltap,
double *deltad)
{
int i;
*deltap = R_PosInf;
*deltad = R_PosInf;
for (i = 0; i < *n; ++i) {
if (dx[i] < 0.) *deltap = fmin2(*deltap, -x[i] / dx[i]);
if (ds[i] < 0.) *deltap = fmin2(*deltap, -s[i] / ds[i]);
if (dz[i] < 0.) *deltad = fmin2(*deltad, -z[i] / dz[i]);
if (dw[i] < 0.) *deltad = fmin2(*deltad, -w[i] / dw[i]);
}
*deltap = fmin2(1., *beta * *deltap);
*deltad = fmin2(1., *beta * *deltad);
return;
} /* bound */
double OMVIdistance::distance(const int&is, const int& js){
//On passe les prefix commun
double minimum=0, j_indel=0, sub=0;//, lenmax=0;
//etats comparés
double maxpossiblecost;
int i=1;
int j=1;
int m=slen[is];
int n=slen[js];
//int minlen = imin2(m, n);
int mSuf = m+1, nSuf = n+1;
int prefix=0;
//Skipping common prefix
/* TMRLOG(6,"Skipping common prefix\n");
while (i<mSuf && j<nSuf && sequences[MINDICE(is,i-1,nseq)]==sequences[MINDICE(js,j-1,nseq)]) {
i++;
j++;
prefix++;
}
//Skipping common suffix
TMRLOG(6,"Skipping common suffix\n");
while (mSuf>i && nSuf>j && sequences[MINDICE(is,(mSuf-2),nseq)]==sequences[MINDICE(js,(nSuf-2),nseq)]) {
mSuf--;
nSuf--;
}
TMRLOG(6,"Skipping common suffix\n"); */
TMRLOG(5,"m =%d, n=%d, mSuf=%d, nSuf=%d i=%d, j=%d, prefix=%d, fmatsize=%d\n", m, n, mSuf, nSuf, i, j, prefix, fmatsize);
//+1 pour correspondre a la matrice F
int fmat_ij_prefix=0;
int i_state_indice=0;
int prev_istate=0, prev_jstate, j_state, i_state;
int firststate= imax2(prefix-1, 0);
fmat[0] = 0;
prev_jstate=sequences[MINDICE(js,prefix,nseq)];
j_state=sequences[MINDICE(js, firststate, nseq)];
TMRLOG(5,"prev_jstate =%d, j_state=%d\n", prev_jstate, j_state);
for(int ii=prefix+1; ii<mSuf; ii++){
i_state=sequences[MINDICE(is, ii-1, nseq)];
fmat[MINDICE(ii-prefix,0,fmatsize)] = fmat[MINDICE(ii-prefix-1,0,fmatsize)]+
getIndel(sequences[MINDICE(is, ii-1, nseq)],
prev_jstate,
j_state);
}
TMRLOGMATRIX(10, fmat, mSuf-prefix, nSuf-prefix, fmatsize);
prev_istate=sequences[MINDICE(is,prefix,nseq)];
i_state=sequences[MINDICE(is, firststate, nseq)];
TMRLOG(5,"prev_istate =%d, i_state=%d\n", prev_istate, i_state);
for(int ii=prefix+1; ii<nSuf; ii++){
fmat[MINDICE(0,ii-prefix,fmatsize)] = fmat[MINDICE(0,ii-prefix-1,fmatsize)]+
getIndel(sequences[MINDICE(js, ii-1, nseq)],
prev_istate,
i_state);
TMRLOG(5,"ii=%d, j_state =%d, indel=%g, current=%g, prev=%g\n", ii, sequences[MINDICE(js, ii-1, nseq)],
getIndel(sequences[MINDICE(js, ii-1, nseq)], prev_istate, i_state),
fmat[MINDICE(0,ii-prefix,fmatsize)],
fmat[MINDICE(0,ii-prefix-1,fmatsize)]);
//prev_istate=i_state;
}
TMRLOG(5,"Fmat initialized\n");
TMRLOGMATRIX(10, fmat, mSuf-prefix, nSuf-prefix, fmatsize);
//prev_jstate=sequences[MINDICE(js, firststate, nseq)];
while (j<nSuf) {
i=prefix+1;
fmat_ij_prefix=1 + ((j-prefix)*fmatsize);
j_state=sequences[MINDICE(js,j-1,nseq)];
//j_indel_val = getIndel(j_state, sequences[MINDICE(js, (j==1?1:(j-2)),nseq)], sequences[MINDICE(js,(j==n?(n-2):j), nseq)]);
//next_jstate= sequences[MINDICE(js,(j==n?(n-2):j), nseq)];
i_state_indice=is+prefix*nseq;
prev_istate =sequences[MINDICE(is, firststate,nseq)];
while (i<mSuf) {
//i_state=sequences[MINDICE(is,i-1,nseq)];
//TMRLOG(6,"Getting i state\n");
i_state=sequences[i_state_indice];
//////////////////////////////
//Computing current indel cost
//////////////////////////////
//fmat_ij_prefix=((i-prefix)+(j-prefix)*(fmatsize));
//minimum=fmat[MINDICE(i-prefix,j-1-prefix,fmatsize)]+ indel;
//TMRLOG(6,"fmat_ij_prefix =%d,th =%d \n", fmat_ij_prefix, (MINDICE(i-prefix,j-prefix,fmatsize)));
minimum=fmat[fmat_ij_prefix-1]+getIndel(i_state, prev_jstate, j_state);
j_indel=fmat[fmat_ij_prefix-fmatsize]+getIndel(j_state, prev_istate, i_state);
//j_indel=fmat[fmat_ij_prefix-fmatsize]+j_indel_val;
if(minimum>j_indel){
minimum=j_indel;
}
//////////////////////////////
//Computing current indel cost
//////////////////////////////
//sub=fmat[MINDICE(i-1-prefix,j-1-prefix,fmatsize)]+ cost;
//TMRLOG(6,"Substitution cost\n");
if (i_state == j_state) {
sub=fmat[fmat_ij_prefix-1-fmatsize];
} else {
//TMRLOG(6,"Sub cost\n");
sub=fmat[fmat_ij_prefix-1-fmatsize]+ scost[MINDICE(i_state,j_state,alphasize)];
}
//sub=fmat[fmat_ij_prefix-1-fmatsize]+ cost;
if (sub<minimum) {
fmat[fmat_ij_prefix]=sub;
} else {
fmat[fmat_ij_prefix]=minimum;
}
//fmat[MINDICE(i-prefix,j-prefix,fmatsize)]=minimum;
i++;
prev_istate=i_state;
fmat_ij_prefix++;
i_state_indice+=nseq;
}
prev_jstate=j_state;
j++;
}//Fmat build
//Max possible cost
maxpossiblecost=abs(n-m)*indel+maxscost*fmin2((double)m,(double)n);
TMRLOG(6,"End of dist compute index %d val %g\n", MINDICE(mSuf-1-prefix,nSuf-1-prefix,fmatsize), fmat[MINDICE(mSuf-1-prefix,nSuf-1-prefix,fmatsize)]);
if(MINDICE(mSuf-1-prefix,nSuf-1-prefix,fmatsize)<0||MINDICE(mSuf-1-prefix,nSuf-1-prefix,fmatsize)>fmatsize*fmatsize){
TMRLOG(4,"End of dist compute index %d val %g\n", MINDICE(mSuf-1-prefix,nSuf-1-prefix,fmatsize), fmat[MINDICE(mSuf-1-prefix,nSuf-1-prefix,fmatsize)]);
TMRLOG(4,"m =%d, n=%d, mSuf=%d, nSuf=%d i=%d, j=%d, prefix=%d, fmatsize=%d\n", m, n, mSuf, nSuf, i, j, prefix, fmatsize);
TMRLOG(4,"is =%d, js=%d\n", is, js);
}
TMRLOGMATRIX(10, fmat, mSuf-prefix, nSuf-prefix, fmatsize);
return normalizeDistance(fmat[MINDICE(mSuf-1-prefix,nSuf-1-prefix,fmatsize)], maxpossiblecost, m, n);
}
/* only used for kode = 1, m = 1, n in {0,1,2,3} : */
void dpsifn(double x, int n, int kode, int m, double *ans, int *nz, int *ierr)
{
const static double bvalues[] = { /* Bernoulli Numbers */
1.00000000000000000e+00,
-5.00000000000000000e-01,
1.66666666666666667e-01,
-3.33333333333333333e-02,
2.38095238095238095e-02,
-3.33333333333333333e-02,
7.57575757575757576e-02,
-2.53113553113553114e-01,
1.16666666666666667e+00,
-7.09215686274509804e+00,
5.49711779448621554e+01,
-5.29124242424242424e+02,
6.19212318840579710e+03,
-8.65802531135531136e+04,
1.42551716666666667e+06,
-2.72982310678160920e+07,
6.01580873900642368e+08,
-1.51163157670921569e+10,
4.29614643061166667e+11,
-1.37116552050883328e+13,
4.88332318973593167e+14,
-1.92965793419400681e+16
};
int i, j, k, mm, mx, nn, np, nx, fn;
double arg, den, elim, eps, fln, fx, rln, rxsq,
r1m4, r1m5, s, slope, t, ta, tk, tol, tols, tss, tst,
tt, t1, t2, wdtol, xdmln, xdmy, xinc, xln = 0.0 /* -Wall */,
xm, xmin, xq, yint;
double trm[23], trmr[n_max + 1];
*ierr = 0;
if (n < 0 || kode < 1 || kode > 2 || m < 1) {
*ierr = 1;
return;
}
if (x <= 0.) {
/* use Abramowitz & Stegun 6.4.7 "Reflection Formula"
* psi(k, x) = (-1)^k psi(k, 1-x) - pi^{n+1} (d/dx)^n cot(x)
*/
if (x == (long)x) {
/* non-positive integer : +Inf or NaN depends on n */
for(j=0; j < m; j++) /* k = j + n : */
ans[j] = ((j+n) % 2) ? ML_POSINF : ML_NAN;
return;
}
/* This could cancel badly */
dpsifn(1. - x, n, /*kode = */ 1, m, ans, nz, ierr);
/* ans[j] == (-1)^(k+1) / gamma(k+1) * psi(k, 1 - x)
* for j = 0:(m-1) , k = n + j
*/
/* Cheat for now: only work for m = 1, n in {0,1,2,3} : */
if(m > 1 || n > 3) {/* doesn't happen for digamma() .. pentagamma() */
/* not yet implemented */
*ierr = 4; return;
}
x *= M_PI; /* pi * x */
if (n == 0)
tt = cos(x)/sin(x);
else if (n == 1)
tt = -1/pow(sin(x),2);
else if (n == 2)
tt = 2*cos(x)/pow(sin(x),3);
else if (n == 3)
tt = -2*(2*pow(cos(x),2) + 1)/pow(sin(x),4);
else /* can not happen! */
tt = ML_NAN;
/* end cheat */
s = (n % 2) ? -1. : 1.;/* s = (-1)^n */
/* t := pi^(n+1) * d_n(x) / gamma(n+1) , where
* d_n(x) := (d/dx)^n cot(x)*/
t1 = t2 = s = 1.;
for(k=0, j=k-n; j < m; k++, j++, s = -s) {
/* k == n+j , s = (-1)^k */
t1 *= M_PI;/* t1 == pi^(k+1) */
if(k >= 2)
t2 *= k;/* t2 == k! == gamma(k+1) */
if(j >= 0) /* by cheat above, tt === d_k(x) */
ans[j] = s*(ans[j] + t1/t2 * tt);
}
if (n == 0 && kode == 2) /* unused from R, but "wrong": xln === 0 :*/
ans[0] += xln;
return;
} /* x <= 0 */
/* else : x > 0 */
*nz = 0;
xln = log(x);
if(kode == 1 && m == 1) {/* the R case --- for very large x: */
double lrg = 1/(2. * DBL_EPSILON);
if(n == 0 && x * xln > lrg) {
ans[0] = -xln;
return;
}
else if(n >= 1 && x > n * lrg) {
ans[0] = exp(-n * xln)/n; /* == x^-n / n == 1/(n * x^n) */
return;
}
}
mm = m;
nx = imin2(-jags_i1mach(15), jags_i1mach(16));/* = 1021 */
r1m5 = jags_d1mach(5);
r1m4 = jags_d1mach(4) * 0.5;
wdtol = fmax2(r1m4, 0.5e-18); /* 1.11e-16 */
/* elim = approximate exponential over and underflow limit */
elim = 2.302 * (nx * r1m5 - 3.0);/* = 700.6174... */
for(;;) {
nn = n + mm - 1;
fn = nn;
t = (fn + 1) * xln;
/* overflow and underflow test for small and large x */
if (fabs(t) > elim) {
if (t <= 0.0) {
*nz = 0;
*ierr = 2;
return;
}
}
else {
if (x < wdtol) {
ans[0] = pow(x, -n-1.0);
if (mm != 1) {
for(k = 1; k < mm ; k++)
ans[k] = ans[k-1] / x;
}
if (n == 0 && kode == 2)
ans[0] += xln;
return;
}
/* compute xmin and the number of terms of the series, fln+1 */
rln = r1m5 * jags_i1mach(14);
rln = fmin2(rln, 18.06);
fln = fmax2(rln, 3.0) - 3.0;
yint = 3.50 + 0.40 * fln;
slope = 0.21 + fln * (0.0006038 * fln + 0.008677);
xm = yint + slope * fn;
mx = (int)xm + 1;
xmin = mx;
if (n != 0) {
xm = -2.302 * rln - fmin2(0.0, xln);
arg = xm / n;
arg = fmin2(0.0, arg);
eps = exp(arg);
xm = 1.0 - eps;
if (fabs(arg) < 1.0e-3)
xm = -arg;
fln = x * xm / eps;
xm = xmin - x;
if (xm > 7.0 && fln < 15.0)
break;
}
xdmy = x;
xdmln = xln;
xinc = 0.0;
if (x < xmin) {
nx = (int)x;
xinc = xmin - nx;
xdmy = x + xinc;
xdmln = log(xdmy);
}
/* generate w(n+mm-1, x) by the asymptotic expansion */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
tk = fmax2(fabs(t), fmax2(fabs(t1), fabs(t2)));
if (tk <= elim) /* for all but large x */
goto L10;
}
nz++; /* underflow */
mm--;
ans[mm] = 0.;
if (mm == 0)
return;
} /* end{for()} */
nn = (int)fln + 1;
np = n + 1;
t1 = (n + 1) * xln;
t = exp(-t1);
s = t;
den = x;
for(i=1; i <= nn; i++) {
den += 1.;
trm[i] = pow(den, (double)-np);
s += trm[i];
}
ans[0] = s;
if (n == 0 && kode == 2)
ans[0] = s + xln;
if (mm != 1) { /* generate higher derivatives, j > n */
tol = wdtol / 5.0;
for(j = 1; j < mm; j++) {
t /= x;
s = t;
tols = t * tol;
den = x;
for(i=1; i <= nn; i++) {
den += 1.;
trm[i] /= den;
s += trm[i];
if (trm[i] < tols)
break;
}
ans[j] = s;
}
}
return;
L10:
tss = exp(-t);
tt = 0.5 / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0)
t1 = tt + 1.0 / fn;
rxsq = 1.0 / (xdmy * xdmy);
ta = 0.5 * rxsq;
t = (fn + 1) * ta;
s = t * bvalues[2];
if (fabs(s) >= tst) {
tk = 2.0;
for(k = 4; k <= 22; k++) {
t = t * ((tk + fn + 1)/(tk + 1.0))*((tk + fn)/(tk + 2.0)) * rxsq;
trm[k] = t * bvalues[k-1];
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
/* backward recur from xdmy to x */
nx = (int)xinc;
np = nn + 1;
if (nx > n_max) {
*nz = 0;
*ierr = 3;
return;
}
else {
if (nn==0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
/* this loop should not be changed. fx is accurate when x is small */
for(i = 1; i <= nx; i++) {
trmr[i] = pow(fx, (double)-np);
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
}
ans[mm-1] = s;
if (fn == 0)
goto L30;
/* generate lower derivatives, j < n+mm-1 */
for(j = 2; j <= mm; j++) {
fn--;
tss *= xdmy;
t1 = tt;
if (fn!=0)
t1 = tt + 1.0 / fn;
t = (fn + 1) * ta;
s = t * bvalues[2];
if (fabs(s) >= tst) {
tk = 4 + fn;
for(k=4; k <= 22; k++) {
trm[k] = trm[k] * (fn + 1) / tk;
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
if (fn == 0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
for(i=1 ; i<=nx ; i++) {
trmr[i] = trmr[i] * fx;
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
ans[mm - j] = s;
if (fn == 0)
goto L30;
}
return;
L20:
for(i = 1; i <= nx; i++)
s += 1. / (x + (nx - i)); /* avoid disastrous cancellation, PR#13714 */
L30:
if (kode != 2) /* always */
ans[0] = s - xdmln;
else if (xdmy != x) {
xq = xdmy / x;
ans[0] = s - log(xq);
}
return;
} /* dpsifn() */
double qnchisq(double p, double df, double ncp, int lower_tail, int log_p)
{
const static double accu = 1e-13;
const static double racc = 4*DBL_EPSILON;
/* these two are for the "search" loops, can have less accuracy: */
const static double Eps = 1e-11; /* must be > accu */
const static double rEps= 1e-10; /* relative tolerance ... */
double ux, lx, ux0, nx, pp;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(df) || ISNAN(ncp))
return p + df + ncp;
#endif
if (!R_FINITE(df)) ML_ERR_return_NAN;
/* Was
* df = floor(df + 0.5);
* if (df < 1 || ncp < 0) ML_ERR_return_NAN;
*/
if (df < 0 || ncp < 0) ML_ERR_return_NAN;
R_Q_P01_boundaries(p, 0, ML_POSINF);
/* Invert pnchisq(.) :
* 1. finding an upper and lower bound */
{
/* This is Pearson's (1959) approximation,
which is usually good to 4 figs or so. */
double b, c, ff;
b = (ncp*ncp)/(df + 3*ncp);
c = (df + 3*ncp)/(df + 2*ncp);
ff = (df + 2 * ncp)/(c*c);
ux = b + c * qchisq(p, ff, lower_tail, log_p);
if(ux < 0) ux = 1;
ux0 = ux;
}
p = R_D_qIv(p);
if(!lower_tail && ncp >= 80) {
/* pnchisq is only for lower.tail = TRUE */
if(p < 1e-10) ML_ERROR(ME_PRECISION, "qnchisq");
p = 1. - p;
lower_tail = TRUE;
}
if(lower_tail) {
if(p > 1 - DBL_EPSILON) return ML_POSINF;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(; ux < DBL_MAX &&
pnchisq_raw(ux, df, ncp, Eps, rEps, 10000, TRUE) < pp;
ux *= 2);
pp = p * (1 - Eps);
for(lx = fmin2(ux0, DBL_MAX);
lx > DBL_MIN &&
pnchisq_raw(lx, df, ncp, Eps, rEps, 10000, TRUE) > pp;
lx *= 0.5);
}
else {
if(p > 1 - DBL_EPSILON) return 0.0;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(; ux < DBL_MAX &&
pnchisq_raw(ux, df, ncp, Eps, rEps, 10000, FALSE) > pp;
ux *= 2);
pp = p * (1 - Eps);
for(lx = fmin2(ux0, DBL_MAX);
lx > DBL_MIN &&
pnchisq_raw(lx, df, ncp, Eps, rEps, 10000, FALSE) < pp;
lx *= 0.5);
}
/* 2. interval (lx,ux) halving : */
if(lower_tail) {
do {
nx = 0.5 * (lx + ux);
if (pnchisq_raw(nx, df, ncp, accu, racc, 100000, TRUE) > p)
ux = nx;
else
lx = nx;
}
while ((ux - lx) / nx > accu);
} else {
do {
nx = 0.5 * (lx + ux);
if (pnchisq_raw(nx, df, ncp, accu, racc, 100000, FALSE) < p)
ux = nx;
else
lx = nx;
}
while ((ux - lx) / nx > accu);
}
return 0.5 * (ux + lx);
}
void orderalpha(int *n1, int *n2, int *pinput, int *qoutput, double *xtab,
double *ytab, double *xref, double *yref, double *lambda, double *output_ref,
double *theta, double *input_ref, double *gammaa, double *hyper_ref,
double *res1, double *res2, double *res3, double *alpha)
{
int i, j, k, l, test_max, test_min, in, out, ind1, ind2, ind3;
double min_ref, max_ref, minmax_ref;
for(i=0; i < *n2; i++)
{
//initialisation
in=0;
out=0;
for(j=0; j < *n1; j++)
{
// efficiency score calculated in the output direction
test_max=0;
for(k=0; k < *pinput; k++)
{if(xtab[*pinput*j+k]<=xref[*pinput*i+k]) // test if the xtab<xref
{test_max = test_max + 1;
}
}
if(test_max==*pinput)
{
min_ref=ytab[*qoutput*j]/yref[*qoutput*i];
for(l=1; l < *qoutput; l++) // research of which output
{min_ref=fmin2(min_ref, ytab[*qoutput*j+l]/yref[*qoutput*i+l]);}
// if(lambda[i]<min_ref)
// {lambda[i]=min_ref;
// output_ref[i]=j+1;
// }
res1[j]=min_ref;
}
else
{res1[j]=0;
in=in+1;}
// efficiency score calculated in the input direction
test_min=0;
for(k=0; k < *qoutput; k++)
{if(ytab[*qoutput*j+k]>=yref[*qoutput*i+k]) // test if the ytab>yref
{test_min = test_min + 1;
}
}
if(test_min==*qoutput)
{
max_ref=xtab[*pinput*j]/xref[*pinput*i];
for(l=1; l < *pinput; l++) // research of which output
{max_ref=fmax2(max_ref,xtab[*pinput*j+l]/xref[*pinput*i+l]);}
if(theta[i]==0) // initialisation of theta[i]
{theta[i]=max_ref;
input_ref[i]=j+1;
}
// if(theta[i]>max_ref)
// {theta[i]=max_ref;
// input_ref[i]=j+1;
// }
res2[j]=max_ref;
}
else
{res2[j]=999;
out=out+1;
}
// efficiency score calculated in the hyperbolic direction
max_ref=xtab[*pinput*j]/xref[*pinput*i];
for(l=1; l < *pinput; l++) // research of which output
{max_ref=fmax2(max_ref,xtab[*pinput*j+l]/xref[*pinput*i+l]);}
min_ref=yref[*qoutput*i]/ytab[*qoutput*j];
for(l=1; l < *qoutput; l++) // research of which output
{min_ref=fmax2(min_ref,yref[*qoutput*i+l]/ytab[*qoutput*j+l]);}
minmax_ref=fmax2(min_ref,max_ref);
// if(gammaa[i]>minmax_ref)
// {gammaa[i]=minmax_ref;
// hyper_ref[i]=j+1;}
res3[j]=minmax_ref;
}
if(in==*n1)
{lambda[i]=-1;}
else
{R_rsort(res1, *n1);
ind1=imin2(*n1-1,ftrunc(in+alpha[i]*(*n1-in)));
//if(ind1!=(in+*alpha*(*n1-in)))
// {ind1=ind1+1;}
lambda[i]=res1[ind1];
}
if(out==*n1)
{theta[i]=-1;}
else
{ R_rsort(res2, *n1);
ind2=ftrunc((1-alpha[i])*(*n1-out));
// if(ind2!=((1-*alpha)*(*n1-out)))
// {ind2=ind2+1;}
theta[i]=res2[ind2];}
R_rsort(res3, *n1);
ind3=ftrunc((1-alpha[i])**n1);
// if(ind3!=fround(((1-*alpha)**n1),5))
// {ind3=fmin2(ind3+1,(*n1-1));}
gammaa[i]=res3[ind3];
}
}
double qt(double p, double ndf, int lower_tail, int log_p)
{
const static double eps = 1.e-12;
double P, q;
Rboolean neg;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(ndf))
return p + ndf;
#endif
R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
if (ndf <= 0) ML_ERR_return_NAN;
if (ndf < 1) { /* based on qnt */
const static double accu = 1e-13;
const static double Eps = 1e-11; /* must be > accu */
double ux, lx, nx, pp;
int iter = 0;
p = R_DT_qIv(p);
/* Invert pt(.) :
* 1. finding an upper and lower bound */
if(p > 1 - DBL_EPSILON) return ML_POSINF;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(ux = 1.; ux < DBL_MAX && pt(ux, ndf, TRUE, FALSE) < pp; ux *= 2);
pp = p * (1 - Eps);
for(lx =-1.; lx > -DBL_MAX && pt(lx, ndf, TRUE, FALSE) > pp; lx *= 2);
/* 2. interval (lx,ux) halving
regula falsi failed on qt(0.1, 0.1)
*/
do {
nx = 0.5 * (lx + ux);
if (pt(nx, ndf, TRUE, FALSE) > p) ux = nx; else lx = nx;
} while ((ux - lx) / fabs(nx) > accu && ++iter < 1000);
if(iter >= 1000) ML_ERROR(ME_PRECISION, "qt");
return 0.5 * (lx + ux);
}
/* Old comment:
* FIXME: "This test should depend on ndf AND p !!
* ----- and in fact should be replaced by
* something like Abramowitz & Stegun 26.7.5 (p.949)"
*
* That would say that if the qnorm value is x then
* the result is about x + (x^3+x)/4df + (5x^5+16x^3+3x)/96df^2
* The differences are tiny even if x ~ 1e5, and qnorm is not
* that accurate in the extreme tails.
*/
if (ndf > 1e20) return qnorm(p, 0., 1., lower_tail, log_p);
P = R_D_qIv(p); /* if exp(p) underflows, we fix below */
neg = (!lower_tail || P < 0.5) && (lower_tail || P > 0.5);
if(neg)
P = 2 * (log_p ? (lower_tail ? P : -expm1(p)) : R_D_Lval(p));
else
P = 2 * (log_p ? (lower_tail ? -expm1(p) : P) : R_D_Cval(p));
/* 0 <= P <= 1 ; P = 2*min(P', 1 - P') in all cases */
/* Use this if(log_p) only : */
#define P_is_exp_2p (lower_tail == neg) /* both TRUE or FALSE == !xor */
if (fabs(ndf - 2) < eps) { /* df ~= 2 */
if(P > DBL_MIN) {
if(3* P < DBL_EPSILON) /* P ~= 0 */
q = 1 / sqrt(P);
else if (P > 0.9) /* P ~= 1 */
q = (1 - P) * sqrt(2 /(P * (2 - P)));
else /* eps/3 <= P <= 0.9 */
q = sqrt(2 / (P * (2 - P)) - 2);
}
else { /* P << 1, q = 1/sqrt(P) = ... */
if(log_p)
q = P_is_exp_2p ? exp(- p/2) / M_SQRT2 : 1/sqrt(-expm1(p));
else
q = ML_POSINF;
}
}
else if (ndf < 1 + eps) { /* df ~= 1 (df < 1 excluded above): Cauchy */
if(P > 0)
q = 1/tan(P * M_PI_2);/* == - tan((P+1) * M_PI_2) -- suffers for P ~= 0 */
else { /* P = 0, but maybe = 2*exp(p) ! */
if(log_p) /* 1/tan(e) ~ 1/e */
q = P_is_exp_2p ? M_1_PI * exp(-p) : -1./(M_PI * expm1(p));
else
q = ML_POSINF;
}
}
else { /*-- usual case; including, e.g., df = 1.1 */
double x = 0., y, log_P2 = 0./* -Wall */,
a = 1 / (ndf - 0.5),
b = 48 / (a * a),
c = ((20700 * a / b - 98) * a - 16) * a + 96.36,
d = ((94.5 / (b + c) - 3) / b + 1) * sqrt(a * M_PI_2) * ndf;
Rboolean P_ok1 = P > DBL_MIN || !log_p, P_ok = P_ok1;
if(P_ok1) {
y = pow(d * P, 2 / ndf);
P_ok = (y >= DBL_EPSILON);
}
if(!P_ok) { /* log_p && P very small */
log_P2 = P_is_exp_2p ? p : R_Log1_Exp(p); /* == log(P / 2) */
x = (log(d) + M_LN2 + log_P2) / ndf;
y = exp(2 * x);
}
if ((ndf < 2.1 && P > 0.5) || y > 0.05 + a) { /* P > P0(df) */
/* Asymptotic inverse expansion about normal */
if(P_ok)
x = qnorm(0.5 * P, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
else /* log_p && P underflowed */
x = qnorm(log_P2, 0., 1., lower_tail, /*log_p*/ TRUE);
y = x * x;
if (ndf < 5)
c += 0.3 * (ndf - 4.5) * (x + 0.6);
c = (((0.05 * d * x - 5) * x - 7) * x - 2) * x + b + c;
y = (((((0.4 * y + 6.3) * y + 36) * y + 94.5) / c
- y - 3) / b + 1) * x;
y = expm1(a * y * y);
q = sqrt(ndf * y);
} else { /* re-use 'y' from above */
if(!P_ok && x < - M_LN2 * DBL_MANT_DIG) {/* 0.5* log(DBL_EPSILON) */
/* y above might have underflown */
q = sqrt(ndf) * exp(-x);
}
else {
y = ((1 / (((ndf + 6) / (ndf * y) - 0.089 * d - 0.822)
* (ndf + 2) * 3) + 0.5 / (ndf + 4))
* y - 1) * (ndf + 1) / (ndf + 2) + 1 / y;
q = sqrt(ndf * y);
}
}
/* Now apply 2-term Taylor expansion improvement (1-term = Newton):
* as by Hill (1981) [ref.above] */
/* FIXME: This can be far from optimal when log_p = TRUE
* but is still needed, e.g. for qt(-2, df=1.01, log=TRUE).
* Probably also improvable when lower_tail = FALSE */
if(P_ok1) {
int it=0;
while(it++ < 10 && (y = dt(q, ndf, FALSE)) > 0 &&
R_FINITE(x = (pt(q, ndf, FALSE, FALSE) - P/2) / y) &&
fabs(x) > 1e-14*fabs(q))
/* Newton (=Taylor 1 term):
* q += x;
* Taylor 2-term : */
q += x * (1. + x * q * (ndf + 1) / (2 * (q * q + ndf)));
}
}
if(neg) q = -q;
return q;
}
double rbeta(double aa, double bb, JRNG *rng)
{
if (aa < 0. || bb < 0.)
ML_ERR_return_NAN;
if (!R_FINITE(aa) && !R_FINITE(bb)) // a = b = Inf : all mass at 1/2
return 0.5;
if (aa == 0. && bb == 0.) // point mass 1/2 at each of {0,1} :
return (unif_rand(rng) < 0.5) ? 0. : 1.;
// now, at least one of a, b is finite and positive
if (!R_FINITE(aa) || bb == 0.)
return 1.0;
if (!R_FINITE(bb) || aa == 0.)
return 0.0;
double a, b, alpha;
double r, s, t, u1, u2, v, w, y, z;
int qsame;
/* FIXME: Keep Globals (properly) for threading */
/* Uses these GLOBALS to save time when many rv's are generated : */
static double beta, gamma, delta, k1, k2;
static double olda = -1.0;
static double oldb = -1.0;
/* Test if we need new "initializing" */
qsame = (olda == aa) && (oldb == bb);
if (!qsame) { olda = aa; oldb = bb; }
a = fmin2(aa, bb);
b = fmax2(aa, bb); /* a <= b */
alpha = a + b;
#define v_w_from__u1_bet(AA) \
v = beta * log(u1 / (1.0 - u1)); \
if (v <= expmax) { \
w = AA * exp(v); \
if(!R_FINITE(w)) w = DBL_MAX; \
} else \
w = DBL_MAX
if (a <= 1.0) { /* --- Algorithm BC --- */
/* changed notation, now also a <= b (was reversed) */
if (!qsame) { /* initialize */
beta = 1.0 / a;
delta = 1.0 + b - a;
k1 = delta * (0.0138889 + 0.0416667 * a) / (b * beta - 0.777778);
k2 = 0.25 + (0.5 + 0.25 / delta) * a;
}
/* FIXME: "do { } while()", but not trivially because of "continue"s:*/
for(;;) {
u1 = unif_rand(rng);
u2 = unif_rand(rng);
if (u1 < 0.5) {
y = u1 * u2;
z = u1 * y;
if (0.25 * u2 + z - y >= k1)
continue;
} else {
z = u1 * u1 * u2;
if (z <= 0.25) {
v_w_from__u1_bet(b);
break;
}
if (z >= k2)
continue;
}
v_w_from__u1_bet(b);
if (alpha * (log(alpha / (a + w)) + v) - 1.3862944 >= log(z))
break;
}
return (aa == a) ? a / (a + w) : w / (a + w);
}
else { /* Algorithm BB */
if (!qsame) { /* initialize */
beta = sqrt((alpha - 2.0) / (2.0 * a * b - alpha));
gamma = a + 1.0 / beta;
}
do {
u1 = unif_rand(rng);
u2 = unif_rand(rng);
v_w_from__u1_bet(a);
z = u1 * u1 * u2;
r = gamma * v - 1.3862944;
s = a + r - w;
if (s + 2.609438 >= 5.0 * z)
break;
t = log(z);
if (s > t)
break;
}
while (r + alpha * log(alpha / (b + w)) < t);
return (aa != a) ? b / (b + w) : w / (b + w);
}
}
GBMRESULT CPoisson::FitBestConstant
(
double *adY,
double *adMisc,
double *adOffset,
double *adW,
double *adF,
double *adZ,
const std::vector<unsigned long>& aiNodeAssign,
unsigned long nTrain,
VEC_P_NODETERMINAL vecpTermNodes,
unsigned long cTermNodes,
unsigned long cMinObsInNode,
bool *afInBag,
double *adFadj,
int cIdxOff
)
{
GBMRESULT hr = GBM_OK;
unsigned long iObs = 0;
unsigned long iNode = 0;
vecdNum.resize(cTermNodes);
vecdNum.assign(vecdNum.size(),0.0);
vecdDen.resize(cTermNodes);
vecdDen.assign(vecdDen.size(),0.0);
vecdMax.resize(cTermNodes);
vecdMax.assign(vecdMax.size(),-HUGE_VAL);
vecdMin.resize(cTermNodes);
vecdMin.assign(vecdMin.size(),HUGE_VAL);
if(adOffset == NULL)
{
for(iObs=0; iObs<nTrain; iObs++)
{
if(afInBag[iObs])
{
vecdNum[aiNodeAssign[iObs]] += adW[iObs]*adY[iObs];
vecdDen[aiNodeAssign[iObs]] += adW[iObs]*exp(adF[iObs]);
}
vecdMax[aiNodeAssign[iObs]] =
fmax2(adF[iObs],vecdMax[aiNodeAssign[iObs]]);
vecdMin[aiNodeAssign[iObs]] =
fmin2(adF[iObs],vecdMin[aiNodeAssign[iObs]]);
}
}
else
{
for(iObs=0; iObs<nTrain; iObs++)
{
if(afInBag[iObs])
{
vecdNum[aiNodeAssign[iObs]] += adW[iObs]*adY[iObs];
vecdDen[aiNodeAssign[iObs]] +=
adW[iObs]*exp(adOffset[iObs]+adF[iObs]);
}
}
}
for(iNode=0; iNode<cTermNodes; iNode++)
{
if(vecpTermNodes[iNode]!=NULL)
{
if(vecdNum[iNode] == 0.0)
{
// DEBUG: if vecdNum==0 then prediction = -Inf
// Not sure what else to do except plug in an arbitrary
// negative number, -1? -10? Let's use -1, then make
// sure |adF| < 19 always.
vecpTermNodes[iNode]->dPrediction = -19.0;
}
else if(vecdDen[iNode] == 0.0)
{
vecpTermNodes[iNode]->dPrediction = 0.0;
}
else
{
vecpTermNodes[iNode]->dPrediction =
log(vecdNum[iNode]/vecdDen[iNode]);
}
vecpTermNodes[iNode]->dPrediction =
fmin2(vecpTermNodes[iNode]->dPrediction,
19-vecdMax[iNode]);
vecpTermNodes[iNode]->dPrediction =
fmax2(vecpTermNodes[iNode]->dPrediction,
-19-vecdMin[iNode]);
}
}
return hr;
}
static void ping_pong(int p1, int p2)
{
int i, other_global_id;
double my_time, my_last_time, other_time;
double td_min, td_max;
double invalid_time = -1.0;
MPI_Status status;
int pp_tag = 43;
/* I had to unroll the main loop because I didn't find a portable way
to define the initial td_min and td_max with INFINITY and NINFINITY */
if( get_measurement_rank() == p1 ) {
other_global_id = get_global_rank(p2);
my_last_time = wtime();
MPI_Send(&my_last_time, 1, MPI_DOUBLE, p2, pp_tag, get_measurement_comm());
MPI_Recv(&other_time, 1, MPI_DOUBLE, p2, pp_tag, get_measurement_comm(), &status);
my_time = wtime();
td_min = other_time - my_time;
td_max = other_time - my_last_time;
MPI_Send(&my_time, 1, MPI_DOUBLE, p2, pp_tag, get_measurement_comm());
} else {
other_global_id = get_global_rank(p1);
MPI_Recv(&other_time, 1, MPI_DOUBLE, p1, pp_tag, get_measurement_comm(), &status);
my_last_time = wtime();
td_min = other_time - my_last_time;
MPI_Send(&my_last_time, 1, MPI_DOUBLE, p1, pp_tag, get_measurement_comm());
MPI_Recv(&other_time, 1, MPI_DOUBLE, p1, pp_tag, get_measurement_comm(), &status);
my_time = wtime();
td_min = fmax2(td_min, other_time - my_time);
td_max = other_time - my_last_time;
}
if( get_measurement_rank() == p1 ) {
i = 1;
while( 1 ) {
MPI_Recv(&other_time, 1, MPI_DOUBLE, p2, pp_tag, get_measurement_comm(), &status);
if( other_time < 0.0 ) break;
my_last_time = my_time;
my_time = wtime();
td_min = fmax2(td_min, other_time - my_time);
td_max = fmin2(td_max, other_time - my_last_time);
if( ping_pong_min_time[other_global_id] >= 0.0 &&
i >= Minimum_ping_pongs &&
my_time - my_last_time < ping_pong_min_time[other_global_id]*1.10 ) {
MPI_Send(&invalid_time, 1, MPI_DOUBLE, p2, pp_tag, get_measurement_comm());
break;
}
i++;
if( i == Number_ping_pongs ) {
MPI_Send(&invalid_time, 1, MPI_DOUBLE, p2, pp_tag, get_measurement_comm());
break;
}
MPI_Send(&my_time, 1, MPI_DOUBLE, p2, pp_tag, get_measurement_comm());
}
} else {
i = 1;
while( 1 ) {
MPI_Send(&my_time, 1, MPI_DOUBLE, p1, pp_tag, get_measurement_comm());
MPI_Recv(&other_time, 1, MPI_DOUBLE, p1, pp_tag, get_measurement_comm(), &status);
if( other_time < 0.0 ) break;
my_last_time = my_time;
my_time = wtime();
td_min = fmax2(td_min, other_time - my_time);
td_max = fmin2(td_max, other_time - my_last_time);
if( ping_pong_min_time[other_global_id] >= 0.0 &&
i >= Minimum_ping_pongs &&
my_time - my_last_time < ping_pong_min_time[other_global_id]*1.10 ) {
MPI_Send(&invalid_time, 1, MPI_DOUBLE, p1, pp_tag, get_measurement_comm());
break;
}
i++;
}
}
if( ping_pong_min_time[other_global_id] < 0.0)
ping_pong_min_time[other_global_id] = td_max-td_min;
else
ping_pong_min_time[other_global_id] =
fmin2(ping_pong_min_time[other_global_id], td_max-td_min);
tds[other_global_id] = (td_min+td_max)/2.0;
}
double sn0(double *x, int n, int is_sorted, double *a2)
{
/*
Efficient algorithm for the scale estimator:
S*_n = LOMED_{i} HIMED_{i} |x_i - x_j|
which can equivalently be written as
S*_n = LOMED_{i} LOMED_{j != i} |x_i - x_j|
Arguments :
x : double array (length >= n) containing the observations
n : number of observations (n>=2)
is_sorted: logical indicating if x is already sorted
a2 : to contain a2[i] := LOMED_{j != i} | x_i - x_j |,
for i=1,...,n
*/
/* Local variables */
double medA, medB;
int i, diff, half, Amin, Amax, even, length;
int leftA,leftB, nA,nB, tryA,tryB, rightA,rightB;
int n1_2;
if(!is_sorted)
R_qsort(x, 1, n);
a2[0] = x[n / 2] - x[0];
n1_2 = (n + 1) / 2;
/* first half for() loop : */
for (i = 2; i <= n1_2; ++i) {
nA = i - 1;
nB = n - i;
diff = nB - nA;
leftA = leftB = 1;
rightA = rightB = nB;
Amin = diff / 2 + 1;
Amax = diff / 2 + nA;
while (leftA < rightA) {
length = rightA - leftA + 1;
even = 1 - length % 2;
half = (length - 1) / 2;
tryA = leftA + half;
tryB = leftB + half;
if (tryA < Amin) {
rightB = tryB;
leftA = tryA + even;
}
else {
if (tryA > Amax) {
rightA = tryA;
leftB = tryB + even;
}
else {
medA = x[i - 1] - x[i - tryA + Amin - 2];
medB = x[tryB + i - 1] - x[i - 1];
if (medA >= medB) {
rightA = tryA;
leftB = tryB + even;
} else {
rightB = tryB;
leftA = tryA + even;
}
}
}
} /* while */
if (leftA > Amax) {
a2[i - 1] = x[leftB + i - 1] - x[i - 1];
} else {
medA = x[i - 1] - x[i - leftA + Amin - 2];
medB = x[leftB + i - 1] - x[i - 1];
a2[i - 1] = fmin2(medA,medB);
}
}
/* second half for() loop : */
for (i = n1_2 + 1; i <= n - 1; ++i) {
nA = n - i;
nB = i - 1;
diff = nB - nA;
leftA = leftB = 1;
rightA = rightB = nB;
Amin = diff / 2 + 1;
Amax = diff / 2 + nA;
while (leftA < rightA) {
length = rightA - leftA + 1;
even = 1 - length % 2;
half = (length - 1) / 2;
tryA = leftA + half;
tryB = leftB + half;
if (tryA < Amin) {
rightB = tryB;
leftA = tryA + even;
} else {
if (tryA > Amax) {
rightA = tryA;
leftB = tryB + even;
} else {
medA = x[i + tryA - Amin] - x[i - 1];
medB = x[i - 1] - x[i - tryB - 1];
if (medA >= medB) {
rightA = tryA;
leftB = tryB + even;
} else {
rightB = tryB;
leftA = tryA + even;
}
}
}
} /* while */
if (leftA > Amax) {
a2[i - 1] = x[i - 1] - x[i - leftB - 1];
} else {
medA = x[i + leftA - Amin] - x[i - 1];
medB = x[i - 1] - x[i - leftB - 1];
a2[i - 1] = fmin2(medA,medB);
}
}
a2[n - 1] = x[n - 1] - x[n1_2 - 1];
return pull(a2, n, n1_2);
} /* sn0 */
double TWEDdistance::distance(const int&is, const int& js){
double minimum=0, i_warp=0, j_warp=0, sub=0;//, lenmax=0;
//etats comparés
int i_state, j_state;
int i_m1_state, j_m1_state; // BH Need previous state also
double cost, maxpossiblecost;
int i=1;
int j=1;
int m=slen[is]+1;
int n=slen[js]+1;
int prefix=0;
// BH Jun 2 2013 23:56:32: Stripping common prefixes is not appropriate for TWED
// This is probably because it looks one token back, so perhaps stripping up
// to prefix-1 would work, TODO
// printf("Dealing with common prefix\n");
// while (i<m&&j<n&&sequences[MINDICE(is,i-1,nseq)]==sequences[MINDICE(js,j-1,nseq)]) {
// i++;
// j++;
// prefix++;
// }
//+1 pour correspondre ? la matrice F
// printf("Dealing with FMAT\n");
while (i<m) {
j=prefix+1;
// printf("i loop: %d %d\n",i,j);
while (j<n) {
// printf("j loop: %d %d\n",i,j);
i_state=sequences[MINDICE(is,i-1,nseq)];
j_state=sequences[MINDICE(js,j-1,nseq)];
// printf("States: %d %d\n",i_state,j_state);
if (i==1) { // BH: set previous to dummy value if before start, else previous
i_m1_state=1;
} else {
i_m1_state=sequences[MINDICE(is,i-2,nseq)];
}
// printf("States i/j and - 1: %d %d %d %d\n",i_state,j_state,i_m1_state,j_m1_state);
if (j==1) {
j_m1_state=1;
} else {
j_m1_state=sequences[MINDICE(js,j-2,nseq)];
}
// printf("test 1\n");
// j_m1_state=sequences[MINDICE(js,j-2,nseq)]; // needs a test for i==1 | j==1
if ((i_state == j_state) && (i_m1_state == j_m1_state)) {
cost = 0;
} else {
cost = scost[MINDICE(i_state,j_state,alphasize)]
+ scost[MINDICE(i_m1_state,j_m1_state,alphasize)];
// Rprintf("costs = %d %d, %d => %f \n",MINDICE(i_state,j_state,alphasize),i_state,j_state,cost);
}
i_warp = fmat[MINDICE(i-prefix,j-1-prefix,fmatsize)] +
scost[MINDICE(j_state,j_m1_state,alphasize)]
+ nu + lambda;
j_warp = fmat[MINDICE(i-1-prefix,j-prefix,fmatsize)]+
scost[MINDICE(i_state,i_m1_state,alphasize)]
+ nu + lambda;
sub = fmat[MINDICE(i-1-prefix,j-1-prefix,fmatsize)]+ cost + 2*nu*abs(i-j);
// printf("i j iw ij match: %d %d %5.2f %5.2f %5.2f\n",i,j,i_warp, j_warp, sub);
minimum = i_warp;
if (j_warp < minimum) minimum = j_warp;
if (sub < minimum) minimum = sub;
fmat[MINDICE(i-prefix,j-prefix,fmatsize)]=minimum;
j++;
}
i++;
}//Fmat build
// for (i=1; i<m; i++) {
// printf("%c", 65+sequences[MINDICE(is,i-1,nseq)]);
// }
// printf("\n");
// for (i=1; i<m; i++) {
// printf("%c", 65+sequences[MINDICE(js,i-1,nseq)]);
// }
// printf("\n");
// for (i=0; i<m; i++) {
// for (j=0; j<n; j++) {
// printf(" %5.2f", fmat[MINDICE(i,j,fmatsize)]);
// }
// printf("\n");
// }
// printf("Finished with FMAT\n");
m--;
n--;
//Warning! m and n decreased!!!!!
maxpossiblecost=abs(n-m)*lambda+maxscost*fmin2((double)m,(double)n); // BH: indel replaced with lambda, probably incorrect May 30 2013 15:57:59
return normalizeDistance(fmat[MINDICE(m-prefix,n-prefix,fmatsize)], maxpossiblecost, m, n);
}
