--- a +++ b/partyMod/src/S3Classes.c @@ -0,0 +1,199 @@ + +/** + S3 classes for dealing with nodes and splits + *\file S3Classes.c + *\author $Author$ + *\date $Date$ +*/ + +#include "party.h" + +void C_init_node(SEXP node, int nobs, int ninputs, int nsurr, int q) { + + SEXP nodeID, weights, criterion, primarysplit, surrogatesplits, + terminal, prediction; + + if (LENGTH(node) < NODE_LENGTH) + error("node is not a list with at least %d elements", NODE_LENGTH); + + SET_VECTOR_ELT(node, S3_NODEID, nodeID = allocVector(INTSXP, 1)); + if (nobs > 0) + SET_VECTOR_ELT(node, S3_WEIGHTS, weights = allocVector(REALSXP, nobs)); + else + SET_VECTOR_ELT(node, S3_WEIGHTS, R_NilValue); + SET_VECTOR_ELT(node, S3_SUMWEIGHTS, allocVector(REALSXP, 1)); + SET_VECTOR_ELT(node, S3_CRITERION, + criterion = allocVector(VECSXP, CRITERION_LENGTH)); + /* teststats */ + SET_VECTOR_ELT(criterion, S3_STATISTICS, allocVector(REALSXP, ninputs)); + /* criterion, aka pvalues */ + SET_VECTOR_ELT(criterion, S3_iCRITERION, allocVector(REALSXP, ninputs)); + /* max(criterion) */ + SET_VECTOR_ELT(criterion, S3_MAXCRITERION, allocVector(REALSXP, 1)); + SET_VECTOR_ELT(node, S3_TERMINAL, terminal = allocVector(LGLSXP, 1)); + INTEGER(terminal)[0] = 0; + SET_VECTOR_ELT(node, S3_PSPLIT, + primarysplit = allocVector(VECSXP, SPLIT_LENGTH)); + SET_VECTOR_ELT(node, S3_SSPLIT, + surrogatesplits = allocVector(VECSXP, nsurr)); + SET_VECTOR_ELT(node, S3_PREDICTION, prediction = allocVector(REALSXP, q)); + +} + +void S3set_nodeID(SEXP node, int nodeID) { + INTEGER(VECTOR_ELT(node, S3_NODEID))[0] = nodeID; +} + +int S3get_nodeID(SEXP node) { + return(INTEGER(VECTOR_ELT(node, S3_NODEID))[0]); +} + +SEXP S3get_nodeweights(SEXP node) { + SEXP ans; + + ans = VECTOR_ELT(node, S3_WEIGHTS); + if (ans == R_NilValue) + error("node has no weights element"); + return(VECTOR_ELT(node, S3_WEIGHTS)); +} + +double S3get_sumweights(SEXP node) { + return(REAL(VECTOR_ELT(node, S3_SUMWEIGHTS))[0]); +} + +SEXP S3get_teststat(SEXP node) { + return(VECTOR_ELT(VECTOR_ELT(node, S3_CRITERION), S3_STATISTICS)); +} + +SEXP S3get_criterion(SEXP node) { + return(VECTOR_ELT(VECTOR_ELT(node, S3_CRITERION), S3_iCRITERION)); +} + +SEXP S3get_maxcriterion(SEXP node) { + return(VECTOR_ELT(VECTOR_ELT(node, S3_CRITERION), S3_MAXCRITERION)); +} + +void S3set_nodeterminal(SEXP node) { + INTEGER(VECTOR_ELT(node, S3_TERMINAL))[0] = 1; +} + +int S3get_nodeterminal(SEXP node) { + return(INTEGER(VECTOR_ELT(node, S3_TERMINAL))[0]); +} + +SEXP S3get_primarysplit(SEXP node) { + return(VECTOR_ELT(node, S3_PSPLIT)); +} + +SEXP S3get_surrogatesplits(SEXP node) { + return(VECTOR_ELT(node, S3_SSPLIT)); +} + +SEXP S3get_prediction(SEXP node) { + return(VECTOR_ELT(node, S3_PREDICTION)); +} + +SEXP S3get_leftnode(SEXP node) { + return(VECTOR_ELT(node, S3_LEFT)); +} + +SEXP S3get_rightnode(SEXP node) { + return(VECTOR_ELT(node, S3_RIGHT)); +} + +void C_init_orderedsplit(SEXP split, int nobs) { + + SEXP variableID, splitpoint, splitstatistics, ordered, toleft; + + if (LENGTH(split) < SPLIT_LENGTH) + error("split is not a list with at least %d elements", SPLIT_LENGTH); + + SET_VECTOR_ELT(split, S3_VARIABLEID, + variableID = allocVector(INTSXP, 1)); + SET_VECTOR_ELT(split, S3_ORDERED, + ordered = allocVector(LGLSXP, 1)); + INTEGER(ordered)[0] = 1; + SET_VECTOR_ELT(split, S3_SPLITPOINT, + splitpoint = allocVector(REALSXP, 1)); + if (nobs > 0) + SET_VECTOR_ELT(split, S3_SPLITSTATISTICS, + splitstatistics = allocVector(REALSXP, nobs)); + else + SET_VECTOR_ELT(split, S3_SPLITSTATISTICS, R_NilValue); + SET_VECTOR_ELT(split, S3_TOLEFT, toleft = allocVector(INTSXP, 1)); + INTEGER(toleft)[0] = 1; + SET_VECTOR_ELT(split, S3_TABLE, R_NilValue); +} + +void C_init_nominalsplit(SEXP split, int nlevels, int nobs) { + + SEXP variableID, splitpoint, splitstatistics, ordered, toleft, table; + + if (LENGTH(split) < SPLIT_LENGTH) + error("split is not a list with at least %d elements", SPLIT_LENGTH); + + SET_VECTOR_ELT(split, S3_VARIABLEID, variableID = allocVector(INTSXP, 1)); + SET_VECTOR_ELT(split, S3_ORDERED, ordered = allocVector(LGLSXP, 1)); + INTEGER(ordered)[0] = 0; + SET_VECTOR_ELT(split, S3_SPLITPOINT, + splitpoint = allocVector(INTSXP, nlevels)); + if (nobs > 0) + SET_VECTOR_ELT(split, S3_SPLITSTATISTICS, + splitstatistics = allocVector(REALSXP, nobs)); + else + SET_VECTOR_ELT(split, S3_SPLITSTATISTICS, R_NilValue); + SET_VECTOR_ELT(split, S3_TOLEFT, toleft = allocVector(INTSXP, 1)); + INTEGER(toleft)[0] = 1; + SET_VECTOR_ELT(split, S3_TABLE, table = allocVector(INTSXP, nlevels)); +} + +void S3set_variableID(SEXP split, int variableID) { + INTEGER(VECTOR_ELT(split, S3_VARIABLEID))[0] = variableID; +} + +int S3get_variableID(SEXP split) { + return(INTEGER(VECTOR_ELT(split, S3_VARIABLEID))[0]); +} + +int S3is_ordered(SEXP split) { + return(INTEGER(VECTOR_ELT(split, S3_ORDERED))[0]); +} + +void S3set_ordered(SEXP split) { + INTEGER(VECTOR_ELT(split, S3_ORDERED))[0] = 1; +} + +void S3set_nominal(SEXP split) { + INTEGER(VECTOR_ELT(split, S3_ORDERED))[0] = 0; +} + +int S3get_toleft(SEXP split) { + return(INTEGER(VECTOR_ELT(split, S3_TOLEFT))[0]); +} + +void S3set_toleft(SEXP split, int left) { + /* <FIXME> use LOGICAL here? </FIXME> */ + INTEGER(VECTOR_ELT(split, S3_TOLEFT))[0] = left; +} + +SEXP S3get_splitpoint(SEXP split) { + return(VECTOR_ELT(split, S3_SPLITPOINT)); +} + +SEXP S3get_splitstatistics(SEXP split) { + SEXP ans; + + ans = VECTOR_ELT(split, S3_SPLITSTATISTICS); + if (ans == R_NilValue) + error("split does not have a splitstatistics element"); + return(ans); +} + +SEXP S3get_table(SEXP split) { + SEXP ans; + + ans = VECTOR_ELT(split, S3_TABLE); + if (ans == R_NilValue) + error("split does not have a table element"); + return(ans); +}