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; } }