SEXP zero(SEXP f, SEXP guesses, SEXP stol, SEXP rho)
{
double x0 = REAL(guesses)[0], x1 = REAL(guesses)[1],
tol = REAL(stol)[0];
double f0, f1, fc, xc;
if(tol <= 0.0) error("non-positive tol value");
f0 = feval(x0, f, rho); f1 = feval(x1, f, rho);
if(f0 == 0.0) return mkans(x0);
if(f1 == 0.0) return mkans(x1);
if(f0*f1 > 0.0) error("x[0] and x[1] have the same sign");
for(;;) {
xc = 0.5*(x0+x1);
if(fabs(x0-x1) < tol) return mkans(xc);
fc = feval(xc, f, rho);
if(fc == 0) return mkans(xc);
if(f0*fc > 0.0) {
x0 = xc; f0 = fc;
} else {
x1 = xc; f1 = fc;
}
}
}
SEXP count_character_missing(SEXP x, SEXP nthrd){
PROTECT(x);
PROTECT(nthrd);
idx l = (idx) length(x);
double n = 0;
int nthreads = INTEGER(nthrd)[0];
#pragma omp parallel for num_threads(nthreads) reduction(+:n)
for( idx i = 0; i < l; i++ ){
if ( STRING_ELT(x,i) == NA_STRING ) ++n;
}
UNPROTECT(2);
return mkans(n);
}
SEXP count_integer_missing(SEXP x, SEXP nthrd){
PROTECT(x);
PROTECT(nthrd);
idx l = (idx) length(x);
int *X = INTEGER(x);
double n = 0;
int nthreads = INTEGER(nthrd)[0];
#pragma omp parallel for num_threads(nthreads) reduction(+:n)
for( idx i = 0; i < l; i++){
if ( X[i] == NA_INTEGER ) ++n;
}
UNPROTECT(2);
return mkans(n);
}
// count any missings (NaN and NA)
SEXP count_double_missing(SEXP x, SEXP nthrd){
PROTECT(x);
PROTECT(nthrd);
idx l = (idx) length(x);
double *X = REAL(x);
double n = 0.0;
int nthreads = INTEGER(nthrd)[0];
#pragma omp parallel for num_threads(nthreads) reduction(+:n)
for ( idx i = 0; i < l; i++ ){
if ( ISNAN(X[i]) ) ++n;
}
UNPROTECT(2);
return mkans(n);
}
SEXP rgenoud(SEXP fn, SEXP rho,
SEXP nvars, SEXP pop_size, SEXP max_generations, SEXP wait_generations,
SEXP n_starting_values, SEXP starting_values,
SEXP P, SEXP Domains,
SEXP max, SEXP gradient_check, SEXP boundary_enforcement,
SEXP solution_tolerance, SEXP BFGS, SEXP data_type_int,
SEXP provide_seeds, SEXP unif_seed, SEXP int_seed,
SEXP print_level, SEXP share_type, SEXP instance_number,
SEXP MemoryMatrix, SEXP Debug,
SEXP output_path, SEXP output_type, SEXP project_path,
SEXP hard_generation_limit,
SEXP fn_optim,
SEXP lexical, SEXP fnLexicalSort, SEXP fnMemoryMatrixEvaluate,
SEXP RuserGradient, SEXP fnGR,
SEXP RP9mix, SEXP BFGSburnin, SEXP transform)
{
SEXP ret;
long parameters, i, j;
double *FitValues, *Results, *Gradients;
if(!isEnvironment(rho))
error ("`rho' should be an environment");
parameters = asInteger(nvars);
// setup GENOUD
struct GND_IOstructure *MainStructure;
MainStructure = (struct GND_IOstructure *) malloc(sizeof(struct GND_IOstructure));
double **domains;
domains = (double **) malloc(parameters*sizeof(double));
for (i=0; i<parameters; i++) {
domains[i] = (double *) malloc(2*sizeof(double));
}
for (j=0; j<2; j++) {
for (i=0; i<parameters; i++) {
domains[i][j] = REAL(Domains)[i + j*parameters];
}
}
// starting values
double **StartingValues;
int nStartingValues;
nStartingValues = asInteger(n_starting_values);
if (nStartingValues > 0) {
/* need to free a matrix of StaringValues below */
StartingValues = (double **) malloc(nStartingValues*sizeof(double));
for (i=0; i<nStartingValues; i++) {
StartingValues[i] = (double *) malloc(parameters*sizeof(double));
for(j=0; j<parameters; j++)
StartingValues[i][j] = REAL(starting_values)[(i * parameters + j)];
}
}
MainStructure->fn=fn;
MainStructure->rho=rho;
MainStructure->fnLexicalSort=fnLexicalSort;
MainStructure->fnMemoryMatrixEvaluate=fnMemoryMatrixEvaluate;
MainStructure->fnGR=fnGR;
MainStructure->fn_optim=fn_optim;
MainStructure->Lexical=asInteger(lexical);
MainStructure->UserGradient=asInteger(RuserGradient);
MainStructure->nvars=parameters;
MainStructure->PopSize=asInteger(pop_size);
MainStructure->MaxGenerations=asInteger(max_generations);
MainStructure->WaitGenerations=asInteger(wait_generations);
MainStructure->HardGenerationLimit=asInteger(hard_generation_limit);
MainStructure->nStartingValues=nStartingValues;
MainStructure->StartingValues=StartingValues;
MainStructure->P[0]=REAL(P)[0];
MainStructure->P[1]=REAL(P)[1];
MainStructure->P[2]=REAL(P)[2];
MainStructure->P[3]=REAL(P)[3];
MainStructure->P[4]=REAL(P)[4];
MainStructure->P[5]=REAL(P)[5];
MainStructure->P[6]=REAL(P)[6];
MainStructure->P[7]=REAL(P)[7];
MainStructure->P[8]=REAL(P)[8];
MainStructure->Domains=domains;
MainStructure->MinMax=asInteger(max);
MainStructure->GradientCheck=asInteger(gradient_check);
MainStructure->BoundaryEnforcement=asInteger(boundary_enforcement);
MainStructure->SolutionTolerance=asReal(solution_tolerance);
MainStructure->UseBFGS=asInteger(BFGS);
MainStructure->MemoryUsage=asInteger(MemoryMatrix);
MainStructure->Debug=asInteger(Debug);
MainStructure->InstanceNumber=asInteger(instance_number);
MainStructure->ProvideSeeds=asInteger(provide_seeds);
MainStructure->UnifSeed=asInteger(unif_seed);
MainStructure->IntSeed=asInteger(int_seed);
MainStructure->PrintLevel=asInteger(print_level);
MainStructure->DataType=asInteger(data_type_int);
/*
Share Type:
(0) no reading of the existing project file and no looking at the public population file
(1) reading of any existing project file, but no examining of public population file
(2) NO reading of any existing project file but examination of public population file
(3) BOTH reading of any existing project file AND examination of public population file
*/
MainStructure->ShareType=asInteger(share_type);
//Paths
char OutputPath[1000], ProjectPath[1000];
strcpy(OutputPath,STRING_VALUE(output_path));
strcpy(ProjectPath,STRING_VALUE(project_path));
MainStructure->OutputPath=OutputPath;
MainStructure->ProjectPath=ProjectPath;
MainStructure->OutputType=asInteger(output_type);
/* output data structures */
FitValues = (double *) malloc(MainStructure->Lexical*sizeof(double));
Results = (double *) malloc(parameters*sizeof(double));
Gradients = (double *) malloc(parameters*sizeof(double));
MainStructure->oFitValues=FitValues;
MainStructure->oResults=Results;
MainStructure->oGradients=Gradients;
/* from setupGenoud */
/* output data structures */
MainStructure->oGenerations=0;
MainStructure->oPeakGeneration=0;
MainStructure->oPopSize=0;
MainStructure->ThreadNumber=0;
/* Operator Options */
MainStructure->P9mix=asReal(RP9mix);
MainStructure->BFGSburnin=asInteger(BFGSburnin);
/* Transform Related Variables */
/* whichFUN == 3 implies EvaluateTransform should be called */
/* whichFUN == 2 implies EvaluateLexical should be called */
/* whichFUN == 1 implies evaluate should be called */
MainStructure->Transform=asInteger(transform);
if(MainStructure->Transform == 1)
MainStructure->whichFUN = 3;
else if(MainStructure->Lexical > 1)
MainStructure->whichFUN = 2;
else
MainStructure->whichFUN = 1;
genoud(MainStructure);
ret = mkans(MainStructure->oFitValues,
MainStructure->oResults, MainStructure->oGradients, MainStructure->oP,
MainStructure->oGenerations, MainStructure->oPeakGeneration,
MainStructure->oPopSize, MainStructure->nvars, MainStructure->Lexical);
// Free memory
free(MainStructure);
for (i=0; i<parameters; i++)
free(domains[i]);
free(domains);
free(Results);
free(Gradients);
free(FitValues);
if (nStartingValues > 0) {
for (i=0; i<nStartingValues; i++)
free(StartingValues[i]);
free(StartingValues);
}
return(ret);
} // end of rgenoud()
double feval(double x, SEXP f, SEXP rho)
{
defineVar(install("x"), mkans(x), rho);
return(REAL(eval(f, rho))[0]);
}
double operator()(double x) {
defineVar(install("x"), mkans(x), m_rho);
return REAL(eval(m_f, m_rho))[0];
}
