SEXP ctree_memory (SEXP object, SEXP MP_INV) {
SEXP ans, weights, splitstatistics, dontuse, dontusetmp, varmemory;
int q, p, nobs, ninputs;
q = ncol(get_test_trafo(GET_SLOT(object, PL2_responsesSym)));
ninputs = get_ninputs(object);
nobs = get_nobs(object);
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("TreeFitMemory")));
SET_SLOT(ans, PL2_expcovinfSym, PROTECT(new_ExpectCovarInfluence(q)));
SET_SLOT(ans, PL2_expcovinfssSym, PROTECT(new_ExpectCovarInfluence(1)));
SET_SLOT(ans, PL2_linexpcov2sampleSym, PROTECT(new_LinStatExpectCovar(1, q)));
SET_SLOT(ans, PL2_weightsSym, weights = PROTECT(allocVector(REALSXP, nobs)));
for (int i = 0; i < nobs; i++)
REAL(weights)[i] = 0.0;
SET_SLOT(ans, PL2_splitstatisticsSym, splitstatistics = PROTECT(allocVector(REALSXP, nobs)));
for (int i = 0; i < nobs; i++)
REAL(splitstatistics)[i] = 0.0;
SET_SLOT(ans, PL2_dontuseSym, dontuse = PROTECT(allocVector(LGLSXP, ninputs)));
for (int i = 0; i < ninputs; i++)
LOGICAL(dontuse)[i] = 0.0;
SET_SLOT(ans, PL2_dontusetmpSym, dontusetmp = PROTECT(allocVector(LGLSXP, ninputs)));
for (int i = 0; i < ninputs; i++)
LOGICAL(dontusetmp)[i] = 0.0;
varmemory = PROTECT(allocVector(VECSXP, ninputs));
for (int i = 0; i < ninputs; i++) {
p = ncol(get_transformation(GET_SLOT(object, PL2_inputsSym), i + 1));
if (LOGICAL(MP_INV)[0]) {
SET_VECTOR_ELT(varmemory, i, new_LinStatExpectCovarMPinv(p, q));
} else {
SET_VECTOR_ELT(varmemory, i, new_LinStatExpectCovar(p, q));
}
}
SET_SLOT(ans, PL2_varmemorySym, varmemory);
UNPROTECT(9);
return(ans);
}
int bound_traction_free_dsoln(exedata *exd, int nbnd, int *facn) {
// pointers.
int *pfacn, *pfccls, *pfcnds;
double *pfcnml, *pndcrd;
double *pidsol, *pjdsoln, *pdsol, *pdsoln;
// arrays.
double nvec[3], svec[3];
double rotm[3][3], bondm[6][6], bondminv[6][6];
double dvel0[3][3], dvel1[3][3], dsts0[6][3], dsts1[6][3];
// iterators.
int ibnd, ifc, icl, jcl, ieq;
int ii, ij, ik;
nvec[2] = 0.0;
svec[2] = 0.0;
pfacn = facn;
for (ibnd=0; ibnd<nbnd; ibnd++) {
ifc = pfacn[0];
pfccls = exd->fccls + ifc * FCREL;
icl = pfccls[0];
jcl = pfccls[1];
pidsol = exd->dsol + icl * NEQ * NDIM;
pjdsoln = exd->dsoln + jcl * NEQ * NDIM;
// get transformation matrices.
pfcnml = exd->fcnml + ifc * NDIM;
nvec[0] = pfcnml[0];
nvec[1] = pfcnml[1];
pfcnds = exd->fcnds + ifc * (FCMND+1);
pndcrd = exd->ndcrd + pfcnds[2] * NDIM;
svec[0] = pndcrd[0];
svec[1] = pndcrd[1];
pndcrd = exd->ndcrd + pfcnds[1] * NDIM;
svec[0] -= pndcrd[0];
svec[1] -= pndcrd[1];
get_transformation(nvec, svec, rotm, bondm, bondminv);
// rotate velocity to boundary coordinate system.
pdsol = pidsol;
for (ieq=0; ieq<3; ieq++) {
dvel1[ieq][0] = pdsol[0];
dvel1[ieq][1] = pdsol[1];
dvel1[ieq][2] = 0.0;
pdsol += NDIM;
};
for (ii=0; ii<3; ii++) {
for (ij=0; ij<3; ij++) {
dvel0[ii][ij] = 0.0;
for (ik=0; ik<3; ik++) {
dvel0[ii][ij] += rotm[ii][ik]*dvel1[ik][ij];
};
};
};
for (ii=0; ii<3; ii++) {
for (ij=0; ij<3; ij++) {
dvel1[ii][ij] = 0.0;
for (ik=0; ik<3; ik++) {
dvel1[ii][ij] += dvel0[ii][ik]*rotm[ij][ik];
};
};
};
// rotate stress to boundary coordinate system.
for (ieq=0; ieq<6; ieq++) {
dsts1[ieq][0] = pdsol[0];
dsts1[ieq][1] = pdsol[1];
dsts1[ieq][2] = 0.0;
pdsol += NDIM;
};
for (ii=0; ii<6; ii++) {
for (ij=0; ij<3; ij++) {
dsts0[ii][ij] = 0.0;
for (ik=0; ik<6; ik++) {
dsts0[ii][ij] += bondm[ii][ik]*dsts1[ik][ij];
};
};
};
for (ii=0; ii<6; ii++) {
for (ij=0; ij<3; ij++) {
dsts1[ii][ij] = 0.0;
for (ik=0; ik<3; ik++) {
dsts1[ii][ij] += dsts0[ii][ik]*rotm[ij][ik];
};
};
};
// set on boundary coordinate system.
for (ieq=0; ieq<3; ieq++) {
dvel1[ieq][0] = -dvel1[ieq][0]; // unchanged.
};
for (ieq=0; ieq<1; ieq++) {
dsts1[ieq][1] = -dsts1[ieq][1]; // vanishing.
};
for (ieq=1; ieq<4; ieq++) {
dsts1[ieq][0] = -dsts1[ieq][0]; // unchanged.
};
for (ieq=4; ieq<6; ieq++) {
dsts1[ieq][1] = -dsts1[ieq][1]; // vanishing.
};
// rotate velocity to global coordinate system.
for (ii=0; ii<3; ii++) {
for (ij=0; ij<3; ij++) {
dvel0[ii][ij] = 0.0;
for (ik=0; ik<3; ik++) {
dvel0[ii][ij] += rotm[ik][ii]*dvel1[ik][ij];
};
};
};
for (ii=0; ii<3; ii++) {
for (ij=0; ij<3; ij++) {
dvel1[ii][ij] = 0.0;
for (ik=0; ik<3; ik++) {
dvel1[ii][ij] += dvel0[ii][ik]*rotm[ik][ij];
};
};
};
// rotate stress to global coordinate system.
for (ii=0; ii<6; ii++) {
for (ij=0; ij<3; ij++) {
dsts0[ii][ij] = 0.0;
for (ik=0; ik<6; ik++) {
dsts0[ii][ij] += bondminv[ii][ik]*dsts1[ik][ij];
};
};
};
for (ii=0; ii<6; ii++) {
for (ij=0; ij<3; ij++) {
dsts1[ii][ij] = 0.0;
for (ik=0; ik<3; ik++) {
dsts1[ii][ij] += dsts0[ii][ik]*rotm[ik][ij];
};
};
};
// set to ghost gradient.
pdsoln = pjdsoln;
for (ieq=0; ieq<3; ieq++) {
pdsoln[0] = dvel1[ieq][0];
pdsoln[1] = dvel1[ieq][1];
pdsoln += NDIM;
};
for (ieq=0; ieq<6; ieq++) {
pdsoln[0] = dsts1[ieq][0];
pdsoln[1] = dsts1[ieq][1];
pdsoln += NDIM;
};
/*for (ieq=0; ieq<9; ieq++) {
pjdsoln[0] = pidsoln[0];
pjdsoln[1] = pidsoln[1];
pidsoln += NDIM;
pjdsoln += NDIM;
};*/
// advance boundary face.
pfacn += 3;
};
return 0;
}
void C_Node(SEXP node, SEXP learnsample, SEXP weights,
SEXP fitmem, SEXP controls, int TERMINAL, int depth) {
int nobs, ninputs, jselect, q, j, k, i;
double mincriterion, sweights, *dprediction;
double *teststat, *pvalue, smax, cutpoint = 0.0, maxstat = 0.0;
double *standstat, *splitstat;
SEXP responses, inputs, x, expcovinf, linexpcov;
SEXP varctrl, splitctrl, gtctrl, tgctrl, split, testy, predy;
double *dxtransf, *thisweights;
int *itable;
nobs = get_nobs(learnsample);
ninputs = get_ninputs(learnsample);
varctrl = get_varctrl(controls);
splitctrl = get_splitctrl(controls);
gtctrl = get_gtctrl(controls);
tgctrl = get_tgctrl(controls);
mincriterion = get_mincriterion(gtctrl);
responses = GET_SLOT(learnsample, PL2_responsesSym);
inputs = GET_SLOT(learnsample, PL2_inputsSym);
testy = get_test_trafo(responses);
predy = get_predict_trafo(responses);
q = ncol(testy);
/* <FIXME> we compute C_GlobalTest even for TERMINAL nodes! </FIXME> */
/* compute the test statistics and the node criteria for each input */
C_GlobalTest(learnsample, weights, fitmem, varctrl,
gtctrl, get_minsplit(splitctrl),
REAL(S3get_teststat(node)), REAL(S3get_criterion(node)), depth);
/* sum of weights: C_GlobalTest did nothing if sweights < mincriterion */
sweights = REAL(GET_SLOT(GET_SLOT(fitmem, PL2_expcovinfSym),
PL2_sumweightsSym))[0];
REAL(VECTOR_ELT(node, S3_SUMWEIGHTS))[0] = sweights;
/* compute the prediction of this node */
dprediction = REAL(S3get_prediction(node));
/* <FIXME> feed raw numeric values OR dummy encoded factors as y
Problem: what happens for survival times ? */
C_prediction(REAL(predy), nobs, ncol(predy), REAL(weights),
sweights, dprediction);
/* </FIXME> */
teststat = REAL(S3get_teststat(node));
pvalue = REAL(S3get_criterion(node));
/* try the two out of ninputs best inputs variables */
/* <FIXME> be more flexible and add a parameter controlling
the number of inputs tried </FIXME> */
for (j = 0; j < 2; j++) {
smax = C_max(pvalue, ninputs);
REAL(S3get_maxcriterion(node))[0] = smax;
/* if the global null hypothesis was rejected */
if (smax > mincriterion && !TERMINAL) {
/* the input variable with largest association to the response */
jselect = C_whichmax(pvalue, teststat, ninputs) + 1;
/* get the raw numeric values or the codings of a factor */
x = get_variable(inputs, jselect);
if (has_missings(inputs, jselect)) {
expcovinf = GET_SLOT(get_varmemory(fitmem, jselect),
PL2_expcovinfSym);
thisweights = C_tempweights(jselect, weights, fitmem, inputs);
} else {
expcovinf = GET_SLOT(fitmem, PL2_expcovinfSym);
thisweights = REAL(weights);
}
/* <FIXME> handle ordered factors separatly??? </FIXME> */
if (!is_nominal(inputs, jselect)) {
/* search for a split in a ordered variable x */
split = S3get_primarysplit(node);
/* check if the n-vector of splitstatistics
should be returned for each primary split */
if (get_savesplitstats(tgctrl)) {
C_init_orderedsplit(split, nobs);
splitstat = REAL(S3get_splitstatistics(split));
} else {
C_init_orderedsplit(split, 0);
splitstat = REAL(get_splitstatistics(fitmem));
}
C_split(REAL(x), 1, REAL(testy), q, thisweights, nobs,
INTEGER(get_ordering(inputs, jselect)), splitctrl,
GET_SLOT(fitmem, PL2_linexpcov2sampleSym),
expcovinf, REAL(S3get_splitpoint(split)), &maxstat,
splitstat);
S3set_variableID(split, jselect);
} else {
/* search of a set of levels (split) in a numeric variable x */
split = S3get_primarysplit(node);
/* check if the n-vector of splitstatistics
should be returned for each primary split */
if (get_savesplitstats(tgctrl)) {
C_init_nominalsplit(split,
LENGTH(get_levels(inputs, jselect)),
nobs);
splitstat = REAL(S3get_splitstatistics(split));
} else {
C_init_nominalsplit(split,
LENGTH(get_levels(inputs, jselect)),
0);
splitstat = REAL(get_splitstatistics(fitmem));
}
linexpcov = get_varmemory(fitmem, jselect);
standstat = Calloc(get_dimension(linexpcov), double);
C_standardize(REAL(GET_SLOT(linexpcov,
PL2_linearstatisticSym)),
REAL(GET_SLOT(linexpcov, PL2_expectationSym)),
REAL(GET_SLOT(linexpcov, PL2_covarianceSym)),
get_dimension(linexpcov), get_tol(splitctrl),
standstat);
C_splitcategorical(INTEGER(x),
LENGTH(get_levels(inputs, jselect)),
REAL(testy), q, thisweights,
nobs, standstat, splitctrl,
GET_SLOT(fitmem, PL2_linexpcov2sampleSym),
expcovinf, &cutpoint,
INTEGER(S3get_splitpoint(split)),
&maxstat, splitstat);
/* compute which levels of a factor are available in this node
(for printing) later on. A real `table' for this node would
induce too much overhead here. Maybe later. */
itable = INTEGER(S3get_table(split));
dxtransf = REAL(get_transformation(inputs, jselect));
for (k = 0; k < LENGTH(get_levels(inputs, jselect)); k++) {
itable[k] = 0;
for (i = 0; i < nobs; i++) {
if (dxtransf[k * nobs + i] * thisweights[i] > 0) {
itable[k] = 1;
continue;
}
}
}
Free(standstat);
}
if (maxstat == 0) {
if (j == 1) {
S3set_nodeterminal(node);
} else {
/* do not look at jselect in next iteration */
pvalue[jselect - 1] = R_NegInf;
}
} else {
S3set_variableID(split, jselect);
break;
}
} else {
int bound_traction_free_soln(exedata *exd, int nbnd, int *facn) {
// pointers.
int *pfacn, *pfccls, *pfcnds;
double *pfcnml, *pndcrd, *pvalue;
double *pisol, *pjsoln, *pcfl;
// scalars.
double amp;
// arrays.
double nvec[3], svec[3];
double rotm[3][3], bondm[6][6], bondminv[6][6];
double sts[6], trc[3];
// iterators.
int ibnd, ifc, icl, jcl, ieq;
int it, jt;
nvec[2] = 0.0;
svec[2] = 0.0;
pcfl = exd->cfl;
amp = 1.0;
pfacn = facn;
for (ibnd=0; ibnd<nbnd; ibnd++) {
ifc = pfacn[0];
pfccls = exd->fccls + ifc * FCREL;
icl = pfccls[0];
jcl = pfccls[1];
// determine amplification factor for vanishing variables.
//amp = pcfl[icl];
//amp = (1+amp)/fabs(1-amp);
//amp = 1/fabs(1-amp);
// set through velocity.
pisol = exd->sol + icl * NEQ;
pjsoln = exd->soln + jcl * NEQ;
pjsoln[0] = pisol[0];
pjsoln[1] = pisol[1];
pjsoln[2] = pisol[2];
// get transformation matrices.
pfcnml = exd->fcnml + ifc * NDIM;
nvec[0] = pfcnml[0];
nvec[1] = pfcnml[1];
pfcnds = exd->fcnds + ifc * (FCMND+1);
pndcrd = exd->ndcrd + pfcnds[2] * NDIM;
svec[0] = pndcrd[0];
svec[1] = pndcrd[1];
pndcrd = exd->ndcrd + pfcnds[1] * NDIM;
svec[0] -= pndcrd[0];
svec[1] -= pndcrd[1];
get_transformation(nvec, svec, rotm, bondm, bondminv);
// rotate original stress values to boundary coordinate system.
for (it=0; it<6; it++) {
sts[it] = 0.0;
for (jt=0; jt<6; jt++) {
sts[it] += bondm[it][jt] * pisol[jt+3];
};
};
// set vanishing rotated stress.
sts[0] = -amp*sts[0];
sts[5] = -amp*sts[5];
sts[4] = -amp*sts[4];
// rotate the boundary stress back to the original coordinate system.
for (it=0; it<6; it++) {
pjsoln[it+3] = 0.0;
for (jt=0; jt<6; jt++) {
pjsoln[it+3] += bondminv[it][jt] * sts[jt];
};
};
// advance boundary face.
pfacn += 3;
};
return 0;
}
