File: allowed.c

package info (click to toggle)
r-cran-earth 4.7.0-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 3,948 kB
  • sloc: ansic: 3,830; fortran: 894; sh: 13; makefile: 5
file content (169 lines) | stat: -rw-r--r-- 5,381 bytes parent folder | download
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();
}