Example #1
0
// 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;
}
Example #2
0
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;
}