The R Project SVN – R – Diff – /trunk/src/main/random.c



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1997--2025  The R Core Team
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 2003--2018  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

NORET static void invalid(SEXP call)
{
    error(_("invalid arguments"));
}
 
static bool
random1(double (*f) (double), double *a, R_xlen_t na, double *x, R_xlen_t n)
{
    bool naflag = false;
    double ai;
    R_xlen_t i, ia;
    errno = 0;
    MOD_ITERATE1(n, na, i, ia, {
	ai = a[ia];
	x[i] = f(ai);
	if (ISNAN(x[i])) naflag = true;
    });
    return(naflag);
}
 
#define RAND1(num,name) \

	for (i = 0; i < n; i++)
	    REAL(x)[i] = NA_REAL;
	warning(_("NAs produced"));
    }
    else {
	bool naflag = false;
	PROTECT(a = coerceVector(CADR(args), REALSXP));
	GetRNGstate();
	switch (PRIMVAL(op)) {
	    RAND1(0, rchisq);
	    RAND1(1, rexp);

    }
    UNPROTECT(1);
    return x;
}
 
static bool random2(double (*f) (double, double),
			double *a, R_xlen_t na, double *b, R_xlen_t nb,
			double *x, R_xlen_t n)
{
    double ai, bi;
    R_xlen_t i, ia, ib;
    bool naflag = false;
    errno = 0;
    MOD_ITERATE2(n, na, nb, i, ia, ib, {
	ai = a[ia];
	bi = b[ib];
	x[i] = f(ai, bi);
	if (ISNAN(x[i])) naflag = true;
    });
    return(naflag);
}
 
#define RAND2(num,name) \

	for (i = 0; i < n; i++)
	    REAL(x)[i] = NA_REAL;
	warning(_("NAs produced"));
    }
    else {
	bool naflag = false;
	PROTECT(a = coerceVector(CADR(args), REALSXP));
	PROTECT(b = coerceVector(CADDR(args), REALSXP));
	GetRNGstate();
	switch (PRIMVAL(op)) {
	    RAND2(0, rbeta);

    }
    UNPROTECT(1);
    return x;
}
 
static bool
random3(double (*f) (double, double, double), double *a,
	R_xlen_t na, double *b, R_xlen_t nb, double *c, R_xlen_t nc,
	double *x, R_xlen_t n)
{
    double ai, bi, ci;
    R_xlen_t i, ia, ib, ic;
    bool naflag = false;
    errno = 0;
    MOD_ITERATE3(n, na, nb, nc, i, ia, ib, ic, {
	ai = a[ia];
	bi = b[ib];
	ci = c[ic];
	x[i] = f(ai, bi, ci);
	if (ISNAN(x[i])) naflag = true;
    });
    return(naflag);
}
 
#define RAND3(num,name) \

	for (i = 0; i < n; i++)
	    REAL(x)[i] = NA_REAL;
	warning(_("NAs produced"));
    }
    else {
	bool naflag = false;
	PROTECT(a = coerceVector(a, REALSXP));
	PROTECT(b = coerceVector(b, REALSXP));
	PROTECT(c = coerceVector(c, REALSXP));
	GetRNGstate();
	switch (PRIMVAL(op)) {

	    perm[k] = perm[k + 1];
	}
    }
}
 
static void FixupProb(double *p, int n, int require_k, bool replace)
{
    double sum = 0.0;
    int npos = 0;
    for (int i = 0; i < n; i++) {
	if (!R_FINITE(p[i]))

	if (MAYBE_REFERENCED(prob)) prob = duplicate(prob);
	PROTECT(prob);
	double *p = REAL(prob);
	if (length(prob) != n)
	    error(_("incorrect number of probabilities"));
	FixupProb(p, n, k, (bool) replace);
	PROTECT(x = allocVector(INTSXP, n));
	if (replace) {
	    int i, nc = 0;
	    for (i = 0; i < n; i++) if(n * p[i] > 0.1) nc++;
	    if (nc > 200)

Rev 87465	Rev 87891
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1997--2022 The R Core Team`	3	`* Copyright (C) 1997--2025 The R Core Team`
4	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	4	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
5	`* Copyright (C) 2003--2018 The R Foundation`	5	`* Copyright (C) 2003--2018 The R Foundation`
6	`*`	6	`*`
7	`* This program is free software; you can redistribute it and/or modify`	7	`* This program is free software; you can redistribute it and/or modify`
8	`* it under the terms of the GNU General Public License as published by`	8	`* it under the terms of the GNU General Public License as published by`
Line 37...	Line 37...
37	`NORET static void invalid(SEXP call)`	37	`NORET static void invalid(SEXP call)`
38	`{`	38	`{`
39	`error(_("invalid arguments"));`	39	`error(_("invalid arguments"));`
40	`}`	40	`}`
41		41
42	`static Rboolean`	42	`static bool`
43	`random1(double (f) (double), double a, R_xlen_t na, double *x, R_xlen_t n)`	43	`random1(double (f) (double), double a, R_xlen_t na, double *x, R_xlen_t n)`
44	`{`	44	`{`
45	`Rboolean naflag = FALSE;`	45	`bool naflag = false;`
46	`double ai;`	46	`double ai;`
47	`R_xlen_t i, ia;`	47	`R_xlen_t i, ia;`
48	`errno = 0;`	48	`errno = 0;`
49	`MOD_ITERATE1(n, na, i, ia, {`	49	`MOD_ITERATE1(n, na, i, ia, {`
50	`ai = a[ia];`	50	`ai = a[ia];`
51	`x[i] = f(ai);`	51	`x[i] = f(ai);`
52	`if (ISNAN(x[i])) naflag = TRUE;`	52	`if (ISNAN(x[i])) naflag = true;`
53	`});`	53	`});`
54	`return(naflag);`	54	`return(naflag);`
55	`}`	55	`}`
56		56
57	`#define RAND1(num,name) \`	57	`#define RAND1(num,name) \`
Line 93...	Line 93...
93	`for (i = 0; i < n; i++)`	93	`for (i = 0; i < n; i++)`
94	`REAL(x)[i] = NA_REAL;`	94	`REAL(x)[i] = NA_REAL;`
95	`warning(_("NAs produced"));`	95	`warning(_("NAs produced"));`
96	`}`	96	`}`
97	`else {`	97	`else {`
98	`Rboolean naflag = FALSE;`	98	`bool naflag = false;`
99	`PROTECT(a = coerceVector(CADR(args), REALSXP));`	99	`PROTECT(a = coerceVector(CADR(args), REALSXP));`
100	`GetRNGstate();`	100	`GetRNGstate();`
101	`switch (PRIMVAL(op)) {`	101	`switch (PRIMVAL(op)) {`
102	`RAND1(0, rchisq);`	102	`RAND1(0, rchisq);`
103	`RAND1(1, rexp);`	103	`RAND1(1, rexp);`
Line 116...	Line 116...
116	`}`	116	`}`
117	`UNPROTECT(1);`	117	`UNPROTECT(1);`
118	`return x;`	118	`return x;`
119	`}`	119	`}`
120		120
121	`static Rboolean random2(double (*f) (double, double),`	121	`static bool random2(double (*f) (double, double),`
122	`double a, R_xlen_t na, double b, R_xlen_t nb,`	122	`double a, R_xlen_t na, double b, R_xlen_t nb,`
123	`double *x, R_xlen_t n)`	123	`double *x, R_xlen_t n)`
124	`{`	124	`{`
125	`double ai, bi;`	125	`double ai, bi;`
126	`R_xlen_t i, ia, ib;`	126	`R_xlen_t i, ia, ib;`
127	`Rboolean naflag = FALSE;`	127	`bool naflag = false;`
128	`errno = 0;`	128	`errno = 0;`
129	`MOD_ITERATE2(n, na, nb, i, ia, ib, {`	129	`MOD_ITERATE2(n, na, nb, i, ia, ib, {`
130	`ai = a[ia];`	130	`ai = a[ia];`
131	`bi = b[ib];`	131	`bi = b[ib];`
132	`x[i] = f(ai, bi);`	132	`x[i] = f(ai, bi);`
133	`if (ISNAN(x[i])) naflag = TRUE;`	133	`if (ISNAN(x[i])) naflag = true;`
134	`});`	134	`});`
135	`return(naflag);`	135	`return(naflag);`
136	`}`	136	`}`
137		137
138	`#define RAND2(num,name) \`	138	`#define RAND2(num,name) \`
Line 176...	Line 176...
176	`for (i = 0; i < n; i++)`	176	`for (i = 0; i < n; i++)`
177	`REAL(x)[i] = NA_REAL;`	177	`REAL(x)[i] = NA_REAL;`
178	`warning(_("NAs produced"));`	178	`warning(_("NAs produced"));`
179	`}`	179	`}`
180	`else {`	180	`else {`
181	`Rboolean naflag = FALSE;`	181	`bool naflag = false;`
182	`PROTECT(a = coerceVector(CADR(args), REALSXP));`	182	`PROTECT(a = coerceVector(CADR(args), REALSXP));`
183	`PROTECT(b = coerceVector(CADDR(args), REALSXP));`	183	`PROTECT(b = coerceVector(CADDR(args), REALSXP));`
184	`GetRNGstate();`	184	`GetRNGstate();`
185	`switch (PRIMVAL(op)) {`	185	`switch (PRIMVAL(op)) {`
186	`RAND2(0, rbeta);`	186	`RAND2(0, rbeta);`
Line 208...	Line 208...
208	`}`	208	`}`
209	`UNPROTECT(1);`	209	`UNPROTECT(1);`
210	`return x;`	210	`return x;`
211	`}`	211	`}`
212		212
213	`static Rboolean`	213	`static bool`
214	`random3(double (f) (double, double, double), double a,`	214	`random3(double (f) (double, double, double), double a,`
215	`R_xlen_t na, double b, R_xlen_t nb, double c, R_xlen_t nc,`	215	`R_xlen_t na, double b, R_xlen_t nb, double c, R_xlen_t nc,`
216	`double *x, R_xlen_t n)`	216	`double *x, R_xlen_t n)`
217	`{`	217	`{`
218	`double ai, bi, ci;`	218	`double ai, bi, ci;`
219	`R_xlen_t i, ia, ib, ic;`	219	`R_xlen_t i, ia, ib, ic;`
220	`Rboolean naflag = FALSE;`	220	`bool naflag = false;`
221	`errno = 0;`	221	`errno = 0;`
222	`MOD_ITERATE3(n, na, nb, nc, i, ia, ib, ic, {`	222	`MOD_ITERATE3(n, na, nb, nc, i, ia, ib, ic, {`
223	`ai = a[ia];`	223	`ai = a[ia];`
224	`bi = b[ib];`	224	`bi = b[ib];`
225	`ci = c[ic];`	225	`ci = c[ic];`
226	`x[i] = f(ai, bi, ci);`	226	`x[i] = f(ai, bi, ci);`
227	`if (ISNAN(x[i])) naflag = TRUE;`	227	`if (ISNAN(x[i])) naflag = true;`
228	`});`	228	`});`
229	`return(naflag);`	229	`return(naflag);`
230	`}`	230	`}`
231		231
232	`#define RAND3(num,name) \`	232	`#define RAND3(num,name) \`
Line 275...	Line 275...
275	`for (i = 0; i < n; i++)`	275	`for (i = 0; i < n; i++)`
276	`REAL(x)[i] = NA_REAL;`	276	`REAL(x)[i] = NA_REAL;`
277	`warning(_("NAs produced"));`	277	`warning(_("NAs produced"));`
278	`}`	278	`}`
279	`else {`	279	`else {`
280	`Rboolean naflag = FALSE;`	280	`bool naflag = false;`
281	`PROTECT(a = coerceVector(a, REALSXP));`	281	`PROTECT(a = coerceVector(a, REALSXP));`
282	`PROTECT(b = coerceVector(b, REALSXP));`	282	`PROTECT(b = coerceVector(b, REALSXP));`
283	`PROTECT(c = coerceVector(c, REALSXP));`	283	`PROTECT(c = coerceVector(c, REALSXP));`
284	`GetRNGstate();`	284	`GetRNGstate();`
285	`switch (PRIMVAL(op)) {`	285	`switch (PRIMVAL(op)) {`
Line 435...	Line 435...
435	`perm[k] = perm[k + 1];`	435	`perm[k] = perm[k + 1];`
436	`}`	436	`}`
437	`}`	437	`}`
438	`}`	438	`}`
439		439
440	`static void FixupProb(double *p, int n, int require_k, Rboolean replace)`	440	`static void FixupProb(double *p, int n, int require_k, bool replace)`
441	`{`	441	`{`
442	`double sum = 0.0;`	442	`double sum = 0.0;`
443	`int npos = 0;`	443	`int npos = 0;`
444	`for (int i = 0; i < n; i++) {`	444	`for (int i = 0; i < n; i++) {`
445	`if (!R_FINITE(p[i]))`	445	`if (!R_FINITE(p[i]))`
Line 489...	Line 489...
489	`if (MAYBE_REFERENCED(prob)) prob = duplicate(prob);`	489	`if (MAYBE_REFERENCED(prob)) prob = duplicate(prob);`
490	`PROTECT(prob);`	490	`PROTECT(prob);`
491	`double *p = REAL(prob);`	491	`double *p = REAL(prob);`
492	`if (length(prob) != n)`	492	`if (length(prob) != n)`
493	`error(_("incorrect number of probabilities"));`	493	`error(_("incorrect number of probabilities"));`
494	`FixupProb(p, n, k, (Rboolean) replace);`	494	`FixupProb(p, n, k, (bool) replace);`
495	`PROTECT(x = allocVector(INTSXP, n));`	495	`PROTECT(x = allocVector(INTSXP, n));`
496	`if (replace) {`	496	`if (replace) {`
497	`int i, nc = 0;`	497	`int i, nc = 0;`
498	`for (i = 0; i < n; i++) if(n * p[i] > 0.1) nc++;`	498	`for (i = 0; i < n; i++) if(n * p[i] > 0.1) nc++;`
499	`if (nc > 200)`	499	`if (nc > 200)`

The R Project SVN R

(root)/trunk/src/main/random.c @ 63243 – Rev 87465 → 87891