https://github.com/cran/rsprng
Tip revision: 84b888fdead7358e6c5f9270add18016996a368a authored by Na (Michael) Li on 01 March 2010, 00:00:00 UTC
version 1.0
version 1.0
Tip revision: 84b888f
sprng_core.c
/*
* Wrapper to core functions of sprng.
* $Id: sprng_core.c,v 1.6 2003/04/17 19:08:05 nali Exp $
*
**/
#include <R.h>
#include <Rdefines.h>
#include <R_ext/Random.h>
#include "sprng.h"
#include <string.h>
/*
* This struct is used to retrieve "rng_type" from the rng specific
* "struct rngen". RNGs have different definitions for "struct rngen",
* however, its first field must be the integer "rng_type"
*
* It is defined in sprng.c but not in sprng.h
*/
struct rngen
{
int rng_type;
};
static int *streamid = 0;
static double rn = 0.0;
SEXP r_init_sprng (SEXP sexp_gtype,
SEXP sexp_streamno,
SEXP sexp_nstreams,
SEXP sexp_seed,
SEXP sexp_param)
{
int gtype = INTEGER (sexp_gtype)[0];
int streamno = INTEGER (sexp_streamno)[0];
int nstreams = INTEGER (sexp_nstreams)[0];
int seed = INTEGER (sexp_seed)[0];
int param = INTEGER (sexp_param)[0];
streamid = init_sprng (gtype, streamno, nstreams, seed, param);
return R_NilValue;
}
SEXP r_pack_sprng ()
{
char *rng_buffer = 0;
int s = 0;
int i = 0;
SEXP sexp_buffer = 0;
if (streamid) {
s = pack_sprng (streamid, &rng_buffer);
PROTECT (sexp_buffer = allocVector (INTSXP, s));
for (i = 0; i < s; ++i) {
INTEGER(sexp_buffer)[i] = (int) rng_buffer[i];
}
UNPROTECT (1);
free (rng_buffer);
return sexp_buffer;
} else {
return R_NilValue;
}
}
SEXP r_free_sprng ()
{
SEXP sexp_oldrng_buffer = 0;
int nstream = 0;
if (streamid) {
sexp_oldrng_buffer = r_pack_sprng ();
nstream = free_sprng (streamid);
streamid = 0;
return sexp_oldrng_buffer;
} else {
return R_NilValue;
}
}
SEXP r_unpack_sprng (SEXP sexp_packed_stream)
{
SEXP sexp_oldrng_buffer = 0;
char *rng_buffer = 0;
int s = length (sexp_packed_stream);
int i = 0;
int have_oldstream = 0;
rng_buffer = (char *) R_alloc (s, sizeof (char));
for (i = 0; i < s; ++i) {
rng_buffer[i] = (char) INTEGER (sexp_packed_stream)[i];
}
if (streamid) {
have_oldstream = 1;
sexp_oldrng_buffer = r_free_sprng ();
}
streamid = unpack_sprng (rng_buffer);
if (have_oldstream) {
return sexp_oldrng_buffer;
} else {
return R_NilValue;
}
}
SEXP r_spawn_new_sprng (SEXP sexp_gtype,
SEXP sexp_nstreams,
SEXP sexp_seed,
SEXP sexp_param)
{
int gtype = INTEGER (sexp_gtype)[0];
int nstreams = INTEGER (sexp_nstreams)[0];
int seed = INTEGER (sexp_seed)[0];
int param = INTEGER (sexp_param)[0];
int *savedstream = streamid;
int i = 0;
SEXP sexp_spawned_streams;
PROTECT (sexp_spawned_streams = allocVector (VECSXP, nstreams));
for (i = 0; i < nstreams; ++i) {
streamid = init_sprng (gtype, i, nstreams, seed, param);
SET_VECTOR_ELT (sexp_spawned_streams, i, r_pack_sprng ());
free_sprng (streamid);
}
UNPROTECT (1);
streamid = savedstream;
return sexp_spawned_streams;
}
SEXP r_spawn_sprng (SEXP sexp_nspawned)
{
int **newstreams = 0;
int *savedstream = streamid;
int i = 0;
int nspawned = INTEGER (sexp_nspawned)[0];
SEXP sexp_spawned_streams = 0;
if (streamid) {
nspawned = spawn_sprng (streamid, nspawned, &newstreams);
} else {
error ("No active sprng avaiable!");
return R_NilValue;
}
PROTECT (sexp_spawned_streams = allocVector (VECSXP, nspawned));
for (i = 0; i < nspawned; ++i) {
streamid = newstreams[i];
SET_VECTOR_ELT (sexp_spawned_streams, i, r_pack_sprng ());
free_sprng (streamid);
}
UNPROTECT (1);
streamid = savedstream;
return sexp_spawned_streams;
}
SEXP r_type_sprng ()
{
int gtype = ((struct rngen *) streamid)->rng_type;
char *type = 0;
switch (gtype) {
case SPRNG_LFG :
type = "LFG";
break;
case SPRNG_LCG :
type = "LCG";
break;
case SPRNG_LCG64 :
type = "LCF64";
break;
case SPRNG_CMRG :
type = "CMRG";
break;
case SPRNG_MLFG :
type = "MLFG";
break;
case SPRNG_PMLCG :
type = "PMLCG";
break;
default :
break;
}
return mkString (type);
}
/* R entry points */
double *user_unif_rand ()
{
rn = sprng (streamid);
return &rn;
}
/*
void user_unif_init (Int32 seed_in)
{
}
int *user_unif_nseed () {
}
int *user_unif_seedloc () {
}
*/