# define USE_RINTERNALS # define attribute_hidden # define extern0 extern #define NULL 0 typedef enum { FALSE = 0, TRUE /*, MAYBE */ } Rboolean; #define CALLED_FROM_DEFN_H 1 //#include //#include typedef unsigned char Rbyte; typedef int R_len_t; /* will be long later, LONG64 or ssize_t on Win64 */ #define R_LEN_T_MAX INT_MAX #ifndef enum_SEXPTYPE typedef unsigned int SEXPTYPE; #define NILSXP 0 /* nil = NULL */ #define SYMSXP 1 /* symbols */ #define LISTSXP 2 /* lists of dotted pairs */ #define CLOSXP 3 /* closures */ #define ENVSXP 4 /* environments */ #define PROMSXP 5 /* promises: [un]evaluated closure arguments */ #define LANGSXP 6 /* language constructs (special lists) */ #define SPECIALSXP 7 /* special forms */ #define BUILTINSXP 8 /* builtin non-special forms */ #define CHARSXP 9 /* "scalar" string type (internal only)*/ #define LGLSXP 10 /* logical vectors */ #define INTSXP 13 /* integer vectors */ #define REALSXP 14 /* real variables */ #define CPLXSXP 15 /* complex variables */ #define STRSXP 16 /* string vectors */ #define DOTSXP 17 /* dot-dot-dot object */ #define ANYSXP 18 /* make "any" args work. Used in specifying types for symbol registration to mean anything is okay */ #define VECSXP 19 /* generic vectors */ #define EXPRSXP 20 /* expressions vectors */ #define BCODESXP 21 /* byte code */ #define EXTPTRSXP 22 /* external pointer */ #define WEAKREFSXP 23 /* weak reference */ #define RAWSXP 24 /* raw bytes */ #define S4SXP 25 /* S4, non-vector */ #define FUNSXP 99 /* Closure or Builtin or Special */ #else /* NOT YET */ /*------ enum_SEXPTYPE ----- */ typedef enum { NILSXP = 0, /* nil = NULL */ SYMSXP = 1, /* symbols */ LISTSXP = 2, /* lists of dotted pairs */ CLOSXP = 3, /* closures */ ENVSXP = 4, /* environments */ PROMSXP = 5, /* promises: [un]evaluated closure arguments */ LANGSXP = 6, /* language constructs (special lists) */ SPECIALSXP = 7, /* special forms */ BUILTINSXP = 8, /* builtin non-special forms */ CHARSXP = 9, /* "scalar" string type (internal only)*/ LGLSXP = 10, /* logical vectors */ INTSXP = 13, /* integer vectors */ REALSXP = 14, /* real variables */ CPLXSXP = 15, /* complex variables */ STRSXP = 16, /* string vectors */ DOTSXP = 17, /* dot-dot-dot object */ ANYSXP = 18, /* make "any" args work */ VECSXP = 19, /* generic vectors */ EXPRSXP = 20, /* expressions vectors */ BCODESXP = 21, /* byte code */ EXTPTRSXP = 22, /* external pointer */ WEAKREFSXP = 23, /* weak reference */ RAWSXP = 24, /* raw bytes */ S4SXP = 25, /* S4 non-vector */ FUNSXP = 99 /* Closure or Builtin */ } SEXPTYPE; #endif #ifdef USE_RINTERNALS /* This is intended for use only within R itself. * It defines internal structures that are otherwise only accessible * via SEXP, and macros to replace many (but not all) of accessor functions * (which are always defined). */ /* Flags */ struct sxpinfo_struct { SEXPTYPE type : 5;/* ==> (FUNSXP == 99) %% 2^5 == 3 == CLOSXP * -> warning: `type' is narrower than values * of its type * when SEXPTYPE was an enum */ unsigned int obj : 1; unsigned int named : 2; unsigned int gp : 16; unsigned int mark : 1; unsigned int debug : 1; unsigned int trace : 1; /* functions and memory tracing */ unsigned int spare : 1; /* currently unused */ unsigned int gcgen : 1; /* old generation number */ unsigned int gccls : 3; /* node class */ }; /* Tot: 32 */ struct vecsxp_struct { R_len_t length; R_len_t truelength; }; struct primsxp_struct { int offset; }; struct symsxp_struct { struct SEXPREC *pname; struct SEXPREC *value; struct SEXPREC *internal; }; struct listsxp_struct { struct SEXPREC *carval; struct SEXPREC *cdrval; struct SEXPREC *tagval; }; struct envsxp_struct { struct SEXPREC *frame; struct SEXPREC *enclos; struct SEXPREC *hashtab; }; struct closxp_struct { struct SEXPREC *formals; struct SEXPREC *body; struct SEXPREC *env; }; struct promsxp_struct { struct SEXPREC *value; struct SEXPREC *expr; struct SEXPREC *env; }; /* Every node must start with a set of sxpinfo flags and an attribute field. Under the generational collector these are followed by the fields used to maintain the collector's linked list structures. */ #define SEXPREC_HEADER \ struct sxpinfo_struct sxpinfo; \ struct SEXPREC *attrib; \ struct SEXPREC *gengc_next_node, *gengc_prev_node /* The standard node structure consists of a header followed by the node data. */ typedef struct SEXPREC { SEXPREC_HEADER; union { struct primsxp_struct primsxp; struct symsxp_struct symsxp; struct listsxp_struct listsxp; struct envsxp_struct envsxp; struct closxp_struct closxp; struct promsxp_struct promsxp; } u; } SEXPREC, *SEXP; /* The generational collector uses a reduced version of SEXPREC as a header in vector nodes. The layout MUST be kept consistent with the SEXPREC definition. The standard SEXPREC takes up 7 words on most hardware; this reduced version should take up only 6 words. In addition to slightly reducing memory use, this can lead to more favorable data alignment on 32-bit architectures like the Intel Pentium III where odd word alignment of doubles is allowed but much less efficient than even word alignment. */ typedef struct VECTOR_SEXPREC { SEXPREC_HEADER; struct vecsxp_struct vecsxp; } VECTOR_SEXPREC, *VECSEXP; typedef union { VECTOR_SEXPREC s; double align; } SEXPREC_ALIGN; /* General Cons Cell Attributes */ #define ATTRIB(x) ((x)->attrib) #define OBJECT(x) ((x)->sxpinfo.obj) #define MARK(x) ((x)->sxpinfo.mark) #define TYPEOF(x) ((x)->sxpinfo.type) #define NAMED(x) ((x)->sxpinfo.named) #define TRACE(x) ((x)->sxpinfo.trace) #define LEVELS(x) ((x)->sxpinfo.gp) #define SET_OBJECT(x,v) (((x)->sxpinfo.obj)=(v)) #define SET_TYPEOF(x,v) (((x)->sxpinfo.type)=(v)) #define SET_NAMED(x,v) (((x)->sxpinfo.named)=(v)) #define SET_TRACE(x,v) (((x)->sxpinfo.trace)=(v)) #define SETLEVELS(x,v) (((x)->sxpinfo.gp)=(v)) /* S4 object bit, set by R_do_new_object for all new() calls */ #define S4_OBJECT_MASK (1<<4) #define IS_S4_OBJECT(x) ((x)->sxpinfo.gp & S4_OBJECT_MASK) #define SET_S4_OBJECT(x) (((x)->sxpinfo.gp) |= S4_OBJECT_MASK) #define UNSET_S4_OBJECT(x) (((x)->sxpinfo.gp) &= ~S4_OBJECT_MASK) /* Vector Access Macros */ #define LENGTH(x) (((VECSEXP) (x))->vecsxp.length) #define TRUELENGTH(x) (((VECSEXP) (x))->vecsxp.truelength) #define SETLENGTH(x,v) ((((VECSEXP) (x))->vecsxp.length)=(v)) #define SET_TRUELENGTH(x,v) ((((VECSEXP) (x))->vecsxp.truelength)=(v)) /* Under the generational allocator the data for vector nodes comes immediately after the node structure, so the data address is a known offset from the node SEXP. */ #define DATAPTR(x) (((SEXPREC_ALIGN *) (x)) + 1) #define CHAR(x) ((const char *) DATAPTR(x)) #define LOGICAL(x) ((int *) DATAPTR(x)) #define INTEGER(x) ((int *) DATAPTR(x)) #define RAW(x) ((Rbyte *) DATAPTR(x)) #define COMPLEX(x) ((Rcomplex *) DATAPTR(x)) #define REAL(x) ((double *) DATAPTR(x)) #define STRING_ELT(x,i) ((SEXP *) DATAPTR(x))[i] #define VECTOR_ELT(x,i) ((SEXP *) DATAPTR(x))[i] #define STRING_PTR(x) ((SEXP *) DATAPTR(x)) #define VECTOR_PTR(x) ((SEXP *) DATAPTR(x)) /* List Access Macros */ /* These also work for ... objects */ #define LISTVAL(x) ((x)->u.listsxp) #define TAG(e) ((e)->u.listsxp.tagval) #define CAR(e) ((e)->u.listsxp.carval) #define CDR(e) ((e)->u.listsxp.cdrval) #define CAAR(e) CAR(CAR(e)) #define CDAR(e) CDR(CAR(e)) #define CADR(e) CAR(CDR(e)) #define CDDR(e) CDR(CDR(e)) #define CADDR(e) CAR(CDR(CDR(e))) #define CADDDR(e) CAR(CDR(CDR(CDR(e)))) #define CAD4R(e) CAR(CDR(CDR(CDR(CDR(e))))) #define MISSING_MASK 15 /* reserve 4 bits--only 2 uses now */ #define MISSING(x) ((x)->sxpinfo.gp & MISSING_MASK)/* for closure calls */ #define SET_MISSING(x,v) do { \ SEXP __x__ = (x); \ int __v__ = (v); \ int __other_flags__ = __x__->sxpinfo.gp & ~MISSING_MASK; \ __x__->sxpinfo.gp = __other_flags__ | __v__; \ } while (0) /* Closure Access Macros */ #define FORMALS(x) ((x)->u.closxp.formals) #define BODY(x) ((x)->u.closxp.body) #define CLOENV(x) ((x)->u.closxp.env) #define DEBUG(x) ((x)->sxpinfo.debug) #define SET_DEBUG(x,v) (((x)->sxpinfo.debug)=(v)) /* Symbol Access Macros */ #define PRINTNAME(x) ((x)->u.symsxp.pname) #define SYMVALUE(x) ((x)->u.symsxp.value) #define INTERNAL(x) ((x)->u.symsxp.internal) #define DDVAL_MASK 1 #define DDVAL(x) ((x)->sxpinfo.gp & DDVAL_MASK) /* for ..1, ..2 etc */ #define SET_DDVAL_BIT(x) (((x)->sxpinfo.gp) |= DDVAL_MASK) #define UNSET_DDVAL_BIT(x) (((x)->sxpinfo.gp) &= ~DDVAL_MASK) #define SET_DDVAL(x,v) ((v) ? SET_DDVAL_BIT(x) : UNSET_DDVAL_BIT(x)) /* for ..1, ..2 etc */ /* Environment Access Macros */ #define FRAME(x) ((x)->u.envsxp.frame) #define ENCLOS(x) ((x)->u.envsxp.enclos) #define HASHTAB(x) ((x)->u.envsxp.hashtab) #define ENVFLAGS(x) ((x)->sxpinfo.gp) /* for environments */ #define SET_ENVFLAGS(x,v) (((x)->sxpinfo.gp)=(v)) #else /* not USE_RINTERNALS */ typedef struct SEXPREC *SEXP; #define CHAR(x) R_CHAR(x) const char *(R_CHAR)(SEXP x); /* Various tests with macro versions below */ Rboolean (Rf_isNull)(SEXP s); Rboolean (Rf_isSymbol)(SEXP s); Rboolean (Rf_isLogical)(SEXP s); Rboolean (Rf_isReal)(SEXP s); Rboolean (Rf_isComplex)(SEXP s); Rboolean (Rf_isExpression)(SEXP s); Rboolean (Rf_isEnvironment)(SEXP s); Rboolean (Rf_isString)(SEXP s); Rboolean (Rf_isObject)(SEXP s); #endif /* USE_RINTERNALS */ /* Accessor functions. Many are declared using () to avoid the macro definitions in the USE_RINTERNALS section. The function STRING_ELT is used as an argument to arrayAssign even if the macro version is in use. */ /* General Cons Cell Attributes */ SEXP (ATTRIB)(SEXP x); int (OBJECT)(SEXP x); int (MARK)(SEXP x); int (TYPEOF)(SEXP x); int (NAMED)(SEXP x); void (SET_OBJECT)(SEXP x, int v); void (SET_TYPEOF)(SEXP x, int v); void (SET_NAMED)(SEXP x, int v); void SET_ATTRIB(SEXP x, SEXP v); void DUPLICATE_ATTRIB(SEXP to, SEXP from); /* Pointer Protection and Unprotection */ #define PROTECT(s) protect(s) #define UNPROTECT(n) unprotect(n) #define UNPROTECT_PTR(s) unprotect_ptr(s) /* We sometimes need to coerce a protected value and place the new coerced value under protection. For these cases PROTECT_WITH_INDEX saves an index of the protection location that can be used to replace the protected value using REPROTECT. */ typedef int PROTECT_INDEX; #define PROTECT_WITH_INDEX(x,i) R_ProtectWithIndex(x,i) #define REPROTECT(x,i) R_Reprotect(x,i) #define LibExtern extern LibExtern int R_NaInt; /* NA_INTEGER:= INT_MIN currently */ #define NA_LOGICAL R_NaInt /* Evaluation Environment */ LibExtern SEXP R_GlobalEnv; /* The "global" environment */ LibExtern SEXP R_EmptyEnv; /* An empty environment at the root of the environment tree */ LibExtern SEXP R_BaseEnv; /* The base environment; formerly R_NilValue */ LibExtern SEXP R_BaseNamespace; /* The (fake) name space for base */ LibExtern SEXP R_NamespaceRegistry;/* Registry for registered name spaces */ /* Special Values */ LibExtern SEXP R_NilValue; /* The nil object */ LibExtern SEXP R_UnboundValue; /* Unbound marker */ LibExtern SEXP R_MissingArg; /* Missing argument marker */ /* Symbol Table Shortcuts */ LibExtern SEXP R_Bracket2Symbol; /* "[[" */ LibExtern SEXP R_BracketSymbol; /* "[" */ LibExtern SEXP R_BraceSymbol; /* "{" */ LibExtern SEXP R_ClassSymbol; /* "class" */ LibExtern SEXP R_DimNamesSymbol; /* "dimnames" */ LibExtern SEXP R_DimSymbol; /* "dim" */ LibExtern SEXP R_DollarSymbol; /* "$" */ LibExtern SEXP R_DotsSymbol; /* "..." */ LibExtern SEXP R_DropSymbol; /* "drop" */ LibExtern SEXP R_LevelsSymbol; /* "levels" */ LibExtern SEXP R_ModeSymbol; /* "mode" */ LibExtern SEXP R_NamesSymbol; /* "names" */ LibExtern SEXP R_RowNamesSymbol; /* "row.names" */ LibExtern SEXP R_SeedsSymbol; /* ".Random.seed" */ LibExtern SEXP R_TspSymbol; /* "tsp" */ /* Missing Values - others from Arith.h */ #define NA_STRING R_NaString LibExtern SEXP R_NaString; /* NA_STRING as a CHARSXP */ LibExtern SEXP R_BlankString; /* "" as a CHARSXP */ //#include SEXP Rf_allocVector(SEXPTYPE, R_len_t); #define allocString(n) Rf_allocVector(CHARSXP, n) #define Rf_allocString(n) Rf_allocVector(CHARSXP, n) #define allocVector Rf_allocVector #define CONS(a, b) cons((a), (b)) #define cons Rf_cons SEXP Rf_cons(SEXP, SEXP); #define LCONS(a, b) lcons((a), (b)) #define lcons Rf_lcons SEXP Rf_lcons(SEXP, SEXP); SEXP Rf_getAttrib(SEXP, SEXP); #define getAttrib Rf_getAttrib SEXP Rf_duplicate(SEXP); #define duplicate Rf_duplicate SEXP Rf_install(const char *); #define install Rf_install SEXP Rf_allocList(int); #define allocList Rf_allocList SEXP SETCAR(SEXP x, SEXP y); SEXP SET_TAG(SEXP x, SEXP y); SEXP Rf_allocMatrix(SEXPTYPE, int, int); #define allocMatrix Rf_allocMatrix #define translateChar Rf_translateChar #define translateCharUTF8 Rf_translateCharUTF8 void *alloca(int size); #if 0 /* gak */ #endif /* gak */ void R_Reprotect(SEXP, PROTECT_INDEX); # define INLINE_FUN extern __attribute__((gnu_inline)) inline #define mkString Rf_mkString SEXP Rf_mkString(const char *); #define ScalarInteger Rf_ScalarInteger SEXP Rf_ScalarInteger(int); int strlen(const char *s); int strcat(char *s1, const char *s); INLINE_FUN R_len_t length(SEXP s) { int i; switch (TYPEOF(s)) { case NILSXP: return 0; case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case CHARSXP: case VECSXP: case EXPRSXP: case RAWSXP: return LENGTH(s); case LISTSXP: case LANGSXP: case DOTSXP: i = 0; while (s != NULL && s != R_NilValue) { i++; s = CDR(s); } return i; case ENVSXP: return Rf_envlength(s); default: return 1; } } INLINE_FUN Rboolean isFrame(SEXP s) { SEXP klass; int i; if (OBJECT(s)) { klass = getAttrib(s, R_ClassSymbol); for (i = 0; i < length(klass); i++) if (!strcmp(CHAR(STRING_ELT(klass, i)), "data.frame")) return TRUE; } return FALSE; } //#include "Rinlinedfuns.h" #define WORDSIZE (8*sizeof(int)) static SEXP tildeSymbol = NULL; static SEXP plusSymbol = NULL; static SEXP minusSymbol = NULL; static SEXP timesSymbol = NULL; static SEXP slashSymbol = NULL; static SEXP colonSymbol = NULL; static SEXP powerSymbol = NULL; static SEXP dotSymbol = NULL; static SEXP parenSymbol = NULL; static SEXP inSymbol = NULL; /* unused static SEXP identSymbol = NULL; */ static int intercept; /* intercept term in the model */ static int parity; /* +/- parity */ static int response; /* response term in the model */ static int nvar; /* Number of variables in the formula */ static int nwords; /* # of words (ints) to code a term */ static int nterm; /* # of model terms */ static SEXP varlist; /* variables in the model */ attribute_hidden SEXP framenames; /* variables names for specified frame */ /* NOTE: framenames can't be static because it must be protected from garbage collection. */ static Rboolean haveDot; /* does RHS of formula contain `.'? */ /*==========================================================================*/ /* Model Formula Manipulation */ /* These functions take a numerically coded */ /* formula and fully expand it. */ static SEXP EncodeVars(SEXP);/* defined below */ static int TermCode(SEXP termlist, SEXP thisterm, int whichbit, SEXP term) { SEXP t; int allzero, i; for (i = 0; i < nwords; i++) INTEGER(term)[i] = INTEGER(CAR(thisterm))[i]; /* Eliminate factor ``whichbit'' */ SetBit(term, whichbit, 0); /* Search preceding terms for a match */ /* Zero is a possibility - it is a special case */ allzero = 1; for (i = 0; i < nwords; i++) { if (INTEGER(term)[i]) { allzero = 0; break; } } if (allzero) return 1; for (t = termlist; t != thisterm; t = CDR(t)) { allzero = 1; for (i = 0; i < nwords; i++) { if ((~(INTEGER(CAR(t))[i])) & INTEGER(term)[i]) allzero = 0; } if (allzero) return 1; } return 2; } /* Internal code for the ``terms'' function */ /* The value is a formula with an assortment */ /* of useful attributes. */ /* .Internal(terms.formula(x, new.specials, abb, data, keep.order)) */ static SEXP ExpandDots(SEXP object, SEXP value); SEXP attribute_hidden do_termsform(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP a, ans, v, pattern, formula, varnames, term, termlabs, ord; SEXP specials, t, data, rhs; int i, j, k, l, n, keepOrder, allowDot; char *cbuf; Rboolean hadFrameNames = FALSE; checkArity(op, args); /* Always fetch these values rather than trying */ /* to remember them between calls. The overhead */ /* is minimal and we don't have to worry about */ /* intervening dump/restore problems. */ tildeSymbol = install("~"); plusSymbol = install("+"); minusSymbol = install("-"); timesSymbol = install("*"); slashSymbol = install("/"); colonSymbol = install(":"); powerSymbol = install("^"); dotSymbol = install("."); parenSymbol = install("("); inSymbol = install("%in%"); /* identSymbol = install("I"); */ /* Do we have a model formula? */ /* Check for unary or binary ~ */ if (!isLanguage(CAR(args)) || CAR(CAR(args)) != tildeSymbol || (length(CAR(args)) != 2 && length(CAR(args)) != 3)) error(_("argument is not a valid model")); haveDot = FALSE; PROTECT(ans = duplicate(CAR(args))); /* The formula will be returned, modified if haveDot becomes TRUE */ specials = CADR(args); a = CDDR(args); /* We use data to get the value to */ /* substitute for "." in formulae */ data = CAR(a); a = CDR(a); if (isNull(data) || isEnvironment(data)) framenames = R_NilValue; else if (isFrame(data)) framenames = getAttrib(data, R_NamesSymbol); else error(_("'data' argument is of the wrong type")); if (framenames != R_NilValue) { if(length(framenames)) hadFrameNames = TRUE; if (length(CAR(args))== 3) CheckRHS(CADR(CAR(args))); } /* Preserve term order? */ keepOrder = asLogical(CAR(a)); if (keepOrder == NA_LOGICAL) keepOrder = 0; a = CDR(a); allowDot = asLogical(CAR(a)); if (allowDot == NA_LOGICAL) allowDot = 0; if (specials == R_NilValue) { a = allocList(8); SET_ATTRIB(ans, a); } else { a = allocList(9); SET_ATTRIB(ans, a); } /* Step 1: Determine the ``variables'' in the model */ /* Here we create an expression of the form */ /* list(...). You can evaluate it to get */ /* the model variables or use substitute and then */ /* pull the result apart to get the variable names. */ intercept = 1; parity = 1; response = 0; PROTECT(varlist = LCONS(install("list"), R_NilValue)); ExtractVars(CAR(args), 1); UNPROTECT(1); SETCAR(a, varlist); SET_TAG(a, install("variables")); a = CDR(a); nvar = length(varlist) - 1; nwords = (nvar - 1) / WORDSIZE + 1; /* Step 2: Recode the model terms in binary form */ /* and at the same time, expand the model formula. */ /* FIXME: this includes specials in the model */ /* There perhaps needs to be a an extra pass */ /* through the model to delete any terms which */ /* contain specials. Actually, specials should */ /* only enter additively so this should also be */ /* checked and abort forced if not. */ /* BDR 2002-01-29: S does include specials, so code may rely on this */ /* FIXME: this is also the point where nesting */ /* needs to be taken care of. */ PROTECT(formula = EncodeVars(CAR(args))); nvar = length(varlist) - 1; /* need to recompute, in case EncodeVars stretched it */ /* Step 2a: Compute variable names */ PROTECT(varnames = allocVector(STRSXP, nvar)); for (v = CDR(varlist), i = 0; v != R_NilValue; v = CDR(v)) SET_STRING_ELT(varnames, i++, STRING_ELT(deparse1line(CAR(v), 0), 0)); /* Step 2b: Find and remove any offset(s) */ /* first see if any of the variables are offsets */ for (l = response, k = 0; l < nvar; l++) if (!strncmp(CHAR(STRING_ELT(varnames, l)), "offset(", 7)) k++; if (k > 0) { Rboolean foundOne = FALSE; /* has there been a non-offset term? */ /* allocate the "offsets" attribute */ SETCAR(a, v = allocVector(INTSXP, k)); for (l = response, k = 0; l < nvar; l++) if (!strncmp(CHAR(STRING_ELT(varnames, l)), "offset(", 7)) INTEGER(v)[k++] = l + 1; SET_TAG(a, install("offset")); a = CDR(a); /* now remove offset terms from the formula */ call = formula; /* call is to be the previous term once one is found */ while (1) { SEXP thisterm = foundOne ? CDR(call) : call; Rboolean have_offset = FALSE; if(length(thisterm) == 0) break; for (i = 1; i <= nvar; i++) if (GetBit(CAR(thisterm), i) && !strncmp(CHAR(STRING_ELT(varnames, i-1)), "offset(", 7)) { have_offset = TRUE; break; } if (have_offset) { if (!foundOne) call = formula = CDR(formula); else SETCDR(call, CDR(thisterm)); } else { if (foundOne) call = CDR(call); foundOne = TRUE; } } } nterm = length(formula); /* Step 3: Reorder the model terms by BitCount, otherwise preserving their order. */ PROTECT(ord = allocVector(INTSXP, nterm)); { SEXP sCounts; int *counts, bitmax = 0, *iord = INTEGER(ord), m = 0; PROTECT(pattern = allocVector(VECSXP, nterm)); PROTECT(sCounts = allocVector(INTSXP, nterm)); counts = INTEGER(sCounts); for (call = formula, n = 0; call != R_NilValue; call = CDR(call)) { SET_VECTOR_ELT(pattern, n, CAR(call)); counts[n++] = BitCount(CAR(call)); } for (n = 0; n < nterm; n++) if(counts[n] > bitmax) bitmax = counts[n]; if(keepOrder) { for (n = 0; n < nterm; n++) iord[n] = counts[n]; } else { call = formula; m = 0; for (i = 0; i <= bitmax; i++) /* can order 0 occur? */ for (n = 0; n < nterm; n++) if (counts[n] == i) { SETCAR(call, VECTOR_ELT(pattern, n)); call = CDR(call); iord[m++] = i; } } UNPROTECT(2); } /* Step 4: Compute the factor pattern for the model. */ /* 0 - the variable does not appear in this term. */ /* 1 - code the variable by contrasts in this term. */ /* 2 - code the variable by indicators in this term. */ if (nterm > 0) { SETCAR(a, pattern = allocMatrix(INTSXP, nvar, nterm)); SET_TAG(a, install("factors")); a = CDR(a); for (i = 0; i < nterm * nvar; i++) INTEGER(pattern)[i] = 0; PROTECT(term = AllocTerm()); n = 0; for (call = formula; call != R_NilValue; call = CDR(call)) { for (i = 1; i <= nvar; i++) { if (GetBit(CAR(call), i)) INTEGER(pattern)[i-1+n*nvar] = TermCode(formula, call, i, term); } n++; } UNPROTECT(1); } else { SETCAR(a, pattern = allocVector(INTSXP,0)); SET_TAG(a, install("factors")); a = CDR(a); } /* Step 5: Compute term labels */ PROTECT(termlabs = allocVector(STRSXP, nterm)); n = 0; for (call = formula; call != R_NilValue; call = CDR(call)) { l = 0; for (i = 1; i <= nvar; i++) { if (GetBit(CAR(call), i)) { if (l > 0) l += 1; l += strlen(CHAR(STRING_ELT(varnames, i - 1))); } } cbuf = (char *) alloca(l+1); cbuf[0] = '\0'; l = 0; for (i = 1; i <= nvar; i++) { if (GetBit(CAR(call), i)) { if (l > 0) strcat(cbuf, ":"); strcat(cbuf, CHAR(STRING_ELT(varnames, i - 1))); l++; } } SET_STRING_ELT(termlabs, n, mkChar(cbuf)); n++; } PROTECT(v = allocVector(VECSXP, 2)); SET_VECTOR_ELT(v, 0, varnames); SET_VECTOR_ELT(v, 1, termlabs); if (nterm > 0) setAttrib(pattern, R_DimNamesSymbol, v); SETCAR(a, termlabs); SET_TAG(a, install("term.labels")); a = CDR(a); /* If there are specials stick them in here */ if (specials != R_NilValue) { i = length(specials); PROTECT(v = allocList(i)); for (j = 0, t = v; j < i; j++, t = CDR(t)) { const char *ss = translateChar(STRING_ELT(specials, j)); SET_TAG(t, install(ss)); n = strlen(ss); SETCAR(t, allocVector(INTSXP, 0)); k = 0; for (l = 0; l < nvar; l++) { if (!strncmp(CHAR(STRING_ELT(varnames, l)), ss, n)) if (CHAR(STRING_ELT(varnames, l))[n] == '(') k++; } if (k > 0) { SETCAR(t, allocVector(INTSXP, k)); k = 0; for (l = 0; l < nvar; l++) { if (!strncmp(CHAR(STRING_ELT(varnames, l)), ss, n)) if (CHAR(STRING_ELT(varnames, l))[n] == '('){ INTEGER(CAR(t))[k++] = l+1; } } } else SETCAR(t, R_NilValue); } SETCAR(a, v); SET_TAG(a, install("specials")); a = CDR(a); UNPROTECT(1); } UNPROTECT(2); /* keep termlabs until here */ /* Step 6: Fix up the formula by substituting for dot, which should be the framenames joined by + */ if (haveDot) { if(length(framenames)) { PROTECT_INDEX ind; PROTECT_WITH_INDEX(rhs = install(translateChar(STRING_ELT(framenames, 0))), &ind); for (i = 1; i < LENGTH(framenames); i++) { REPROTECT(rhs = lang3(plusSymbol, rhs, install(translateChar(STRING_ELT(framenames, i)))), ind); } if (!isNull(CADDR(ans))) SETCADDR(ans, ExpandDots(CADDR(ans), rhs)); else SETCADR(ans, ExpandDots(CADR(ans), rhs)); UNPROTECT(1); } else if(!allowDot && !hadFrameNames) { error(_("'.' in formula and no 'data' argument")); } } SETCAR(a, allocVector(INTSXP, nterm)); n = 0; { int *ia = INTEGER(CAR(a)), *iord = INTEGER(ord); for (call = formula; call != R_NilValue; call = CDR(call), n++) ia[n] = iord[n]; } SET_TAG(a, install("order")); a = CDR(a); SETCAR(a, ScalarInteger(intercept != 0)); SET_TAG(a, install("intercept")); a = CDR(a); SETCAR(a, ScalarInteger(response != 0)); SET_TAG(a, install("response")); a = CDR(a); SETCAR(a, mkString("terms")); SET_TAG(a, install("class")); SET_OBJECT(ans, 1); SETCDR(a, R_NilValue); /* truncate if necessary */ UNPROTECT(4); return ans; }