SEXP librinterface_remove(SEXP symbol, SEXP env, SEXP rho)
{
SEXP c_R, call_R, res;
static SEXP fun_R = NULL;
/* Only fetch rm() the first time */
if (fun_R == NULL) {
PROTECT(fun_R = librinterface_FindFun(install("rm"), rho));
R_PreserveObject(fun_R);
UNPROTECT(1);
}
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2+1));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the name of the variable to be removed */
SETCAR(c_R, symbol);
//SET_TAG(c_R, install("list"));
c_R = CDR(c_R);
/* second argument is the environment in which the variable
should be removed */
SETCAR(c_R, env);
SET_TAG(c_R, install("envir"));
c_R = CDR(c_R);
int error = 0;
PROTECT(res = R_tryEval(call_R, rho, &error));
UNPROTECT(3);
return res;
}
SEXP rpy_remove(SEXP symbol, SEXP env, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
PROTECT(fun_R = rpy_findFun(install("rm"), rho));
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2+1));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the name of the variable to be removed */
SETCAR(c_R, symbol);
//SET_TAG(c_R, install("list"));
c_R = CDR(c_R);
/* second argument is the environment in which the variable
should be removed */
SETCAR(c_R, env);
SET_TAG(c_R, install("envir"));
c_R = CDR(c_R);
int error = 0;
PROTECT(res = R_tryEval(call_R, rho, &error));
UNPROTECT(3);
return res;
}
SEXP single_arg_R_fun(char* fun, SEXP x){
SEXP s, t;
t = s = PROTECT(allocList(2));
SET_TYPEOF(s, LANGSXP);
SETCAR(t, install(fun)); t = CDR(t);
SETCAR(t, x);
UNPROTECT(1);
return eval(s, R_GlobalEnv);
}
/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, argList;
int addit = 0;
static SEXP do_onexit_formals = NULL;
if (do_onexit_formals == NULL)
do_onexit_formals = allocFormalsList2(install("expr"), install("add"));
PROTECT(argList = matchArgs(do_onexit_formals, args, call));
if (CAR(argList) == R_MissingArg) code = R_NilValue;
else code = CAR(argList);
if (CADR(argList) != R_MissingArg) {
addit = asLogical(eval(CADR(args), rho));
if (addit == NA_INTEGER)
errorcall(call, _("invalid '%s' argument"), "add");
}
ctxt = R_GlobalContext;
/* Search for the context to which the on.exit action is to be
attached. Lexical scoping is implemented by searching for the
first closure call context with an environment matching the
expression evaluation environment. */
while (ctxt != R_ToplevelContext &&
!((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) )
ctxt = ctxt->nextcontext;
if (ctxt->callflag & CTXT_FUNCTION)
{
if (addit && (oldcode = ctxt->conexit) != R_NilValue ) {
if ( CAR(oldcode) != R_BraceSymbol )
{
PROTECT(tmp = allocList(3));
SETCAR(tmp, R_BraceSymbol);
SETCADR(tmp, oldcode);
SETCADDR(tmp, code);
SET_TYPEOF(tmp, LANGSXP);
ctxt->conexit = tmp;
UNPROTECT(1);
}
else
{
PROTECT(tmp = allocList(1));
SETCAR(tmp, code);
ctxt->conexit = listAppend(duplicate(oldcode),tmp);
UNPROTECT(1);
}
}
else
ctxt->conexit = code;
}
UNPROTECT(1);
return R_NilValue;
}
SEXP rpy_devoff(SEXP devnum, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): checking 'rho'.\n");
#endif
if(!isEnvironment(rho)) {
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): invalid 'rho'.\n");
#endif
error("'rho' should be an environment\n");
}
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): Looking for dev.off()...\n");
#endif
PROTECT(fun_R = rpy2_findfun(install("dev.off"), rho));
if (fun_R == R_UnboundValue)
printf("dev.off() could not be found.\n");
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): found.\n");
#endif
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the device number to be closed */
SETCAR(c_R, devnum);
SET_TAG(c_R, install("which"));
c_R = CDR(c_R);
int error = 0;
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): R_tryEval()\n");
#endif
PROTECT(res = R_tryEval(call_R, rho, &error));
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): unprotecting.\n");
#endif
UNPROTECT(3);
return res;
}
size_t dplRlength(SEXP x) {
size_t xlength;
SEXP sn, tmp, ncall;
PROTECT_INDEX ipx;
PROTECT(tmp = ncall = allocList(2));
SET_TYPEOF(ncall, LANGSXP);
SETCAR(tmp, install("length")); tmp = CDR(tmp);
SETCAR(tmp, x);
PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx);
REPROTECT(sn = coerceVector(sn, REALSXP), ipx);
xlength = (size_t) *REAL(sn);
UNPROTECT(2);
return xlength;
}
Datum
plr_get_raw(PG_FUNCTION_ARGS)
{
SEXP result;
SEXP s, t, obj;
int status;
bytea *bvalue = PG_GETARG_BYTEA_P(0);
int len, rsize;
bytea *bresult;
char *brptr;
PROTECT(obj = NEW_RAW(VARSIZE(bvalue)));
memcpy((char *) RAW(obj), VARDATA(bvalue), VARSIZE(bvalue));
/*
* Need to construct a call to
* unserialize(rval)
*/
PROTECT(t = s = allocList(2));
SET_TYPEOF(s, LANGSXP);
SETCAR(t, install("unserialize")); t = CDR(t);
SETCAR(t, obj);
PROTECT(result = R_tryEval(s, R_GlobalEnv, &status));
if(status != 0)
{
if (last_R_error_msg)
ereport(ERROR,
(errcode(ERRCODE_DATA_EXCEPTION),
errmsg("R interpreter expression evaluation error"),
errdetail("%s", last_R_error_msg)));
else
ereport(ERROR,
(errcode(ERRCODE_DATA_EXCEPTION),
errmsg("R interpreter expression evaluation error"),
errdetail("R expression evaluation error caught in \"unserialize\".")));
}
len = LENGTH(result);
rsize = VARHDRSZ + len;
bresult = (bytea *) palloc(rsize);
SET_VARSIZE(bresult, rsize);
brptr = VARDATA(bresult);
memcpy(brptr, (char *) RAW(result), rsize - VARHDRSZ);
UNPROTECT(2);
PG_RETURN_BYTEA_P(bresult);
}
int enableWarnings(int val)
{
SEXP s, t;
PROTECT(t = s = allocList(2));
SET_TYPEOF(s, LANGSXP);
SETCAR(t, install("options"));
t = CDR(t);
SETCAR(t,allocVector(INTSXP, 1));
INTEGER(CAR(t))[0] = val;
SET_TAG(t, install("warn"));
SEXP oldStatus;
PROTECT(oldStatus = coerceVector(eval(s, R_GlobalEnv),INTSXP));
UNPROTECT(2);
return INTEGER(oldStatus)[0];
}
void InitAllowedFunc(
SEXP Allowed, // can be NULL
int nAllowedArgs, SEXP Env,
const char** sPredNames, int nPreds)
{
if(Allowed == R_NilValue)
AllowedFuncGlobal = NULL;
else {
if(nAllowedArgs < 3 || nAllowedArgs > 5)
error("Bad nAllowedArgs %d", nAllowedArgs);
AllowedEnvGlobal = Env;
nArgsGlobal = nAllowedArgs;
// the UNPROTECT for the PROTECT below is in FreeAllowedFunc()
PROTECT(AllowedFuncGlobal = allocList(1 + nAllowedArgs));
SEXP s = AllowedFuncGlobal; // 1st element is the function
SETCAR(s, Allowed);
SET_TYPEOF(s, LANGSXP);
s = CDR(s); // 2nd element is "degree"
SETCAR(s, allocVector(INTSXP, 1));
s = CDR(s); // 3rd element is "pred"
SETCAR(s, allocVector(INTSXP, 1));
s = CDR(s); // 4th element is "parents"
SETCAR(s, allocVector(INTSXP, nPreds));
if(nAllowedArgs >= 4) {
SEXP namesx;
s = CDR(s); // 5th element is "namesx"
SETCAR(s, namesx = allocVector(STRSXP, nPreds));
PROTECT(namesx);
if(sPredNames == NULL)
error("Bad sPredNames");
for(int i = 0; i < nPreds; i++)
SET_STRING_ELT(namesx, i, mkChar(sPredNames[i]));
UNPROTECT(1);
}
if(nAllowedArgs >= 5) {
s = CDR(s); // 6th element is "first"
SETCAR(s, allocVector(LGLSXP, 1));
}
}
FirstGlobal = true;
}
SEXP tryXts (SEXP x)
{
if( !isXts(x) ) {
SEXP s, t, result;
PROTECT(s = t = allocList(2));
SET_TYPEOF(s, LANGSXP);
SETCAR(t, install("try.xts")); t = CDR(t);
SETCAR(t, x); t=CDR(t);
PROTECT(result = eval(s, R_GlobalEnv));
if( !isXts(result) ) {
UNPROTECT(2);
error("rbind.xts requires xtsible data");
}
UNPROTECT(2);
return result;
}
return x;
}
SEXP rpy_unserialize(SEXP connection, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
PROTECT(fun_R = rpy_findFun(install("unserialize"), rho));
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* obscure incatation to summon R */
PROTECT(c_R = call_R = allocList(2));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is a RAWSXP representation of the object to unserialize */
SETCAR(c_R, connection);
c_R = CDR(c_R);
PROTECT(res = eval(call_R, rho));
UNPROTECT(2);
return res;
}
/* Convert a list of promise objects into a DOTSXP. */
SEXP _list_to_dotslist(SEXP list) {
assert_type(list, VECSXP);
int len = length(list);
int i;
SEXP output, names;
names = getAttrib(list, R_NamesSymbol);
if (len > 0) {
output = PROTECT(allocList(len));
SEXP output_iter = output;
for (i = 0; i < len; i++, output_iter=CDR(output_iter)) {
SET_TYPEOF(output_iter, DOTSXP);
if ((names != R_NilValue) && (STRING_ELT(names, i) != R_BlankString)) {
SET_TAG(output_iter, install(CHAR(STRING_ELT(names, i)) ));
}
SETCAR(output_iter, VECTOR_ELT(list, i));
}
} else {
output = PROTECT(allocVector(VECSXP, 0));
}
setAttrib(output, R_ClassSymbol, ScalarString(mkChar("...")));
UNPROTECT(1);
return output;
}
SEXP rpy_serialize(SEXP object, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
PROTECT(fun_R = rpy_findFun(install("serialize"), rho));
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* obscure incatation to summon R */
PROTECT(c_R = call_R = allocList(3));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the SEXP object to serialize */
SETCAR(c_R, object);
c_R = CDR(c_R);
/* second argument is NULL */
SETCAR(c_R, R_NilValue);
c_R = CDR(c_R);
PROTECT(res = eval(call_R, rho));
UNPROTECT(3);
return res;
}
static void RIntegrand(ccount *ndim, ctreal xx[],
ccount *ncomp,
ctreal *lower, ctreal *upper, ctreal prdbounds, real ff[],
ctreal *weight)
{
SEXP args, argw, s, t, resultsxp;
int i;
/*f: the R function and its environment, rho are global */
// The input arguments are x +1 weight
PROTECT(args=allocVector(REALSXP, ( *ndim )));
PROTECT(argw=allocVector(REALSXP, (1 )));
PROTECT(resultsxp=allocVector(REALSXP, ( *ncomp )));
/* Fill in the input arguments with rescaling between 0-1,
according to the bounds */
for (i =0; i<*ndim; i++)
REAL(args)[i] = xx[i] * (upper[i] - lower[i]) + lower[i];
REAL(argw)[ 0]=*weight;
/* Appel de la fonction R */
PROTECT(t = s = allocList(3));
SET_TYPEOF(s, LANGSXP);
SETCAR(t, globf); t = CDR(t);
SETCAR(t, args); t = CDR(t);
SETCAR(t, argw);
PROTECT(resultsxp=eval(s,rho));
UNPROTECT(5);
if (length(resultsxp) != *ncomp)
error("Function integrand does not return a vector of length ncomp\n Length of returned vector= %d. ncomp=%d\n",
length(resultsxp), *ncomp);
for (i =0; i<*ncomp; i++) {
ff[i] = REAL(resultsxp)[i] * prdbounds;
}
} // End RIntegrand
// hack by calling paste using eval. could change this to strcat, but not sure about buffer size for large data.tables... Any ideas Matthew?
SEXP concat(SEXP vec, SEXP idx) {
SEXP s, t, v;
int i;
if (TYPEOF(vec) != STRSXP) error("concat: 'vec must be a character vector");
if (!isInteger(idx) || length(idx) < 0) error("concat: 'idx' must be an integer vector of length >= 0");
for (i=0; i<length(idx); i++) {
if (INTEGER(idx)[i] < 0 || INTEGER(idx)[i] > length(vec))
error("concat: 'idx' must take values between 0 and length(vec); 0 <= idx <= length(vec)");
}
PROTECT(v = allocVector(STRSXP, length(idx)));
for (i=0; i<length(idx); i++) {
SET_STRING_ELT(v, i, STRING_ELT(vec, INTEGER(idx)[i]-1));
}
PROTECT(t = s = allocList(3));
SET_TYPEOF(t, LANGSXP);
SETCAR(t, install("paste")); t = CDR(t);
SETCAR(t, v); t = CDR(t);
SETCAR(t, mkString(", "));
SET_TAG(t, install("collapse"));
UNPROTECT(2); // v, (t,s)
return(eval(s, R_GlobalEnv));
}
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ax, px, x, subs;
int drop, i, nsubs, type;
/* By default we drop extents of length 1 */
/* Handle cases of extracting a single element from a simple vector
or matrix directly to improve speed for these simple cases. */
SEXP cdrArgs = CDR(args);
SEXP cddrArgs = CDR(cdrArgs);
if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
TAG(cdrArgs) == R_NilValue) {
/* one index, not named */
SEXP x = CAR(args);
if (ATTRIB(x) == R_NilValue) {
SEXP s = CAR(cdrArgs);
R_xlen_t i = scalarIndex(s);
switch (TYPEOF(x)) {
case REALSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarReal( REAL(x)[i-1] );
break;
case INTSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarInteger( INTEGER(x)[i-1] );
break;
case LGLSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarLogical( LOGICAL(x)[i-1] );
break;
// do the more rare cases as well, since we've already prepared everything:
case CPLXSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarComplex( COMPLEX(x)[i-1] );
break;
case RAWSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarRaw( RAW(x)[i-1] );
break;
default: break;
}
}
}
else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
/* two indices, not named */
SEXP x = CAR(args);
SEXP attr = ATTRIB(x);
if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
/* only attribute of x is 'dim' */
SEXP dim = CAR(attr);
if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
/* x is a matrix */
SEXP si = CAR(cdrArgs);
SEXP sj = CAR(cddrArgs);
R_xlen_t i = scalarIndex(si);
R_xlen_t j = scalarIndex(sj);
int nrow = INTEGER(dim)[0];
int ncol = INTEGER(dim)[1];
if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
/* indices are legal scalars */
R_xlen_t k = i - 1 + nrow * (j - 1);
switch (TYPEOF(x)) {
case REALSXP:
if (k < LENGTH(x))
return ScalarReal( REAL(x)[k] );
break;
case INTSXP:
if (k < LENGTH(x))
return ScalarInteger( INTEGER(x)[k] );
break;
case LGLSXP:
if (k < LENGTH(x))
return ScalarLogical( LOGICAL(x)[k] );
break;
case CPLXSXP:
if (k < LENGTH(x))
return ScalarComplex( COMPLEX(x)[k] );
break;
case RAWSXP:
if (k < LENGTH(x))
return ScalarRaw( RAW(x)[k] );
break;
default: break;
}
}
}
}
}
PROTECT(args);
drop = 1;
ExtractDropArg(args, &drop);
x = CAR(args);
/* This was intended for compatibility with S, */
/* but in fact S does not do this. */
/* FIXME: replace the test by isNull ... ? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
subs = CDR(args);
nsubs = length(subs); /* Will be short */
type = TYPEOF(x);
/* Here coerce pair-based objects into generic vectors. */
/* All subsetting takes place on the generic vector form. */
ax = x;
if (isVector(x))
PROTECT(ax);
else if (isPairList(x)) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
if (ndim > 1) {
PROTECT(ax = allocArray(VECSXP, dim));
setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
else {
PROTECT(ax = allocVector(VECSXP, length(x)));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
SET_VECTOR_ELT(ax, i++, CAR(px));
}
else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
/* This is the actual subsetting code. */
/* The separation of arrays and matrices is purely an optimization. */
if(nsubs < 2) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
call));
/* one-dimensional arrays went through here, and they should
have their dimensions dropped only if the result has
length one and drop == TRUE
*/
if(ndim == 1) {
SEXP attr, attrib, nattrib;
int len = length(ans);
if(!drop || len > 1) {
// must grab these before the dim is set.
SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
PROTECT(attr = allocVector(INTSXP, 1));
INTEGER(attr)[0] = length(ans);
setAttrib(ans, R_DimSymbol, attr);
if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
/* reinstate dimnames, include names of dimnames */
PROTECT(nattrib = duplicate(attrib));
SET_VECTOR_ELT(nattrib, 0, nm);
setAttrib(ans, R_DimNamesSymbol, nattrib);
setAttrib(ans, R_NamesSymbol, R_NilValue);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
} else {
if (nsubs != length(getAttrib(x, R_DimSymbol)))
errorcall(call, _("incorrect number of dimensions"));
if (nsubs == 2)
ans = MatrixSubset(ax, subs, call, drop);
else
ans = ArraySubset(ax, subs, call, drop);
PROTECT(ans);
}
/* Note: we do not coerce back to pair-based lists. */
/* They are "defunct" in this version of R. */
if (type == LANGSXP) {
ax = ans;
PROTECT(ans = allocList(LENGTH(ax)));
if ( LENGTH(ax) > 0 )
SET_TYPEOF(ans, LANGSXP);
for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
SETCAR(px, VECTOR_ELT(ax, i++));
setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
}
else {
PROTECT(ans);
}
if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
if(!IS_S4_OBJECT(x))
#endif
setAttrib(ans, R_ClassSymbol, R_NilValue);
}
UNPROTECT(4);
return ans;
}
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( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("column") ){
call = get_column(CADR(obj), env, subsets) ;
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("column")){
Symbol column = get_column( CADR(head), env, subsets) ;
SETCAR(obj, column ) ;
head = CAR(obj) ;
proxies.push_back( CallElementProxy( head, obj ) );
break ;
}
if( CAR(head) == Rf_install("~")) 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) ) ;
}
}
SEXP attribute_hidden matchPositionalArgsCreateEnv(SEXP formals, SEXP *supplied, int nsupplied, SEXP call, SEXP rho, SEXP* outActuals)
{
SEXP *s;
SEXP f, a;
SEXP actuals = R_NilValue;
SEXP newrho = PROTECT(NewEnvironmentNR(rho));
SEXP *endSupplied = supplied + nsupplied;
for (f = formals, s = supplied, a = actuals ; f != R_NilValue ; f = CDR(f), s++) {
if (TAG(f) == R_DotsSymbol) {
/* pack all remaining arguments into ... */
SEXP *rs = endSupplied - 1;
SEXP dotsContent = R_NilValue;
for(; rs >= s; rs--) {
dotsContent = CONS(*rs, dotsContent); /* FIXME: enabling refcnt? */
}
SEXP dots = CONS_NR(dotsContent, R_NilValue);
SET_TAG(dots, R_DotsSymbol);
if (dotsContent != R_NilValue) {
SET_TYPEOF(dotsContent, DOTSXP);
} else {
SET_MISSING(dots, 1);
}
if (a == R_NilValue) {
PROTECT(actuals = dots);
} else {
SETCDR(a, dots);
ENABLE_REFCNT(a); /* dots are part of a protected list */
}
a = dots;
f = CDR(f);
s = endSupplied;
/* falls through into noMoreSupplied branch below */
}
if (s == endSupplied) {
/* possibly fewer supplied arguments than formals */
SEXP ds;
for(; f != R_NilValue ; f = CDR(f), a = ds) {
ds = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(ds, TAG(f));
if (a == R_NilValue) {
PROTECT(actuals = ds);
} else {
SETCDR(a, ds);
ENABLE_REFCNT(a); /* ds is part of a protected list */
}
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(ds, 2);
SETCAR(ds, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(ds, 1);
}
}
break;
}
/* normal case, the next supplied arg is available */
SEXP arg = CONS_NR(*s, R_NilValue);
SET_TAG(arg, TAG(f));
if (a == R_NilValue) {
PROTECT(actuals = arg);
} else {
SETCDR(a, arg);
ENABLE_REFCNT(a);
}
a = arg;
}
if (s < endSupplied) {
/* some arguments are not used */
SEXP *rs = endSupplied - 1;
SEXP unusedForError = R_NilValue;
for(; rs >= s; rs--) {
SEXP rsValue = *rs;
if (TYPEOF(rsValue) == PROMSXP) {
rsValue = PREXPR(rsValue);
}
unusedForError = CONS(rsValue, unusedForError);
}
PROTECT(unusedForError); /* needed? */
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
UNPROTECT(1);
}
if (a != R_NilValue) {
ENABLE_REFCNT(a);
}
SET_FRAME(newrho, actuals);
ENABLE_REFCNT(newrho);
UNPROTECT(1); /* newrho */
if (actuals != R_NilValue) {
UNPROTECT(1); /* actuals */
}
*outActuals = actuals;
return(newrho);
}
/* dplR: y <- lmfit(x, y)[["residuals"]]
*/
void rmtrend(SEXP x, SEXP y, SEXP lengthfun, SEXP lmfit) {
SEXP tmp, lmcall, lmres, lmnames, rduals;
SEXP sn, ncall;
PROTECT_INDEX ipx;
double *y_data;
size_t i, nameslength;
size_t n = 0;
Rboolean found = FALSE;
Rboolean mismatch = TRUE;
/* dplR: call lm.fit(x, y) */
PROTECT(tmp = lmcall = allocList(3));
SET_TYPEOF(lmcall, LANGSXP);
SETCAR(tmp, lmfit); tmp = CDR(tmp);
SETCAR(tmp, x); tmp = CDR(tmp);
SETCAR(tmp, y);
PROTECT(lmres = eval(lmcall, R_EmptyEnv));
/* dplR: get residuals from the list given by lm.fit(x, y) */
lmnames = getAttrib(lmres, R_NamesSymbol);
PROTECT(tmp = ncall = allocList(2));
SET_TYPEOF(ncall, LANGSXP);
SETCAR(tmp, lengthfun); tmp = CDR(tmp);
SETCAR(tmp, lmnames);
PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx);
REPROTECT(sn = coerceVector(sn, REALSXP), ipx);
nameslength = (size_t) *REAL(sn);
UNPROTECT(2);
for (i = 0; i < nameslength; i++) {
if (strcmp(CHAR(STRING_ELT(lmnames, i)), "residuals") == 0) {
rduals = VECTOR_ELT(lmres, i);
PROTECT(rduals = coerceVector(rduals, REALSXP));
found = TRUE;
break;
}
}
/* dplR: compare length of y with length of residuals */
PROTECT(tmp = ncall = allocList(2));
SET_TYPEOF(ncall, LANGSXP);
SETCAR(tmp, lengthfun); tmp = CDR(tmp);
SETCAR(tmp, y);
PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx);
REPROTECT(sn = coerceVector(sn, REALSXP), ipx);
n = (size_t) *REAL(sn);
UNPROTECT(1);
if (found) {
SETCAR(tmp, rduals);
PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx);
REPROTECT(sn = coerceVector(sn, REALSXP), ipx);
mismatch = n != (size_t) *REAL(sn);
UNPROTECT(1);
}
UNPROTECT(1);
y_data = REAL(y);
if (!mismatch) {
/* dplR: Copy residuals over y */
memcpy(y_data, REAL(rduals), n * sizeof(double));
} else {
for (i = 0; i < n; i++) {
y_data[i] = NA_REAL;
}
}
UNPROTECT(2);
if (found) {
UNPROTECT(1);
}
return;
}
/* dplR: Returns the spectrum of x(t), a vector of length nfreq.
*/
SEXP spectr(SEXP t, SEXP x, SEXP np, SEXP ww, SEXP tsin, SEXP tcos, SEXP wtau,
SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP freq, SEXP n50,
SEXP segskip, SEXP lmfit) {
SEXP gxx, twk, xwk, ftrx, ftix, tmp, cbindcall, lengthfun;
double dnseg, segskip_val, scal, np_val;
long double sumx, sqrt_nseg;
size_t i, j, nseg_val, nfreq_val, n50_val, segstart, ncopy;
size_t sincos_skip, wtau_skip;
size_t wwidx = 0;
double *t_data, *x_data, *ww_data, *tsin_data, *tcos_data, *wtau_data;
double *gxx_data, *twk_data, *xwk_data, *ftrx_data, *ftix_data, *freq_data;
const double si = 1.0;
const double tzero = 0.0;
const size_t lfreq = 0;
PROTECT_INDEX pidx;
dnseg = *REAL(nseg);
nseg_val = (size_t) dnseg;
nfreq_val = (size_t) *REAL(nfreq);
np_val = *REAL(np);
n50_val = (size_t) *REAL(n50);
segskip_val = *REAL(segskip);
t_data = REAL(t);
x_data = REAL(x);
ww_data = REAL(ww);
tsin_data = REAL(tsin);
tcos_data = REAL(tcos);
wtau_data = REAL(wtau);
freq_data = REAL(freq);
PROTECT(gxx = allocVector(REALSXP, nfreq_val));
PROTECT_WITH_INDEX(twk = allocVector(REALSXP, nseg_val), &pidx);
/* dplR: cbind(1, twk) needed for lm.fit() in rmtrend(). Another
* approach would be to use 1. allocMatrix() or to assign
* dim=c(nseg, 2) on a vector and 2. fill the first column with
* ones. The cbind() approach should be compatible with array
* dimensions greater than 2^31 - 1 if that is allowed in future
* versions of R. I don't see that limit becoming a problem,
* though.*/
PROTECT(tmp = cbindcall = allocList(3));
SET_TYPEOF(cbindcall, LANGSXP);
SETCAR(tmp, install("cbind")); tmp = CDR(tmp);
SETCAR(tmp, ScalarReal(1.0)); tmp = CDR(tmp);
SETCAR(tmp, twk);
REPROTECT(twk = eval(cbindcall, R_BaseEnv), pidx);
/* dplR: twk_data points to the non-constant column; the constant
* column will not be altered */
twk_data = REAL(twk) + nseg_val;
PROTECT(xwk = allocVector(REALSXP, nseg_val));
/* dplR: unused halves of ftrx and ftix were removed */
PROTECT(ftrx = allocVector(REALSXP, nfreq_val));
PROTECT(ftix = allocVector(REALSXP, nfreq_val));
gxx_data = REAL(gxx);
xwk_data = REAL(xwk);
ftrx_data = REAL(ftrx);
ftix_data = REAL(ftix);
sqrt_nseg = sqrtl((long double) dnseg);
wtau_skip = nfreq_val - 1;
sincos_skip = wtau_skip * nseg_val;
for (i = 0; i < nfreq_val; i++) {
gxx_data[i] = 0.0;
}
lengthfun = install("length");
ncopy = nseg_val * sizeof(double);
for (i = 0; i < n50_val; i++) {
/* copy data of i'th segment into workspace */
segstart = (size_t) segfirst((double) i, segskip_val, np_val, dnseg);
memcpy(twk_data, t_data + segstart, ncopy);
memcpy(xwk_data, x_data + segstart, ncopy);
/* detrend data */
rmtrend(twk, xwk, lengthfun, lmfit);
/* apply window to data */
sumx = 0.0L;
for (j = 0; j < nseg_val; j++) {
xwk_data[j] *= ww_data[wwidx++];
sumx += xwk_data[j];
}
/* Lomb-Scargle Fourier transform */
ftfix(xwk_data, twk_data, nseg_val, freq_data, nfreq_val, si,
lfreq, tzero, tcos_data, tsin_data, wtau_data,
sumx / sqrt_nseg, ftrx_data, ftix_data);
/* dplR: adjust tsin, tcos, wtau for next segment */
tsin_data += sincos_skip;
tcos_data += sincos_skip;
wtau_data += wtau_skip;
/* sum raw spectra */
for (j = 0; j < nfreq_val; j++) {
gxx_data[j] += ftrx_data[j] * ftrx_data[j] +
ftix_data[j] * ftix_data[j];
}
}
/* scale autospectrum */
scal = 2.0 * *REAL(avgdt) / n50_val;
for (j = 0; j < nfreq_val; j++) {
gxx_data[j] *= scal;
}
UNPROTECT(6);
return(gxx);
}
int Engine::hardSearch()
{
SEXP s, t, val;
SEXP uiMatrix, ciVector;
SEXP thetaVector;
SEXP xlow;
SEXP xhigh;
//int lsConvergence = 0;
int counts = 0;
double mu;
int xSize = x_.size();
PROTECT(uiMatrix = allocMatrix(REALSXP, xSize * 2, xSize));
//protect 1
PROTECT(ciVector = allocVector(REALSXP, xSize * 2));
//protect 2
PROTECT(thetaVector = allocVector(REALSXP, xSize));
//protect 3
PROTECT(xlow = allocVector(REALSXP, xSize));
// protect 4
PROTECT(xhigh = allocVector(REALSXP, xSize));
// protect 5
mu = 1.e-4;
// Initialize ui with zeros
for (int i = 0; i < xSize * 2; ++i)
{
for (int j = 0; j < xSize; ++j)
{
REAL(uiMatrix)[i * xSize + j] = 0.;
}
}
for (int i = 0; i < xSize; ++i)
{
// Initialize theta
REAL(thetaVector)[i] = xBuffer_[i];
// Initialize ci
REAL(ciVector)[i * 2] = lower_[i];
REAL(ciVector)[i * 2 + 1] = -upper_[i];
REAL(uiMatrix)[i * 2 * xSize + i * 2] = 1.0;
REAL(uiMatrix)[i * 2 * xSize + i * 2 + 1] = -1.0;
REAL(xlow)[i] = lower_[i];
REAL(xhigh)[i] = upper_[i];
}
PROTECT(t = s = allocList(8));
//protect 6
SET_TYPEOF(s, LANGSXP);
SETCAR(t, install("LSE"));
t = CDR(t);
SETCAR(t, thetaVector);
SET_TAG(t, install("theta"));
t = CDR(t);
SETCAR(t, uiMatrix);
SET_TAG(t, install("ui"));
t = CDR(t);
SETCAR(t, ciVector);
SET_TAG(t, install("ci"));
t = CDR(t);
SETCAR(t, ScalarReal(mu));
SET_TAG(t, install("mu"));
t = CDR(t);
SETCAR(t, xlow);
SET_TAG(t, install("xlow"));
t = CDR(t);
SETCAR(t, xhigh);
SET_TAG(t, install("xhigh"));
t = CDR(t);
SETCAR(t, ScalarInteger(nbFctCall_));
SET_TAG(t, install("count"));
for (unsigned int i = 0; i < xBuffer_.size(); ++i)
{
if (xBuffer_[i] < lower_[i] || xBuffer_[i] > upper_[i])
{
Rprintf("PROBLEM WITH x(%d):\n", i);
printVect(xBuffer_);
}
}
val = eval(s, rEnv_->R_env);
fValue_ = REAL(VECTOR_ELT(val, 0))[0];
//lsConvergence = INTEGER(VECTOR_ELT(val, 1))[0];
for (unsigned int i = 0; i < xBuffer_.size(); ++i)
{
xBuffer_[i] = REAL(VECTOR_ELT(val, 2))[i];
}
counts = INTEGER(VECTOR_ELT(val, 3))[0];
nbFctCall_ = counts;
UNPROTECT(6);
return 0;
}
static void PrintGenericVector(SEXP s, SEXP env)
{
int i, taglen, ns, w, d, e, wr, dr, er, wi, di, ei;
SEXP dims, t, names, newcall, tmp;
char pbuf[115], *ptag, save[TAGBUFLEN0];
ns = length(s);
if((dims = getAttrib(s, R_DimSymbol)) != R_NilValue && length(dims) > 1) {
// special case: array-like list
PROTECT(dims);
PROTECT(t = allocArray(STRSXP, dims));
/* FIXME: check (ns <= R_print.max +1) ? ns : R_print.max; */
for (i = 0; i < ns; i++) {
switch(TYPEOF(PROTECT(tmp = VECTOR_ELT(s, i)))) {
case NILSXP:
snprintf(pbuf, 115, "NULL");
break;
case LGLSXP:
if (LENGTH(tmp) == 1) {
const int *x = LOGICAL_RO(tmp);
formatLogical(x, 1, &w);
snprintf(pbuf, 115, "%s",
EncodeLogical(x[0], w));
} else
snprintf(pbuf, 115, "Logical,%d", LENGTH(tmp));
break;
case INTSXP:
/* factors are stored as integers */
if (inherits(tmp, "factor")) {
snprintf(pbuf, 115, "factor,%d", LENGTH(tmp));
} else {
if (LENGTH(tmp) == 1) {
const int *x = INTEGER_RO(tmp);
formatInteger(x, 1, &w);
snprintf(pbuf, 115, "%s",
EncodeInteger(x[0], w));
} else
snprintf(pbuf, 115, "Integer,%d", LENGTH(tmp));
}
break;
case REALSXP:
if (LENGTH(tmp) == 1) {
const double *x = REAL_RO(tmp);
formatReal(x, 1, &w, &d, &e, 0);
snprintf(pbuf, 115, "%s",
EncodeReal0(x[0], w, d, e, OutDec));
} else
snprintf(pbuf, 115, "Numeric,%d", LENGTH(tmp));
break;
case CPLXSXP:
if (LENGTH(tmp) == 1) {
const Rcomplex *x = COMPLEX_RO(tmp);
if (ISNA(x[0].r) || ISNA(x[0].i))
/* formatReal(NA) --> w=R_print.na_width, d=0, e=0 */
snprintf(pbuf, 115, "%s",
EncodeReal0(NA_REAL, R_print.na_width, 0, 0, OutDec));
else {
formatComplex(x, 1, &wr, &dr, &er, &wi, &di, &ei, 0);
snprintf(pbuf, 115, "%s",
EncodeComplex(x[0],
wr, dr, er, wi, di, ei, OutDec));
}
} else
snprintf(pbuf, 115, "Complex,%d", LENGTH(tmp));
break;
case STRSXP:
if (LENGTH(tmp) == 1) {
const void *vmax = vmaxget();
/* This can potentially overflow */
const char *ctmp = translateChar(STRING_ELT(tmp, 0));
int len = (int) strlen(ctmp);
if(len < 100)
snprintf(pbuf, 115, "\"%s\"", ctmp);
else {
snprintf(pbuf, 101, "\"%s\"", ctmp);
pbuf[100] = '"'; pbuf[101] = '\0';
strcat(pbuf, " [truncated]");
}
vmaxset(vmax);
} else
snprintf(pbuf, 115, "Character,%d", LENGTH(tmp));
break;
case RAWSXP:
snprintf(pbuf, 115, "Raw,%d", LENGTH(tmp));
break;
case LISTSXP:
case VECSXP:
snprintf(pbuf, 115, "List,%d", length(tmp));
break;
case LANGSXP:
snprintf(pbuf, 115, "Expression");
break;
default:
snprintf(pbuf, 115, "?");
break;
}
UNPROTECT(1); /* tmp */
pbuf[114] = '\0';
SET_STRING_ELT(t, i, mkChar(pbuf));
}
if (LENGTH(dims) == 2) {
SEXP rl, cl;
const char *rn, *cn;
GetMatrixDimnames(s, &rl, &cl, &rn, &cn);
/* as from 1.5.0: don't quote here as didn't in array case */
printMatrix(t, 0, dims, 0, R_print.right, rl, cl,
rn, cn);
}
else {
PROTECT(names = GetArrayDimnames(s));
printArray(t, dims, 0, Rprt_adj_left, names);
UNPROTECT(1);
}
UNPROTECT(2);
}
else { // no dim()
PROTECT(names = getAttrib(s, R_NamesSymbol));
taglen = (int) strlen(tagbuf);
ptag = tagbuf + taglen;
PROTECT(newcall = allocList(2));
SETCAR(newcall, install("print"));
SET_TYPEOF(newcall, LANGSXP);
if(ns > 0) {
int n_pr = (ns <= R_print.max +1) ? ns : R_print.max;
/* '...max +1' ==> will omit at least 2 ==> plural in msg below */
for (i = 0; i < n_pr; i++) {
if (i > 0) Rprintf("\n");
if (names != R_NilValue &&
STRING_ELT(names, i) != R_NilValue &&
*CHAR(STRING_ELT(names, i)) != '\0') {
const void *vmax = vmaxget();
/* Bug for L <- list(`a\\b` = 1, `a\\c` = 2) :
const char *ss = translateChar(STRING_ELT(names, i));
*/
const char *ss = EncodeChar(STRING_ELT(names, i));
#ifdef Win32
/* FIXME: double translation to native encoding, in
EncodeChar and translateChar; it is however necessary
to call isValidName() on a string without Rgui
escapes, because Rgui escapes cause a name to be
regarded invalid;
note also differences with printList
*/
const char *st = ss;
if (WinUTF8out)
st = translateChar(STRING_ELT(names, i));
#endif
if (taglen + strlen(ss) > TAGBUFLEN) {
if (taglen <= TAGBUFLEN)
sprintf(ptag, "$...");
} else {
/* we need to distinguish character NA from "NA", which
is a valid (if non-syntactic) name */
if (STRING_ELT(names, i) == NA_STRING)
sprintf(ptag, "$<NA>");
#ifdef Win32
else if( isValidName(st) )
#else
else if( isValidName(ss) )
#endif
sprintf(ptag, "$%s", ss);
else
sprintf(ptag, "$`%s`", ss);
}
vmaxset(vmax);
}
else {
if (taglen + IndexWidth(i) > TAGBUFLEN) {
if (taglen <= TAGBUFLEN)
sprintf(ptag, "$...");
} else
sprintf(ptag, "[[%d]]", i+1);
}
Rprintf("%s\n", tagbuf);
if(isObject(VECTOR_ELT(s, i))) {
SEXP x = VECTOR_ELT(s, i);
int nprot = 0;
if (TYPEOF(x) == LANGSXP) {
// quote(x) to not accidentally evaluate it with newcall() below:
x = PROTECT(lang2(R_Primitive("quote"), x)); nprot++;
}
/* need to preserve tagbuf */
strcpy(save, tagbuf);
SETCADR(newcall, x);
eval(newcall, env);
strcpy(tagbuf, save);
UNPROTECT(nprot);
}
else PrintValueRec(VECTOR_ELT(s, i), env);
*ptag = '\0';
}
Rprintf("\n");
if(n_pr < ns)
Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
ns - n_pr);
}
static SEXP duplicate1(SEXP s, Rboolean deep)
{
SEXP t;
R_xlen_t i, n;
duplicate1_elts++;
duplicate_elts++;
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
return s;
case CLOSXP:
PROTECT(s);
PROTECT(t = allocSExp(CLOSXP));
SET_FORMALS(t, FORMALS(s));
SET_BODY(t, BODY(s));
SET_CLOENV(t, CLOENV(s));
DUPLICATE_ATTRIB(t, s, deep);
if (NOJIT(s)) SET_NOJIT(t);
if (MAYBEJIT(s)) SET_MAYBEJIT(t);
UNPROTECT(2);
break;
case LISTSXP:
PROTECT(s);
t = duplicate_list(s, deep);
UNPROTECT(1);
break;
case LANGSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, LANGSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case DOTSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, DOTSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case CHARSXP:
return s;
break;
case EXPRSXP:
case VECSXP:
n = XLENGTH(s);
PROTECT(s);
PROTECT(t = allocVector(TYPEOF(s), n));
for(i = 0 ; i < n ; i++)
SET_VECTOR_ELT(t, i, duplicate_child(VECTOR_ELT(s, i), deep));
DUPLICATE_ATTRIB(t, s, deep);
COPY_TRUELENGTH(t, s);
UNPROTECT(2);
break;
case LGLSXP: DUPLICATE_ATOMIC_VECTOR(int, LOGICAL, t, s, deep); break;
case INTSXP: DUPLICATE_ATOMIC_VECTOR(int, INTEGER, t, s, deep); break;
case REALSXP: DUPLICATE_ATOMIC_VECTOR(double, REAL, t, s, deep); break;
case CPLXSXP: DUPLICATE_ATOMIC_VECTOR(Rcomplex, COMPLEX, t, s, deep); break;
case RAWSXP: DUPLICATE_ATOMIC_VECTOR(Rbyte, RAW, t, s, deep); break;
case STRSXP:
/* direct copying and bypassing the write barrier is OK since
t was just allocated and so it cannot be older than any of
the elements in s. LT */
DUPLICATE_ATOMIC_VECTOR(SEXP, STRING_PTR, t, s, deep);
break;
case PROMSXP:
return s;
break;
case S4SXP:
PROTECT(s);
PROTECT(t = allocS4Object());
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
default:
UNIMPLEMENTED_TYPE("duplicate", s);
t = s;/* for -Wall */
}
if(TYPEOF(t) == TYPEOF(s) ) { /* surely it only makes sense in this case*/
SET_OBJECT(t, OBJECT(s));
(IS_S4_OBJECT(s) ? SET_S4_OBJECT(t) : UNSET_S4_OBJECT(t));
}
return t;
}
SEXP typeconvert(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP cvec, a, dup, levs, dims, names, dec;
SEXP rval = R_NilValue; /* -Wall */
int i, j, len, asIs;
Rboolean done = FALSE;
char *endp;
const char *tmp = NULL;
LocalData data = {NULL, 0, 0, '.', NULL, NO_COMCHAR, 0, NULL, FALSE,
FALSE, 0, FALSE, FALSE};
Typecvt_Info typeInfo; /* keep track of possible types of cvec */
typeInfo.islogical = TRUE; /* we can't rule anything out initially */
typeInfo.isinteger = TRUE;
typeInfo.isreal = TRUE;
typeInfo.iscomplex = TRUE;
data.NAstrings = R_NilValue;
args = CDR(args);
if (!isString(CAR(args)))
error(_("the first argument must be of mode character"));
data.NAstrings = CADR(args);
if (TYPEOF(data.NAstrings) != STRSXP)
error(_("invalid '%s' argument"), "na.strings");
asIs = asLogical(CADDR(args));
if (asIs == NA_LOGICAL) asIs = 0;
dec = CADDDR(args);
if (isString(dec) || isNull(dec)) {
if (length(dec) == 0)
data.decchar = '.';
else
data.decchar = translateChar(STRING_ELT(dec, 0))[0];
}
cvec = CAR(args);
len = length(cvec);
/* save the dim/dimnames attributes */
PROTECT(dims = getAttrib(cvec, R_DimSymbol));
if (isArray(cvec))
PROTECT(names = getAttrib(cvec, R_DimNamesSymbol));
else
PROTECT(names = getAttrib(cvec, R_NamesSymbol));
/* Use the first non-NA to screen */
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (!(STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp)))
break;
}
if (i < len) { /* not all entries are NA */
ruleout_types(tmp, &typeInfo, &data);
}
if (typeInfo.islogical) {
PROTECT(rval = allocVector(LGLSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
LOGICAL(rval)[i] = NA_LOGICAL;
else {
if (strcmp(tmp, "F") == 0 || strcmp(tmp, "FALSE") == 0)
LOGICAL(rval)[i] = 0;
else if(strcmp(tmp, "T") == 0 || strcmp(tmp, "TRUE") == 0)
LOGICAL(rval)[i] = 1;
else {
typeInfo.islogical = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if (typeInfo.islogical) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isinteger) {
PROTECT(rval = allocVector(INTSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
INTEGER(rval)[i] = NA_INTEGER;
else {
INTEGER(rval)[i] = Strtoi(tmp, 10);
if (INTEGER(rval)[i] == NA_INTEGER) {
typeInfo.isinteger = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isinteger) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isreal) {
PROTECT(rval = allocVector(REALSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
REAL(rval)[i] = NA_REAL;
else {
REAL(rval)[i] = Strtod(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.isreal = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isreal) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.iscomplex) {
PROTECT(rval = allocVector(CPLXSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
COMPLEX(rval)[i].r = COMPLEX(rval)[i].i = NA_REAL;
else {
COMPLEX(rval)[i] = strtoc(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.iscomplex = FALSE;
/* this is not needed, unless other cases are added */
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.iscomplex) done = TRUE; else UNPROTECT(1);
}
if (!done) {
if (asIs) {
PROTECT(rval = duplicate(cvec));
for (i = 0; i < len; i++)
if(isNAstring(CHAR(STRING_ELT(rval, i)), 1, &data))
SET_STRING_ELT(rval, i, NA_STRING);
}
else {
PROTECT(dup = duplicated(cvec, FALSE));
j = 0;
for (i = 0; i < len; i++) {
/* <NA> is never to be a level here */
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
j++;
}
PROTECT(levs = allocVector(STRSXP,j));
j = 0;
for (i = 0; i < len; i++) {
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
SET_STRING_ELT(levs, j++, STRING_ELT(cvec, i));
}
/* We avoid an allocation by reusing dup,
* a LGLSXP of the right length
*/
rval = dup;
SET_TYPEOF(rval, INTSXP);
/* put the levels in lexicographic order */
sortVector(levs, FALSE);
PROTECT(a = matchE(levs, cvec, NA_INTEGER, env));
for (i = 0; i < len; i++)
INTEGER(rval)[i] = INTEGER(a)[i];
setAttrib(rval, R_LevelsSymbol, levs);
PROTECT(a = mkString("factor"));
setAttrib(rval, R_ClassSymbol, a);
UNPROTECT(3);
}
}
setAttrib(rval, R_DimSymbol, dims);
setAttrib(rval, isArray(cvec) ? R_DimNamesSymbol : R_NamesSymbol, names);
UNPROTECT(3);
return rval;
}
SEXP attribute_hidden matchUnnamedArgsCreateEnv(SEXP formals, SEXP supplied, SEXP call, SEXP rho, SEXP* outActuals)
{
SEXP f, s;
SEXP actuals = PROTECT(supplied);
SEXP newrho = PROTECT(NewEnvironmentNR(rho));
SEXP prevS = R_NilValue;
for (f = formals, s = supplied ; f != R_NilValue ; f = CDR(f), prevS = s, s = CDR(s)) {
if (TAG(f) == R_DotsSymbol) {
/* pack all arguments into ... */
SEXP dots = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(dots, R_DotsSymbol);
if (prevS == R_NilValue) {
UNPROTECT(1); /* old actuals */
PROTECT(actuals = dots);
} else {
SETCDR(prevS, dots);
ENABLE_REFCNT(prevS); /* dots are part of a protected list */
}
if (s != R_NilValue) {
SET_TYPEOF(s, DOTSXP);
SETCAR(dots, s);
s = R_NilValue;
} else {
SET_MISSING(dots, 1);
}
prevS = dots;
f = CDR(f);
/* falls through into s == R_NilValue case */
}
if (s == R_NilValue) {
/* fewer supplied arguments than formals */
SEXP ds;
for(; f != R_NilValue ; f = CDR(f), prevS = ds) {
ds = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(ds, TAG(f));
if (prevS == R_NilValue) {
UNPROTECT(1); /* old actuals */
PROTECT(actuals = ds);
} else {
SETCDR(prevS, ds);
ENABLE_REFCNT(prevS); /* ds is part of a protected list */
}
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(ds, 2);
SETCAR(ds, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(ds, 1);
}
}
break;
}
/* normal case, the next supplied arg is available */
SET_TAG(s, TAG(f));
if (CAR(s) == R_MissingArg) {
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(s, 2);
SETCAR(s, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(s, 1);
}
}
if (prevS != R_NilValue) {
ENABLE_REFCNT(prevS);
}
}
if (s != R_NilValue) {
/* some arguments are not used */
SEXP unusedForError = PROTECT(s);
SETCDR(prevS, R_NilValue); /* make sure they're not in the new environment */
/* show bad arguments in call without evaluating them */
for (; s != R_NilValue; s = CDR(s)) {
SEXP carS = CAR(s);
if (TYPEOF(carS) == PROMSXP) {
SETCAR(s, PREXPR(carS));
}
}
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
UNPROTECT(1);
}
if (prevS != R_NilValue) {
ENABLE_REFCNT(prevS);
}
SET_FRAME(newrho, actuals);
ENABLE_REFCNT(newrho);
UNPROTECT(2); /* newrho, actuals */
*outActuals = actuals;
return(newrho);
}
SEXP fmelt(SEXP DT, SEXP id, SEXP measure, SEXP varfactor, SEXP valfactor, SEXP var_name, SEXP val_name, SEXP na_rm, SEXP drop_levels, SEXP print_out) {
int i, j, k, nrow, ncol, protecti=0, lids=-1, lvalues=-1, totlen=0, counter=0, thislen=0;
SEXP thiscol, ans, dtnames, ansnames, idcols, valuecols, levels, factorLangSxp;
SEXP vars, target, idxkeep = R_NilValue, thisidx = R_NilValue;
Rboolean isfactor=FALSE, isidentical=TRUE, narm = FALSE, droplevels=FALSE, verbose=FALSE;
SEXPTYPE valtype=NILSXP;
size_t size;
if (TYPEOF(DT) != VECSXP) error("Input is not of type VECSXP, expected a data.table, data.frame or list");
if (TYPEOF(valfactor) != LGLSXP) error("Argument 'value.factor' should be logical TRUE/FALSE");
if (TYPEOF(varfactor) != LGLSXP) error("Argument 'variable.factor' should be logical TRUE/FALSE");
if (TYPEOF(na_rm) != LGLSXP) error("Argument 'na.rm' should be logical TRUE/FALSE");
if (LOGICAL(na_rm)[0] == TRUE) narm = TRUE;
if (TYPEOF(print_out) != LGLSXP) error("Argument 'verbose' should be logical TRUE/FALSE");
if (LOGICAL(print_out)[0] == TRUE) verbose = TRUE;
// check for var and val names
if (TYPEOF(var_name) != STRSXP || length(var_name) != 1) error("Argument 'variable.name' must be a character vector of length 1");
if (TYPEOF(val_name) != STRSXP || length(val_name) != 1) error("Argument 'value.name' must be a character vector of length 1");
// droplevels future feature request, maybe... should ask on data.table-help
// if (!isLogical(drop_levels)) error("Argument 'drop.levels' should be logical TRUE/FALSE");
// if (LOGICAL(drop_levels)[0] == TRUE) droplevels = TRUE;
// if (droplevels && !narm) warning("Ignoring argument 'drop.levels'. 'drop.levels' should be set to remove any unused levels as a result of setting 'na.rm=TRUE'. Here there is nothing to do because 'na.rm=FALSE'");
ncol = LENGTH(DT);
nrow = length(VECTOR_ELT(DT, 0));
if (ncol <= 0) {
warning("ncol(data) is 0. Nothing to do, returning original data.table.");
return(DT);
}
PROTECT(dtnames = getAttrib(DT, R_NamesSymbol)); protecti++;
if (isNull(dtnames)) error("names(data) is NULL. Please report to data.table-help");
vars = checkVars(DT, id, measure, verbose);
PROTECT(idcols = VECTOR_ELT(vars, 0)); protecti++;
PROTECT(valuecols = VECTOR_ELT(vars, 1)); protecti++; // <~~~ not protecting vars leads to segfault (on big data)
lids = length(idcols);
lvalues = length(valuecols);
// edgecase where lvalues = 0 and lids > 0
if (lvalues == 0 && lids > 0) {
if (verbose) Rprintf("length(measure.var) is 0. Edge case detected. Nothing to melt. Returning data.table with all 'id.vars' which are columns %s\n", CHAR(STRING_ELT(concat(dtnames, idcols), 0)));
PROTECT(ansnames = allocVector(STRSXP, lids)); protecti++;
PROTECT(ans = allocVector(VECSXP, lids)); protecti++;
for (i=0; i<lids; i++) {
SET_VECTOR_ELT(ans, i, VECTOR_ELT(DT, INTEGER(idcols)[i]-1));
SET_STRING_ELT(ansnames, i, STRING_ELT(dtnames, INTEGER(idcols)[i]-1));
}
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(protecti);
return(ans);
}
if (lvalues == 0 && lids == 0 && verbose)
Rprintf("length(measure.var) and length(id.var) are both 0. Edge case detected. Nothing to melt.\n"); // <~~ don't think this will ever happen though with all the checks
// set names for 'ans' - the output list
PROTECT(ansnames = allocVector(STRSXP, lids+2)); protecti++;
for (i=0; i<lids; i++) {
SET_STRING_ELT(ansnames, i, STRING_ELT(dtnames, INTEGER(idcols)[i]-1));
}
SET_STRING_ELT(ansnames, lids, mkChar(CHAR(STRING_ELT(var_name, 0)))); // mkChar("variable")
SET_STRING_ELT(ansnames, lids+1, mkChar(CHAR(STRING_ELT(val_name, 0)))); // mkChar("value")
// get "value" column
for (i=0; i<lvalues; i++) {
thiscol = VECTOR_ELT(DT, INTEGER(valuecols)[i]-1);
if (!isfactor && isFactor(thiscol)) isfactor = TRUE;
if (TYPEOF(thiscol) > valtype) valtype = TYPEOF(thiscol);
}
if (isfactor && valtype != VECSXP) valtype = STRSXP;
for (i=0; i<lvalues; i++) {
thiscol = VECTOR_ELT(DT, INTEGER(valuecols)[i]-1);
if (TYPEOF(thiscol) != valtype && isidentical) {
if (!(isFactor(thiscol) && valtype == STRSXP)) {
isidentical = FALSE; // for Date like column (not implemented for now)
warning("All 'measure.vars are NOT of the SAME type. By order of hierarchy, the molten data value column will be of type '%s'. Therefore all measure variables that are not of type '%s' will be coerced to. Check the DETAILS section of ?melt.data.table for more on coercion.\n", type2char(valtype), type2char(valtype));
break;
}
}
}
if (valtype == VECSXP && narm) {
narm = FALSE;
if (verbose) Rprintf("The molten data value type is a list. 'na.rm=TRUE' is therefore ignored.\n");
}
if (narm) {
PROTECT(idxkeep = allocVector(VECSXP, lvalues)); protecti++;
for (i=0; i<lvalues; i++) {
SET_VECTOR_ELT(idxkeep, i, which_notNA(VECTOR_ELT(DT, INTEGER(valuecols)[i]-1)));
totlen += length(VECTOR_ELT(idxkeep, i));
}
} else
totlen = nrow * lvalues;
PROTECT(ans = allocVector(VECSXP, lids + 2)); protecti++;
target = PROTECT(allocVector(valtype, totlen));
for (i=0; i<lvalues; i++) {
thiscol = VECTOR_ELT(DT, INTEGER(valuecols)[i]-1);
if (isFactor(thiscol))
thiscol = asCharacterFactor(thiscol);
if (TYPEOF(thiscol) != valtype && !isFactor(thiscol)) {
// thiscol = valtype == STRSXP ? PROTECT(coerce_to_char(thiscol, R_GlobalEnv)) : PROTECT(coerceVector(thiscol, valtype));
// protecti++; // for now, no preserving of class attributes
thiscol = PROTECT(coerceVector(thiscol, valtype)); protecti++;
}
size = SIZEOF(thiscol);
if (narm) {
thisidx = VECTOR_ELT(idxkeep, i);
thislen = length(thisidx);
}
switch(valtype) {
case VECSXP :
if (narm) {
for (j=0; j<thislen; j++)
SET_VECTOR_ELT(target, counter + j, VECTOR_ELT(thiscol, INTEGER(thisidx)[j]-1));
} else {
for (j=0; j<nrow; j++) SET_VECTOR_ELT(target, i*nrow + j, VECTOR_ELT(thiscol, j));
}
break;
case STRSXP :
if (narm) {
for (j=0; j<thislen; j++)
SET_STRING_ELT(target, counter + j, STRING_ELT(thiscol, INTEGER(thisidx)[j]-1));
} else {
for (j=0; j<nrow; j++) SET_STRING_ELT(target, i*nrow + j, STRING_ELT(thiscol, j));
}
break;
case REALSXP :
if (narm) {
for (j=0; j<thislen; j++)
REAL(target)[counter + j] = REAL(thiscol)[INTEGER(thisidx)[j]-1];
} else {
memcpy((char *)DATAPTR(target)+i*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case INTSXP :
if (narm) {
for (j=0; j<thislen; j++)
INTEGER(target)[counter + j] = INTEGER(thiscol)[INTEGER(thisidx)[j]-1];
} else {
memcpy((char *)DATAPTR(target)+i*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case LGLSXP :
if (narm) {
for (j=0; j<thislen; j++)
LOGICAL(target)[counter + j] = LOGICAL(thiscol)[INTEGER(thisidx)[j]-1];
} else {
memcpy((char *)DATAPTR(target)+i*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
default : error("Unknown column type '%s' for column '%s' in 'data'", type2char(TYPEOF(thiscol)), CHAR(STRING_ELT(dtnames, INTEGER(valuecols)[i]-1)));
}
if (narm) counter += thislen;
// if (isidentical && valtype != VECSXP) // for now, no preserving of class attributes
// setAttrib(target, R_ClassSymbol, getAttrib(VECTOR_ELT(DT, INTEGER(valuecols)[0]-1), R_ClassSymbol)); // for Date like column
}
// check for factor
if (LOGICAL(valfactor)[0] == TRUE && valtype == VECSXP) warning("argument 'value.factor' ignored because 'value' column is a list\n");
if (LOGICAL(valfactor)[0] == TRUE && valtype != VECSXP) {
PROTECT(factorLangSxp = allocList(2));
SET_TYPEOF(factorLangSxp, LANGSXP);
SETCAR(factorLangSxp, install("factor"));
SETCAR(CDR(factorLangSxp), target);
SET_VECTOR_ELT(ans, lids+1, eval(factorLangSxp, R_GlobalEnv)); // last column
UNPROTECT(1); // factorLangSxp
} else
SET_VECTOR_ELT(ans, lids+1, target);
UNPROTECT(1); // target
// get "variable" column
counter = 0, i=0;
target = PROTECT(allocVector(INTSXP, totlen));
for (j=0; j<lvalues; j++) {
if (narm) {
thislen = length(VECTOR_ELT(idxkeep, j));
for (k=0; k<thislen; k++)
INTEGER(target)[counter + k] = i+1;
counter += thislen;
if (thislen > 0 || !droplevels) i++;
} else {
for (k=0; k<nrow; k++)
INTEGER(target)[nrow*j + k] = j+1;
}
}
setAttrib(target, R_ClassSymbol, mkString("factor"));
if (narm && droplevels) {
counter = 0;
for (j=0; j<lvalues; j++) {
if (length(VECTOR_ELT(idxkeep, j)) > 0) counter++;
}
} else counter = lvalues;
levels = PROTECT(allocVector(STRSXP, counter));
i = 0;
for (j=0; j<lvalues; j++) {
if (narm && droplevels) {
if (length(VECTOR_ELT(idxkeep, j)) > 0)
SET_STRING_ELT(levels, i++, STRING_ELT(dtnames, INTEGER(valuecols)[j]-1));
} else
SET_STRING_ELT(levels, j, STRING_ELT(dtnames, INTEGER(valuecols)[j]-1));
}
setAttrib(target, R_LevelsSymbol, levels);
UNPROTECT(1); // levels
if (LOGICAL(varfactor)[0] == FALSE)
target = asCharacterFactor(target);
SET_VECTOR_ELT(ans, lids, target);
UNPROTECT(1); // target
// generate idcols (left part)
for (i=0; i<lids; i++) {
counter = 0;
thiscol = VECTOR_ELT(DT, INTEGER(idcols)[i]-1);
size = SIZEOF(thiscol);
target = PROTECT(allocVector(TYPEOF(thiscol), totlen));
switch(TYPEOF(thiscol)) {
case REALSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
REAL(target)[counter + k] = REAL(thiscol)[INTEGER(thisidx)[k]-1];
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
for (j=0; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case INTSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
INTEGER(target)[counter + k] = INTEGER(thiscol)[INTEGER(thisidx)[k]-1];
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
for (j=0; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case LGLSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
LOGICAL(target)[counter + k] = LOGICAL(thiscol)[INTEGER(thisidx)[k]-1];
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
for (j=0; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case STRSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
SET_STRING_ELT(target, counter + k, STRING_ELT(thiscol, INTEGER(thisidx)[k]-1));
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
// SET_STRING_ELT for j=0 and memcpy for j>0, WHY?
// From assign.c's memcrecycle - only one SET_STRING_ELT per RHS item is needed to set generations (overhead)
for (k=0; k<nrow; k++) SET_STRING_ELT(target, k, STRING_ELT(thiscol, k));
for (j=1; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(target), nrow*size);
}
break;
case VECSXP :
for (j=0; j<lvalues; j++) {
for (k=0; k<nrow; k++) {
SET_VECTOR_ELT(target, j*nrow + k, VECTOR_ELT(thiscol, k));
}
}
break;
default : error("Unknown column type '%s' for column '%s' in 'data'", type2char(TYPEOF(thiscol)), CHAR(STRING_ELT(dtnames, INTEGER(idcols)[i]-1)));
}
copyMostAttrib(thiscol, target); // all but names,dim and dimnames. And if so, we want a copy here, not keepattr's SET_ATTRIB.
SET_VECTOR_ELT(ans, i, target);
UNPROTECT(1); // target
}
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(protecti);
return(ans);
}
SEXP attribute_hidden matchArgs(SEXP formals, SEXP supplied, SEXP call)
{
int i, seendots, arg_i = 0;
SEXP f, a, b, dots, actuals;
actuals = R_NilValue;
for (f = formals ; f != R_NilValue ; f = CDR(f), arg_i++) {
/* CONS_NR is used since argument lists created here are only
used internally and so should not increment reference
counts */
actuals = CONS_NR(R_MissingArg, actuals);
SET_MISSING(actuals, 1);
}
/* We use fargused instead of ARGUSED/SET_ARGUSED on elements of
formals to avoid modification of the formals SEXPs. A gc can
cause matchArgs to be called from finalizer code, resulting in
another matchArgs call with the same formals. In R-2.10.x, this
corrupted the ARGUSED data of the formals and resulted in an
incorrect "formal argument 'foo' matched by multiple actual
arguments" error.
*/
int fargused[arg_i ? arg_i : 1]; // avoid undefined behaviour
memset(fargused, 0, sizeof(fargused));
for(b = supplied; b != R_NilValue; b = CDR(b)) SET_ARGUSED(b, 0);
PROTECT(actuals);
/* First pass: exact matches by tag */
/* Grab matched arguments and check */
/* for multiple exact matches. */
f = formals;
a = actuals;
arg_i = 0;
while (f != R_NilValue) {
if (TAG(f) != R_DotsSymbol) {
i = 1;
for (b = supplied; b != R_NilValue; b = CDR(b)) {
if (TAG(b) != R_NilValue && pmatch(TAG(f), TAG(b), 1)) {
if (fargused[arg_i] == 2)
error(_("formal argument \"%s\" matched by multiple actual arguments"),
CHAR(PRINTNAME(TAG(f))));
if (ARGUSED(b) == 2)
error(_("argument %d matches multiple formal arguments"), i);
SETCAR(a, CAR(b));
if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 2);
fargused[arg_i] = 2;
}
i++;
}
}
f = CDR(f);
a = CDR(a);
arg_i++;
}
/* Second pass: partial matches based on tags */
/* An exact match is required after first ... */
/* The location of the first ... is saved in "dots" */
dots = R_NilValue;
seendots = 0;
f = formals;
a = actuals;
arg_i = 0;
while (f != R_NilValue) {
if (fargused[arg_i] == 0) {
if (TAG(f) == R_DotsSymbol && !seendots) {
/* Record where ... value goes */
dots = a;
seendots = 1;
} else {
i = 1;
for (b = supplied; b != R_NilValue; b = CDR(b)) {
if (ARGUSED(b) != 2 && TAG(b) != R_NilValue &&
pmatch(TAG(f), TAG(b), seendots)) {
if (ARGUSED(b))
error(_("argument %d matches multiple formal arguments"), i);
if (fargused[arg_i] == 1)
error(_("formal argument \"%s\" matched by multiple actual arguments"),
CHAR(PRINTNAME(TAG(f))));
if (R_warn_partial_match_args) {
warningcall(call,
_("partial argument match of '%s' to '%s'"),
CHAR(PRINTNAME(TAG(b))),
CHAR(PRINTNAME(TAG(f))) );
}
SETCAR(a, CAR(b));
if (CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 1);
fargused[arg_i] = 1;
}
i++;
}
}
}
f = CDR(f);
a = CDR(a);
arg_i++;
}
/* Third pass: matches based on order */
/* All args specified in tag=value form */
/* have now been matched. If we find ... */
/* we gobble up all the remaining args. */
/* Otherwise we bind untagged values in */
/* order to any unmatched formals. */
f = formals;
a = actuals;
b = supplied;
seendots = 0;
while (f != R_NilValue && b != R_NilValue && !seendots) {
if (TAG(f) == R_DotsSymbol) {
/* Skip ... matching until all tags done */
seendots = 1;
f = CDR(f);
a = CDR(a);
} else if (CAR(a) != R_MissingArg) {
/* Already matched by tag */
/* skip to next formal */
f = CDR(f);
a = CDR(a);
} else if (ARGUSED(b) || TAG(b) != R_NilValue) {
/* This value used or tagged , skip to next value */
/* The second test above is needed because we */
/* shouldn't consider tagged values for positional */
/* matches. */
/* The formal being considered remains the same */
b = CDR(b);
} else {
/* We have a positional match */
SETCAR(a, CAR(b));
if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 1);
b = CDR(b);
f = CDR(f);
a = CDR(a);
}
}
if (dots != R_NilValue) {
/* Gobble up all unused actuals */
SET_MISSING(dots, 0);
i = 0;
for(a = supplied; a != R_NilValue ; a = CDR(a)) if(!ARGUSED(a)) i++;
if (i) {
a = allocList(i);
SET_TYPEOF(a, DOTSXP);
f = a;
for(b = supplied; b != R_NilValue; b = CDR(b))
if(!ARGUSED(b)) {
SETCAR(f, CAR(b));
SET_TAG(f, TAG(b));
f = CDR(f);
}
SETCAR(dots, a);
}
} else {
/* Check that all arguments are used */
SEXP unused = R_NilValue, last = R_NilValue;
for (b = supplied; b != R_NilValue; b = CDR(b))
if (!ARGUSED(b)) {
if(last == R_NilValue) {
PROTECT(unused = CONS(CAR(b), R_NilValue));
SET_TAG(unused, TAG(b));
last = unused;
} else {
SETCDR(last, CONS(CAR(b), R_NilValue));
last = CDR(last);
SET_TAG(last, TAG(b));
}
}
if(last != R_NilValue) {
/* show bad arguments in call without evaluating them */
SEXP unusedForError = R_NilValue, last = R_NilValue;
for(b = unused ; b != R_NilValue ; b = CDR(b)) {
SEXP tagB = TAG(b), carB = CAR(b) ;
if (TYPEOF(carB) == PROMSXP) carB = PREXPR(carB) ;
if (last == R_NilValue) {
PROTECT(last = CONS(carB, R_NilValue));
SET_TAG(last, tagB);
unusedForError = last;
} else {
SETCDR(last, CONS(carB, R_NilValue));
last = CDR(last);
SET_TAG(last, tagB);
}
}
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
}
}
UNPROTECT(1);
return(actuals);
}
