1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
|
// allowed.c: routines for the "allowed" parameter of the R function earth().
#include "R.h"
#include "Rinternals.h"
#ifndef _MSC_VER // microsoft
#ifndef bool
typedef int bool;
#define false 0
#define true 1
#endif
#endif
#define Dirs_(iTerm,iPred) Dirs[(iTerm) + (iPred)*(nMaxTerms)]
static SEXP AllowedFuncGlobal;
static SEXP AllowedEnvGlobal;
static int nArgsGlobal;
static bool FirstGlobal;
// Initialize the R function AllowedFuncGlobal from the Allowed function
// argument which was passed into ForwardPassR.
// For efficiency, we initialize once here rather than in IsAllowed.
//
// The caller of ForwardPassR has already checked that Allowed is
// a function and has three arguments: degree, pred, parents.
//
// The "allowed" function has the following prototype, where
// namesx and first are optional.
//
// allowed <- function(degree, pred, parents, namesx, first)
// {
// ...
// TRUE # return TRUE if allowed
// }
//
// where "degree" is the MARS term degree, with pred in the term.
// "pred" is column index in the input matrix x
// "parents" is an integer vector of parent predictors
// (it's a copy of Dirs[iParent,]
// "namesx" is optional and is the colnames of the x arg
// to earth, after factor expansion
// "first" is optional and is 1 the first time "allowed"
// is invoked for the current model
void InitAllowedFunc(
SEXP Allowed, // can be NULL
int nAllowedArgs, SEXP Env,
const char** sPredNames, int nPreds)
{
if(Allowed == R_NilValue)
AllowedFuncGlobal = NULL;
else {
if(nAllowedArgs < 3 || nAllowedArgs > 5)
error("Bad nAllowedArgs %d", nAllowedArgs);
AllowedEnvGlobal = Env;
nArgsGlobal = nAllowedArgs;
// the UNPROTECT for the PROTECT below is in FreeAllowedFunc()
PROTECT(AllowedFuncGlobal = allocList(1 + nAllowedArgs));
SEXP s = AllowedFuncGlobal; // 1st element is the function
SETCAR(s, Allowed);
SET_TYPEOF(s, LANGSXP);
s = CDR(s); // 2nd element is "degree"
SETCAR(s, allocVector(INTSXP, 1));
s = CDR(s); // 3rd element is "pred"
SETCAR(s, allocVector(INTSXP, 1));
s = CDR(s); // 4th element is "parents"
SETCAR(s, allocVector(INTSXP, nPreds));
if(nAllowedArgs >= 4) {
SEXP namesx;
s = CDR(s); // 5th element is "namesx"
SETCAR(s, namesx = allocVector(STRSXP, nPreds));
PROTECT(namesx);
if(sPredNames == NULL)
error("Bad sPredNames");
for(int i = 0; i < nPreds; i++)
SET_STRING_ELT(namesx, i, mkChar(sPredNames[i]));
UNPROTECT(1);
}
if(nAllowedArgs >= 5) {
s = CDR(s); // 6th element is "first"
SETCAR(s, allocVector(LGLSXP, 1));
}
}
FirstGlobal = true;
}
void FreeAllowedFunc(void)
{
if(AllowedFuncGlobal != NULL) {
UNPROTECT(1); // matches PROTECT in InitAllowedFunc
AllowedFuncGlobal = NULL;
}
}
static bool EvalAllowedFunc(void)
{
if(AllowedFuncGlobal == NULL)
error("EvalAllowedFunc: AllowedFuncGlobal == NULL");
SEXP s = eval(AllowedFuncGlobal, AllowedEnvGlobal);
bool allowed;
switch(TYPEOF(s)) { // be fairly permissive with return type
case LGLSXP:
allowed = (bool)(LOGICAL(s)[0] != 0);
break;
case INTSXP:
allowed = INTEGER(s)[0] != 0;
break;
case REALSXP:
allowed = (bool)(REAL(s)[0] != 0.);
break;
default:
error("the \"allowed\" function returned a %s instead of a logical",
Rf_type2char(TYPEOF(s)));
allowed = FALSE; // -Wall
break;
}
if(LENGTH(s) != 1)
error("the \"allowed\" function did not return a logical of length 1");
return allowed;
}
// Return TRUE if the current iPred can be used in a term with iParent
// i.e. TRUE means no constraint.
//
// This calls the R function Allowed which was passed in as a parameter to
// ForwardPassR. The fields of Allowed have been preallocated into
// AllowedFuncGlobal and so all we do here is fill in the values and call eval.
bool IsAllowed(
const int iPred, // in: candidate predictor
const int iParent, // in: candidate parent term
const int Dirs[], // in:
const int nPreds, // in:
const int nMaxTerms) // in:
{
if(AllowedFuncGlobal == NULL)
return TRUE;
SEXP s = AllowedFuncGlobal; // 1st element is the function
s = CDR(s); // 2nd element is "degree"
INTEGER(CADR(s))[0] = iPred+1; // 3rd element is "pred"
int* p = INTEGER(CADDR(s)); // 4th element is "parents"
int i, nDegree = 1;
for(i = 0; i < nPreds; i++) {
p[i] = Dirs_(iParent, i);
if(p[i])
nDegree++;
}
INTEGER(CAR(s))[0] = nDegree;
// optional 5th element already initialized to predictor names
if(nArgsGlobal >= 5) // optional 6th element is "first"
*(LOGICAL(CAD4R(s))) = FirstGlobal;
FirstGlobal = false;
return EvalAllowedFunc();
}
|