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);
}
/* This counts the number of choices with statistic = k */
double PWilcox::cwilcox(int k, int m, int n, double*** w) {
try {
int c, u, i, j, l;
if (mout->control_pressed) {
return 0;
}
u = m * n;
if (k < 0 || k > u)
return(0);
c = (int)(u / 2);
if (k > c)
k = u - k; /* hence k <= floor(u / 2) */
if (m < n) {
i = m;
j = n;
} else {
i = n;
j = m;
} /* hence i <= j */
if (j == 0) /* and hence i == 0 */
return (k == 0);
/* We can simplify things if k is small. Consider the Mann-Whitney
definition, and sort y. Then if the statistic is k, no more
than k of the y's can be <= any x[i], and since they are sorted
these can only be in the first k. So the count is the same as
if there were just k y's.
*/
if (j > 0 && k < j) return cwilcox(k, i, k, w);
if (w[i][j] == 0) {
w[i][j] = (double *) calloc((size_t) c + 1, sizeof(double));
for (l = 0; l <= c; l++)
w[i][j][l] = -1;
}
if (w[i][j][k] < 0) {
if (j == 0) /* and hence i == 0 */
w[i][j][k] = (k == 0);
else
w[i][j][k] = cwilcox(k - j, i - 1, j, w) + cwilcox(k, i, j - 1, w);
}
return(w[i][j][k]);
}
catch(exception& e) {
mout->errorOut(e, "PWilcox", "cwilcox");
exit(1);
}
}
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);
}
/* This counts the number of choices with statistic = k */
static double
cwilcox(int k, int m, int n)
{
int c, u, i, j, l;
#ifndef MATHLIB_STANDALONE
R_CheckUserInterrupt();
#endif
u = m * n;
if (k < 0 || k > u)
return(0);
c = (int)(u / 2);
if (k > c)
k = u - k; /* hence k <= floor(u / 2) */
if (m < n) {
i = m; j = n;
} else {
i = n; j = m;
} /* hence i <= j */
if (j == 0) /* and hence i == 0 */
return (k == 0);
/* We can simplify things if k is small. Consider the Mann-Whitney
definition, and sort y. Then if the statistic is k, no more
than k of the y's can be <= any x[i], and since they are sorted
these can only be in the first k. So the count is the same as
if there were just k y's.
*/
if (j > 0 && k < j) return cwilcox(k, i, k);
if (w[i][j] == 0) {
w[i][j] = (double *) calloc((size_t) c + 1, sizeof(double));
#ifdef MATHLIB_STANDALONE
if (!w[i][j]) MATHLIB_ERROR(_("wilcox allocation error %d"), 3);
#endif
for (l = 0; l <= c; l++)
w[i][j][l] = -1;
}
if (w[i][j][k] < 0) {
if (j == 0) /* and hence i == 0 */
w[i][j][k] = (k == 0);
else
w[i][j][k] = cwilcox(k - j, i - 1, j) + cwilcox(k, i, j - 1);
}
return(w[i][j][k]);
}
/* 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 */
/* args have the same meaning as R function pwilcox */
double PWilcox::pwilcox(double q, double m, double n, bool lower_tail) {
try {
int i;
double c, p;
bool log_p = false;
double*** w;
if (isnan(m) || isnan(n))
{
return 0;
}
m = floor(m + 0.5);
n = floor(n + 0.5);
if (m <= 0 || n <= 0) {
return 0;
}
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;
if (mout->control_pressed) {
return 0;
}
//w_init_maybe(mm, nn);
/********************************************/
int thisi;
if (mm > nn) {
thisi = nn;
nn = mm;
mm = thisi;
}
mm = max(mm, 50);
nn = max(nn, 50);
w = (double ***) calloc((size_t) mm + 1, sizeof(double **));
for (thisi = 0; thisi <= mm; thisi++) {
w[thisi] = (double **) calloc((size_t) nn + 1, sizeof(double *));
}
allocated_m = m;
allocated_n = n;
/********************************************/
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, m, n, w) / c;
}
else {
q = m * n - q;
for (i = 0; i < q; i++) {
p += cwilcox(i, m, n, w) / c;
}
lower_tail = !lower_tail; /* p = 1 - p; */
}
//free w
/********************************************/
for (int i = allocated_m; i >= 0; i--) {
for (int j = allocated_n; j >= 0; j--) {
if (w[i][j] != 0)
free((void *) w[i][j]);
}
free((void *) w[i]);
}
free((void *) w);
w = 0;
allocated_m = allocated_n = 0;
/********************************************/
return(R_DT_val(p));
}
catch(exception& e) {
mout->errorOut(e, "PWilcox", "pwilcox");
exit(1);
}
} /* pwilcox */
