SEXP _dots_unpack(SEXP dots) {
int i;
SEXP s;
int length = 0;
SEXP names, environments, expressions, values;
//SEXP evaluated, codeptr, missing, wraplist;
//SEXP seen;
SEXP dataFrame;
SEXP colNames;
//check inputs and measure length
length = _dots_length(dots);
// unpack information for each item:
// names, environemnts, expressions, values, evaluated, seen
PROTECT(names = allocVector(STRSXP, length));
PROTECT(environments = allocVector(VECSXP, length));
PROTECT(expressions = allocVector(VECSXP, length));
PROTECT(values = allocVector(VECSXP, length));
for (s = dots, i = 0; i < length; s = CDR(s), i++) {
if (TYPEOF(s) != DOTSXP && TYPEOF(s) != LISTSXP)
error("Expected dotlist or pairlist, got %s at index %d", type2char(TYPEOF(s)), i);
SEXP item = CAR(s);
if (item == R_MissingArg) item = emptypromise();
if (TYPEOF(item) != PROMSXP)
error("Expected PROMSXP as CAR of DOTSXP, got %s", type2char(TYPEOF(item)));
// if we have an unevluated promise whose code is another promise, descend
while ((PRENV(item) != R_NilValue) && (TYPEOF(PRCODE(item)) == PROMSXP)) {
item = PRCODE(item);
}
if ((TYPEOF(PRENV(item)) != ENVSXP) && (PRENV(item) != R_NilValue))
error("Expected ENVSXP or NULL in environment slot of DOTSXP, got %s",
type2char(TYPEOF(item)));
SET_STRING_ELT(names, i, isNull(TAG(s)) ? mkChar("") : PRINTNAME(TAG(s)));
SET_VECTOR_ELT(environments, i, PRENV(item));
SET_VECTOR_ELT(expressions, i, PREXPR(item));
if (PRVALUE(item) != R_UnboundValue) {
SET_VECTOR_ELT(values, i, PRVALUE(item));
} else {
SET_VECTOR_ELT(values, i, R_NilValue);
}
}
PROTECT(dataFrame = allocVector(VECSXP, 4));
SET_VECTOR_ELT(dataFrame, 0, names);
SET_VECTOR_ELT(dataFrame, 1, environments);
SET_VECTOR_ELT(dataFrame, 2, expressions);
SET_VECTOR_ELT(dataFrame, 3, values);
PROTECT(colNames = allocVector(STRSXP, 4));
SET_STRING_ELT(colNames, 0, mkChar("name"));
SET_STRING_ELT(colNames, 1, mkChar("envir"));
SET_STRING_ELT(colNames, 2, mkChar("expr"));
SET_STRING_ELT(colNames, 3, mkChar("value"));
setAttrib(expressions, R_ClassSymbol, ScalarString(mkChar("deparse")));
setAttrib(environments, R_ClassSymbol, ScalarString(mkChar("deparse")));
setAttrib(values, R_ClassSymbol, ScalarString(mkChar("deparse")));
setAttrib(dataFrame, R_NamesSymbol, colNames);
setAttrib(dataFrame, R_RowNamesSymbol, names);
setAttrib(dataFrame, R_ClassSymbol, ScalarString(mkChar("data.frame")));
UNPROTECT(6);
return(dataFrame);
}
SEXP attribute_hidden do_sprintf(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
int i, nargs, cnt, v, thislen, nfmt, nprotect = 0;
/* fmt2 is a copy of fmt with '*' expanded.
bit will hold numeric formats and %<w>s, so be quite small. */
char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
*outputString;
const char *formatString;
size_t n, cur, chunk;
SEXP format, _this, a[MAXNARGS], ans /* -Wall */ = R_NilValue;
int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;
static R_StringBuffer outbuff = {nullptr, 0, MAXELTSIZE};
Rboolean has_star, use_UTF8;
#define _my_sprintf(_X_) \
{ \
int nc = snprintf(bit, MAXLINE+1, fmtp, _X_); \
if (nc > MAXLINE) \
error(_("required resulting string length %d is greater than maximal %d"), \
nc, MAXLINE); \
}
nargs = num_args;
/* grab the format string */
format = num_args ? args[0] : nullptr;
if (!isString(format))
error(_("'fmt' is not a character vector"));
nfmt = length(format);
if (nfmt == 0) return allocVector(STRSXP, 0);
args = (args + 1); nargs--;
if(nargs >= MAXNARGS)
error(_("only %d arguments are allowed"), MAXNARGS);
/* record the args for possible coercion and later re-ordering */
for(i = 0; i < nargs; i++, args = (args + 1)) {
SEXPTYPE t_ai;
a[i] = args[0];
if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */
error(_("invalid type of argument[%d]: '%s'"),
i+1, CHAR(type2str(t_ai)));
lens[i] = length(a[i]);
if(lens[i] == 0) return allocVector(STRSXP, 0);
}
#define CHECK_maxlen \
maxlen = nfmt; \
for(i = 0; i < nargs; i++) \
if(maxlen < lens[i]) maxlen = lens[i]; \
if(maxlen % nfmt) \
error(_("arguments cannot be recycled to the same length")); \
for(i = 0; i < nargs; i++) \
if(maxlen % lens[i]) \
error(_("arguments cannot be recycled to the same length"))
CHECK_maxlen;
outputString = CXXRCONSTRUCT(static_cast<char*>, R_AllocStringBuffer(0, &outbuff));
/* We do the format analysis a row at a time */
for(ns = 0; ns < maxlen; ns++) {
outputString[0] = '\0';
use_UTF8 = CXXRCONSTRUCT(Rboolean, getCharCE(STRING_ELT(format, ns % nfmt)) == CE_UTF8);
if (!use_UTF8) {
for(i = 0; i < nargs; i++) {
if (!isString(a[i])) continue;
if (getCharCE(STRING_ELT(a[i], ns % lens[i])) == CE_UTF8) {
use_UTF8 = TRUE; break;
}
}
}
formatString = TRANSLATE_CHAR(format, ns % nfmt);
n = strlen(formatString);
if (n > MAXLINE)
error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);
/* process the format string */
for (cur = 0, cnt = 0; cur < n; cur += chunk) {
const char *curFormat = formatString + cur, *ss;
char *starc;
ss = nullptr;
if (formatString[cur] == '%') { /* handle special format command */
if (cur < n - 1 && formatString[cur + 1] == '%') {
/* take care of %% in the format */
chunk = 2;
strcpy(bit, "%");
}
else {
/* recognise selected types from Table B-1 of K&R */
/* NB: we deal with "%%" in branch above. */
/* This is MBCS-OK, as we are in a format spec */
chunk = strcspn(curFormat + 1, "diosfeEgGxXaA") + 2;
if (cur + chunk > n)
error(_("unrecognised format specification '%s'"), curFormat);
strncpy(fmt, curFormat, chunk);
fmt[chunk] = '\0';
nthis = -1;
/* now look for %n$ or %nn$ form */
if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') {
v = fmt[1] - '0';
if(fmt[2] == '$') {
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nthis = v-1;
memmove(fmt+1, fmt+3, strlen(fmt)-2);
} else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') {
v = 10*v + fmt[2] - '0';
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nthis = v-1;
memmove(fmt+1, fmt+4, strlen(fmt)-3);
}
}
starc = Rf_strchr(fmt, '*');
if (starc) { /* handle * format if present */
nstar = -1;
if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') {
v = starc[1] - '0';
if(starc[2] == '$') {
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nstar = v-1;
memmove(starc+1, starc+3, strlen(starc)-2);
} else if(starc[2] >= '0' && starc[2] <= '9'
&& starc[3] == '$') {
v = 10*v + starc[2] - '0';
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nstar = v-1;
memmove(starc+1, starc+4, strlen(starc)-3);
}
}
if(nstar < 0) {
if (cnt >= nargs) error(_("too few arguments"));
nstar = cnt++;
}
if (Rf_strchr(starc+1, '*'))
error(_("at most one asterisk '*' is supported in each conversion specification"));
_this = a[nstar];
if(ns == 0 && TYPEOF(_this) == REALSXP) {
_this = coerceVector(_this, INTSXP);
PROTECT(a[nstar] = _this);
nprotect++;
}
if(TYPEOF(_this) != INTSXP || LENGTH(_this)<1 ||
INTEGER(_this)[ns % LENGTH(_this)] == NA_INTEGER)
error(_("argument for '*' conversion specification must be a number"));
star_arg = INTEGER(_this)[ns % LENGTH(_this)];
has_star = TRUE;
}
else
has_star = FALSE;
if (fmt[strlen(fmt) - 1] == '%') {
/* handle % with formatting options */
if (has_star)
snprintf(bit, MAXLINE+1, fmt, star_arg);
else
strcpy(bit, fmt);
/* was sprintf(..) for which some compiler warn */
} else {
Rboolean did_this = FALSE;
if(nthis < 0) {
if (cnt >= nargs) error(_("too few arguments"));
nthis = cnt++;
}
_this = a[nthis];
if (has_star) {
size_t nf; char *p, *q = fmt2;
for (p = fmt; *p; p++)
if (*p == '*') q += sprintf(q, "%d", star_arg);
else *q++ = *p;
*q = '\0';
nf = strlen(fmt2);
if (nf > MAXLINE)
error(_("'fmt' length exceeds maximal format length %d"),
MAXLINE);
fmtp = fmt2;
} else fmtp = fmt;
#define CHECK_this_length \
PROTECT(_this); \
thislen = length(_this); \
if(thislen == 0) \
error(_("coercion has changed vector length to 0"))
/* Now let us see if some minimal coercion
would be sensible, but only do so once, for ns = 0: */
if(ns == 0) {
SEXP tmp; Rboolean do_check;
switch(*findspec(fmtp)) {
case 'd':
case 'i':
case 'o':
case 'x':
case 'X':
if(TYPEOF(_this) == REALSXP) {
double r = REAL(_this)[0];
if(double(int( r)) == r)
_this = coerceVector(_this, INTSXP);
PROTECT(a[nthis] = _this);
nprotect++;
}
break;
case 'a':
case 'A':
case 'e':
case 'f':
case 'g':
case 'E':
case 'G':
if(TYPEOF(_this) != REALSXP &&
/* no automatic as.double(<string>) : */
TYPEOF(_this) != STRSXP) {
PROTECT(tmp = lang2(install("as.double"), _this));
#define COERCE_THIS_TO_A \
_this = eval(tmp, env); \
UNPROTECT(1); \
PROTECT(a[nthis] = _this); \
nprotect++; \
did_this = TRUE; \
CHECK_this_length; \
do_check = (CXXRCONSTRUCT(Rboolean, lens[nthis] == maxlen)); \
lens[nthis] = thislen; /* may have changed! */ \
if(do_check && thislen < maxlen) { \
CHECK_maxlen; \
}
COERCE_THIS_TO_A
}
break;
case 's':
if(TYPEOF(_this) != STRSXP) {
/* as.character method might call sprintf() */
size_t nc = strlen(outputString);
char *z = Calloc(nc+1, char);
strcpy(z, outputString);
PROTECT(tmp = lang2(install("as.character"), _this));
COERCE_THIS_TO_A
strcpy(outputString, z);
Free(z);
}
break;
default:
break;
}
} /* ns == 0 (first-time only) */
if(!did_this)
CHECK_this_length;
switch(TYPEOF(_this)) {
case LGLSXP:
{
int x = LOGICAL(_this)[ns % thislen];
if (checkfmt(fmtp, "di"))
error(_("invalid format '%s'; %s"), fmtp,
_("use format %d or %i for logical objects"));
if (x == NA_LOGICAL) {
fmtp[strlen(fmtp)-1] = 's';
_my_sprintf("NA")
} else {
_my_sprintf(x)
}
break;
}
case INTSXP:
{
int x = INTEGER(_this)[ns % thislen];
if (checkfmt(fmtp, "dioxX"))
error(_("invalid format '%s'; %s"), fmtp,
_("use format %d, %i, %o, %x or %X for integer objects"));
if (x == NA_INTEGER) {
fmtp[strlen(fmtp)-1] = 's';
_my_sprintf("NA")
} else {
_my_sprintf(x)
}
break;
}
/* conditional linear Gaussian mutual information test. */
static double ct_micg(SEXP xx, SEXP yy, SEXP zz, int nobs, int ntests,
double *pvalue, double *df) {
int xtype = 0, ytype = TYPEOF(yy), *nlvls = NULL, llx = 0, lly = 0, llz = 0;
int ndp = 0, ngp = 0, nsx = length(zz), **dp = NULL, *dlvls = NULL, j = 0, k = 0;
int i = 0, *zptr = 0;
void *xptr = NULL, *yptr = NULL, **columns = NULL;
double **gp = NULL;
double statistic = 0;
SEXP xdata;
if (ytype == INTSXP) {
/* cache the number of levels. */
lly = NLEVELS(yy);
yptr = INTEGER(yy);
}/*THEN*/
else {
yptr = REAL(yy);
}/*ELSE*/
/* extract the conditioning variables and cache their types. */
columns = Calloc1D(nsx, sizeof(void *));
nlvls = Calloc1D(nsx, sizeof(int));
df2micg(zz, columns, nlvls, &ndp, &ngp);
dp = Calloc1D(ndp + 1, sizeof(int *));
gp = Calloc1D(ngp + 1, sizeof(double *));
dlvls = Calloc1D(ndp + 1, sizeof(int));
for (i = 0, j = 0, k = 0; i < nsx; i++)
if (nlvls[i] > 0) {
dlvls[1 + j] = nlvls[i];
dp[1 + j++] = columns[i];
}/*THEN*/
else {
gp[1 + k++] = columns[i];
}/*ELSE*/
/* allocate vector for the configurations of the discrete parents; or, if
* there no discrete parents, for the means of the continuous parents. */
if (ndp > 0) {
zptr = Calloc1D(nobs, sizeof(int));
c_fast_config(dp + 1, nobs, ndp, dlvls + 1, zptr, &llz, 1);
}/*THEN*/
for (i = 0; i < ntests; i++) {
xdata = VECTOR_ELT(xx, i);
xtype = TYPEOF(xdata);
if (xtype == INTSXP) {
xptr = INTEGER(xdata);
llx = NLEVELS(xdata);
}/*THEN*/
else {
xptr = REAL(xdata);
}/*ELSE*/
if ((ytype == INTSXP) && (xtype == INTSXP)) {
if (ngp > 0) {
/* need to reverse conditioning to actually compute the test. */
statistic = 2 * nobs * nobs *
c_cmicg_unroll(xptr, llx, yptr, lly, zptr, llz,
gp + 1, ngp, df, nobs);
}/*THEN*/
else {
/* the test reverts back to a discrete mutual information test. */
statistic = 2 * nobs * c_cchisqtest(xptr, llx, yptr, lly, zptr, llz,
nobs, df, MI);
}/*ELSE*/
}/*THEN*/
else if ((ytype == REALSXP) && (xtype == REALSXP)) {
gp[0] = xptr;
statistic = 2 * nobs * c_cmicg(yptr, gp, ngp + 1, NULL, 0, zptr, llz,
dlvls, nobs);
/* one regression coefficient for each conditioning level is added;
* if all conditioning variables are continuous that's just one global
* regression coefficient. */
*df = (llz == 0) ? 1 : llz;
}/*THEN*/
else if ((ytype == INTSXP) && (xtype == REALSXP)) {
dp[0] = yptr;
dlvls[0] = lly;
statistic = 2 * nobs * c_cmicg(xptr, gp + 1, ngp, dp, ndp + 1, zptr,
llz, dlvls, nobs);
/* for each additional configuration of the discrete conditioning
* variables plus the discrete yptr, one whole set of regression
* coefficients (plus the intercept) is added. */
*df = (lly - 1) * ((llz == 0) ? 1 : llz) * (ngp + 1);
}/*THEN*/
else if ((ytype == REALSXP) && (xtype == INTSXP)) {
dp[0] = xptr;
dlvls[0] = llx;
statistic = 2 * nobs * c_cmicg(yptr, gp + 1, ngp, dp, ndp + 1, zptr,
llz, dlvls, nobs);
/* same as above, with xptr and yptr swapped. */
*df = (llx - 1) * ((llz == 0) ? 1 : llz) * (ngp + 1);
}/*ELSE*/
pvalue[i] = pchisq(statistic, *df, FALSE, FALSE);
}/*FOR*/
Free1D(columns);
Free1D(nlvls);
Free1D(dlvls);
Free1D(zptr);
Free1D(dp);
Free1D(gp);
return statistic;
}/*CT_MICG*/
SEXP imputeObservations(SEXP R_forest, SEXP registered_data, SEXP new_data)
{
hpdRFforest *forest = (hpdRFforest *) R_ExternalPtrAddr(R_forest);
int temp_leaf_count, leaf_count=0, num_obs = length(VECTOR_ELT(new_data,0));
hpdRFnode **temp_leaves, **leaves = NULL;
void **new_feature_observations =
(void **) malloc(sizeof(void*)*length(new_data));
bool* new_int_data = (bool *) malloc(sizeof(bool)*length(new_data));
void **old_feature_observations =
(void **) malloc(sizeof(void*)*length(registered_data));
bool* old_int_data = (bool *) malloc(sizeof(bool)*length(registered_data));
double *temp_weights, *weights;
for(int col = 0; col < length(new_data); col++)
{
new_feature_observations[col] =
RtoCArray<void *>(VECTOR_ELT(new_data,col));
new_int_data[col] = TYPEOF(VECTOR_ELT(new_data,col)) == INTSXP;
}
for(int col = 0; col < length(registered_data); col++)
{
old_feature_observations[col] =
RtoCArray<void *>(VECTOR_ELT(registered_data,col));
old_int_data[col] = TYPEOF(VECTOR_ELT(registered_data,col)) == INTSXP;
}
for(int obs_index = 0; obs_index < num_obs; obs_index++)
{
for(int i = 0; i < forest->ntree; i++)
{
temp_leaf_count = 0;
temp_leaves=
treeTraverseObservation(forest->trees[i],
new_data,
forest->features_cardinality,
obs_index,
true,
&temp_leaf_count, &temp_weights);
hpdRFnode** temp = (hpdRFnode**)
malloc(sizeof(hpdRFnode*)*(temp_leaf_count+leaf_count));
double* temp1 = (double *)
malloc(sizeof(double)*(temp_leaf_count+leaf_count));
double total_tree_weight = 0;
for(int j = 0; j < temp_leaf_count; j++)
total_tree_weight += temp_leaves[j]->additional_info->num_obs;
for(int j = 0; j < temp_leaf_count; j++)
temp_weights[j] = temp_leaves[j]->additional_info->num_obs/
total_tree_weight;
if(leaf_count != 0)
{
memcpy(temp,leaves,leaf_count*sizeof(hpdRFnode*));
memcpy(temp1,weights, leaf_count*sizeof(double));
}
if(temp_leaf_count != 0)
{
memcpy(temp+leaf_count,temp_leaves,
temp_leaf_count*sizeof(hpdRFnode*));
memcpy(temp1+leaf_count,temp_weights,
temp_leaf_count*sizeof(double));
}
free(temp_leaves);
free(leaves);
free(weights);
free(temp_weights);
leaves = temp;
weights = temp1;
leaf_count += temp_leaf_count;
}
for(int i = 0; i < leaf_count; i++)
if(isnan(weights[i]))
weights[i] = 0;
double sample_id = forest->ntree*((double)rand()/(double)RAND_MAX);
int i = 0;
while(i < leaf_count)
{
if(sample_id >= weights[i])
sample_id -= weights[i];
else
break;
i++;
}
if(i < leaf_count && leaves[i]->additional_info->num_obs > 0)
{
int index = (int) (sample_id*leaves[i]->additional_info->num_obs);
index = leaves[i]->additional_info->indices[index]-1;
for(int col = 0; col < length(new_data); col++)
{
if(new_int_data[col] && old_int_data[col])
{
((int **) new_feature_observations)[col][obs_index] =
((int **) old_feature_observations)[col][index];
}
if(new_int_data[col] && !old_int_data[col])
{
((int **) new_feature_observations)[col][obs_index] =
((double **) old_feature_observations)[col][index];
}
if(!new_int_data[col] && old_int_data[col])
{
((double **) new_feature_observations)[col][obs_index] =
((int **) old_feature_observations)[col][index];
}
if(!new_int_data[col] && !old_int_data[col])
{
((double **) new_feature_observations)[col][obs_index] =
((double **) old_feature_observations)[col][index];
}
}
}
free(leaves);
leaves = NULL;
leaf_count = 0;
free(weights);
weights = NULL;
}
return R_NilValue;
}
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call)
{
/* ExtractSubset is currently copied/inspired by subset.c from GNU-R
This is slated to be reimplemented using the previous method
in xts to get the correct dimnames
*/
int i, ii, n, nx, mode;
SEXP tmp, tmp2;
mode = TYPEOF(x);
n = LENGTH(indx);
nx = length(x);
tmp = result;
/*if (x == R_NilValue)*/
if (isNull(x))
return x;
for (i = 0; i < n; i++) {
ii = INTEGER(indx)[i];
if (ii != NA_INTEGER)
ii--;
switch (mode) {
case LGLSXP:
if (0 <= ii && ii < nx && ii != NA_LOGICAL)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_LOGICAL;
break;
case INTSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
}
else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
case EXPRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case LISTSXP:
/* cannot happen: pairlists are coerced to lists */
case LANGSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
tmp2 = nthcdr(x, ii);
SETCAR(tmp, CAR(tmp2));
SET_TAG(tmp, TAG(tmp2));
}
else
SETCAR(tmp, R_NilValue);
tmp = CDR(tmp);
break;
case RAWSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
error("error in subset\n");
break;
}
}
return result;
}
Result* nth_prototype(SEXP call, const ILazySubsets& subsets, int nargs) {
// has to have at least two arguments
if (nargs < 2) return 0;
SEXP tag = TAG(CDR(call));
if (tag != R_NilValue && tag != Rf_install("x")) {
stop("the first argument of 'nth' should be either 'x' or unnamed");
}
SEXP data = CADR(call);
if (TYPEOF(data) == SYMSXP) {
if (! subsets.count(data)) {
stop("could not find variable '%s'", CHAR(PRINTNAME(data)));
}
data = subsets.get_variable(data);
}
tag = TAG(CDDR(call));
if (tag != R_NilValue && tag != Rf_install("n")) {
stop("the second argument of 'first' should be either 'n' or unnamed");
}
SEXP nidx = CADDR(call);
if ((TYPEOF(nidx) != REALSXP && TYPEOF(nidx) != INTSXP) || LENGTH(nidx) != 1) {
// we only know how to handle the case where nidx is a length one
// integer or numeric. In any other case, e.g. an expression for R to evaluate
// we just fallback to R evaluation (#734)
return 0;
}
int idx = as<int>(nidx);
// easy case : just a single variable: first(x,n)
if (nargs == 2) {
switch (TYPEOF(data)) {
case INTSXP:
return new Nth<INTSXP>(data, idx);
case REALSXP:
return new Nth<REALSXP>(data, idx);
case STRSXP:
return new Nth<STRSXP>(data, idx);
case LGLSXP:
return new Nth<LGLSXP>(data, idx);
default:
break;
}
} else {
// now get `order_by` and default
SEXP order_by = R_NilValue;
SEXP def = R_NilValue;
SEXP p = CDR(CDDR(call));
while (p != R_NilValue) {
SEXP tag = TAG(p);
if (tag == R_NilValue) stop("all arguments of 'first' after the first one should be named");
std::string argname = CHAR(PRINTNAME(tag));
if (argmatch("order_by", argname)) {
order_by = CAR(p);
} else if (argmatch("default", argname)) {
def = CAR(p);
} else {
stop("argument to 'first' does not match either 'default' or 'order_by' ");
}
p = CDR(p);
}
// handle cases
if (def == R_NilValue) {
// then we know order_by is not NULL, we only handle the case where
// order_by is a symbol and that symbol is in the data
if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) {
order_by = subsets.get_variable(order_by);
switch (TYPEOF(data)) {
case LGLSXP:
return nth_with<LGLSXP>(data, idx, order_by);
case INTSXP:
return nth_with<INTSXP>(data, idx, order_by);
case REALSXP:
return nth_with<REALSXP>(data, idx, order_by);
case STRSXP:
return nth_with<STRSXP>(data, idx, order_by);
default:
break;
}
}
else {
return 0;
}
} else {
if (order_by == R_NilValue) {
switch (TYPEOF(data)) {
case LGLSXP:
return nth_noorder_default<LGLSXP>(data, idx, def);
case INTSXP:
return nth_noorder_default<INTSXP>(data, idx, def);
case REALSXP:
return nth_noorder_default<REALSXP>(data, idx, def);
case STRSXP:
return nth_noorder_default<STRSXP>(data, idx, def);
default:
break;
}
} else {
if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) {
order_by = subsets.get_variable(order_by);
switch (TYPEOF(data)) {
case LGLSXP:
return nth_with_default<LGLSXP>(data, idx, order_by, def);
case INTSXP:
return nth_with_default<INTSXP>(data, idx, order_by, def);
case REALSXP:
return nth_with_default<REALSXP>(data, idx, order_by, def);
case STRSXP:
return nth_with_default<STRSXP>(data, idx, order_by, def);
default:
break;
}
}
else {
return 0;
}
}
}
}
stop("Unsupported vector type %s", Rf_type2char(TYPEOF(data)));
return 0;
}
void CallProxy::set_call( SEXP call_ ){
proxies.clear() ;
call = call_ ;
if( TYPEOF(call) == LANGSXP ) traverse_call(call) ;
}
SEXP printNode(hpdRFnode *tree, int depth, int max_depth, SEXP classes)
{
#define tab for(int i = 0; i < depth; i++) printf("\t")
if(depth > max_depth)
{
tab;
printf("Ommitting subtree\n");
return R_NilValue;
}
double prediction = tree->prediction;
tab;
int index = (int) prediction;
if(classes != R_NilValue && TYPEOF(classes) == STRSXP &&
index >= 0 && index < length(classes))
printf("<prediction> %s </prediction>\n",
CHAR(STRING_ELT(classes,(int)prediction)));
else
printf("<prediction> %f </prediction>\n", prediction);
tab;
printf("<deviance> %f </deviance>\n", tree->deviance);
tab;
printf("<complexity> %f </complexity>\n", tree->complexity);
double* split_criteria = tree->split_criteria;
int split_var=tree->split_variable;
if(split_criteria != NULL)
{
tab;
printf("<split_criteria> ");
for(int i = 0; i < tree->split_criteria_length; i++)
printf("%f ",split_criteria[i]);
printf("</split_criteria>\n");
tab;
printf("<split variable> %d </split variable>\n", split_var);
}
if(tree->additional_info)
{
tab;
printf("leaf_id: %d\n", tree->additional_info->leafID);
tab;
printf("num_obs: %d\n", tree->additional_info->num_obs);
tab;
printf("indices: ");
for(int i = 0; i < tree->additional_info->num_obs; i++)
printf("%d ", tree->additional_info->indices[i]);
printf("\n");
/*
tab;
printf("weights: ");
for(int i = 0; i < tree->additional_info->num_obs; i++)
printf("%f ", tree->additional_info->weights[i]);
printf("\n");
*/
}
if(tree->left != NULL)
{
tab;
printf("<Left Child Node>\n");
printNode(tree->left,
depth+1,max_depth,classes);
tab;
printf("</Left Child Node>\n");
}
if(tree->right != NULL)
{
tab;
printf("<Right Child Node>\n");
printNode(tree->right,
depth+1,max_depth,classes);
tab;
printf("</Right Child Node>\n");
}
return R_NilValue;
}
SEXP
R_tarExtract(SEXP r_filename, SEXP r_filenames, SEXP r_fun, SEXP r_data,
SEXP r_workBuf)
{
TarExtractCallbackFun callback = R_tarCollectContents;
RTarCallInfo rcb;
Rboolean doRcallback = (TYPEOF(r_fun) == CLOSXP);
void *data;
gzFile *f = NULL;
int numFiles = LENGTH(r_filenames), i;
const char **argv;
int argc = numFiles + 1;
if(TYPEOF(r_filename) == STRSXP) {
const char *filename;
filename = CHAR(STRING_ELT(r_filename, 0));
f = gzopen(filename, "rb");
if(!f) {
PROBLEM "Can't open file %s", filename
ERROR;
}
}
if(doRcallback) {
SEXP p;
rcb.rawData = r_workBuf;
rcb.numProtects = 0;
rcb.offset = 0;
PROTECT(rcb.e = p = allocVector( LANGSXP, 3));
SETCAR(p, r_fun);
callback = R_tarCollectContents;
data = (void *) &rcb;
} else {
data = (void *) r_data;
callback = (TarExtractCallbackFun) R_ExternalPtrAddr(r_fun);
}
argv = (char **) S_alloc(numFiles + 1, sizeof(char *));
argv[0] = "R";
for(i = 1; i < numFiles + 1; i++)
argv[i] = CHAR(STRING_ELT(r_filenames, i-1));
if(TYPEOF(r_filename) == STRSXP)
tar(f, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data);
else {
DataSource src;
R_rawStream stream;
stream.data = RAW(r_filename);
stream.len = LENGTH(r_filename);
stream.pos = 0;
src.data = &stream;
src.throwError = rawError;
src.read = rawRead;
funTar(&src, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data);
}
if(doRcallback)
UNPROTECT(1);
if(rcb.numProtects > 0)
UNPROTECT(rcb.numProtects);
if (f && gzclose(f) != Z_OK)
error("failed gzclose");
return(R_NilValue);
}
static jl_value_t *R_Julia_MD(SEXP Var, const char *VarName)
{
if ((LENGTH(Var)) != 0)
{
jl_tuple_t *dims = RDims_JuliaTuple(Var);
switch (TYPEOF( Var))
{
case LGLSXP:
{
jl_array_t *ret = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
JL_GC_PUSH1(&ret);
char *retData = (char *)jl_array_data(ret);
for (size_t i = 0; i < jl_array_len(ret); i++)
retData[i] = LOGICAL(Var)[i];
jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
return (jl_value_t *) ret;
JL_GC_POP();
break;
};
case INTSXP:
{
jl_array_t *ret = CreateArray(jl_int32_type, jl_tuple_len(dims), dims);
JL_GC_PUSH1(&ret);
int *retData = (int *)jl_array_data(ret);
for (size_t i = 0; i < jl_array_len(ret); i++)
retData[i] = INTEGER(Var)[i];
jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
return (jl_value_t *) ret;
JL_GC_POP();
break;
}
case REALSXP:
{
jl_array_t *ret = CreateArray(jl_float64_type, jl_tuple_len(dims), dims);
JL_GC_PUSH1(&ret);
double *retData = (double *)jl_array_data(ret);
for (size_t i = 0; i < jl_array_len(ret); i++)
retData[i] = REAL(Var)[i];
jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
JL_GC_POP();
return (jl_value_t *) ret;
break;
}
case STRSXP:
{
jl_array_t *ret;
if (!IS_ASCII(Var))
ret = CreateArray(jl_utf8_string_type, jl_tuple_len(dims), dims);
else
ret = CreateArray(jl_ascii_string_type, jl_tuple_len(dims), dims);
JL_GC_PUSH1(&ret);
jl_value_t **retData = jl_array_data(ret);
for (size_t i = 0; i < jl_array_len(ret); i++)
if (!IS_ASCII(Var))
retData[i] = jl_cstr_to_string(translateChar0(STRING_ELT(Var, i)));
else
retData[i] = jl_cstr_to_string(CHAR(STRING_ELT(Var, i)));
jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
JL_GC_POP();
return (jl_value_t *) ret;
break;
}
case VECSXP:
{
char eltcmd[eltsize];
jl_tuple_t *ret = jl_alloc_tuple(length(Var));
JL_GC_PUSH1(&ret);
for (int i = 0; i < length(Var); i++)
{
snprintf(eltcmd, eltsize, "%selement%d", VarName, i);
jl_tupleset(ret, i, R_Julia_MD(VECTOR_ELT(Var, i), eltcmd));
}
jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
JL_GC_POP();
return (jl_value_t *) ret;
}
default:
{
return (jl_value_t *) jl_nothing;
}
break;
}
return (jl_value_t *) jl_nothing;
}
return (jl_value_t *) jl_nothing;
}
SEXP R_initMethodDispatch(SEXP envir)
{
if(envir && !isNull(envir))
Methods_Namespace = envir;
if(!Methods_Namespace)
Methods_Namespace = R_GlobalEnv;
if(initialized)
return(envir);
s_dot_Methods = install(".Methods");
s_skeleton = install("skeleton");
s_expression = install("expression");
s_function = install("function");
s_getAllMethods = install("getAllMethods");
s_objectsEnv = install("objectsEnv");
s_MethodsListSelect = install("MethodsListSelect");
s_sys_dot_frame = install("sys.frame");
s_sys_dot_call = install("sys.call");
s_sys_dot_function = install("sys.function");
s_generic = install("generic");
s_generic_dot_skeleton = install("generic.skeleton");
s_subset_gets = install("[<-");
s_element_gets = install("[[<-");
s_argument = install("argument");
s_allMethods = install("allMethods");
R_FALSE = ScalarLogical(FALSE);
R_PreserveObject(R_FALSE);
R_TRUE = ScalarLogical(TRUE);
R_PreserveObject(R_TRUE);
/* some strings (NOT symbols) */
s_missing = mkString("missing");
setAttrib(s_missing, R_PackageSymbol, mkString("methods"));
R_PreserveObject(s_missing);
s_base = mkString("base");
R_PreserveObject(s_base);
/* Initialize method dispatch, using the static */
R_set_standardGeneric_ptr(
(table_dispatch_on ? R_dispatchGeneric : R_standardGeneric)
, Methods_Namespace);
R_set_quick_method_check(
(table_dispatch_on ? R_quick_dispatch : R_quick_method_check));
/* Some special lists of primitive skeleton calls.
These will be promises under lazy-loading.
*/
PROTECT(R_short_skeletons =
findVar(install(".ShortPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_short_skeletons) == PROMSXP)
R_short_skeletons = eval(R_short_skeletons, Methods_Namespace);
R_PreserveObject(R_short_skeletons);
UNPROTECT(1);
PROTECT(R_empty_skeletons =
findVar(install(".EmptyPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_empty_skeletons) == PROMSXP)
R_empty_skeletons = eval(R_empty_skeletons, Methods_Namespace);
R_PreserveObject(R_empty_skeletons);
UNPROTECT(1);
if(R_short_skeletons == R_UnboundValue ||
R_empty_skeletons == R_UnboundValue)
error(_("could not find the skeleton calls for 'methods' (package detached?): expect very bad things to happen"));
f_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 0);
fgets_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 1);
f_x_skeleton = VECTOR_ELT(R_empty_skeletons, 0);
fgets_x_skeleton = VECTOR_ELT(R_empty_skeletons, 1);
init_loadMethod();
initialized = 1;
return(envir);
}
static jl_value_t *R_Julia_MD_NA(SEXP Var, const char *VarName)
{
if ((LENGTH(Var)) != 0)
{
jl_tuple_t *dims = RDims_JuliaTuple(Var);
switch (TYPEOF(Var))
{
case LGLSXP:
{
jl_array_t *ret = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
JL_GC_PUSH(&ret, &ret1);
char *retData = (char *)jl_array_data(ret);
bool *retData1 = (bool *)jl_array_data(ret1);
for (size_t i = 0; i < jl_array_len(ret); i++)
{
if (LOGICAL(Var)[i] == NA_LOGICAL)
{
retData[i] = 1;
retData1[i] = true;
}
else
{
retData[i] = LOGICAL(Var)[i];
retData1[i] = false;
}
}
JL_GC_POP();
return TransArrayToDataArray(ret, ret1, VarName);
break;
};
case INTSXP:
{
jl_array_t *ret = CreateArray(jl_int32_type, jl_tuple_len(dims), dims);
jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
JL_GC_PUSH(&ret, &ret1);
int *retData = (int *)jl_array_data(ret);
bool *retData1 = (bool *)jl_array_data(ret1);
for (size_t i = 0; i < jl_array_len(ret); i++)
{
if (INTEGER(Var)[i] == NA_INTEGER)
{
retData[i] = 999;
retData1[i] = true;
}
else
{
retData[i] = INTEGER(Var)[i];
retData1[i] = false;
}
}
JL_GC_POP();
return TransArrayToDataArray(ret, ret1, VarName);
break;
}
case REALSXP:
{
jl_array_t *ret = CreateArray(jl_float64_type, jl_tuple_len(dims), dims);
jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
JL_GC_PUSH(&ret, &ret1);
double *retData = (double *)jl_array_data(ret);
bool *retData1 = (bool *)jl_array_data(ret1);
for (size_t i = 0; i < jl_array_len(ret); i++)
{
if (ISNAN(REAL(Var)[i]))
{
retData[i] = 999.01;
retData1[i] = true;
}
else
{
retData[i] = REAL(Var)[i];
retData1[i] = false;
}
}
JL_GC_POP();
return TransArrayToDataArray(ret, ret1, VarName);
break;
}
case STRSXP:
{
jl_array_t *ret;
if (!IS_ASCII(Var))
ret = CreateArray(jl_utf8_string_type, jl_tuple_len(dims), dims);
else
ret = CreateArray(jl_ascii_string_type, jl_tuple_len(dims), dims);
jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
JL_GC_PUSH(&ret, &ret1);
jl_value_t **retData = jl_array_data(ret);
bool *retData1 = (bool *)jl_array_data(ret1);
for (size_t i = 0; i < jl_array_len(ret); i++)
{
if (STRING_ELT(Var, i) == NA_STRING)
{
retData[i] = jl_cstr_to_string("999");
retData1[i] = true;
}
else
{
if (!IS_ASCII(Var))
retData[i] = jl_cstr_to_string(translateChar0(STRING_ELT(Var, i)));
else
retData[i] = jl_cstr_to_string(CHAR(STRING_ELT(Var, i)));
retData1[i] = false;
}
}
JL_GC_POP();
return TransArrayToDataArray(ret, ret1, VarName);
break;
}
default:
return (jl_value_t *) jl_nothing;
break;
}//case end
return (jl_value_t *) jl_nothing;
}//if length !=0
return (jl_value_t *) jl_nothing;
}
SEXP R_export2dataset(SEXP path, SEXP dataframe, SEXP shape, SEXP shape_info)
{
std::wstring dataset_name;
tools::copy_to(path, dataset_name);
struct _cleanup
{
typedef std::vector<cols_base*> c_type;
std::vector<std::wstring> name;
c_type c;
//std::vector<c_type::const_iterator> shape;
c_type shape;
~_cleanup()
{
for (size_t i = 0; i < c.size(); i++)
delete c[i];
for (size_t i = 0; i < shape.size(); i++)
delete shape[i];
}
}cols;
shape_extractor extractor;
bool isShape = extractor.init(shape, shape_info) == S_OK;
//SEXP sinfo = Rf_getAttrib(shape, Rf_mkChar("shape_info"));
//cols.name = df.attr("names");
tools::getNames(dataframe, cols.name);
//tools::vectorGeneric shape_info(sinfo);
//std::string gt_type;
//tools::copy_to(shape_info.at("type"), gt_type);
esriGeometryType gt = extractor.type();//str2geometryType(gt_type.c_str());
R_xlen_t n = 0;
ATLTRACE("dataframe type:%s", Rf_type2char(TYPEOF(dataframe)));
if (Rf_isVectorList(dataframe))
{
size_t k = tools::size(dataframe);
cols.name.resize(k);
for (size_t i = 0; i < k; i++)
{
n = std::max(n, tools::size(VECTOR_ELT(dataframe, (R_xlen_t)i)));
if (cols.name[i].empty())
cols.name[i] = L"data";
}
}
else
{
n = tools::size(dataframe);
ATLASSERT(cols.name.empty());
}
if (isShape == false && n == 0)
return showError<false>(L"nothing to save"), R_NilValue;
if (isShape && n != extractor.size() )
return showError<false>(L"length of shape != data.frame"), R_NilValue;
CComPtr<IGPUtilities> ipDEUtil;
if (ipDEUtil.CoCreateInstance(CLSID_GPUtilities) != S_OK)
return showError<true>(L"IDEUtilitiesImpl - CoCreateInstance has failed"), R_NilValue;
HRESULT hr = 0;
CComPtr<IName> ipName;
if (isShape)
hr = ipDEUtil->CreateFeatureClassName(CComBSTR(dataset_name.c_str()), &ipName);
else
hr = ipDEUtil->CreateTableName(CComBSTR(dataset_name.c_str()), &ipName);
CComQIPtr<IDatasetName> ipDatasetName(ipName);
CComPtr<IWorkspaceName> ipWksName;
CComQIPtr<IWorkspace> ipWks;
if (hr == S_OK)
hr = ipDatasetName->get_WorkspaceName(&ipWksName);
if (hr == S_OK)
{
CComPtr<IUnknown> ipUnk;
hr = CComQIPtr<IName>(ipWksName)->Open(&ipUnk);
ipWks = ipUnk;
}
if (hr != S_OK)
return showError<true>(L"invalid table name"), R_NilValue;
CComQIPtr<IFeatureWorkspace> ipFWKS(ipWks);
ATLASSERT(ipFWKS);
if (!ipFWKS)
return showError<true>(L"not a FeatureWorkspace"), R_NilValue;
CComBSTR bstrTableName;
ipDatasetName->get_Name(&bstrTableName);
CComPtr<IFieldsEdit> ipFields;
hr = ipFields.CoCreateInstance(CLSID_Fields);
if (hr != S_OK) return showError<true>(L"CoCreateInstance"), R_NilValue;
createField(NULL, esriFieldTypeOID, ipFields);
CComPtr<ISpatialReference> ipSR;
if (isShape)
{
long pos = createField(NULL, esriFieldTypeGeometry, ipFields);
CComPtr<IGeometryDef> ipGeoDef;
CComPtr<IField> ipField;
ipFields->get_Field(pos, &ipField);
ipField->get_GeometryDef(&ipGeoDef);
CComQIPtr<IGeometryDefEdit> ipGeoDefEd(ipGeoDef);
ipGeoDefEd->put_GeometryType(gt);
ipGeoDefEd->putref_SpatialReference(extractor.sr());
}
if (cols.name.empty())
{
cols.name.push_back(L"data");
cols_base* item = setup_field(ipFields, dataframe, cols.name[0].c_str());
if (!item)
return showError<false>(L"unsupported datat.field column type"), NULL;
cols.c.push_back(item);
item->name_ref = &cols.name[0];
}
else
for (size_t i = 0; i < cols.name.size(); i++)
{
if (cols.name[i].empty())
continue;
const wchar_t* str = cols.name[i].c_str();
SEXP it = VECTOR_ELT(dataframe, (R_len_t)i);
cols_base* item = setup_field(ipFields, it, str);
if (!item)
return showError<false>(L"unsupported datat.field column type"), NULL;
cols.c.push_back(item);
item->name_ref = &cols.name[i];
}
CComPtr<IFieldChecker> ipFieldChecker; ipFieldChecker.CoCreateInstance(CLSID_FieldChecker);
if (ipFieldChecker)
{
ipFieldChecker->putref_ValidateWorkspace(ipWks);
long error = 0;
//fix fields names
CComPtr<IFields> ipFixedFields;
CComPtr<IEnumFieldError> ipEError;
hr = ipFieldChecker->Validate(ipFields, &ipEError, &ipFixedFields);
if (hr != S_OK)
return showError<true>(L"validate fields failed"), NULL;
if (ipFixedFields)
{
ipFields = ipFixedFields;
for (size_t c = 0; c < cols.c.size(); c++)
{
CComPtr<IField> ipFixedField;
ipFixedFields->get_Field(cols.c[c]->pos, &ipFixedField);
_bstr_t name;
ipFixedField->get_Name(name.GetAddress());
cols.c[c]->name_ref->assign(name);
}
}
}
CComPtr<IUID> ipUID; ipUID.CoCreateInstance(CLSID_UID);
if (ipUID)
{
OLECHAR buf[256];
::StringFromGUID2(isShape ? CLSID_Feature : CLSID_Row, buf, 256);
ipUID->put_Value(CComVariant(buf));
}
CComQIPtr<ITable> ipTableNew;
CComBSTR keyword(L"");
hr = E_FAIL;
if (isShape)
{
CComPtr<IFeatureClass> ipFClass;
hr = ipFWKS->CreateFeatureClass(bstrTableName, ipFields, ipUID, 0, esriFTSimple, CComBSTR(L"Shape"), keyword, &ipFClass);
ipTableNew = ipFClass;
}
else
{
hr = ipFWKS->CreateTable(bstrTableName, ipFields, ipUID, 0, keyword, &ipTableNew);
}
if (hr != S_OK)
{
std::wstring err_txt(isShape ? L"Create FeatureClass :" : L"Create Table :");
err_txt += bstrTableName;
err_txt += L" has failed";
return showError<true>(err_txt.c_str()), R_NilValue;
}
CComVariant oid;
CComPtr<ICursor> ipCursor;
CComPtr<IRowBuffer> ipRowBuffer;
hr = ipTableNew->Insert(VARIANT_TRUE, &ipCursor);
if (hr != S_OK)
return showError<true>(L"Insert cursor failed"), R_NilValue;
hr = ipTableNew->CreateRowBuffer(&ipRowBuffer);
if (hr != S_OK)
return showError<true>(L"Insert cursor failed"), R_NilValue;
//re-map fields
CComPtr<IFields> ipRealFields;
ipCursor->get_Fields(&ipRealFields);
for (size_t c = 0; c < cols.c.size(); c++)
{
ipRealFields->FindField(CComBSTR(cols.c[c]->name_ref->c_str()), &(cols.c[c]->pos));
CComPtr<IField> ipField;
ipRealFields->get_Field(cols.c[c]->pos, &ipField);
VARIANT_BOOL b = VARIANT_FALSE;
ipField->get_IsNullable(&b);
if (b == VARIANT_FALSE)
{
esriFieldType ft = esriFieldTypeInteger;
ipField->get_Type(&ft);
switch(ft)
{
case esriFieldTypeInteger:
cols.c[c]->vNULL = 0;//std::numeric_limits<int>::min();
break;
case esriFieldTypeDouble:
cols.c[c]->vNULL = 0.0;//-std::numeric_limits<double>::max();
break;
case esriFieldTypeString:
cols.c[c]->vNULL = L"";
}
}
}
CComQIPtr<IFeatureBuffer> ipFBuffer(ipRowBuffer);
for (R_len_t i = 0; i < n; i++)
{
//ATLTRACE("\n");
for (size_t c = 0; c < cols.c.size(); c++)
{
if (cols.c[c]->pos < 0)
continue;
CComVariant val;
cols.c[c]->get(i, val);
if (val.vt == VT_NULL)
hr = ipRowBuffer->put_Value(cols.c[c]->pos, cols.c[c]->vNULL);
else
hr = ipRowBuffer->put_Value(cols.c[c]->pos, val);
if (FAILED(hr))
return showError<true>(L"insert row value failed"), R_NilValue;
}
VARIANT oid;
if (isShape)
{
ATLASSERT(ipFBuffer);
CComQIPtr<IGeometry> ipNewShape;
hr = extractor.at(i, &ipNewShape);
if (hr != S_OK)
return R_NilValue;
hr = ipFBuffer->putref_Shape(ipNewShape);
if (FAILED(hr))
return showError<true>(L"insert shape failed"), R_NilValue;
}
hr = ipCursor->InsertRow(ipRowBuffer, &oid);
if (hr != S_OK)
return showError<true>(L"insert row failed"), R_NilValue;
}
return R_NilValue;
}
SEXP R_dataframe2dataset(SEXP dtaframe, SEXP path, SEXP shape_columns)
{
if (!Rf_isFrame(dtaframe))
return showError<false>(L"argument 0 is not a data.frame"), R_NilValue;
//same as narray_tools.cpp
std::wstring dataset_name;
tools::copy_to(path, dataset_name);
struct _cleanup
{
typedef std::vector<cols_base*> c_type;
std::vector<std::string> name;
c_type c;
//std::vector<c_type::const_iterator> shape;
c_type shape;
~_cleanup()
{
for (size_t i = 0; i < c.size(); i++)
delete c[i];
for (size_t i = 0; i < shape.size(); i++)
delete shape[i];
}
}cols;
//cols.name = df.attr("names");
tools::getNames(dtaframe, cols.name);
if (cols.name.empty())
return showError<false>(L"data.frame has 0 column"), R_NilValue;
if (tools::size(dtaframe) != cols.name.size())
return showError<false>(L"unknown"), R_NilValue;
CComPtr<IGPUtilities> ipDEUtil;
if (ipDEUtil.CoCreateInstance(CLSID_GPUtilities) != S_OK)
return showError<true>(L"IDEUtilitiesImpl - CoCreateInstance has failed"), R_NilValue;
HRESULT hr;
//cols.c.resize(cols.name.size(), NULL);
bool isShape = false;
if (shape_columns != R_NilValue)
{
std::vector<std::string> shapes;
tools::copy_to(shape_columns, shapes);
if (shapes.size() < 2 || shapes.size() > 4)
return showError<false>(L"shape expecting 2 strings"), NULL;
isShape = true;
for (size_t i = 0; i < shapes.size(); i++)
{
std::vector<std::string>::iterator it = std::find(cols.name.begin(), cols.name.end(), shapes[i]);
if (it == cols.name.end())
return showError<false>(L"cannot find shape in data.frame"), NULL;
size_t pos = std::distance(cols.name.begin(), it);
cols.shape.push_back(new cols_wrap<double>(VECTOR_ELT(dtaframe, pos)));
//cols.shape.[i] = cols.c.begin() + pos;
it->clear();
}
}
CComPtr<IName> ipName;
if (isShape)
hr = ipDEUtil->CreateFeatureClassName(CComBSTR(dataset_name.c_str()), &ipName);
else
hr = ipDEUtil->CreateTableName(CComBSTR(dataset_name.c_str()), &ipName);
CComQIPtr<IDatasetName> ipDatasetName(ipName);
CComPtr<IWorkspaceName> ipWksName;
CComQIPtr<IWorkspace> ipWks;
if (hr == S_OK)
hr = ipDatasetName->get_WorkspaceName(&ipWksName);
if (hr == S_OK)
{
CComPtr<IUnknown> ipUnk;
hr = CComQIPtr<IName>(ipWksName)->Open(&ipUnk);
ipWks = ipUnk;
}
if (hr != S_OK)
return showError<true>(L"invalid table name"), R_NilValue;
CComQIPtr<IFeatureWorkspace> ipFWKS(ipWks);
ATLASSERT(ipFWKS);
if (!ipFWKS)
return showError<true>(L"not a FeatureWorkspace"), R_NilValue;
CComBSTR bstrTableName;
ipDatasetName->get_Name(&bstrTableName);
/*
CComQIPtr<IWorkspaceSchemaImpl> ipWSchema(ipWks);
if (ipWSchema)
{
VARIANT_BOOL b = VARIANT_FALSE;
ipWSchema->TableExists(bstrTableName, &b);
if (b != VARIANT_FALSE)
return ::Rf_error("table Exists"), NULL;
}*/
CComPtr<IFieldsEdit> ipFields;
hr = ipFields.CoCreateInstance(CLSID_Fields);
if (hr != S_OK) return showError<true>(L"CoCreateInstance"), R_NilValue;
//if (!createField(NULL, esriFieldTypeOID, ipFields))
// return NULL;
if (isShape)
{
long pos = createField(NULL, esriFieldTypeGeometry, ipFields);
CComPtr<IGeometryDef> ipGeoDef;
CComPtr<IField> ipField;
ipFields->get_Field(pos, &ipField);
ipField->get_GeometryDef(&ipGeoDef);
CComQIPtr<IGeometryDefEdit> ipGeoDefEd(ipGeoDef);
ipGeoDefEd->put_GeometryType(esriGeometryPoint);
CComQIPtr<ISpatialReference> ipSR(g_lastUsedSR);
if (!ipSR)
{
ipSR.CoCreateInstance(CLSID_UnknownCoordinateSystem);
CComQIPtr<ISpatialReferenceResolution> ipSRR(ipSR);
if (ipSRR) FIX_DEFAULT_SR(ipSRR);
}
ipGeoDefEd->putref_SpatialReference(ipSR);
}
for (size_t i = 0; i < cols.name.size(); i++)
{
if (cols.name[i].empty())
continue;
const char* str = cols.name[i].c_str();
cols_base* item = NULL;
SEXP it = VECTOR_ELT(dtaframe, i);
switch (TYPEOF(it))
{
case NILSXP: case SYMSXP: case RAWSXP: case LISTSXP:
case CLOSXP: case ENVSXP: case PROMSXP: case LANGSXP:
case SPECIALSXP: case BUILTINSXP:
case CPLXSXP: case DOTSXP: case ANYSXP: case VECSXP:
case EXPRSXP: case BCODESXP: case EXTPTRSXP: case WEAKREFSXP:
case S4SXP:
default:
return showError<false>(L"unsupported datat.field column type"), NULL;
case INTSXP:
item = new cols_wrap<int>(it);
item->pos = createField(str, esriFieldTypeInteger, ipFields);
break;
case REALSXP:
item = new cols_wrap<double>(it);
item->pos = createField(str, esriFieldTypeDouble, ipFields);
break;
case STRSXP:
case CHARSXP:
item = new cols_wrap<std::string>(it);
item->pos = createField(str, esriFieldTypeString, ipFields);
break;
case LGLSXP:
item = new cols_wrap<bool>(it);
item->pos = createField(str, esriFieldTypeInteger, ipFields);
break;
}
ATLASSERT(item);
cols.c.push_back(item);
item->name_ref = &cols.name[i];
}
CComPtr<IFieldChecker> ipFieldChecker; ipFieldChecker.CoCreateInstance(CLSID_FieldChecker);
if (ipFieldChecker)
{
ipFieldChecker->putref_ValidateWorkspace(ipWks);
long error = 0;
//fix fields names
CComPtr<IFields> ipFixedFields;
CComPtr<IEnumFieldError> ipEError;
hr = ipFieldChecker->Validate(ipFields, &ipEError, &ipFixedFields);
if (hr != S_OK)
return showError<true>(L"validate fields failed"), NULL;
if (ipFixedFields)
{
ipFields = ipFixedFields;
for (size_t c = 0; c < cols.c.size(); c++)
{
CComPtr<IField> ipFixedField;
ipFixedFields->get_Field(cols.c[c]->pos, &ipFixedField);
_bstr_t name;
ipFixedField->get_Name(name.GetAddress());
cols.c[c]->name_ref->assign(name);
}
}
}
CComPtr<IUID> ipUID; ipUID.CoCreateInstance(CLSID_UID);
CComQIPtr<ITable> ipTableNew;
CComBSTR keyword(L"");
hr = E_FAIL;
if (isShape)
{
if (ipUID)
{
OLECHAR buf[256];
::StringFromGUID2(CLSID_Feature, buf, 256);
ipUID->put_Value(CComVariant(buf));
}
CComPtr<IFeatureClass> ipFClass;
hr = ipFWKS->CreateFeatureClass(bstrTableName, ipFields, ipUID, 0, esriFTSimple, CComBSTR(L"Shape"), keyword, &ipFClass);
ipTableNew = ipFClass;
}
else
{
if (ipUID)
{
OLECHAR buf[256];
::StringFromGUID2(CLSID_Row, buf, 256);
ipUID->put_Value(CComVariant(buf));
}
hr = ipFWKS->CreateTable(bstrTableName, ipFields, ipUID, 0, keyword, &ipTableNew);
}
if (hr != S_OK)
return showError<true>(L"validate fields failed"), R_NilValue;
CComVariant oid;
CComPtr<ICursor> ipCursor;
CComPtr<IRowBuffer> ipRowBuffer;
hr = ipTableNew->Insert(VARIANT_TRUE, &ipCursor);
if (hr != S_OK)
return showError<true>(L"Insert cursor failed"), R_NilValue;
hr = ipTableNew->CreateRowBuffer(&ipRowBuffer);
if (hr != S_OK)
return showError<true>(L"Insert cursor failed"), R_NilValue;
//re-map fields
for (size_t c = 0; c < cols.c.size(); c++)
ipCursor->FindField(CComBSTR(cols.c[c]->name_ref->c_str()), &(cols.c[c]->pos));
R_len_t n = tools::size(VECTOR_ELT(dtaframe, 0));
for (R_len_t i = 0; i < n; i++)
{
//ATLTRACE("\n");
for (size_t c = 0; c < cols.c.size(); c++)
{
if (cols.c[c]->pos < 0)
continue;
CComVariant val;
cols.c[c]->get(i, val);
hr = ipRowBuffer->put_Value(cols.c[c]->pos, val);
if (hr != S_OK)
return showError<true>(L"insert row value failed"), R_NilValue;
//ATLTRACE(" [%i]=%f",cols[c]->pos, (float)val.dblVal);
}
VARIANT oid;
if (isShape)
{
CComQIPtr<IPoint> ipPoint; ipPoint.CoCreateInstance(CLSID_Point);
CComVariant valX, valY;
cols.shape[0]->get(i, valX);
cols.shape[1]->get(i, valY);
ipPoint->PutCoords(valX.dblVal, valY.dblVal);
CComQIPtr<IFeatureBuffer> ipFBuffer(ipRowBuffer);
ATLASSERT(ipFBuffer);
hr = ipFBuffer->putref_Shape(ipPoint);
if (hr != S_OK)
return showError<true>(L"insert shape failed"), R_NilValue;
}
hr = ipCursor->InsertRow(ipRowBuffer, &oid);
if (hr != S_OK)
return showError<true>(L"insert row failed"), R_NilValue;
}
return R_NilValue;
}
SEXP attribute_hidden
do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args);
int m, zero = 0;
R_xlen_t *lengths, *counters, longest = 0;
m = length(varyingArgs);
SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
Rboolean named = CXXRCONSTRUCT(Rboolean, vnames != R_NilValue);
lengths = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
for (int i = 0; i < m; i++) {
SEXP tmp1 = VECTOR_ELT(varyingArgs, i);
lengths[i] = xlength(tmp1);
if (isObject(tmp1)) { // possibly dispatch on length()
/* Cache the .Primitive: unclear caching is worthwhile. */
static SEXP length_op = NULL;
if (length_op == NULL) length_op = R_Primitive("length");
// DispatchOrEval() needs 'args' to be a pairlist
SEXP ans, tmp2 = PROTECT(list1(tmp1));
if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1))
lengths[i] = R_xlen_t( (TYPEOF(ans) == REALSXP ?
REAL(ans)[0] : asInteger(ans)));
UNPROTECT(1);
}
if (lengths[i] == 0) zero++;
if (lengths[i] > longest) longest = lengths[i];
}
if (zero && longest)
error(_("zero-length inputs cannot be mixed with those of non-zero length"));
counters = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
memset(counters, 0, m * sizeof(R_xlen_t));
SEXP mindex = PROTECT(allocVector(VECSXP, m));
SEXP nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
SEXP fcall = R_NilValue; // -Wall
if (constantArgs == R_NilValue)
;
else if (isVectorList(constantArgs))
fcall = VectorToPairList(constantArgs);
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
PROTECT_INDEX fi;
PROTECT_WITH_INDEX(fcall, &fi);
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, longest > INT_MAX);
SEXP Dots = install("dots");
for (int j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j)));
SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j)));
REPROTECT(fcall = CONS(tmp2, fcall), fi);
UNPROTECT(2);
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j)));
}
REPROTECT(fcall = LCONS(f, fcall), fi);
SEXP ans = PROTECT(allocVector(VECSXP, longest));
for (int i = 0; i < longest; i++) {
for (int j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
if (realIndx)
REAL(VECTOR_ELT(nindex, j))[0] = double( counters[j]);
else
INTEGER(VECTOR_ELT(nindex, j))[0] = int( counters[j]);
}
SEXP tmp = eval(fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
for (int j = 0; j < m; j++)
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
UNPROTECT(5);
return ans;
}
SEXP
R_tarInfo(SEXP r_filename, SEXP r_fun, SEXP r_data)
{
gzFile *f = NULL;
const char *filename;
char *argv[] = {"R"};
TarCallbackFun callback = R_tarInfo_callback;
RTarCallInfo rcb;
Rboolean doRcallback = (TYPEOF(r_fun) == CLOSXP);
void *data;
if(TYPEOF(r_filename) == STRSXP) {
filename = CHAR(STRING_ELT(r_filename, 0));
f = gzopen(filename, "rb");
if(!f) {
PROBLEM "Can't open file %s", filename
ERROR;
}
}
if(doRcallback) {
SEXP p;
PROTECT(rcb.e = p = allocVector(LANGSXP, 6));
SETCAR(p, r_fun); p = CDR(p);
SETCAR(p, allocVector(STRSXP, 1)); p = CDR(p); /* file */
SETCAR(p, mkString("a")); p = CDR(p); /* type flag */
SETCAR(p, allocVector(REALSXP, 1)); p = CDR(p); /* time */
SETCAR(p, allocVector(INTSXP, 1)); p = CDR(p); /* remaining */
SETCAR(p, allocVector(INTSXP, 1)); p = CDR(p); /* counter */
data = (void *) &rcb;
} else {
data = (void *) r_data;
callback = (TarCallbackFun) R_ExternalPtrAddr(r_fun);
}
if(f) {
tar(f, TGZ_LIST, 1, sizeof(argv)/sizeof(argv[0]), argv, callback, (void *) data);
} else {
DataSource src;
R_rawStream stream;
stream.data = RAW(r_filename);
stream.len = LENGTH(r_filename);
stream.pos = 0;
src.data = &stream;
src.throwError = rawError;
src.read = rawRead;
funTar(&src, TGZ_LIST, 1, sizeof(argv)/sizeof(argv[0]), argv, callback, (void *) data);
}
if(doRcallback)
UNPROTECT(1);
if (f && gzclose(f) != Z_OK)
error("failed gzclose");
return(R_NilValue);
}
static void extractItem(char *buffer, SEXP ans, int i, LocalData *d)
{
char *endp;
switch(TYPEOF(ans)) {
case NILSXP:
break;
case LGLSXP:
if (isNAstring(buffer, 0, d))
LOGICAL(ans)[i] = NA_INTEGER;
else {
int tr = StringTrue(buffer), fa = StringFalse(buffer);
if(tr || fa) LOGICAL(ans)[i] = tr;
else expected("a logical", buffer, d);
}
break;
case INTSXP:
if (isNAstring(buffer, 0, d))
INTEGER(ans)[i] = NA_INTEGER;
else {
INTEGER(ans)[i] = Strtoi(buffer, 10);
if (INTEGER(ans)[i] == NA_INTEGER)
expected("an integer", buffer, d);
}
break;
case REALSXP:
if (isNAstring(buffer, 0, d))
REAL(ans)[i] = NA_REAL;
else {
REAL(ans)[i] = Strtod(buffer, &endp, TRUE, d);
if (!isBlankString(endp))
expected("a real", buffer, d);
}
break;
case CPLXSXP:
if (isNAstring(buffer, 0, d))
COMPLEX(ans)[i].r = COMPLEX(ans)[i].i = NA_REAL;
else {
COMPLEX(ans)[i] = strtoc(buffer, &endp, TRUE, d);
if (!isBlankString(endp))
expected("a complex", buffer, d);
}
break;
case STRSXP:
if (isNAstring(buffer, 1, d))
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, insertString(buffer, d));
break;
case RAWSXP:
if (isNAstring(buffer, 0, d))
RAW(ans)[i] = 0;
else {
RAW(ans)[i] = strtoraw(buffer, &endp);
if (!isBlankString(endp))
expected("a raw", buffer, d);
}
break;
default:
UNIMPLEMENTED_TYPE("extractItem", ans);
}
}
Rboolean Rf_isReal(SEXP x) {
return TYPEOF(x) == REALSXP;
}
/*! @decl int bind(int|string port, void|function accept_callback, @
*! void|string ip, void|string reuse_port)
*!
*! Opens a socket and binds it to port number on the local machine.
*! If the second argument is present, the socket is set to
*! nonblocking and the callback funcition is called whenever
*! something connects to it. The callback will receive the id for
*! this port as argument and should typically call @[accept] to
*! establish a connection.
*!
*! If the optional argument @[ip] is given, @[bind] will try to bind
*! to an interface with that host name or IP number. Omitting this
*! will bind to all available IPv4 addresses; specifying "::" will
*! bind to all IPv4 and IPv6 addresses.
*!
*! If the OS supports TCP_FASTOPEN it is enabled automatically.
*!
*! If the OS supports SO_REUSEPORT it is enabled if the fourth argument is true.
*!
*! @returns
*! 1 is returned on success, zero on failure. @[errno] provides
*! further details about the error in the latter case.
*!
*! @seealso
*! @[accept], @[set_id]
*/
static void port_bind(INT32 args)
{
struct port *p = THIS;
PIKE_SOCKADDR addr;
int addr_len,fd,tmp;
do_close(p);
if(args < 1)
SIMPLE_WRONG_NUM_ARGS_ERROR("bind", 1);
if(TYPEOF(Pike_sp[-args]) != PIKE_T_INT &&
(TYPEOF(Pike_sp[-args]) != PIKE_T_STRING ||
Pike_sp[-args].u.string->size_shift))
SIMPLE_ARG_TYPE_ERROR("bind", 1, "int|string(8bit)");
addr_len = get_inet_addr(&addr,
(args > 2 && TYPEOF(Pike_sp[2-args])==PIKE_T_STRING?
Pike_sp[2-args].u.string->str : NULL),
(TYPEOF(Pike_sp[-args]) == PIKE_T_STRING?
Pike_sp[-args].u.string->str : NULL),
(TYPEOF(Pike_sp[-args]) == PIKE_T_INT?
Pike_sp[-args].u.integer : -1), 0);
INVALIDATE_CURRENT_TIME();
fd=fd_socket(SOCKADDR_FAMILY(addr), SOCK_STREAM, 0);
if(fd < 0)
{
p->my_errno=errno;
pop_n_elems(args);
push_int(0);
return;
}
#ifdef SO_REUSEPORT
if( args > 3 && Pike_sp[3-args].u.integer )
{
/* FreeBSD 7.x wants this to reuse portnumbers.
* Linux 2.6.x seems to have reserved a slot for the option, but not
* enabled it. Survive libc's with the option on kernels without.
*
* The emulated Linux runtime on MS Windows 10 fails this with EINVAL.
*/
int o=1;
if((fd_setsockopt(fd, SOL_SOCKET, SO_REUSEPORT, (char *)&o, sizeof(int)) < 0)
#ifdef ENOPROTOOPT
&& (errno != ENOPROTOOPT)
#endif
#ifdef EINVAL
&& (errno != EINVAL)
#endif
#ifdef WSAENOPROTOOPT
&& (errno != WSAENOPROTOOPT)
#endif
){
p->my_errno=errno;
while (fd_close(fd) && errno == EINTR) {}
errno = p->my_errno;
pop_n_elems(args);
push_int(0);
return;
}
}
#endif
#ifndef __NT__
{
int o=1;
if(fd_setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, (char *)&o, sizeof(int)) < 0)
{
p->my_errno=errno;
while (fd_close(fd) && errno == EINTR) {}
errno = p->my_errno;
pop_n_elems(args);
push_int(0);
return;
}
}
#endif
#if defined(IPV6_V6ONLY) && defined(IPPROTO_IPV6)
if (SOCKADDR_FAMILY(addr) == AF_INET6) {
/* Attempt to enable dual-stack (ie mapped IPv4 adresses).
* Needed on WIN32.
* cf http://msdn.microsoft.com/en-us/library/windows/desktop/bb513665(v=vs.85).aspx
*/
int o = 0;
fd_setsockopt(fd, IPPROTO_IPV6, IPV6_V6ONLY, (char *)&o, sizeof(int));
}
#endif
my_set_close_on_exec(fd,1);
THREADS_ALLOW_UID();
if( !(tmp=fd_bind(fd, (struct sockaddr *)&addr, addr_len) < 0) )
#ifdef TCP_FASTOPEN
tmp = 256,
setsockopt(fd,SOL_TCP, TCP_FASTOPEN, &tmp, sizeof(tmp)),
#endif
(tmp = fd_listen(fd, 16384) < 0);
THREADS_DISALLOW_UID();
if(!Pike_fp->current_object->prog)
{
if (fd >= 0)
while (fd_close(fd) && errno == EINTR) {}
Pike_error("Object destructed in Stdio.Port->bind()\n");
}
if(tmp)
{
p->my_errno=errno;
while (fd_close(fd) && errno == EINTR) {}
errno = p->my_errno;
pop_n_elems(args);
push_int(0);
return;
}
change_fd_for_box (&p->box, fd);
if(args > 1) assign_accept_cb (p, Pike_sp+1-args);
p->my_errno=0;
pop_n_elems(args);
push_int(1);
}
Rboolean Rf_isSymbol(SEXP x) {
return TYPEOF(x) == SYMSXP;
}
void CallProxy::traverse_call( SEXP obj ){
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("local") ) return ;
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("global") ){
SEXP symb = CADR(obj) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find(CHAR(PRINTNAME(symb))) ;
call = res ;
return ;
}
if( ! Rf_isNull(obj) ){
SEXP head = CAR(obj) ;
switch( TYPEOF( head ) ){
case LANGSXP:
if( CAR(head) == Rf_install("global") ){
SEXP symb = CADR(head) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find( CHAR(PRINTNAME(symb)) ) ;
SETCAR(obj, res) ;
SET_TYPEOF(obj, LISTSXP) ;
break ;
}
if( CAR(head) == Rf_install("order_by") ) break ;
if( CAR(head) == Rf_install("function") ) break ;
if( CAR(head) == Rf_install("local") ) return ;
if( CAR(head) == Rf_install("<-") ){
stop( "assignments are forbidden" ) ;
}
if( Rf_length(head) == 3 ){
SEXP symb = CAR(head) ;
if( symb == R_DollarSymbol || symb == Rf_install("@") || symb == Rf_install("::") || symb == Rf_install(":::") ){
// Rprintf( "CADR(obj) = " ) ;
// Rf_PrintValue( CADR(obj) ) ;
// for things like : foo( bar = bling )$bla
// so that `foo( bar = bling )` gets processed
if( TYPEOF(CADR(head)) == LANGSXP ){
traverse_call( CDR(head) ) ;
}
// deal with foo$bar( bla = boom )
if( TYPEOF(CADDR(head)) == LANGSXP ){
traverse_call( CDDR(head) ) ;
}
break ;
} else {
traverse_call( CDR(head) ) ;
}
} else {
traverse_call( CDR(head) ) ;
}
break ;
case LISTSXP:
traverse_call( head ) ;
traverse_call( CDR(head) ) ;
break ;
case SYMSXP:
if( TYPEOF(obj) != LANGSXP ){
if( ! subsets.count(head) ){
if( head == R_MissingArg ) break ;
if( head == Rf_install(".") ) break ;
// in the Environment -> resolve
try{
Shield<SEXP> x( env.find( CHAR(PRINTNAME(head)) ) ) ;
SETCAR( obj, x );
} catch( ...){
// what happens when not found in environment
}
} else {
// in the data frame
proxies.push_back( CallElementProxy( head, obj ) );
}
break ;
}
}
traverse_call( CDR(obj) ) ;
}
}
Rboolean Rf_isComplex(SEXP x) {
return TYPEOF(x) == CPLXSXP;
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ti, ed, t;
char *filename, *editcmd, *vmaxsave, *cmd;
FILE *fp;
#ifdef Win32
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char));
strcpy(filename, CHAR(STRING_ELT(fn, 0)));
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(t = getAttrib(x, R_SourceSymbol)))
t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(t); i++)
fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i)));
fclose(fp);
}
ti = CAR(args); args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = CHAR(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, 1, 1, "");
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "%s %s", cmd, filename);
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
R_ParseCnt = 0;
x = PROTECT(R_ParseFile(fp, -1, &status));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(2);
vmaxset(vmaxsave);
return (x);
}
Rboolean Rf_isEnvironment(SEXP x) {
return TYPEOF(x) == ENVSXP;
}
SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
SEXP result;
int i, j, nr, nc, nrs, ncs;
int P=0;
SEXP Dim = getAttrib(x, R_DimSymbol);
nrs = nrows(x);ncs = ncols(x);
nr = length(sr); nc = length(sc);
SEXP oindex, nindex;
oindex = getAttrib(x, install("index"));
PROTECT(nindex = allocVector(TYPEOF(oindex), nr)); P++;
PROTECT(result = allocVector(TYPEOF(x), nr*nc)); P++;
j = 0;
double *real_nindex=NULL, *real_oindex, *real_result=NULL, *real_x=NULL;
int *int_nindex=NULL, *int_oindex, *int_result=NULL, *int_x=NULL;
int *int_sr=NULL, *int_sc=NULL;
int_sr = INTEGER(sr);
int_sc = INTEGER(sc);
copyAttributes(x, result);
if(TYPEOF(x)==LGLSXP) {
int_x = LOGICAL(x);
int_result = LOGICAL(result);
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
/* branch into INTSXP and REALSXP, as these are most
common/important types for time series data
*/
if(TYPEOF(x)==INTSXP) {
int_x = INTEGER(x);
int_result = INTEGER(result);
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
/* loop through remaining columns */
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
if(TYPEOF(x)==REALSXP) {
real_x = REAL(x);
real_result = REAL(result);
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
real_result[i+j*nr] = NA_REAL;
else
real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
real_result[i+j*nr] = NA_REAL;
else
real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
real_result[i+j*nr] = NA_REAL;
else
real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
if(TYPEOF(x)==CPLXSXP) {
/*
real_x = REAL(x);
real_result = REAL(result);
*/
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER) {
COMPLEX(result)[i+j*nr].r = NA_REAL;
COMPLEX(result)[i+j*nr].i = NA_REAL;
} else
COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER) {
COMPLEX(result)[i+j*nr].r = NA_REAL;
COMPLEX(result)[i+j*nr].i = NA_REAL;
} else
COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER) {
COMPLEX(result)[i+j*nr].r = NA_REAL;
COMPLEX(result)[i+j*nr].i = NA_REAL;
} else
COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
if(TYPEOF(x)==STRSXP) {
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
SET_STRING_ELT(result, i+j*nr, NA_STRING);
else
SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
SET_STRING_ELT(result, i+j*nr, NA_STRING);
else
SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
SET_STRING_ELT(result, i+j*nr, NA_STRING);
else
SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
}
}
} else
if(TYPEOF(x)==RAWSXP) {
/*
real_x = REAL(x);
real_result = REAL(result);
*/
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
RAW(result)[i+j*nr] = 0;
else
RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
RAW(result)[i+j*nr] = 0;
else
RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
RAW(result)[i+j*nr] = 0;
else
RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
}
if(!isNull(Dim) && nr >= 0 && nc >= 0) {
SEXP dim;
PROTECT(dim = allocVector(INTSXP,2));P++;
INTEGER(dim)[0] = nr;
INTEGER(dim)[1] = nc;
setAttrib(result, R_DimSymbol, dim);
if (nr >= 0 && nc >= 0) {
SEXP dimnames, dimnamesnames, newdimnames;
dimnames = getAttrib(x, R_DimNamesSymbol);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
if (!isNull(dimnames)) {
PROTECT(newdimnames = allocVector(VECSXP, 2));
if (TYPEOF(dimnames) == VECSXP) {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(VECTOR_ELT(dimnames, 0),
allocVector(STRSXP, nr), sr));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, nc), sc));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(CAR(dimnames),
allocVector(STRSXP, nr), sr));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(CADR(dimnames),
allocVector(STRSXP, nc), sc));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1);
}
}
}
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
if(nc == 1 && LOGICAL(drop)[0])
setAttrib(result, R_DimSymbol, R_NilValue);
UNPROTECT(P);
return result;
}
Rboolean Rf_isExpression(SEXP x) {
return TYPEOF(x) == EXPRSXP;
}
SEXP extract_col (SEXP x, SEXP j, SEXP drop, SEXP first_, SEXP last_) {
SEXP result, index, new_index;
int nrs, nrsx, i, ii, jj, first, last;
nrsx = nrows(x);
first = asInteger(first_)-1;
last = asInteger(last_)-1;
/* nrs = offset_end - offset_start - 1; */
nrs = last - first + 1;
PROTECT(result = allocVector(TYPEOF(x), nrs * length(j)));
switch(TYPEOF(x)) {
case REALSXP:
for(i=0; i<length(j); i++) {
/*
Rprintf("j + i*nrs + first=%i\n", (int)(INTEGER(j)[i]-1 + i*nrs + first));
Rprintf("i=%i, j=%i, nrs=%i, first=%i\n", i, INTEGER(j)[i]-1, nrs, first);
*/
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
REAL(result)[(i*nrs) + ii] = NA_REAL;
}
} else {
memcpy(&(REAL(result)[i*nrs]),
&(REAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(double));
}
}
break;
case INTSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
INTEGER(result)[(i*nrs) + ii] = NA_INTEGER;
}
} else {
memcpy(&(INTEGER(result)[i*nrs]),
&(INTEGER(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(int));
}
}
break;
case LGLSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
LOGICAL(result)[(i*nrs) + ii] = NA_LOGICAL;
}
} else {
memcpy(&(LOGICAL(result)[i*nrs]),
&(LOGICAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(int));
}
}
break;
case CPLXSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
COMPLEX(result)[(i*nrs) + ii].r = NA_REAL;
COMPLEX(result)[(i*nrs) + ii].i = NA_REAL;
}
} else {
memcpy(&(COMPLEX(result)[i*nrs]),
&(COMPLEX(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
RAW(result)[(i*nrs) + ii] = 0;
}
} else {
memcpy(&(RAW(result)[i*nrs]),
&(RAW(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(Rbyte));
}
}
break;
case STRSXP:
for(jj=0; jj<length(j); jj++) {
if(INTEGER(j)[jj] == NA_INTEGER) {
for(i=0; i< nrs; i++)
SET_STRING_ELT(result, i+jj*nrs, NA_STRING);
} else {
for(i=0; i< nrs; i++)
SET_STRING_ELT(result, i+jj*nrs, STRING_ELT(x, i+(INTEGER(j)[jj]-1)*nrsx+first));
}
}
break;
default:
error("unsupported type");
}
if(nrs != nrows(x)) {
copyAttributes(x, result);
/* subset index */
index = getAttrib(x, install("index"));
PROTECT(new_index = allocVector(TYPEOF(index), nrs));
if(TYPEOF(index) == REALSXP) {
memcpy(REAL(new_index), &(REAL(index)[first]), nrs*sizeof(double));
} else { /* INTSXP */
memcpy(INTEGER(new_index), &(INTEGER(index)[first]), nrs*sizeof(int));
}
copyMostAttrib(index, new_index);
setAttrib(result, install("index"), new_index);
UNPROTECT(1);
} else {
copyMostAttrib(x, result); /* need an xts/zoo equal that skips 'index' */
}
if(!asLogical(drop)) { /* keep dimension and dimnames */
SEXP dim;
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = nrs;
INTEGER(dim)[1] = length(j);
setAttrib(result, R_DimSymbol, dim);
UNPROTECT(1);
SEXP dimnames, currentnames, newnames;
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(newnames = allocVector(STRSXP, length(j)));
currentnames = getAttrib(x, R_DimNamesSymbol);
if(!isNull(currentnames)) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(currentnames,0));
if(!isNull(VECTOR_ELT(currentnames,1))) {
/* if colnames isn't NULL set */
for(i=0; i<length(j); i++) {
SET_STRING_ELT(newnames, i, STRING_ELT(VECTOR_ELT(currentnames,1), INTEGER(j)[i]-1));
}
SET_VECTOR_ELT(dimnames, 1, newnames);
} else {
/* else set to NULL */
SET_VECTOR_ELT(dimnames, 1, R_NilValue);
}
setAttrib(result, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
UNPROTECT(1);
return result;
}
Rboolean Rf_isLogical(SEXP x) {
return TYPEOF(x) == LGLSXP;
}
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
int nx, ny, xarray, yarray, xts, yts;
Rboolean mismatch = FALSE, iS;
PROTECT_INDEX xpi, ypi;
PROTECT_WITH_INDEX(x, &xpi);
PROTECT_WITH_INDEX(y, &ypi);
nx = length(x);
ny = length(y);
/* pre-test to handle the most common case quickly.
Used to skip warning too ....
*/
if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
LENGTH(x) > 0 && LENGTH(y) > 0) {
SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (mismatch) {
PROTECT(ans);
warningcall(call, _("longer object length is not a multiple of shorter object length"));
UNPROTECT(1);
}
UNPROTECT(2);
return ans;
}
/* That symbols and calls were allowed was undocumented prior to
R 2.5.0. We deparse them as deparse() would, minus attributes */
if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
REPROTECT(x = tmp, xpi);
UNPROTECT(1);
}
if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
REPROTECT(y = tmp, ypi);
UNPROTECT(1);
}
if (!isVector(x) || !isVector(y)) {
if (isNull(x) || isNull(y)) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
errorcall(call,
_("comparison (%d) is possible only for atomic and list types"),
PRIMVAL(op));
}
if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
errorcall(call, _("comparison is not allowed for expressions"));
/* ELSE : x and y are both atomic or list */
if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
mismatch = FALSE;
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (length(x) < length(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (length(y) < length(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (mismatch)
warningcall(call, _("longer object length is not a multiple of shorter object length"));
if (isString(x) || isString(y)) {
REPROTECT(x = coerceVector(x, STRSXP), xpi);
REPROTECT(y = coerceVector(y, STRSXP), ypi);
x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isComplex(x) || isComplex(y)) {
REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
}
else if (isReal(x) || isReal(y)) {
REPROTECT(x = coerceVector(x, REALSXP), xpi);
REPROTECT(y = coerceVector(y, REALSXP), ypi);
x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isInteger(x) || isInteger(y)) {
REPROTECT(x = coerceVector(x, INTSXP), xpi);
REPROTECT(y = coerceVector(y, INTSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isLogical(x) || isLogical(y)) {
REPROTECT(x = coerceVector(x, LGLSXP), xpi);
REPROTECT(y = coerceVector(y, LGLSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
REPROTECT(x = coerceVector(x, RAWSXP), xpi);
REPROTECT(y = coerceVector(y, RAWSXP), ypi);
x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
} else errorcall(call, _("comparison of these types is not implemented"));
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if (xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if (ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if (length(x) == length(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if (length(x) == length(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(6);
return x;
}
SEXP zoo_lag (SEXP x, SEXP _k, SEXP _pad)
{
#ifdef ZOO_DEBUG
Rprintf("zoo_lag\n");
#endif
SEXP result;
int i,j;
double *result_real=NULL;
int *result_int=NULL;
int k=INTEGER(_k)[0] * -1; /* -1 is zoo convention */
int k_positive = (k > 0) ? 1 : 0;
int nr = nrows(x);
int nc = ncols(x);
int P=0;
int PAD = INTEGER(coerceVector(_pad,INTSXP))[0];
if(k > nr)
error("abs(k) must be less than nrow(x)");
if(k < 0 && -1*k > nr)
error("abs(k) must be less than nrow(x)");
PROTECT(result = allocVector(TYPEOF(x),
length(x) - (PAD ? 0 : abs(k)*nc))); P++;
int nrr = (int)(length(result)/nc);
if(k_positive) {
switch(TYPEOF(x)) {
case REALSXP:
result_real = REAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_real[i+(j*nrr)] = NA_REAL;
memcpy(&REAL(result)[k+(j*nrr)],
&REAL(x)[(j*nrr)],
(nrr-k) * sizeof(double));
} else {
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[(j*nr)], /* original data need the original 'nr' offset */
nrr * sizeof(double));
}
}
break;
case INTSXP:
result_int = INTEGER(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&INTEGER(result)[k+(j*nrr)],
&INTEGER(x)[(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[(j*nr)],
nrr * sizeof(int));
}
}
break;
case LGLSXP:
result_int = LOGICAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&LOGICAL(result)[k+(j*nrr)],
&LOGICAL(x)[(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[(j*nr)],
nrr * sizeof(int));
}
}
break;
case CPLXSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++) {
COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
}
memcpy(&COMPLEX(result)[k+(j*nrr)],
&COMPLEX(x)[(j*nrr)],
(nrr-k) * sizeof(Rcomplex));
} else {
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[(j*nr)],
nrr * sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
RAW(result)[i+(j*nrr)] = (Rbyte) 0;
memcpy(&RAW(result)[k+(j*nrr)],
&RAW(x)[(j*nrr)],
(nrr-k) * sizeof(Rbyte));
} else {
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[(j*nr)],
nrr * sizeof(Rbyte));
}
}
break;
case STRSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
for(i = 0; i < nrr-k; i++)
SET_STRING_ELT(result, k+i+j*nrr, STRING_ELT(x, i+j*nrr));
} else {
for(i = 0; i < nrr; i++)
SET_STRING_ELT(result, i+j*nrr, STRING_ELT(x, i+j*nr));
}
}
break;
default:
error("unsupported type");
break;
}
} else
if(!k_positive) {
k = abs(k);
switch(TYPEOF(x)) {
case REALSXP:
result_real = REAL(result);
for(j =0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_real[i+(j*nrr)] = NA_REAL;
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[k+(j*nrr)],
(nrr-k) * sizeof(double));
} else {
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[k+(j*nr)],
nrr * sizeof(double));
}
}
break;
case INTSXP:
result_int = INTEGER(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[k+(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[k+(j*nr)],
nrr * sizeof(int));
}
}
break;
case LGLSXP:
result_int = LOGICAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[k+(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[k+(j*nr)],
nrr * sizeof(int));
}
}
break;
case CPLXSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++) {
COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
}
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[k+(j*nrr)],
(nrr-k) * sizeof(Rcomplex));
} else {
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[k+(j*nr)],
nrr * sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
RAW(result)[i+(j*nrr)] = (Rbyte) 0;
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[k+(j*nrr)],
(nrr-k) * sizeof(Rbyte));
} else {
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[k+(j*nr)],
nrr * sizeof(Rbyte));
}
}
break;
case STRSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
for(i = 0; i < nrr-k; i++)
SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nrr)));
} else {
for(i = 0; i < nr-k; i++)
SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nr)));
}
}
break;
default:
error("unsupported type");
break;
}
}
copyMostAttrib(x,result);
if(!PAD) {
// likely unneeded as copyMostAttrib will cover
// setAttrib(result, install("index"), getAttrib(x, install("index")));
//} else {
SEXP index, newindex;
PROTECT(index = getAttrib(x, install("index"))); P++;
if(IS_S4_OBJECT(index)) {
/* should make this
1) generic for any S4 object if possible
2) test for timeDate as this is important
*/
if(STRING_ELT(getAttrib(index, R_ClassSymbol),0)!=mkChar("timeDate"))
error("'S4' objects must be of class 'timeDate'");
index = GET_SLOT(index, install("Data"));
}
PROTECT(newindex = allocVector(TYPEOF(index), nrr)); P++;
switch(TYPEOF(index)) {
case REALSXP:
if(k_positive) {
memcpy(REAL(newindex), &REAL(index)[k], nrr * sizeof(double));
} else {
memcpy(REAL(newindex), REAL(index), nrr * sizeof(double));
}
break;
case INTSXP:
if(k_positive) {
memcpy(INTEGER(newindex), &INTEGER(index)[k], nrr * sizeof(int));
} else {
memcpy(INTEGER(newindex), INTEGER(index), nrr * sizeof(int));
}
break;
default:
break;
}
if(IS_S4_OBJECT(getAttrib(x, install("index")))) {
/* need to assure that this is timeDate */
SEXP tmp = PROTECT(getAttrib(x, install("index"))); P++;
SEXP timeDate = PROTECT(NEW_OBJECT(MAKE_CLASS("timeDate"))); P++;
copyMostAttrib(index,newindex);
SET_SLOT(timeDate,install("Data"),newindex);
SET_SLOT(timeDate,install("format"),
GET_SLOT(tmp, install("format")));
SET_SLOT(timeDate,install("FinCenter"),
GET_SLOT(tmp, install("FinCenter")));
setAttrib(result, install("index"), timeDate);
} else {
copyMostAttrib(index, newindex);
setAttrib(result, install("index"), newindex);
}
}
/* reset dims */
if(!isNull(getAttrib(x, R_DimSymbol))) {
SEXP dims;
PROTECT(dims = allocVector(INTSXP, 2)); P++;
INTEGER(dims)[0] = nrr;
INTEGER(dims)[1] = nc;
setAttrib(result, R_DimSymbol, dims);
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
UNPROTECT(P);
return result;
}