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 */