static SEXP shallow(SEXP dt, SEXP cols, R_len_t n)
{
// NEW: cols argument to specify the columns to shallow copy on. If NULL, all columns.
// called from alloccol where n is checked carefully, or from shallow() at R level
// where n is set to truelength (i.e. a shallow copy only with no size change)
SEXP newdt, names, newnames;
R_len_t i,l;
int protecti=0;
PROTECT(newdt = allocVector(VECSXP, n)); // to do, use growVector here?
protecti++;
//copyMostAttrib(dt, newdt); // including class
DUPLICATE_ATTRIB(newdt, dt);
// TO DO: keepattr() would be faster, but can't because shallow isn't merely a shallow copy. It
// also increases truelength. Perhaps make that distinction, then, and split out, but marked
// so that the next change knows to duplicate.
// Does copyMostAttrib duplicate each attrib or does it point? It seems to point, hence DUPLICATE_ATTRIB
// for now otherwise example(merge.data.table) fails (since attr(d4,"sorted") gets written by setnames).
names = getAttrib(dt, R_NamesSymbol);
PROTECT(newnames = allocVector(STRSXP, n));
protecti++;
if (isNull(cols)) {
l = LENGTH(dt);
for (i=0; i<l; i++) SET_VECTOR_ELT(newdt, i, VECTOR_ELT(dt,i));
if (length(names)) {
if (length(names) < l) error("Internal error: length(names)>0 but <length(dt)");
for (i=0; i<l; i++) SET_STRING_ELT(newnames, i, STRING_ELT(names,i));
}
// else an unnamed data.table is valid e.g. unname(DT) done by ggplot2, and .SD may have its names cleared in dogroups, but shallow will always create names for data.table(NULL) which has 100 slots all empty so you can add to an empty data.table by reference ok.
} else {
l = length(cols);
for (i=0; i<l; i++) SET_VECTOR_ELT(newdt, i, VECTOR_ELT(dt,INTEGER(cols)[i]-1));
if (length(names)) {
// no need to check length(names) < l here. R-level checks if all value
// in 'cols' are valid - in the range of 1:length(names(x))
for (i=0; i<l; i++) SET_STRING_ELT( newnames, i, STRING_ELT(names,INTEGER(cols)[i]-1) );
}
}
setAttrib(newdt, R_NamesSymbol, newnames);
// setAttrib appears to change length and truelength, so need to do that first _then_ SET next,
// otherwise (if the SET were were first) the 100 tl is assigned to length.
SETLENGTH(newnames,l);
SET_TRUELENGTH(newnames,n);
SETLENGTH(newdt,l);
SET_TRUELENGTH(newdt,n);
setselfref(newdt);
// SET_NAMED(dt,1); // for some reason, R seems to set NAMED=2 via setAttrib? Need NAMED to be 1 for passing to assign via a .C dance before .Call (which sets NAMED to 2), and we can't use .C with DUP=FALSE on lists.
UNPROTECT(protecti);
return(newdt);
}
SEXP parse_headers(SEXP sRaw) {
SEXP res = PROTECT(allocVector(STRSXP, MAX_HDR_ENTRIES)), rn = allocVector(STRSXP, MAX_HDR_ENTRIES);
Rf_setAttrib(res, R_NamesSymbol, rn);
int i = 0;
const char *cs = (const char*) RAW(sRaw), *c = cs, *e;
R_xlen_t len = XLENGTH(sRaw), ct = 0;
e = c + len;
while (c < e) {
const char *r = memchr(c, ':', e - c);
if (!r) /* we jsut ignore trailing content - it shouldn't be there ... */
break;
if (i == MAX_HDR_ENTRIES)
Rf_error("Sorry, too many header entries, aborting");
/* we have header field entry - add it */
SET_STRING_ELT(rn, i, mkCharLen(c, r - c));
c = r + 1;
while (c < e && (*c == ' ' || *c == '\t')) c++;
const char *val = c;
while (1) {
r = memchr(c, '\n', e - c);
/* if we don't find a newline then just use everything till the end */
if (!r) {
while (e > c && (e[-1] == '\r' || e[-1] == '\n')) e--;
SET_STRING_ELT(res, i, mkCharLen(val, e - val));
i++;
c = e; /* end */
break;
}
/* advance */
c = r + 1;
/* not a continuation? add it */
if (!(c < e && (*c == ' ' || *c == '\t'))) {
/* trim newlines */
while (r > val && (*r == '\n' || *r == '\t')) r--;
SET_STRING_ELT(res, i, mkCharLen(val, r - val));
i++;
break;
}
/* continuation */
}
}
SETLENGTH(rn, i);
SETLENGTH(res, i);
UNPROTECT(1);
return res;
}
SEXP mc_children()
{
rm_closed();
child_info_t *ci = children;
unsigned int count = 0;
while (ci && ci->pid > 0) {
count++;
ci = ci->next;
}
SEXP res = allocVector(INTSXP, count);
if (count) {
int *pids = INTEGER(res);
ci = children;
while (ci && ci->pid > 0) {
(pids++)[0] = ci->pid;
ci = ci->next;
}
/* in theory signals can flag a pid as closed in the
meantime, we may end up with fewer children than
expected - highly unlikely but possible */
if (pids - INTEGER(res) < LENGTH(res))
SETLENGTH(res, (int)(pids - INTEGER(res)));
}
return res;
}
/* used in devWindows.c and cairoDevice */
void doMouseEvent(pDevDesc dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(mouseHandlers[event]), dd->eventEnv);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, dd->eventEnv);
if (TYPEOF(handler) == CLOSXP) {
defineVar(install("which"), ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(bvec = allocVector(INTSXP, 3));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
SETLENGTH(bvec, i);
PROTECT(sx = ScalarReal( (x - dd->left) / (dd->right - dd->left) ));
PROTECT(sy = ScalarReal((y - dd->bottom) / (dd->top - dd->bottom) ));
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(5);
R_FlushConsole();
}
dd->gettingEvent = TRUE;
return;
}
void setFinalNrow(size_t nrow) {
// TODO realloc
if (length(DT)) {
if (nrow == length(VECTOR_ELT(DT, 0)))
return;
for (int i=0; i<LENGTH(DT); i++) {
SETLENGTH(VECTOR_ELT(DT,i), nrow);
SET_TRUELENGTH(VECTOR_ELT(DT,i), nrow);
}
}
}
void setFinalNrow(size_t nrow) {
// TODO realloc
if (length(DT)) {
if (nrow == dtnrows)
return;
for (int i=0; i<LENGTH(DT); i++) {
SETLENGTH(VECTOR_ELT(DT,i), nrow);
SET_TRUELENGTH(VECTOR_ELT(DT,i), nrow);
}
}
R_FlushConsole(); // # 2481. Just a convenient place; nothing per se to do with setFinalNrow()
}
/* FIXME: we may want to deprecate this in favor of file("stdin", "rb")
unless there is a substantial performance difference. */
SEXP stdin_read(SEXP sN) {
FILE *f = stdin;
int n = asInteger(sN), i = 0, incomplete = 0;
SEXP res = PROTECT(allocVector(STRSXP, n));
while (i < n && !feof(f) && fgets(buf, sizeof(buf), f)) {
char *eol = strchr(buf, '\n');
if (eol) *eol = 0; else incomplete++;
SET_STRING_ELT(res, i++, mkChar(buf));
}
if (i < n) SETLENGTH(res, i);
UNPROTECT(1);
if (incomplete) Rf_warning("incomplete lines encountered (%d)", incomplete);
return res;
}
void RVector::append(SEXP e) {
if (size_ == capacity_) {
Protect p(e);
capacity_ *= grow;
SEXP new_vector = Rf_allocVector(VECSXP, capacity_);
for (size_t i = 0; i < size_; ++i) {
SET_VECTOR_ELT(new_vector, i, at(i));
}
R_ReleaseObject(vector);
R_PreserveObject(new_vector);
vector = new_vector;
}
size_++;
SETLENGTH(vector, size_);
SET_VECTOR_ELT(vector, size_ - 1, e);
}
SEXP PKI_decrypt(SEXP what, SEXP sKey, SEXP sCipher) {
SEXP res;
EVP_PKEY *key;
RSA *rsa;
int len;
if (TYPEOF(what) != RAWSXP)
Rf_error("invalid payload to sign - must be a raw vector");
PKI_init();
if (!inherits(sKey, "private.key")) {
int transient_cipher = 0, fin = 0;
EVP_CIPHER_CTX *ctx = get_cipher(sKey, sCipher, 0, &transient_cipher);
/* FIXME: ctx will leak on alloc errors for transient ciphers - wrap them first */
res = allocVector(RAWSXP, len = LENGTH(what));
if (!EVP_CipherUpdate(ctx, RAW(res), &len, RAW(what), LENGTH(what))) {
if (transient_cipher) {
EVP_CIPHER_CTX_cleanup(ctx);
free(ctx);
}
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
}
if (EVP_CipherFinal(ctx, RAW(res) + len, &fin))
len += fin;
if (len < LENGTH(res))
SETLENGTH(res, len);
if (transient_cipher) {
EVP_CIPHER_CTX_cleanup(ctx);
free(ctx);
}
return res;
}
key = (EVP_PKEY*) R_ExternalPtrAddr(sKey);
if (!key)
Rf_error("NULL key");
if (EVP_PKEY_type(key->type) != EVP_PKEY_RSA)
Rf_error("Sorry only RSA keys are supported at this point");
rsa = EVP_PKEY_get1_RSA(key);
if (!rsa)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
len = RSA_private_decrypt(LENGTH(what), RAW(what), (unsigned char*) buf, rsa, RSA_PKCS1_PADDING);
if (len < 0)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
res = allocVector(RAWSXP, len);
memcpy(RAW(res), buf, len);
return res;
}
static void finalizer(SEXP p)
{
SEXP x;
R_len_t n, l, tl;
if(!R_ExternalPtrAddr(p)) error("Internal error: finalizer hasn't received an ExternalPtr");
p = R_ExternalPtrTag(p);
if (!isString(p)) error("Internal error: finalizer's ExternalPtr doesn't see names in tag");
l = LENGTH(p);
tl = TRUELENGTH(p);
if (l<0 || tl<l) error("Internal error: finalizer sees l=%d, tl=%d",l,tl);
n = tl-l;
if (n==0) {
// gc's ReleaseLargeFreeVectors() will have reduced R_LargeVallocSize by the correct amount
// already, so nothing to do (but almost never the case).
return;
}
x = PROTECT(allocVector(VECSXP, 50)); // 50 so it's big enough to be on LargeVector heap. See NodeClassSize in memory.c:allocVector
SETLENGTH(x,50+n*2); // 1*n for the names, 1*n for the VECSXP itself (both are over allocated)
UNPROTECT(1);
return;
}
SEXP doMouseEvent(SEXP eventRho, NewDevDesc *dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(mouseHandlers[event]), eventRho);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, eventRho);
result = NULL;
if (handler != R_UnboundValue && handler != R_NilValue) {
PROTECT(bvec = allocVector(INTSXP, 3));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
SETLENGTH(bvec, i);
PROTECT(sx = allocVector(REALSXP, 1));
REAL(sx)[0] = (x - dd->left) / (dd->right - dd->left);
PROTECT(sy = allocVector(REALSXP, 1));
REAL(sy)[0] = (y - dd->bottom) / (dd->top - dd->bottom);
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, eventRho));
R_FlushConsole();
UNPROTECT(5);
}
dd->gettingEvent = TRUE;
return result;
}
RVector::RVector(size_t init_size)
: size_(0), capacity_(slack), vector(Rf_allocVector(VECSXP, init_size)) {
SETLENGTH(vector, 0);
R_PreserveObject(vector);
}
SEXP glm_sampleworep(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
SEXP Rprobinit, SEXP Rmodeldim,
SEXP modelprior, SEXP betaprior,SEXP Rbestmodel, SEXP plocal,
SEXP family, SEXP Rcontrol,
SEXP Rupdate, SEXP Rlaplace, SEXP Rparents) {
int nProtected = 0;
int nModels=LENGTH(Rmodeldim);
// Rprintf("Allocating Space for %d Models\n", nModels) ;
SEXP ANS = PROTECT(allocVector(VECSXP, 14)); ++nProtected;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 14)); ++nProtected;
SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP deviance = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Q = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Rintercept = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
double *probs,logmargy, shrinkage_m;
int i;
glmstptr *glmfamily;
glmfamily = make_glmfamily_structure(family);
betapriorptr *betapriorfamily;
betapriorfamily = make_betaprior_structure(betaprior, family);
//get dimsensions of all variables
int p = INTEGER(getAttrib(X,R_DimSymbol))[1];
int k = LENGTH(modelprobs);
int update = INTEGER(Rupdate)[0];
double eps = DBL_EPSILON;
double problocal = REAL(plocal)[0];
struct Var *vars = (struct Var *) R_alloc(p, sizeof(struct Var)); // Info about the model variables.
probs = REAL(Rprobs);
int n = sortvars(vars, probs, p);
int *model = ivecalloc(p);
/* fill in the sure things */
for (i = n; i < p; i++) {
model[vars[i].index] = (int) vars[i].prob;
}
GetRNGstate();
NODEPTR tree, branch;
tree = make_node(vars[0].prob);
// Rprintf("For m=0, Initialize Tree with initial Model\n");
int m = 0;
int *bestmodel = INTEGER(Rbestmodel);
for (i = n; i < p; i++) {
model[vars[i].index] = bestmodel[vars[i].index];
INTEGER(modeldim)[m] += bestmodel[vars[i].index];
}
double *pigamma = vecalloc(p);
branch = tree;
CreateTree_with_pigamma(branch, vars, bestmodel, model, n, m, modeldim,pigamma, Rparents);
branch=tree;
Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);
int pmodel = INTEGER(modeldim)[m];
SEXP Rmodel_m = PROTECT(allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
//evaluate logmargy and shrinkage
SEXP glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
double prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q,Rintercept, m);
UNPROTECT(2);
int *modelwork= ivecalloc(p);
// sample models
for (m = 1; m < k && pigamma[0] < 1.0; m++) {
INTEGER(modeldim)[m] = 0.0;
for (i = n; i < p; i++) {
INTEGER(modeldim)[m] += model[vars[i].index];
}
branch = tree;
GetNextModel_swop(branch, vars, model, n, m, pigamma, problocal,
modeldim, bestmodel,Rparents);
/* Now subtract off the visited probability mass. */
branch=tree;
Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);
/* Now get model specific calculations */
pmodel = INTEGER(modeldim)[m];
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
memset(INTEGER(Rmodel_m), 0, pmodel * sizeof(int));
GetModel_m(Rmodel_m, model, p);
glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2,Q,Rintercept, m);
UNPROTECT(2);
REAL(sampleprobs)[m] = pigamma[0];
//update best model
//update marginal inclusion probs
if (m > 1) {
double mod;
double rem = modf((double) m/(double) update, &mod);
if (rem == 0.0) {
int mcurrent = m;
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
if (update_probs(probs, vars, mcurrent, k, p) == 1) {
// Rprintf("Updating Model Tree %d \n", m);
update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);
}
}
}
}
if (m < k) {
// resize if constraints have reduced the number of models
k = m;
SETLENGTH(modelspace, m);
SETLENGTH(logmarg, m);
SETLENGTH(modelprobs, m);
SETLENGTH(priorprobs, m);
SETLENGTH(sampleprobs, m);
SETLENGTH(beta, m);
SETLENGTH(se, m);
SETLENGTH(deviance, m);
SETLENGTH(Q, m);
SETLENGTH(Rintercept, m);
SETLENGTH(shrinkage, m);
SETLENGTH(modeldim, m);
SETLENGTH(R2, m);
}
compute_modelprobs(modelprobs, logmarg, priorprobs,k);
compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p);
SET_VECTOR_ELT(ANS, 0, Rprobs);
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));
SET_VECTOR_ELT(ANS, 1, modelspace);
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
SET_VECTOR_ELT(ANS, 2, logmarg);
SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));
SET_VECTOR_ELT(ANS, 3, modelprobs);
SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));
SET_VECTOR_ELT(ANS, 4, priorprobs);
SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));
SET_VECTOR_ELT(ANS, 5,sampleprobs);
SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));
SET_VECTOR_ELT(ANS, 6, deviance);
SET_STRING_ELT(ANS_names, 6, mkChar("deviance"));
SET_VECTOR_ELT(ANS, 7, beta);
SET_STRING_ELT(ANS_names, 7, mkChar("mle"));
SET_VECTOR_ELT(ANS, 8, se);
SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));
SET_VECTOR_ELT(ANS, 9, shrinkage);
SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));
SET_VECTOR_ELT(ANS, 10, modeldim);
SET_STRING_ELT(ANS_names, 10, mkChar("size"));
SET_VECTOR_ELT(ANS, 11, R2);
SET_STRING_ELT(ANS_names, 11, mkChar("R2"));
SET_VECTOR_ELT(ANS, 12, Q);
SET_STRING_ELT(ANS_names, 12, mkChar("Q"));
SET_VECTOR_ELT(ANS, 13, Rintercept);
SET_STRING_ELT(ANS_names, 13, mkChar("intercept"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
PutRNGstate();
UNPROTECT(nProtected);
return(ANS);
}
SEXP time_rel_seq( SEXP start_time, SEXP end_time,
SEXP len_vec, SEXP has_len,
SEXP rel_strs, SEXP hol_vec,
SEXP zone_list)
{
SEXP ret, tmp_days, tmp_ms;
Sint *start_days, *start_ms, *end_days, *end_ms,
*out_days, *out_ms, *use_len, *seq_len;
Sint *hol_days, *hol_ms, num_alloc;
Sint i, lng_hol, lng, direction=0;
TIME_DATE_STRUCT td, td_hol;
TZONE_STRUCT *tzone, *tzone_hol;
char *in_strs;
Sint *hol_dates;
Sint pre_start_day, pre_start_ms, used_old_alg ;
Sint num_protect=0;
/* figure out if we have end time or length */
PROTECT(has_len = AS_LOGICAL(has_len));
num_protect++;
if( length(has_len) < 1L){
UNPROTECT(num_protect);
error( "Problem extracting data from second argument in C function time_rel_seq" );
}
use_len = (Sint *) LOGICAL(has_len);
/* get the desired parts of the time objects */
if( !time_get_pieces( start_time, NULL, &start_days, &start_ms, &lng, NULL,
&td.zone, NULL ) ||
!td.zone || !lng || !start_days || !start_ms ){
UNPROTECT(num_protect);
error( "Invalid time argument in C function time_rel_seq" );
}
num_protect += 2; //from time_get_pieces
if( lng > 1 )
warning( "Start time has multiple elements; only the first will be used" );
tzone = find_zone( td.zone, zone_list );
if( !tzone ){
UNPROTECT(num_protect);
error( "Unknown or unreadable time zone in C function time_rel_seq" );
}
if( !(*use_len))
{
if( !time_get_pieces( end_time, NULL, &end_days, &end_ms,
&lng, NULL, NULL, NULL ) ||
!lng || !end_days || !end_ms ){
error( "Invalid time argument in C function time_rel_seq" );
UNPROTECT(num_protect);
}
num_protect +=2;
if( lng > 1 )
warning( "End time has multiple elements; only the first will be used" );
}
if( !time_get_pieces( hol_vec, NULL, &hol_days, &hol_ms, &lng_hol, NULL,
&td_hol.zone, NULL ) ||
(( lng_hol && (!hol_days || !hol_ms )) || !td_hol.zone )){
UNPROTECT(num_protect);
error( "Invalid holiday argument in C function time_rel_seq" );
}
num_protect +=2;
tzone_hol = find_zone( td_hol.zone, zone_list );
if( !tzone_hol ){
UNPROTECT(num_protect);
error( "Unknown or unreadable time zone for holidays in C function time_rel_seq" );
}
/* extract the rel time string */
if(!isString(rel_strs) || (lng = length(rel_strs)) < 1L){
UNPROTECT(num_protect);
error( "Problem extracting relative time strings in C function time_rel_seq" );
}
if( lng > 1 )
warning( "Relative time has multiple elements; only the first will be used" );
in_strs = (char *) CHAR(STRING_ELT(rel_strs, 0));
/* extract the length */
if( *use_len )
{
if( !IS_INTEGER(len_vec) || (lng = length(len_vec)) < 1L){
UNPROTECT(num_protect);
error( "Problem extracting data from third argument in C function time_rel_seq" );
}
seq_len = INTEGER(len_vec);
if( *seq_len < 0 )
error( "Length cannot be less than zero" );
if( lng > 1 )
warning( "Length has multiple elements; only the first will be used" );
}
/* get list of holiday dates */
hol_dates = NULL;
if( lng_hol )
{
hol_dates = (Sint *) R_alloc( lng_hol, sizeof(Sint) );
for( i = 0; i < lng_hol; i++ )
{
if( hol_days[i] ==NA_INTEGER ||
hol_ms[i] ==NA_INTEGER ||
!jms_to_struct( hol_days[i], hol_ms[i], &td_hol ) ||
!GMT_to_zone( &td_hol, tzone_hol ) ||
!julian_from_mdy( td_hol, &(hol_dates[i])))
error( "Bad holiday data in C function time_rel_seq" );
}
}
/* create output time object or temporary storage */
if( *use_len )
{
if( *seq_len ==NA_INTEGER){
UNPROTECT(num_protect);
error( "NA not allowed in sequence" );
}
PROTECT(ret = time_create_new( *seq_len, &out_days, &out_ms ));
num_protect++;
if( !out_days || !out_ms || !ret ){
UNPROTECT(num_protect);
error( "Could not create return object in C function time_rel_seq" );
}
if(*seq_len == 0){
UNPROTECT(num_protect);
return ret;
}
} else
{
/* figure out the direction */
if( *end_days ==NA_INTEGER || *end_ms ==NA_INTEGER){
UNPROTECT(num_protect);
error( "NA not allowed in sequence" );
}
if(( *start_days > *end_days ) ||
(( *start_days == *end_days ) && ( *start_ms > *end_ms )))
direction = -1;
else if(( *end_days > *start_days ) ||
(( *start_days == *end_days ) && ( *end_ms > *start_ms )))
direction = 1;
else
direction = 0; /* this will be a flag to end after copying in start */
/* we don't know the length we'll need. Allocate at least 100,
and assume daily to figure out approx length if longer */
num_alloc = 100;
if( *start_days - *end_days > 100 )
num_alloc = *start_days - *end_days + 20;
if( *end_days - *start_days > 100 )
num_alloc = *end_days - *start_days + 20;
PROTECT(tmp_days = NEW_INTEGER(num_alloc));
PROTECT(tmp_ms = NEW_INTEGER(num_alloc));
num_protect += 2;
out_days = INTEGER(tmp_days);
out_ms = INTEGER(tmp_ms);
}
/* start with the start time */
if( *start_days ==NA_INTEGER || *start_ms ==NA_INTEGER){
UNPROTECT(num_protect);
error( "NA not allowed in sequence" );
}
/* fprintf(stderr, " time_rel_seq: start=%ld,%ld, in_strs[0]=%s\n", *start_days, *start_ms, in_strs[0]); */
if (avoid_bad_start_day) {
/* the following is gross. -wwd */
char tmp_strs[100] ;
strncpy(tmp_strs, in_strs, 99);
if (tmp_strs[0] == '-')
tmp_strs[0] = '+';
else if (tmp_strs[0] == '+')
tmp_strs[0] = '-';
if (tmp_strs[1] == 'a') {
/* fprintf(stderr, " time_rel_seq: alignment might have caused problems -- using old algorithm\n"); */
out_days[0] = *start_days;
out_ms[0] = *start_ms;
used_old_alg = 1 ;
i = 1 ;
} else {
/* convert to local zone, add, and convert back */
if( !jms_to_struct( *start_days, *start_ms, &td ) ||
!rtime_add_with_zones( &td, tmp_strs, hol_dates, lng_hol, tzone ) ||
!julian_from_mdy( td, &pre_start_day) ||
!ms_from_hms( td, &pre_start_ms)){
UNPROTECT(num_protect);
error( "Could not subtract relative time in C function time_rel_seq" );
}
/* fprintf(stderr, "pre_start=%ld,%ld\n", pre_start_day, pre_start_ms); */
i = 0; /* was i=1 */
used_old_alg = 0 ;
}
} else {
/* original algorithm */
out_days[0] = *start_days;
out_ms[0] = *start_ms;
i = 1 ;
used_old_alg = 1 ;
}
/* go through input and perform operation */
#define PREV_DAY ( (i>0) ? out_days[i-1] : pre_start_day )
#define PREV_MS ( (i>0) ? out_ms[i-1] : pre_start_ms )
/*LINTED: Const meant to be in cond context here */
while( 1 )
{
/* see if we are done */
if( *use_len && ( i >= *seq_len )){
UNPROTECT(num_protect);
return ret;
}
if( !*use_len )
{
if( !direction )
break;
if(( direction * ( PREV_DAY - *end_days ) > 0 ) ||
(( PREV_DAY == *end_days ) &&
( direction * ( PREV_MS - *end_ms ) > 0 )))
{
if (i>0) /* is i==0 possible? I think it means an error */
i--;
break;
}
/* also check on our allocation */
if( i >= num_alloc - 1 )
{
num_alloc += 200;
SETLENGTH( tmp_days, num_alloc );
out_days = INTEGER(tmp_days) ;
SETLENGTH( tmp_ms, num_alloc );
out_ms = INTEGER(tmp_ms) ;
}
}
/* convert to local zone, add, and convert back */
if( !jms_to_struct( PREV_DAY, PREV_MS, &td ) ||
!rtime_add_with_zones( &td, in_strs, hol_dates, lng_hol, tzone ) ||
!julian_from_mdy( td, &(out_days[i] )) ||
!ms_from_hms( td, &(out_ms[i] ))){
UNPROTECT(num_protect);
error( "Could not add relative time in C function time_rel_seq" );
}
/* make sure we went in the right direction */
if(( out_days[i] == PREV_DAY ) &&
( out_ms[i] == PREV_MS )){
UNPROTECT(num_protect);
error( "Relative date addition resulted in stationary time" );
}
if( !direction )
{
if(( out_days[i] > PREV_DAY ) ||
(( out_days[i] == PREV_DAY ) &&
( out_ms[i] > PREV_MS )))
direction = 1;
else
direction = -1;
} else
{
if(( direction * ( out_days[i] - PREV_DAY ) < 0 ) ||
(( out_days[i] == PREV_DAY ) &&
( direction * ( out_ms[i] - PREV_MS) < 0 ))){
UNPROTECT(num_protect);
error( "Relative date addition resulted in non-monotonic sequence" );
}
}
i++;
}
/* if we got here, it means we have to make a time object and
copy in the numbers now */
num_alloc = i;
PROTECT(ret = time_create_new( num_alloc, &end_days, &end_ms ));
num_protect++;
if( !end_days || !end_ms || !ret ){
UNPROTECT(num_protect);
error( "Could not create return object in C function time_rel_seq" );
}
for( i = 0; i < num_alloc; i++ )
{
end_days[i] = out_days[i];
end_ms[i] = out_ms[i];
}
UNPROTECT(num_protect);
return ret;
}
/*
This function updates the forest by splitting the nodes specified
@param R_observations - observations of feature vectors
@param R_responses - observations of response variable
@param R_forest - forest
@param R_active_nodes - active nodes to update
@param R_splits_info - best splits for all nodes
@param R_max_depth - the depth for which to stop growing trees
@return - count of observations in all leaf nodes
*/
SEXP updateNodes(SEXP R_observations, SEXP R_responses, SEXP R_forest, SEXP R_active_nodes, SEXP R_splits_info, SEXP R_max_depth)
{
hpdRFforest *forest = (hpdRFforest *) R_ExternalPtrAddr(R_forest);
int* features_categorical = forest-> features_cardinality;
int* bin_num = forest->bin_num;
int features_num = forest->features_num;
int leaf_nodes = forest->nleaves -
length(R_active_nodes) +
2*INTEGER(getAttrib(R_splits_info,install("total_completed")))[0];
hpdRFnode **new_leaves = (hpdRFnode**)malloc(sizeof(hpdRFnode*)*leaf_nodes);
SEXP R_node_counts;
PROTECT(R_node_counts = allocVector(INTSXP,leaf_nodes));
int *node_counts = INTEGER(R_node_counts);
int max_depth = INTEGER(R_max_depth)[0];
leaf_nodes = 0;
int index = 0;
for(int i = 0; i < forest->nleaves;i++)
{
hpdRFnode* node_curr = forest->leaf_nodes[i];
int next_active_node = index < length(R_active_nodes) ?
INTEGER(R_active_nodes)[index]-1: -1;
if(i == next_active_node)
{
if(INTEGER(VECTOR_ELT(VECTOR_ELT(R_splits_info,index),0))[0]==1)
{
int active_node = INTEGER(R_active_nodes)[index]-1;
node_curr = forest->leaf_nodes[active_node];
int* left_child_node_observations;
int* right_child_node_observations;
double* left_child_weights, *right_child_weights;
int left_child_num_obs, right_child_num_obs;
int* node_observations = node_curr->additional_info->indices;
double* node_weights = node_curr->additional_info->weights;
int node_observations_num = node_curr->additional_info->num_obs;
int node_split_variable = INTEGER(VECTOR_ELT(VECTOR_ELT(R_splits_info,index),1))[0]-1;
SEXP node_split_criteria = VECTOR_ELT(VECTOR_ELT(R_splits_info,index),2);
updateNode(VECTOR_ELT(R_observations,node_split_variable),
node_split_criteria, node_observations, node_observations_num,
&left_child_node_observations,
&right_child_node_observations,
features_categorical[node_split_variable] != NA_INTEGER,
bin_num[node_split_variable],
node_weights, &left_child_weights, &right_child_weights,
&left_child_num_obs, &right_child_num_obs);
hpdRFnode *node_left_child = createChildNode(node_curr, FALSE,
left_child_node_observations,
left_child_weights,
left_child_num_obs,features_num);
hpdRFnode *node_right_child = createChildNode(node_curr, FALSE,
right_child_node_observations,
right_child_weights,
right_child_num_obs,features_num);
node_curr->left = node_left_child;
node_curr->right = node_right_child;
if(node_left_child->additional_info->depth <= max_depth)
{
node_left_child->additional_info->leafID = leaf_nodes+1;
node_counts[leaf_nodes] =
node_left_child->additional_info->num_obs;
new_leaves[leaf_nodes++] = node_left_child;
}
if(node_right_child->additional_info->depth <= max_depth)
{
node_right_child->additional_info->leafID = leaf_nodes+1;
node_counts[leaf_nodes] =
node_right_child->additional_info->num_obs;
new_leaves[leaf_nodes++] = node_right_child;
}
}
cleanSingleNode(node_curr);
index ++;
}
else if(i != next_active_node &&
node_curr->additional_info->depth <= max_depth)
{
node_curr->additional_info->leafID = leaf_nodes+1;
node_counts[leaf_nodes] = node_curr->additional_info->num_obs;
new_leaves[leaf_nodes++] = node_curr;
}
}
free(forest->leaf_nodes);
forest->nleaves = leaf_nodes;
forest->leaf_nodes = new_leaves;
SETLENGTH(R_node_counts,leaf_nodes);
UNPROTECT(1);
return R_node_counts;
}
static SEXP subsetVectorRaw(SEXP x, SEXP idx, int l, int tl)
// Only for use by subsetDT() or subsetVector() below, hence static
// l is the count of non-zero (including NAs) in idx i.e. the length of the result
// tl is the amount to be allocated, tl>=l
// TO DO: if no 0 or NA detected up front in subsetDT() below, could switch to a faster subsetVectorRawNo0orNA()
{
int i, this, ansi=0, max=length(x), n=LENGTH(idx), *pidx=INTEGER(idx);
if (tl<l) error("Internal error: tl<n passed to subsetVectorRaw");
SEXP ans = PROTECT(allocVector(TYPEOF(x), tl));
SETLENGTH(ans, l);
SET_TRUELENGTH(ans, tl);
// Rprintf("l=%d, tl=%d, LENGTH(idx)=%d\n", l, tl, LENGTH(idx));
#ifdef _OPENMP
int *ctr = (int *)calloc(omp_get_max_threads()+1, sizeof(int));
#endif
switch(TYPEOF(x)) {
case INTSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads(); // local
// computing count indices correctly is tricky when there are 0-indices.
// 1. count number of non-0 'idx' for each thread
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0); // don't use ctr[ithread+1] here -- false sharing
// TODO: use SIMD here?
ctr[ithread+1] = tmp; // ctr[0]=0, rest contains count where iidx!=0,
// within each thread's range
#pragma omp barrier // wait for all threads, important
// 2. using that, set the starting index for each thread appropriately
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i]; // for each thread, compute the right starting point, by
// taking (non)0-count into account, computed above.
tmp = ctr[ithread]; // copy back from shared to thread's local var. All set.
#pragma omp barrier // wait for all threads, important
// 3. use old code, but with thread's local var with right start index as counter
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
// have to use 'tmp' here, and not ctr[ithread++] -- false sharing
INTEGER(ans)[tmp++] = (this==NA_INTEGER || this>max) ? NA_INTEGER : INTEGER(x)[this-1];
ansi++; // not required, but just to be sure
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
INTEGER(ans)[ansi++] = (this==NA_INTEGER || this>max) ? NA_INTEGER : INTEGER(x)[this-1];
}
#endif
break;
case REALSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
REAL(ans)[tmp++] = (this==NA_INTEGER || this>max) ? NA_REAL : REAL(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
REAL(ans)[ansi++] = (this==NA_INTEGER || this>max) ? NA_REAL : REAL(x)[this-1];
}
#endif
break;
case LGLSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
LOGICAL(ans)[tmp++] = (this==NA_INTEGER || this>max) ? NA_LOGICAL : LOGICAL(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
LOGICAL(ans)[ansi++] = (this==NA_INTEGER || this>max) ? NA_LOGICAL : LOGICAL(x)[this-1];
}
#endif
break;
case STRSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_STRING_ELT(ans, tmp++, (this==NA_INTEGER || this>max) ? NA_STRING : STRING_ELT(x, this-1));
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_STRING_ELT(ans, ansi++, (this==NA_INTEGER || this>max) ? NA_STRING : STRING_ELT(x, this-1));
}
#endif
break;
case VECSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_VECTOR_ELT(ans, tmp++, (this==NA_INTEGER || this>max) ? R_NilValue : VECTOR_ELT(x, this-1));
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_VECTOR_ELT(ans, ansi++, (this==NA_INTEGER || this>max) ? R_NilValue : VECTOR_ELT(x, this-1));
}
#endif
break;
// Fix for #982
// source: https://github.com/wch/r-source/blob/fbf5cdf29d923395b537a9893f46af1aa75e38f3/src/main/subset.c
case CPLXSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
if (this == NA_INTEGER || this>max) {
COMPLEX(ans)[tmp].r = NA_REAL;
COMPLEX(ans)[tmp++].i = NA_REAL;
} else COMPLEX(ans)[tmp++] = COMPLEX(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this == 0) continue;
if (this == NA_INTEGER || this>max) {
COMPLEX(ans)[ansi].r = NA_REAL;
COMPLEX(ans)[ansi].i = NA_REAL;
} else COMPLEX(ans)[ansi] = COMPLEX(x)[this-1];
ansi++;
}
#endif
break;
case RAWSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
RAW(ans)[tmp++] = (this == NA_INTEGER || this>max) ? (Rbyte) 0 : RAW(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this == 0) continue;
RAW(ans)[ansi++] = (this == NA_INTEGER || this>max) ? (Rbyte) 0 : RAW(x)[this-1];
}
#endif
break;
default :
error("Unknown column type '%s'", type2char(TYPEOF(x)));
}
#ifdef _OPENMP
free(ctr);
#endif
if (ansi != l) error("Internal error: ansi [%d] != l [%d] at the end of subsetVector", ansi, l);
copyMostAttrib(x, ans);
UNPROTECT(1);
return(ans);
}
