static void
w_init_maybe(int m, int n)
{
int i;
if (m > n) {
i = n; n = m; m = i;
}
if (w && (m > allocated_m || n > allocated_n))
w_free(allocated_m, allocated_n); /* zeroes w */
if (!w) { /* initialize w[][] */
m = imax2(m, WILCOX_MAX);
n = imax2(n, WILCOX_MAX);
w = (double ***) calloc((size_t) m + 1, sizeof(double **));
#ifdef MATHLIB_STANDALONE
if (!w) MATHLIB_ERROR(_("wilcox allocation error %d"), 1);
#endif
for (i = 0; i <= m; i++) {
w[i] = (double **) calloc((size_t) n + 1, sizeof(double *));
#ifdef MATHLIB_STANDALONE
/* the apparent leak here in the in-R case should be
swept up by the on.exit action */
if (!w[i]) {
/* first free all earlier allocations */
w_free(i-1, n);
MATHLIB_ERROR(_("wilcox allocation error %d"), 2);
}
#endif
}
allocated_m = m; allocated_n = n;
}
}
double rwilcox(double m, double n)
{
int i, j, k, *x;
double r;
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(m) || ISNAN(n))
return(m + n);
#endif
m = R_forceint(m);
n = R_forceint(n);
if ((m < 0) || (n < 0))
ML_ERR_return_NAN;
if ((m == 0) || (n == 0))
return(0);
r = 0.0;
k = (int) (m + n);
x = (int *) calloc((size_t) k, sizeof(int));
#ifdef MATHLIB_STANDALONE
if (!x) MATHLIB_ERROR(_("wilcox allocation error %d"), 4);
#endif
for (i = 0; i < k; i++)
x[i] = i;
for (i = 0; i < n; i++) {
j = (int) floor(k * unif_rand());
r += x[j];
x[j] = x[--k];
}
free(x);
return(r - n * (n - 1) / 2);
}
void rmultinom(int n, double* prob, int K, int* rN)
/* `Return' vector rN[1:K] {K := length(prob)}
* where rN[j] ~ Bin(n, prob[j]) , sum_j rN[j] == n, sum_j prob[j] == 1,
*/
{
int k;
double pp;
LDOUBLE p_tot = 0.;
/* This calculation is sensitive to exact values, so we try to
ensure that the calculations are as accurate as possible
so different platforms are more likely to give the same
result. */
#ifdef MATHLIB_STANDALONE
if (K < 1) {
ML_ERROR(ME_DOMAIN, "rmultinom");
return;
}
if (n < 0) ML_ERR_ret_NAN(0);
#else
if (K == NA_INTEGER || K < 1) {
ML_ERROR(ME_DOMAIN, "rmultinom");
return;
}
if (n == NA_INTEGER || n < 0) ML_ERR_ret_NAN(0);
#endif
/* Note: prob[K] is only used here for checking sum_k prob[k] = 1 ;
* Could make loop one shorter and drop that check !
*/
for(k = 0; k < K; k++) {
pp = prob[k];
if (!R_FINITE(pp) || pp < 0. || pp > 1.) ML_ERR_ret_NAN(k);
p_tot += pp;
rN[k] = 0;
}
if(fabs((double)(p_tot - 1.)) > 1e-7)
MATHLIB_ERROR(_("rbinom: probability sum should be 1, but is %g"),
(double) p_tot);
if (n == 0) return;
if (K == 1 && p_tot == 0.) return;/* trivial border case: do as rbinom */
/* Generate the first K-1 obs. via binomials */
for(k = 0; k < K-1; k++) { /* (p_tot, n) are for "remaining binomial" */
if(prob[k]) {
pp = (double)(prob[k] / p_tot);
/* printf("[%d] %.17f\n", k+1, pp); */
rN[k] = ((pp < 1.) ? (int) rbinom((double) n, pp) :
/*>= 1; > 1 happens because of rounding */
n);
n -= rN[k];
}
else rN[k] = 0;
if(n <= 0) /* we have all*/ return;
p_tot -= prob[k]; /* i.e. = sum(prob[(k+1):K]) */
}
rN[K-1] = n;
return;
}
// unused now from R
double bessel_j(double x, double alpha)
{
int nb, ncalc;
double na, *bj;
#ifndef MATHLIB_STANDALONE
const void *vmax;
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
if (x < 0) {
ML_ERROR(ME_RANGE, "bessel_j");
return ML_NAN;
}
na = floor(alpha);
if (alpha < 0) {
/* Using Abramowitz & Stegun 9.1.2
* this may not be quite optimal (CPU and accuracy wise) */
return(((alpha - na == 0.5) ? 0 : bessel_j(x, -alpha) * cospi(alpha)) +
((alpha == na ) ? 0 : bessel_y(x, -alpha) * sinpi(alpha)));
}
else if (alpha > 1e7) {
MATHLIB_WARNING("besselJ(x, nu): nu=%g too large for bessel_j() algorithm", alpha);
return ML_NAN;
}
nb = 1 + (int)na; /* nb-1 <= alpha < nb */
alpha -= (double)(nb-1);
#ifdef MATHLIB_STANDALONE
bj = (double *) calloc(nb, sizeof(double));
#ifndef _RENJIN
if (!bj) MATHLIB_ERROR("%s", _("bessel_j allocation error"));
#endif
#else
vmax = vmaxget();
bj = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
J_bessel(&x, &alpha, &nb, bj, &ncalc);
if(ncalc != nb) {/* error input */
if(ncalc < 0)
MATHLIB_WARNING4(_("bessel_j(%g): ncalc (=%d) != nb (=%d); alpha=%g. Arg. out of range?\n"),
x, ncalc, nb, alpha);
else
MATHLIB_WARNING2(_("bessel_j(%g,nu=%g): precision lost in result\n"),
x, alpha+(double)nb-1);
}
x = bj[nb-1];
#ifdef MATHLIB_STANDALONE
free(bj);
#else
vmaxset(vmax);
#endif
return x;
}
double bessel_y(double x, double alpha)
{
long nb, ncalc;
double na, *by;
#ifndef MATHLIB_STANDALONE
const void *vmax;
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
if (x < 0) {
ML_ERROR(ME_RANGE, "bessel_y");
return ML_NAN;
}
na = floor(alpha);
if (alpha < 0) {
/* Using Abramowitz & Stegun 9.1.2
* this may not be quite optimal (CPU and accuracy wise) */
return(bessel_y(x, -alpha) * cos(M_PI * alpha) -
((alpha == na) ? 0 :
bessel_j(x, -alpha) * sin(M_PI * alpha)));
}
nb = 1+ (long)na;/* nb-1 <= alpha < nb */
alpha -= (nb-1);
#ifdef MATHLIB_STANDALONE
by = (double *) calloc(nb, sizeof(double));
if (!by) MATHLIB_ERROR("%s", _("bessel_y allocation error"));
#else
vmax = vmaxget();
by = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
Y_bessel(&x, &alpha, &nb, by, &ncalc);
if(ncalc != nb) {/* error input */
if(ncalc == -1)
return ML_POSINF;
else if(ncalc < -1)
MATHLIB_WARNING4(_("bessel_y(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
x, ncalc, nb, alpha);
else /* ncalc >= 0 */
MATHLIB_WARNING2(_("bessel_y(%g,nu=%g): precision lost in result\n"),
x, alpha+nb-1);
}
x = by[nb-1];
#ifdef MATHLIB_STANDALONE
free(by);
#else
vmaxset(vmax);
#endif
return x;
}
/* 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]);
}
double bessel_k(double x, double alpha, double expo)
{
long nb, ncalc, ize;
double *bk;
#ifndef MATHLIB_STANDALONE
const void *vmax;
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
if (x < 0) {
ML_ERROR(ME_RANGE, "bessel_k");
return ML_NAN;
}
ize = (long)expo;
if(alpha < 0)
alpha = -alpha;
nb = 1+ (long)floor(alpha);/* nb-1 <= |alpha| < nb */
alpha -= (double)(nb-1);
#ifdef MATHLIB_STANDALONE
bk = (double *) calloc(nb, sizeof(double));
if (!bk) MATHLIB_ERROR("%s", _("bessel_k allocation error"));
#else
vmax = vmaxget();
bk = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
K_bessel(&x, &alpha, &nb, &ize, bk, &ncalc);
if(ncalc != nb) {/* error input */
if(ncalc < 0)
MATHLIB_WARNING4(_("bessel_k(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
x, ncalc, nb, alpha);
else
MATHLIB_WARNING2(_("bessel_k(%g,nu=%g): precision lost in result\n"),
x, alpha+(double)nb-1);
}
x = bk[nb-1];
#ifdef MATHLIB_STANDALONE
free(bk);
#else
vmaxset(vmax);
#endif
return x;
}
static void
w_init_maybe(int n)
{
int u, c;
u = n * (n + 1) / 2;
c = (u / 2);
if (w) {
if(n != allocated_n) {
w_free();
}
else return;
}
if(!w) {
w = (double *) calloc((size_t) c + 1, sizeof(double));
#ifdef MATHLIB_STANDALONE
if (!w) MATHLIB_ERROR("%s", _("signrank allocation error"));
#endif
allocated_n = n;
}
}
