/* 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 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;
}
List *createNewList(void) {
List *newList = allocList();
assert(newList);
newList = initList(newList);
return newList;
}
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;
}
static SEXP CreateHess(SEXP names)
{
SEXP p, q, data, dim, dimnames;
int i, n;
n = length(names);
PROTECT(dimnames = lang4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SETCAR(dimnames, install("list"));
p = install("c");
PROTECT(q = allocList(n));
SETCADDR(dimnames, LCONS(p, q));
UNPROTECT(1);
for(i = 0 ; i < n ; i++) {
SETCAR(q, ScalarString(STRING_ELT(names, i)));
q = CDR(q);
}
SETCADDDR(dimnames, duplicate(CADDR(dimnames)));
PROTECT(dim = lang4(R_NilValue, R_NilValue, R_NilValue,R_NilValue));
SETCAR(dim, install("c"));
SETCADR(dim, lang2(install("length"), install(".value")));
SETCADDR(dim, ScalarInteger(length(names)));
SETCADDDR(dim, ScalarInteger(length(names)));
PROTECT(data = ScalarReal(0.));
PROTECT(p = lang4(install("array"), data, dim, dimnames));
p = lang3(install("<-"), install(".hessian"), p);
UNPROTECT(4);
return p;
}
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);
}
// {{{ copyList
List * copyList(List * l) {
List * res = allocList();
if (nb(l) !=0) {
Item * it = begin(l);
while (it != NULL) {
pushTail(res, num(it), val(it));
it = next(it);
}
}
return res;
}
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 InstanceObjectTable::methodClosure(const char *name) const {
static SEXP qtbaseNS = R_FindNamespace(mkString("qtbase"));
static SEXP qinvokeSym = install("qinvoke");
SEXP f, pf, body;
PROTECT(f = allocSExp(CLOSXP));
SET_CLOENV(f, qtbaseNS);
pf = allocList(1);
SET_FORMALS(f, pf);
SET_TAG(pf, R_DotsSymbol);
SETCAR(pf, R_MissingArg);
PROTECT(body =
lang4(qinvokeSym, _instance->sexp(), mkString(name), R_DotsSymbol));
SET_BODY(f, body);
UNPROTECT(2);
return f;
}
SEXP make_closure(SEXP body, SEXP formal_parameter_list, SEXP envir) {
SEXP closure, formals;
PROTECT(closure = allocSExp(CLOSXP));
SET_CLOENV(closure, envir);
const int number_of_formals = length(formal_parameter_list);
PROTECT(formals = allocList(number_of_formals));
SEXP formals_iterator = formals;
for (int i = 0; i < number_of_formals; i++, formals_iterator = CDR(formals_iterator)) {
SEXP formal = STRING_ELT(VECTOR_ELT(formal_parameter_list, i), 0);
SET_TAG(formals_iterator, CreateTag(formal));
SETCAR(formals_iterator, R_MissingArg);
}
SET_FORMALS(closure, formals);
SET_BODY(closure, body);
UNPROTECT(2);
return closure;
}
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;
}
/* vector(mode="logical", length=0) */
SEXP attribute_hidden do_makevector(SEXP call, SEXP op, SEXP args, SEXP rho)
{
R_xlen_t len;
SEXP s;
SEXPTYPE mode;
checkArity(op, args);
if (length(CADR(args)) != 1) error(_("invalid '%s' argument"), "length");
len = asVecSize(CADR(args));
if (len < 0) error(_("invalid '%s' argument"), "length");
s = coerceVector(CAR(args), STRSXP);
if (length(s) != 1) error(_("invalid '%s' argument"), "mode");
mode = str2type(CHAR(STRING_ELT(s, 0))); /* ASCII */
if (mode == -1 && streql(CHAR(STRING_ELT(s, 0)), "double"))
mode = REALSXP;
switch (mode) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case EXPRSXP:
case VECSXP:
case RAWSXP:
s = allocVector(mode, len);
break;
case LISTSXP:
if (len > INT_MAX) error("too long for a pairlist");
s = allocList((int) len);
break;
default:
error(_("vector: cannot make a vector of mode '%s'."),
translateChar(STRING_ELT(s, 0))); /* should be ASCII */
}
if (mode == INTSXP || mode == LGLSXP)
Memzero(INTEGER(s), len);
else if (mode == REALSXP)
Memzero(REAL(s), len);
else if (mode == CPLXSXP)
Memzero(COMPLEX(s), len);
else if (mode == RAWSXP)
Memzero(RAW(s), len);
/* other cases: list/expression have "NULL", ok */
return s;
}
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;
}
SEXP exprToFunction(int nVariables, const char **vaList, SEXP rExpr) {
PROTECT(rExpr);
SEXP charList, rChar, pl;
SEXP rFunc;
PROTECT(rFunc= allocSExp(CLOSXP));
SET_CLOENV(rFunc, R_GlobalEnv);
int i = 0, warn= 0, n= 0;
if(nVariables > 0) {
PROTECT(charList = allocVector(STRSXP, nVariables));
for(int i=0; i < nVariables; i++){ //TODO STRSXP fill
PROTECT(rChar= mkChar(vaList[i]));
SET_STRING_ELT(charList, i, rChar);
UNPROTECT(1);
}
PROTECT(charList= VectorToPairList(charList));
n= length(charList);
if(n > 0) {
PROTECT(pl = allocList(n));
if(n == 1) {
SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
}
else
{ SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
SEXP nextpl= CDR(pl);
SEXP nextChar= CDR(charList);
for (i= 1; i < n; i++, nextpl = CDR(nextpl), nextChar = CDR(nextChar)) {
SET_TAG(nextpl, CreateTag(CAR(nextChar)));
SETCAR(nextpl, R_MissingArg);
}
}
} }
SET_FORMALS(rFunc, pl);
SET_BODY(rFunc, rExpr);
//setAttrib(rFunc, R_SourceSymbol, eval(lang2(install("deparse"), rFunc), R_BaseEnv)); // TODO: Deparse not necessary
if(n > 0) {UNPROTECT(1);}
UNPROTECT(4);
return rFunc;
}
/* 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;
}
void setUpFreeList (MemMgr *mgr)
{
int i = 0;
MngdMem *memory = NULL;
//ListNode *node = NULL;
void *node = NULL;
void *baseTypObj = NULL;
void *nestedTypObj = NULL;
mgr->freeList = allocList();
for (i = 0; i < mgr->initialSize; i++) {
memory = (MngdMem*)malloc(sizeof(MngdMem));
memory->rc = 0;
memory->data = malloc(mgr->quanta);
baseTypObj = newObjectType((void*)memory, freeMngdMem, 0);
//node = makeNode((void*)memory);
node = makeNode(baseTypObj);
insertAtListHead(mgr->freeList, node);
memory->_listNodeHandle = node;
}
return;
}
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_sys(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, n = -1, nframe;
SEXP rval, t;
RCNTXT *cptr;
checkArity(op, args);
/* first find the context that sys.xxx needs to be evaluated in */
cptr = R_GlobalContext;
t = cptr->sysparent;
while (cptr != R_ToplevelContext) {
if (cptr->callflag & CTXT_FUNCTION )
if (cptr->cloenv == t)
break;
cptr = cptr->nextcontext;
}
if (length(args) == 1) n = asInteger(CAR(args));
switch (PRIMVAL(op)) {
case 1: /* parent */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "n");
i = nframe = framedepth(cptr);
/* This is a pretty awful kludge, but the alternative would be
a major redesign of everything... -pd */
while (n-- > 0)
i = R_sysparent(nframe - i + 1, cptr);
return ScalarInteger(i);
case 2: /* call */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_syscall(n, cptr);
case 3: /* frame */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_sysframe(n, cptr);
case 4: /* sys.nframe */
return ScalarInteger(framedepth(cptr));
case 5: /* sys.calls */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t=rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_syscall(i, cptr));
UNPROTECT(1);
return rval;
case 6: /* sys.frames */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t = rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_sysframe(i, cptr));
UNPROTECT(1);
return rval;
case 7: /* sys.on.exit */
if( R_GlobalContext->nextcontext != NULL)
return R_GlobalContext->nextcontext->conexit;
else
return R_NilValue;
case 8: /* sys.parents */
nframe = framedepth(cptr);
rval = allocVector(INTSXP, nframe);
for(i = 0; i < nframe; i++)
INTEGER(rval)[i] = R_sysparent(nframe - i, cptr);
return rval;
case 9: /* sys.function */
if(n == NA_INTEGER)
error(_("invalid '%s' value"), "which");
return(R_sysfunction(n, cptr));
default:
error(_("internal error in 'do_sys'"));
return R_NilValue;/* just for -Wall */
}
}
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 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;
}
SEXP deriv(SEXP args)
{
/* deriv(expr, namevec, function.arg, tag, hessian) */
SEXP ans, ans2, expr, funarg, names, s;
int f_index, *d_index, *d2_index;
int i, j, k, nexpr, nderiv=0, hessian;
SEXP exprlist, tag;
args = CDR(args);
InitDerivSymbols();
PROTECT(exprlist = LCONS(R_BraceSymbol, R_NilValue));
/* expr: */
if (isExpression(CAR(args)))
PROTECT(expr = VECTOR_ELT(CAR(args), 0));
else PROTECT(expr = CAR(args));
args = CDR(args);
/* namevec: */
names = CAR(args);
if (!isString(names) || (nderiv = length(names)) < 1)
error(_("invalid variable names"));
args = CDR(args);
/* function.arg: */
funarg = CAR(args);
args = CDR(args);
/* tag: */
tag = CAR(args);
if (!isString(tag) || length(tag) < 1
|| length(STRING_ELT(tag, 0)) < 1 || length(STRING_ELT(tag, 0)) > 60)
error(_("invalid tag"));
args = CDR(args);
/* hessian: */
hessian = asLogical(CAR(args));
/* NOTE: FindSubexprs is destructive, hence the duplication.
It can allocate, so protect the duplicate.
*/
PROTECT(ans = duplicate(expr));
f_index = FindSubexprs(ans, exprlist, tag);
d_index = (int*)R_alloc((size_t) nderiv, sizeof(int));
if (hessian)
d2_index = (int*)R_alloc((size_t) ((nderiv * (1 + nderiv))/2),
sizeof(int));
else d2_index = d_index;/*-Wall*/
UNPROTECT(1);
for(i=0, k=0; i<nderiv ; i++) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */
d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */
PROTECT(ans = duplicate(ans2)); /* restore the copy */
if (hessian) {
for(j = i; j < nderiv; j++) {
PROTECT(ans2 = duplicate(ans)); /* install could allocate */
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
d2_index[k] = FindSubexprs(ans2, exprlist, tag);
k++;
UNPROTECT(2);
}
}
UNPROTECT(4);
}
nexpr = length(exprlist) - 1;
if (f_index) {
Accumulate2(MakeVariable(f_index, tag), exprlist);
}
else {
PROTECT(ans = duplicate(expr));
Accumulate2(expr, exprlist);
UNPROTECT(1);
}
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
for (i = 0, k = 0; i < nderiv ; i++) {
if (d_index[i]) {
Accumulate2(MakeVariable(d_index[i], tag), exprlist);
if (hessian) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
UNPROTECT(2);
}
} else { /* the first derivative is constant or simple variable */
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
Accumulate2(ans, exprlist);
UNPROTECT(2);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist);
else Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
}
}
}
Accumulate2(R_NilValue, exprlist);
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
i = 0;
ans = CDR(exprlist);
while (i < nexpr) {
if (CountOccurrences(MakeVariable(i+1, tag), CDR(ans)) < 2) {
SETCDR(ans, Replace(MakeVariable(i+1, tag), CAR(ans), CDR(ans)));
SETCAR(ans, R_MissingArg);
}
else {
SEXP var;
PROTECT(var = MakeVariable(i+1, tag));
SETCAR(ans, lang3(install("<-"), var, AddParens(CAR(ans))));
UNPROTECT(1);
}
i = i + 1;
ans = CDR(ans);
}
/* .value <- ... */
SETCAR(ans, lang3(install("<-"), install(".value"), AddParens(CAR(ans))));
ans = CDR(ans);
/* .grad <- ... */
SETCAR(ans, CreateGrad(names));
ans = CDR(ans);
/* .hessian <- ... */
if (hessian) { SETCAR(ans, CreateHess(names)); ans = CDR(ans); }
/* .grad[, "..."] <- ... */
for (i = 0; i < nderiv ; i++) {
SETCAR(ans, DerivAssign(STRING_ELT(names, i), AddParens(CAR(ans))));
ans = CDR(ans);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (CAR(ans) != R_MissingArg) {
if (i == j) {
SETCAR(ans, HessAssign1(STRING_ELT(names, i),
AddParens(CAR(ans))));
} else {
SETCAR(ans, HessAssign2(STRING_ELT(names, i),
STRING_ELT(names, j),
AddParens(CAR(ans))));
}
}
ans = CDR(ans);
}
}
}
/* attr(.value, "gradient") <- .grad */
SETCAR(ans, AddGrad());
ans = CDR(ans);
if (hessian) { SETCAR(ans, AddHess()); ans = CDR(ans); }
/* .value */
SETCAR(ans, install(".value"));
/* Prune the expression list removing eliminated sub-expressions */
SETCDR(exprlist, Prune(CDR(exprlist)));
if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
funarg = names;
}
if (TYPEOF(funarg) == CLOSXP)
{
funarg = mkCLOSXP(FORMALS(funarg), exprlist, CLOENV(funarg));
}
else if (isString(funarg)) {
SEXP formals = allocList(length(funarg));
ans = formals;
for(i = 0; i < length(funarg); i++) {
SET_TAG(ans, installTrChar(STRING_ELT(funarg, i)));
SETCAR(ans, R_MissingArg);
ans = CDR(ans);
}
funarg = mkCLOSXP(formals, exprlist, R_GlobalEnv);
}
else {
funarg = allocVector(EXPRSXP, 1);
SET_VECTOR_ELT(funarg, 0, exprlist);
/* funarg = lang2(install("expression"), exprlist); */
}
UNPROTECT(2);
return funarg;
}
static SEXP rep(SEXP s, SEXP ncopy)
{
int i, ns, na, nc;
SEXP a, t;
if (!isVector(ncopy))
error(_("rep() incorrect type for second argument"));
if (!isVector(s) && (!isList(s)))
error(_("attempt to replicate non-vector"));
if ((length(ncopy) == length(s)))
return rep2(s, ncopy);
if ((length(ncopy) != 1))
error(_("invalid number of copies in rep()"));
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid number of copies in rep()"));
ns = length(s);
na = nc * ns;
if (isVector(s))
a = allocVector(TYPEOF(s), na);
else
a = allocList(na);
PROTECT(a);
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < na; i++)
LOGICAL(a)[i] = LOGICAL(s)[i % ns];
break;
case INTSXP:
for (i = 0; i < na; i++)
INTEGER(a)[i] = INTEGER(s)[i % ns];
break;
case REALSXP:
for (i = 0; i < na; i++)
REAL(a)[i] = REAL(s)[i % ns];
break;
case CPLXSXP:
for (i = 0; i < na; i++)
COMPLEX(a)[i] = COMPLEX(s)[i % ns];
break;
case STRSXP:
for (i = 0; i < na; i++)
SET_STRING_ELT(a, i, STRING_ELT(s, i% ns));
break;
case LISTSXP:
i = 0;
for (t = a; t != R_NilValue; t = CDR(t), i++)
SETCAR(t, duplicate(CAR(nthcdr(s, (i % ns)))));
break;
case VECSXP:
i = 0;
for (i = 0; i < na; i++)
SET_VECTOR_ELT(a, i, duplicate(VECTOR_ELT(s, i% ns)));
break;
case RAWSXP:
for (i = 0; i < na; i++)
RAW(a)[i] = RAW(s)[i % ns];
break;
default:
UNIMPLEMENTED_TYPE("rep", s);
}
if (inherits(s, "factor")) {
SEXP tmp;
if(inherits(s, "ordered")) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, mkChar("ordered"));
SET_STRING_ELT(tmp, 1, mkChar("factor"));
}
else {
PROTECT(tmp = allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkChar("factor"));
}
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
}
UNPROTECT(1);
return a;
}
/* It is assumed that type-checking has been done in rep */
static SEXP rep2(SEXP s, SEXP ncopy)
{
int i, na, nc, n, j;
SEXP a, t, u;
t = coerceVector(ncopy, INTSXP);
PROTECT(t);
nc = length(ncopy);
na = 0;
for (i = 0; i < nc; i++) {
if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i]<0)
error(_("invalid number of copies in rep()"));
na += INTEGER(t)[i];
}
if (isVector(s))
a = allocVector(TYPEOF(s), na);
else
a = allocList(na);
PROTECT(a);
n = 0;
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
LOGICAL(a)[n++] = LOGICAL(s)[i];
break;
case INTSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
INTEGER(a)[n++] = INTEGER(s)[i];
break;
case REALSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
REAL(a)[n++] = REAL(s)[i];
break;
case CPLXSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
COMPLEX(a)[n++] = COMPLEX(s)[i];
break;
case STRSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
SET_STRING_ELT(a, n++, STRING_ELT(s, i));
break;
case VECSXP:
case EXPRSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
SET_VECTOR_ELT(a, n++, VECTOR_ELT(s, i));
break;
case LISTSXP:
u = a;
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++) {
SETCAR(u, duplicate(CAR(nthcdr(s, i))));
u = CDR(u);
}
break;
case RAWSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
RAW(a)[n++] = RAW(s)[i];
break;
default:
UNIMPLEMENTED_TYPE("rep2", s);
}
if (inherits(s, "factor")) {
SEXP tmp;
if(inherits(s, "ordered")) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, mkChar("ordered"));
SET_STRING_ELT(tmp, 1, mkChar("factor"));
}
else {
PROTECT(tmp = allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkChar("factor"));
}
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
}
UNPROTECT(2);
return a;
}
SEXP Xest_gen_Q_C( CFmMatrix* pFmYDelt, CFmMatrix* pFmZ, CFmMatrix* pFmX, CFmVector* pFmMaf, CFmVector* pFmParNull)
{
CFmNewTemp fmRef;
double sig_a2 = pow(pFmParNull->Get(0), 2);
double sig_b2 = pow(pFmParNull->Get(1), 2);
double sig_e2 = pow(pFmParNull->Get(2), 2);
double par_rho = pFmParNull->Get(3);
int N = pFmYDelt->GetNumRows();
int M = pFmYDelt->GetNumCols();
int K = pFmMaf->GetLength();
//Rprintf("N=%d, M=%d, K=%d a2=%f b2=%f e2=%f rho=%f\n", N, M, K, sig_a2, sig_b2, sig_e2, par_rho);
CFmMatrix fmAR1( M, M );
for(int i=0; i<M; i++)
for(int j=0; j<M; j++)
fmAR1.Set( i, j, pow( par_rho, abs( i - j ) ) );
CFmMatrix fmV_j( M, M );
CFmMatrix fmV_j1( M, M );
//CFmMatrix fmDiag( M, true, 1.0 ); //???HERE
CFmMatrix fmDiag( M, M );
for(int i=0; i<M; i++) fmDiag.Set(i, i, 1.0);
fmV_j = (fmV_j + 1.0) * sig_a2 + fmAR1 * sig_b2 + fmDiag * sig_e2;
fmV_j1 = fmV_j.GetInverted();
CFmVector fmVectMj_x(N, 0.0);
CFmVector fmVecTmp (M, 0.0);
CFmVector fmVecTmp2(M, 0.0);
CFmMatrix fmVj_i(M, M);
CFmMatrix** ppVj = Calloc(N, CFmMatrix*);
CFmVector** ppYj = Calloc( N, CFmVector*);
for(int i=0; i<N ;i++)
{
fmVecTmp = pFmYDelt->GetRow(i);
fmVecTmp2.Resize(0);
for(int j=0; j<fmVecTmp.GetLength(); j++)
{
if (!isnan(fmVecTmp[j]))
fmVecTmp2.Put(j);
}
int NonNA = fmVecTmp2.GetLength();
ppVj[i] = new (fmRef) CFmMatrix(NonNA, NonNA);
ppYj[i] = new (fmRef) CFmVector(NonNA, 0.0);
fmVj_i.Resize(NonNA, NonNA);
if (NonNA>0)
{
for( int k=0; k<NonNA; k++)
for( int l=0; l<NonNA; l++)
fmVj_i.Set(k, l,fmV_j.Get( (int)fmVecTmp2[k], (int)fmVecTmp2[l] ) );
*(ppVj[i]) = fmVj_i.GetInverted( );
fmVecTmp.RemoveNan();
*(ppYj[i]) = fmVecTmp;
fmVectMj_x[i] = fmVecTmp.GetLength();
}
}
CFmVector fmQi(1, 0.0);
CFmMatrix fmTrans(1, N );
double fQv=0.0;
for(int i=0; i<K ;i++)
{
fmQi.Resize(1);
for(int j=0; j<N ;j++)
{
fmTrans.Resize(1, fmVectMj_x[j]);
for( int l=0;l<(int)(fmVectMj_x[j]);l++)
fmTrans.Set(0, l, 1.0);
fmQi = (fmTrans * (*(ppVj[j])) * (*(ppYj[j])) * pFmZ->Get(j,i)).GetRow(0) + fmQi;
}
fmQi = fmQi*fmQi;
fQv = fQv + fmQi.Sum();
}
fQv = fQv/2.0;
int NX = pFmX->GetNumCols();
CFmMatrix fmW0( K, K );
CFmMatrix fmW1( K, NX );
CFmMatrix fmW2( NX,NX );
CFmMatrix fmW3( NX,K );
CFmMatrix fmKrZ( 0,0);
CFmMatrix fmKrX( 0,0);
CFmMatrix fmKron( N, 1 );
for(int i=0; i<N; i++)
{
fmKron.Resize( fmVectMj_x[i],1 );
for(int k=0;k<fmVectMj_x[i]; k++) fmKron.Set(k, 0, 1.0);
fmVecTmp = pFmZ->GetRow(i);
kronecker_vm( fmVecTmp, fmKron, &fmKrZ );
fmVecTmp = pFmX->GetRow(i);
kronecker_vm( fmVecTmp, fmKron, &fmKrX );
fmW0 = fmW0 + fmKrZ.GetTransposed() * (*(ppVj[i])) * fmKrZ;
fmW1 = fmW1 + fmKrZ.GetTransposed() * (*(ppVj[i])) * fmKrX;
fmW2 = fmW2 + fmKrX.GetTransposed() * (*(ppVj[i])) * fmKrX;
fmW3 = fmW3 + fmKrX.GetTransposed() * (*(ppVj[i])) * fmKrZ;
}
CFmMatrix fmQw( K, K );
fmQw = fmW0 - fmW1 * fmW2.GetInverted() * fmW3;
fmQw = fmQw / 2.0;
for(int i=0; i<N; i++) { destroy( ppVj[i] );}
for(int i=0; i<N; i++) { destroy( ppYj[i] );}
Free(ppVj);
Free(ppYj);
//double fQv = 0.5;
//CFmMatrix fmQw( K, K );
//for(int i=0; i<K; i++) fmQw.Set(i, i, i+1);
SEXP sRet, t;
PROTECT(sRet = t = allocList(2));
SEXP expVS = GetSEXP(&fmQw);
SETCAR( t, expVS );
SET_TAG(t, install("w") );
t = CDR(t);
CFmVector frmQv(1, fQv);
SEXP expVS1 = GetSEXP(&frmQv);
SETCAR( t, expVS1 );
SET_TAG(t, install("v") );
t = CDR(t);
UNPROTECT(1);
return(sRet);
}
