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