double psignrank(double x, double n, int lower_tail, int log_p)
{
int i;
double f, p;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n))
return(x + n);
#endif
if (!R_FINITE(n)) ML_ERR_return_NAN;
n = floor(n + 0.5);
if (n <= 0) ML_ERR_return_NAN;
x = floor(x + 1e-7);
if (x < 0.0)
return(R_DT_0);
if (x >= n * (n + 1) / 2)
return(R_DT_1);
w_init_maybe(n);
f = exp(- n * M_LN2);
p = 0;
if (x <= (n * (n + 1) / 4)) {
for (i = 0; i <= x; i++)
p += csignrank(i, n) * f;
}
else {
x = n * (n + 1) / 2 - x;
for (i = 0; i < x; i++)
p += csignrank(i, n) * f;
lower_tail = !lower_tail; /* p = 1 - p; */
}
return(R_DT_val(p));
} /* psignrank() */
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);
}
double qwilcox(double x, double m, double n, int lower_tail, int log_p)
{
double c, p;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(m) || ISNAN(n))
return(x + m + n);
#endif
if(!R_FINITE(x) || !R_FINITE(m) || !R_FINITE(n))
ML_ERR_return_NAN;
R_Q_P01_check(x);
m = R_forceint(m);
n = R_forceint(n);
if (m <= 0 || n <= 0)
ML_ERR_return_NAN;
if (x == R_DT_0)
return(0);
if (x == R_DT_1)
return(m * n);
if(log_p || !lower_tail)
x = R_DT_qIv(x); /* lower_tail,non-log "p" */
int mm = (int) m, nn = (int) n;
w_init_maybe(mm, nn);
c = choose(m + n, n);
p = 0;
int q = 0;
if (x <= 0.5) {
x = x - 10 * DBL_EPSILON;
for (;;) {
p += cwilcox(q, mm, nn) / c;
if (p >= x)
break;
q++;
}
}
else {
x = 1 - x + 10 * DBL_EPSILON;
for (;;) {
p += cwilcox(q, mm, nn) / c;
if (p > x) {
q = (int) (m * n - q);
break;
}
q++;
}
}
return(q);
}
double qsignrank(double x, double n, int lower_tail, int log_p)
{
double f, p;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n))
return(x + n);
#endif
if (!R_FINITE(x) || !R_FINITE(n))
ML_ERR_return_NAN;
R_Q_P01_check(x);
n = floor(n + 0.5);
if (n <= 0)
ML_ERR_return_NAN;
if (x == R_DT_0)
return(0);
if (x == R_DT_1)
return(n * (n + 1) / 2);
if(log_p || !lower_tail)
x = R_DT_qIv(x); /* lower_tail,non-log "p" */
int nn = (int) n;
w_init_maybe(nn);
f = exp(- n * M_LN2);
p = 0;
int q = 0;
if (x <= 0.5) {
x = x - 10 * DBL_EPSILON;
for (;;) {
p += csignrank(q, nn) * f;
if (p >= x)
break;
q++;
}
}
else {
x = 1 - x + 10 * DBL_EPSILON;
for (;;) {
p += csignrank(q, nn) * f;
if (p > x) {
q = (int)(n * (n + 1) / 2 - q);
break;
}
q++;
}
}
return(q);
}
/* args have the same meaning as R function pwilcox */
double pwilcox(double q, double m, double n, int lower_tail, int log_p)
{
int i;
double c, p;
#ifdef IEEE_754
if (ISNAN(q) || ISNAN(m) || ISNAN(n))
return(q + m + n);
#endif
if (!R_FINITE(m) || !R_FINITE(n))
ML_ERR_return_NAN;
m = R_forceint(m);
n = R_forceint(n);
if (m <= 0 || n <= 0)
ML_ERR_return_NAN;
q = floor(q + 1e-7);
if (q < 0.0)
return(R_DT_0);
if (q >= m * n)
return(R_DT_1);
int mm = (int) m, nn = (int) n;
w_init_maybe(mm, nn);
c = choose(m + n, n);
p = 0;
/* Use summation of probs over the shorter range */
if (q <= (m * n / 2)) {
for (i = 0; i <= q; i++)
p += cwilcox(i, mm, nn) / c;
}
else {
q = m * n - q;
for (i = 0; i < q; i++)
p += cwilcox(i, mm, nn) / c;
lower_tail = !lower_tail; /* p = 1 - p; */
}
return(R_DT_val(p));
} /* pwilcox */
double dsignrank(double x, double n, int give_log)
{
double d;
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(n)) return(x + n);
#endif
n = floor(n + 0.5);
if (n <= 0)
ML_ERR_return_NAN;
if (fabs(x - floor(x + 0.5)) > 1e-7)
return(R_D__0);
x = floor(x + 0.5);
if ((x < 0) || (x > (n * (n + 1) / 2)))
return(R_D__0);
w_init_maybe(n);
d = R_D_exp(log(csignrank(x, n)) - n * M_LN2);
return(d);
}
