// modificato il prototipo per aumentare l'efficienza
VETTOREi *sample1(VETTOREi *ris, int n, int k, int replace, double *p)
{
int *x;
int i, nc = 0;
GetRNGstate();
CREAv_i(ris, k);
// g_x mi serve comunque (e sempre di dim. n)
// OTTIMIZZATA da me!
CREAv_i(g_x, n); // cosi` non ho problemi nel caso sia troppo piccolo
x = g_x->dati;
if (p != NULL) {
FixupProb(p, n, k, replace);
if (replace) {
for (i = 0; i < n; i++) {
if (n * p[i] > 0.1)
nc++;
}
if (nc > 200)
walker_ProbSampleReplace(n, p, x, k, ris->dati);
else
ProbSampleReplace(n, p, x, k, ris->dati);
}
else
ProbSampleNoReplace(n, p, x, k, ris->dati);
}
else {
/* avoid allocation for a single sample */
if (replace || k < 2)
SampleReplace(k, n, ris->dati);
else { // ho gia` allocato g_x
SampleNoReplace(k, n, ris->dati, x);
}
}
PutRNGstate();
return ris;
}
SEXP Rmultinom(SEXP args)
{
SEXP prob, ans, nms;
int n, size, k, i, ik;
args = CDR(args);
n = asInteger(CAR(args)); args = CDR(args);/* n= #{samples} */
size = asInteger(CAR(args)); args = CDR(args);/* 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 = CAR(args);
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, /*require_k = */ 0, TRUE);
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;
}
