SEXP dieharderCallback(SEXP callback_sexp, SEXP bits_sexp, SEXP testnum_sexp,
SEXP seed_sexp, SEXP psamples_sexp, SEXP tsamples_sexp,
SEXP ntuple_sexp, SEXP quiet_sexp, SEXP verbose_sexp) {
initialize_globals(bits_sexp, seed_sexp, ntuple_sexp,
quiet_sexp, verbose_sexp);
Dtest *test_type = dh_test_types[INTEGER_VALUE(testnum_sexp)];
Test **test_results = create_test(test_type, INTEGER_VALUE(tsamples_sexp),
INTEGER_VALUE(psamples_sexp));
global_parsed_callback = parse_and_test_callback(callback_sexp);
if (global_parsed_callback) {
PROTECT(global_parsed_callback);
std_test(test_type, test_results);
UNPROTECT(1);
} else {
result = NULL;
}
global_parsed_callback = NULL;
output(test_type, test_results);
save_values_for_R(test_type, test_results);
destroy_test(test_type, test_results);
gsl_rng_free(rng);
rng = NULL;
reset_bit_buffers();
return result;
}
SEXP dieharder(SEXP genS, SEXP testS, SEXP seedS, SEXP psamplesS, SEXP verbS, SEXP infileS, SEXP ntupleS) {
int verb, testarg;
unsigned int i;
SEXP result = NULL, vec, pv, name, desc, nkps;
char *inputfile;
/* Setup argv to allow call of parsecl() to let dieharder set globals */
char *argv[] = { "dieharder" };
optind = 0;
parsecl(1, argv);
/* Parse 'our' parameters from R */
generator = INTEGER_VALUE(genS);
testarg = INTEGER_VALUE(testS);
diehard = rgb = sts = user = 0;
if (testarg < 100) {
diehard = testarg;
} else if (testarg < 200) {
rgb = testarg - 100;
} else if (testarg < 300) {
sts = testarg - 200;
} else {
user = testarg - 300;
}
Seed = (unsigned long int) INTEGER_VALUE(seedS); /* (user-select) Seed, not (save switch) seed */
psamples = INTEGER_VALUE(psamplesS);
verb = INTEGER_VALUE(verbS);
inputfile = (char*) CHARACTER_VALUE(infileS);
ntuple = INTEGER_VALUE(ntupleS);
rdh_testptr = NULL;
rdh_dtestptr = NULL; /* to be safe, explicitly flag as NULL; cf test in output.c */
if (strcmp(inputfile, "") != 0) {
strncpy(filename, inputfile, 128);
fromfile = 1; /* flag this as file input */
}
if (Seed == 0) {
seed = random_seed();
} else {
seed = (unsigned long int) Seed;
}
if (verb) {
Rprintf("Dieharder called with gen=%d test=%d seed=%lu\n", generator, diehard, seed);
quiet = 0;
hist_flag = 1;
} else {
quiet = 1; /* override dieharder command-line default */
hist_flag = 0;
}
/* Now do the work that dieharder.c does */
startup();
work();
gsl_rng_free(rng);
reset_bit_buffers();
/* And then bring our results back to R */
/* create vector of size four: [0] is vector (!!) ks_pv, [1] is pvalues vec, [2] name, [3] nkps */
PROTECT(result = allocVector(VECSXP, 4));
/* alloc vector and scalars, and set it */
PROTECT(pv = allocVector(REALSXP, rdh_dtestptr->nkps));
PROTECT(name = allocVector(STRSXP, 1));
PROTECT(nkps = allocVector(INTSXP, 1));
if (rdh_testptr != NULL && rdh_dtestptr != NULL) {
for (i=0; i<rdh_dtestptr->nkps; i++) { /* there can be nkps p-values per test */
REAL(pv)[i] = rdh_testptr[i]->ks_pvalue;
}
PROTECT(vec = allocVector(REALSXP, rdh_testptr[0]->psamples)); /* alloc vector and set it */
for (i = 0; i < rdh_testptr[0]->psamples; i++) {
REAL(vec)[i] = rdh_testptr[0]->pvalues[i];
}
SET_STRING_ELT(name, 0, mkChar(rdh_dtestptr->name));
INTEGER(nkps)[0] = rdh_dtestptr->nkps; /* nb of Kuiper KS p-values in pv vector */
} else {
PROTECT(vec = allocVector(REALSXP, 1));
REAL(pv)[0] = R_NaN;
REAL(vec)[0] = R_NaN;
SET_STRING_ELT(name, 0, mkChar(""));
INTEGER(nkps)[0] = R_NaN;
}
/* insert vectors and scalars into result vector */
SET_VECTOR_ELT(result, 0, pv);
SET_VECTOR_ELT(result, 1, vec);
SET_VECTOR_ELT(result, 2, name);
SET_VECTOR_ELT(result, 3, nkps);
UNPROTECT(5);
return result;
}
SEXP dieharder(SEXP genS, SEXP testS, SEXP seedS, SEXP psamplesS, SEXP verbS, SEXP infileS, SEXP ntupleS) {
/* In the RDieHarder/R/zzz.R startup code, dieharderGenerators()
* has already called dieharder_rng_types(), and dieharderTests()
* has already called dieharder_rng_tests(). The results are
* stored in RDieHarder:::.dieharderGenerators and
* RDieHarder:::.dieharderTests, as well as C static variables
* used by libdieharder. Since user defined generators and tests
* may have been added, we do not call these routines again.
*/
int verb;
char *inputfile;
char *argv[] = { "dieharder" }; /* Setup argv to allow call of parsecl() to let dieharder set globals */
optind = 0;
parsecl(1, argv); /* also covers part of setup_globals() */
generator = INTEGER_VALUE(genS); /* 'our' parameters from R; used below by choose_rng() and run_test() */
dtest_num = INTEGER_VALUE(testS);
Seed = (unsigned long int) INTEGER_VALUE(seedS); /* (user-select) Seed, not (save switch) seed */
psamples = INTEGER_VALUE(psamplesS);
verb = INTEGER_VALUE(verbS);
inputfile = (char*) CHARACTER_VALUE(infileS);
ntuple = INTEGER_VALUE(ntupleS);
result = NULL;
if (strcmp(inputfile, "") != 0) {
strncpy(filename, inputfile, 128);
fromfile = 1; /* flag this as file input */
}
if (Seed == 0) {
seed = random_seed();
} else {
seed = (unsigned long int) Seed;
}
if (verb) {
Rprintf("Dieharder called with gen=%d test=%d seed=%lu\n", generator, dtest_num, seed);
quiet = 0;
hist_flag = 1;
} else {
quiet = 1; /* override dieharder command-line default */
hist_flag = 0;
}
/*
* Pick a rng, establish a seed based on how things were initialized
* in parsecl() or elsewhere. Note that choose_rng() times the selected
* rng as a matter of course now.
*/
choose_rng();
/*
* At this point, a valid rng should be selected, allocated, and
* provisionally seeded. It -a(ll) is set (CLI only) run all the
* available tests on the selected rng, reseeding at the beginning of
* each test if Seed is nonzero. Otherwise, run the single selected
* test (which may still return a vector of pvalues) on the single
* selected rng. The CLI then goes on to exit; an interactive UI would
* presumably loop back to permit the user to run another test on the
* selected rng or select a new rng (and run more tests on it) until the
* user elects to exit.
*
* It is the UI's responsibility to ensure that run_test() is not called
* without choosing a valid rng first!
*/
/* if(all){ */
/* run_all_tests(); */
/* } else { */
run_test();
/* } */
/*
* This ends the core loop for a non-CLI interactive UI. GUIs will
* typically exit directly from the event loop. Tool UIs may well fall
* through, and the CLI simply proceeds sequentially to exit. It isn't
* strictly necessary to execute an exit() command at the end, but it
* does make the code a bit clearer (and let's one choose an exit code,
* if that might ever matter. Exit code 0 clearly means "completed
* normally".
*/
if (rng != NULL) {
gsl_rng_free(rng);
rng = NULL;
}
reset_bit_buffers();
return result; /* And then bring our results back to R */
}
