| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka |
| * Copyright (C) 1997--2012 The R Core Team |
| * Copyright (C) 2003--2008 The R Foundation |
| * |
| * This program is free software; you can redistribute it and/or modify |
| * it under the terms of the GNU General Public License as published by |
| * the Free Software Foundation; either version 2 of the License, or |
| * (at your option) any later version. |
| * |
| * This program is distributed in the hope that it will be useful, |
| * but WITHOUT ANY WARRANTY; without even the implied warranty of |
| * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| * GNU General Public License for more details. |
| * |
| * You should have received a copy of the GNU General Public License |
| * along with this program; if not, a copy is available at |
| * https://www.R-project.org/Licenses/ |
| */ |
| |
| #ifdef HAVE_CONFIG_H |
| # include <config.h> |
| #endif |
| |
| #include <Defn.h> |
| #include <R_ext/Random.h> |
| #include <Rmath.h> /* for lgammafn, rmultinom */ |
| #include <errno.h> |
| #include "statsR.h" |
| #undef _ |
| #include "stats.h" // for rcont2 |
| |
| /* interval at which to check interrupts */ |
| #define NINTERRUPT 1000000 |
| |
| typedef double (*ran1) (double); |
| typedef double (*ran2) (double, double); |
| typedef double (*ran3) (double, double, double); |
| |
| static void fillWithNAs(SEXP x, R_xlen_t n, SEXPTYPE type) { |
| R_xlen_t i; |
| |
| if (type == INTSXP) { |
| for (i = 0; i < n; i++) { |
| INTEGER(x)[i] = NA_INTEGER; |
| } |
| } else { /* REALSXP */ |
| for (i = 0; i < n; i++) { |
| REAL(x)[i] = NA_REAL; |
| } |
| } |
| warning(_("NAs produced")); |
| } |
| |
| static R_INLINE R_xlen_t resultLength(SEXP lengthArgument) { |
| R_xlen_t n; |
| |
| if (!isVector(lengthArgument)) { |
| error(_("invalid arguments")); |
| } |
| if (XLENGTH(lengthArgument) == 1) { |
| #ifdef LONG_VECTOR_SUPPORT |
| double dn = asReal(lengthArgument); |
| if (ISNAN(dn) || dn < 0 || dn > R_XLEN_T_MAX) { |
| error(_("invalid arguments")); |
| } |
| n = (R_xlen_t) dn; |
| #else |
| n = asInteger(lengthArgument); |
| if (n == NA_INTEGER || n < 0) { |
| error(_("invalid arguments")); |
| } |
| #endif |
| } else { |
| n = XLENGTH(lengthArgument); |
| } |
| |
| return n; |
| } |
| |
| /* random sampling from 1 parameter families. */ |
| |
| static R_INLINE SEXP random1(SEXP sn, SEXP sa, ran1 fn, SEXPTYPE type) |
| { |
| SEXP x, a; |
| R_xlen_t n, na; |
| |
| if (!isNumeric(sa)) { |
| error(_("invalid arguments")); |
| } |
| n = resultLength(sn); |
| PROTECT(x = allocVector(type, n)); |
| if (n == 0) { |
| UNPROTECT(1); |
| return(x); |
| } |
| na = XLENGTH(sa); |
| if (na < 1) { |
| fillWithNAs(x, n, type); |
| } else { |
| Rboolean naflag = FALSE; |
| PROTECT(a = coerceVector(sa, REALSXP)); |
| GetRNGstate(); |
| double *ra = REAL(a); |
| errno = 0; |
| if (type == INTSXP) { |
| double rx; |
| int *ix = INTEGER(x); |
| |
| for (R_xlen_t i = 0; i < n; i++) { |
| // if ((i+1) % NINTERRUPT) R_CheckUserInterrupt(); |
| rx = fn(ra[i % na]); |
| if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN ) { |
| naflag = TRUE; |
| ix[i] = NA_INTEGER; |
| } |
| else ix[i] = (int) rx; |
| } |
| } else { |
| double *rx = REAL(x); |
| for (R_xlen_t i = 0; i < n; i++) { |
| // if ((i+1) % NINTERRUPT) R_CheckUserInterrupt(); |
| rx[i] = fn(ra[i % na]); |
| if (ISNAN(rx[i])) naflag = TRUE; |
| } |
| } |
| if (naflag) warning(_("NAs produced")); |
| PutRNGstate(); |
| UNPROTECT(1); |
| } |
| UNPROTECT(1); |
| return x; |
| } |
| |
| #define DEFRAND1_REAL(name) \ |
| SEXP do_##name(SEXP sn, SEXP sa) { \ |
| return random1(sn, sa, name, REALSXP); \ |
| } |
| |
| #define DEFRAND1_INT(name) \ |
| SEXP do_##name(SEXP sn, SEXP sa) { \ |
| return random1(sn, sa, name, INTSXP); \ |
| } |
| |
| DEFRAND1_REAL(rchisq) |
| DEFRAND1_REAL(rexp) |
| DEFRAND1_INT(rgeom) |
| DEFRAND1_INT(rpois) |
| DEFRAND1_REAL(rt) |
| DEFRAND1_INT(rsignrank) |
| |
| /* random sampling from 2 parameter families. */ |
| |
| static R_INLINE SEXP random2(SEXP sn, SEXP sa, SEXP sb, ran2 fn, SEXPTYPE type) |
| { |
| SEXP x, a, b; |
| R_xlen_t n, na, nb; |
| |
| if (!isNumeric(sa) || !isNumeric(sb)) { |
| error(_("invalid arguments")); |
| } |
| n = resultLength(sn); |
| PROTECT(x = allocVector(type, n)); |
| if (n == 0) { |
| UNPROTECT(1); |
| return(x); |
| } |
| na = XLENGTH(sa); |
| nb = XLENGTH(sb); |
| if (na < 1 || nb < 1) { |
| fillWithNAs(x, n, type); |
| } |
| else { |
| Rboolean naflag = FALSE; |
| PROTECT(a = coerceVector(sa, REALSXP)); |
| PROTECT(b = coerceVector(sb, REALSXP)); |
| GetRNGstate(); |
| double *ra = REAL(a), *rb = REAL(b); |
| if (type == INTSXP) { |
| int *ix = INTEGER(x); double rx; |
| errno = 0; |
| for (R_xlen_t i = 0; i < n; i++) { |
| // if ((i+1) % NINTERRUPT) R_CheckUserInterrupt(); |
| rx = fn(ra[i % na], rb[i % nb]); |
| if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN) { |
| naflag = TRUE; |
| ix[i] = NA_INTEGER; |
| } else ix[i] = (int) rx; |
| } |
| } else { |
| double *rx = REAL(x); |
| errno = 0; |
| for (R_xlen_t i = 0; i < n; i++) { |
| // if ((i+1) % NINTERRUPT) R_CheckUserInterrupt(); |
| rx[i] = fn(ra[i % na], rb[i % nb]); |
| if (ISNAN(rx[i])) naflag = TRUE; |
| } |
| } |
| if (naflag) warning(_("NAs produced")); |
| PutRNGstate(); |
| UNPROTECT(2); |
| } |
| UNPROTECT(1); |
| return x; |
| } |
| |
| #define DEFRAND2_REAL(name) \ |
| SEXP do_##name(SEXP sn, SEXP sa, SEXP sb) { \ |
| return random2(sn, sa, sb, name, REALSXP); \ |
| } |
| |
| #define DEFRAND2_INT(name) \ |
| SEXP do_##name(SEXP sn, SEXP sa, SEXP sb) { \ |
| return random2(sn, sa, sb, name, INTSXP); \ |
| } |
| |
| DEFRAND2_REAL(rbeta) |
| DEFRAND2_INT(rbinom) |
| DEFRAND2_REAL(rcauchy) |
| DEFRAND2_REAL(rf) |
| DEFRAND2_REAL(rgamma) |
| DEFRAND2_REAL(rlnorm) |
| DEFRAND2_REAL(rlogis) |
| DEFRAND2_INT(rnbinom) |
| DEFRAND2_REAL(rnorm) |
| DEFRAND2_REAL(runif) |
| DEFRAND2_REAL(rweibull) |
| DEFRAND2_INT(rwilcox) |
| DEFRAND2_REAL(rnchisq) |
| DEFRAND2_REAL(rnbinom_mu) |
| |
| /* random sampling from 3 parameter families. */ |
| |
| static R_INLINE SEXP random3(SEXP sn, SEXP sa, SEXP sb, SEXP sc, ran3 fn, |
| SEXPTYPE type) |
| { |
| SEXP x, a, b, c; |
| R_xlen_t n, na, nb, nc; |
| |
| if (!isNumeric(sa) || !isNumeric(sb) || !isNumeric(sc)) { |
| error(_("invalid arguments")); |
| } |
| n = resultLength(sn); |
| PROTECT(x = allocVector(type, n)); |
| if (n == 0) { |
| UNPROTECT(1); |
| return(x); |
| } |
| na = XLENGTH(sa); |
| nb = XLENGTH(sb); |
| nc = XLENGTH(sc); |
| if (na < 1 || nb < 1 || nc < 1) { |
| fillWithNAs(x, n, type); |
| } |
| else { |
| Rboolean naflag = FALSE; |
| PROTECT(a = coerceVector(sa, REALSXP)); |
| PROTECT(b = coerceVector(sb, REALSXP)); |
| PROTECT(c = coerceVector(sc, REALSXP)); |
| GetRNGstate(); |
| double *ra = REAL(a), *rb = REAL(b), *rc = REAL(c); |
| errno = 0; |
| if (type == INTSXP) { |
| int *ix = INTEGER(x); double rx; |
| errno = 0; |
| for (R_xlen_t i = 0; i < n; i++) { |
| // if ((i+1) % NINTERRUPT) R_CheckUserInterrupt(); |
| rx = fn(ra[i % na], rb[i % nb], rc[i % nc]); |
| if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN) { |
| naflag = TRUE; |
| ix[i] = NA_INTEGER; |
| } else ix[i] = (int) rx; |
| } |
| } else { |
| double *rx = REAL(x); |
| errno = 0; |
| for (R_xlen_t i = 0; i < n; i++) { |
| // if ((i+1) % NINTERRUPT) R_CheckUserInterrupt(); |
| rx[i] = fn(ra[i % na], rb[i % nb], rc[i % nc]); |
| if (ISNAN(rx[i])) naflag = TRUE; |
| } |
| } |
| if (naflag) warning(_("NAs produced")); |
| PutRNGstate(); |
| UNPROTECT(3); |
| } |
| UNPROTECT(1); |
| return x; |
| } |
| |
| #define DEFRAND3_REAL(name) \ |
| SEXP do_##name(SEXP sn, SEXP sa, SEXP sb, SEXP sc) { \ |
| return random3(sn, sa, sb, sc, name, REALSXP); \ |
| } |
| |
| #define DEFRAND3_INT(name) \ |
| SEXP do_##name(SEXP sn, SEXP sa, SEXP sb, SEXP sc) { \ |
| return random3(sn, sa, sb, sc, name, INTSXP); \ |
| } |
| |
| DEFRAND3_INT(rhyper) |
| |
| static void FixupProb(double *p, int n) |
| { |
| double sum = 0.0; |
| int npos = 0; |
| for (int i = 0; i < n; i++) { |
| if (!R_FINITE(p[i])) |
| error(_("NA in probability vector")); |
| if (p[i] < 0.0) |
| error(_("negative probability")); |
| if (p[i] > 0.0) { |
| npos++; |
| sum += p[i]; |
| } |
| } |
| if (npos == 0) error(_("no positive probabilities")); |
| for (int i = 0; i < n; i++) p[i] /= sum; |
| } |
| |
| SEXP do_rmultinom(SEXP sn, SEXP ssize, SEXP prob) |
| { |
| SEXP ans, nms; |
| int n, size, k, i, ik; |
| |
| n = asInteger(sn);/* n= #{samples} */ |
| size = asInteger(ssize);/* X ~ Multi(size, prob) */ |
| if (n == NA_INTEGER || n < 0) |
| error(_("invalid first argument 'n'")); |
| if (size == NA_INTEGER || size < 0) |
| error(_("invalid second argument 'size'")); |
| prob = coerceVector(prob, REALSXP); |
| k = length(prob);/* k = #{components or classes} = X-vector length */ |
| if (MAYBE_REFERENCED(prob)) prob = duplicate(prob);/*as `do_sample' -- need this line? */ |
| PROTECT(prob); |
| /* check and make sum = 1: */ |
| FixupProb(REAL(prob), k); |
| GetRNGstate(); |
| PROTECT(ans = allocMatrix(INTSXP, k, n));/* k x n : natural for columnwise store */ |
| for(i=ik = 0; i < n; i++, ik += k) { |
| // if ((i+1) % NINTERRUPT) R_CheckUserInterrupt(); |
| rmultinom(size, REAL(prob), k, &INTEGER(ans)[ik]); |
| } |
| PutRNGstate(); |
| if(!isNull(nms = getAttrib(prob, R_NamesSymbol))) { |
| SEXP dimnms; |
| PROTECT(nms); |
| PROTECT(dimnms = allocVector(VECSXP, 2)); |
| SET_VECTOR_ELT(dimnms, 0, nms); |
| setAttrib(ans, R_DimNamesSymbol, dimnms); |
| UNPROTECT(2); |
| } |
| UNPROTECT(2); |
| return ans; |
| } |
| |
| SEXP r2dtable(SEXP n, SEXP r, SEXP c) |
| { |
| int nr, nc, *row_sums, *col_sums, i, *jwork; |
| int n_of_samples, n_of_cases; |
| double *fact; |
| SEXP ans, tmp; |
| const void *vmax = vmaxget(); |
| |
| nr = length(r); |
| nc = length(c); |
| |
| /* Note that the R code in r2dtable() also checks for missing and |
| negative values. |
| Should maybe do the same here ... |
| */ |
| if(!isInteger(n) || (length(n) == 0) || |
| !isInteger(r) || (nr <= 1) || |
| !isInteger(c) || (nc <= 1)) |
| error(_("invalid arguments")); |
| |
| n_of_samples = INTEGER(n)[0]; |
| row_sums = INTEGER(r); |
| col_sums = INTEGER(c); |
| |
| /* Compute total number of cases as the sum of the row sums. |
| Note that the R code in r2dtable() also checks whether this is |
| the same as the sum of the col sums. |
| Should maybe do the same here ... |
| */ |
| n_of_cases = 0; |
| jwork = row_sums; |
| for(i = 0; i < nr; i++) |
| n_of_cases += *jwork++; |
| |
| /* Log-factorials from 0 to n_of_cases. |
| (I.e., lgamma(1), ..., lgamma(n_of_cases + 1).) |
| */ |
| fact = (double *) R_alloc(n_of_cases + 1, sizeof(double)); |
| fact[0] = 0.; |
| for(i = 1; i <= n_of_cases; i++) |
| fact[i] = lgammafn((double) (i + 1)); |
| |
| jwork = (int *) R_alloc(nc, sizeof(int)); |
| |
| PROTECT(ans = allocVector(VECSXP, n_of_samples)); |
| |
| GetRNGstate(); |
| |
| for(i = 0; i < n_of_samples; i++) { |
| PROTECT(tmp = allocMatrix(INTSXP, nr, nc)); |
| rcont2(&nr, &nc, row_sums, col_sums, &n_of_cases, fact, |
| jwork, INTEGER(tmp)); |
| SET_VECTOR_ELT(ans, i, tmp); |
| UNPROTECT(1); |
| } |
| |
| PutRNGstate(); |
| |
| UNPROTECT(1); |
| vmaxset(vmax); |
| |
| return(ans); |
| } |