SEXP attribute_hidden do_earg_matprod_star(SEXP call, SEXP op, SEXP arg_x, SEXP arg_y, SEXP rho) {
if ((IS_S4_OBJECT(arg_x) || IS_S4_OBJECT(arg_y)) && R_has_methods(op)) {
SEXP value;
value = R_possible_dispatch(call, op, BUILD_2ARGS(NULL, arg_x, arg_y), rho, FALSE);
if (value) return value;
}
/* CTK, FIXME: note that %*% does not honor the argument names, calling it e.g.
`%*%`(y=1:3, x=matrix(1:9, nrow=3)) will yield y%*%x, x%*%y
(and this was also the case of the original code */
return do_earg_matprod(call, op, arg_x, arg_y, rho);
}
bool
RwxHtmlWinTagHandler::HandleTag(const wxHtmlTag & varib)
{
SEXP r_this, r_info, r_parser;
PROTECT(r_this = R_make_wxWidget_Ref(this, "RwxHtmlWinTagHandler"));
PROTECT(r_info = R_make_wxWidget_Ref( &varib, "wxHtmlTag"));
PROTECT(r_parser = R_make_wxWidget_Ref(m_WParser, "wxHtmlParser"));
SEXP r_ans;
bool ans = true;
r_ans = invoke(handler, r_this, r_info, r_parser);
UNPROTECT(3);
if(r_ans == NULL) {
ans = false;
} else if(TYPEOF(r_ans) == LGLSXP) {
ans = LOGICAL(r_ans)[0];
}
else if(IS_S4_OBJECT(r_ans)) {
/* insert the widget for the user. */
if(Rf_inherits(r_ans, "wxWindow")) {
wxWindow *w = (wxWindow *) R_get_wxWidget_Ref(r_ans, "wxWindow");
wxHtmlWidgetCell *cell = new wxHtmlWidgetCell(w);
wxHtmlContainerCell *container = m_WParser->GetContainer();
container->InsertCell(cell);
}
}
return(ans);
}
SEXP attribute_hidden do_rep_len(SEXP call, SEXP op, SEXP args, SEXP rho)
{
R_xlen_t ns, na;
SEXP a, s, len;
checkArity(op, args);
s = CAR(args);
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate non-vector"));
len = CADR(args);
if(length(len) != 1)
error(_("invalid '%s' value"), "length.out");
#ifdef LONG_VECTOR_SUPPORT
double sna = asReal(len);
if (!R_FINITE(sna) || sna < 0)
error(_("invalid '%s' value"), "length.out");
na = (R_xlen_t) sna;
#else
if ((na = asInteger(len)) == NA_INTEGER || na < 0) /* na = 0 ok */
error(_("invalid '%s' value"), "length.out");
#endif
if (TYPEOF(s) == NILSXP && na > 0)
error(_("cannot replicate NULL to a non-zero length"));
ns = xlength(s);
if (ns == 0) {
SEXP a;
PROTECT(a = duplicate(s));
if(na > 0) a = xlengthgets(a, na);
UNPROTECT(1);
return a;
}
PROTECT(a = rep3(s, ns, na));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
/* This is allowed to change 'out' */
attribute_hidden
SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP in = CAR(args), out = CADR(args);
SET_ATTRIB(out, ATTRIB(in));
IS_S4_OBJECT(in) ? SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
SET_OBJECT(out, OBJECT(in));
return out;
}
SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP s = CAR(args), ncopy = CADR(args);
R_xlen_t nc;
SEXP a;
if (!isVector(ncopy))
error(_("incorrect type for second argument"));
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate an object of type '%s'"),
type2char(TYPEOF(s)));
nc = xlength(ncopy); // might be 0
if (nc == xlength(s))
PROTECT(a = rep2(s, ncopy));
else {
if (nc != 1) error(_("invalid '%s' value"), "times");
#ifdef LONG_VECTOR_SUPPORT
double snc = asReal(ncopy);
if (!R_FINITE(snc) || snc < 0)
error(_("invalid '%s' value"), "times");
nc = (R_xlen_t) snc;
#else
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid '%s' value"), "times");
#endif
R_xlen_t ns = xlength(s);
PROTECT(a = rep3(s, ns, nc * ns));
}
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
/* oldClass, primitive */
SEXP attribute_hidden do_class(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
SEXP x = CAR(args), s3class;
if(IS_S4_OBJECT(x)) {
if((s3class = S3Class(x)) != R_NilValue) {
return s3class;
}
} /* else */
return getAttrib(x, R_ClassSymbol);
}
SEXP attribute_hidden do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho) {
if (PRIMVAL(op) != 0) { /* crossprod or tcrossprod */
RETURN_EARG2(do_earg_matprod, call, op, args, rho);
}
/* %*% */
SEXP x = CAR(args), y = CADR(args);
/* %*% is primitive, the others are .Internal() */
if ((IS_S4_OBJECT(x) || IS_S4_OBJECT(y)) && R_has_methods(op)) {
SEXP s, value;
/* Remove argument names to ensure positional matching */
for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
value = R_possible_dispatch(call, op, args, rho, FALSE);
if (value) return value;
}
return do_earg_matprod(call, op, x, y, rho);
}
/* oldClass<-(), primitive */
SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
if(IS_S4_OBJECT(CAR(args)))
UNSET_S4_OBJECT(CAR(args));
setAttrib(CAR(args), R_ClassSymbol, CADR(args));
SET_NAMED(CAR(args), 0);
return CAR(args);
}
attribute_hidden
SEXP tspgets(SEXP vec, SEXP val)
{
double start, end, frequency;
int n;
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if(IS_S4_OBJECT(vec)) { /* leave validity checking to validObject */
if (!isNumeric(val)) /* but should have been checked */
error(_("'tsp' attribute must be numeric"));
installAttrib(vec, R_TspSymbol, val);
return vec;
}
if (!isNumeric(val) || length(val) != 3)
error(_("'tsp' attribute must be numeric of length three"));
if (isReal(val)) {
start = REAL(val)[0];
end = REAL(val)[1];
frequency = REAL(val)[2];
}
else {
start = (INTEGER(val)[0] == NA_INTEGER) ?
NA_REAL : INTEGER(val)[0];
end = (INTEGER(val)[1] == NA_INTEGER) ?
NA_REAL : INTEGER(val)[1];
frequency = (INTEGER(val)[2] == NA_INTEGER) ?
NA_REAL : INTEGER(val)[2];
}
if (frequency <= 0) badtsp();
n = nrows(vec);
if (n == 0) error(_("cannot assign 'tsp' to zero-length vector"));
/* FIXME: 1.e-5 should rather be == option('ts.eps') !! */
if (fabs(end - start - (n - 1)/frequency) > 1.e-5)
badtsp();
PROTECT(vec);
val = allocVector(REALSXP, 3);
PROTECT(val);
REAL(val)[0] = start;
REAL(val)[1] = end;
REAL(val)[2] = frequency;
installAttrib(vec, R_TspSymbol, val);
UNPROTECT(2);
return vec;
}
static void checkNames(SEXP x, SEXP s)
{
if (isVector(x) || isList(x) || isLanguage(x)) {
if (!isVector(s) && !isList(s))
error(_("invalid type (%s) for 'names': must be vector"),
type2char(TYPEOF(s)));
if (xlength(x) != xlength(s))
error(_("'names' attribute [%d] must be the same length as the vector [%d]"), length(s), length(x));
}
else if(IS_S4_OBJECT(x)) {
/* leave validity checks to S4 code */
}
else error(_("names() applied to a non-vector"));
}
Cholesky_rd::Cholesky_rd(SEXP x, int nn) {
if (!(IS_S4_OBJECT(x)))
error(_("S4 object expected but not provided"));
// FIXME: This check should be changed to an S4 "is" check, which
// should be available in Rinternals.h but isn't.
if (strcmp(CHAR(asChar(getAttrib(x, R_ClassSymbol))),
"Cholesky") != 0)
error(_("Object must be of class \"Cholesky\""));
uplo = CHAR(asChar(GET_SLOT(x, install("uplo"))));
int *dims = INTEGER(GET_SLOT(x, lme4_DimSym));
n = nn;
if (dims[0] != n || dims[1] != n)
error(_("Cholesky object must be a square matrix of size %d"));
X = REAL(GET_SLOT(x, lme4_xSym));
}
/*
Determine if obj is an instance of the class given by className
which should be an S4 class.
*/
Rboolean
IS_S4_INSTANCE(SEXP obj, const char *className)
{
SEXP e, ans;
Rboolean status;
if(!IS_S4_OBJECT(obj))
return(FALSE);
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("is"));
SETCAR(CDR(e), obj);
SETCAR(CDR(CDR(e)), mkString(className));
ans = eval(e, R_GlobalEnv);
status = LOGICAL(ans)[0];
UNPROTECT(1);
return(status);
}
dpoMatrix::dpoMatrix(SEXP x) {
if (!(IS_S4_OBJECT(x)))
error(_("S4 object expected but not provided"));
// FIXME: This check should be changed to an S4 inherits check, which
// should be available in Rinternals.h but isn't.
if (strcmp(CHAR(asChar(getAttrib(x, R_ClassSymbol))),
"dpoMatrix") != 0)
error(_("Object must be of class \"dpoMatrix\""));
uplo = CHAR(asChar(GET_SLOT(x, install("uplo"))));
int *dims = INTEGER(GET_SLOT(x, lme4_DimSym));
n = dims[0];
if (dims[1] != n)
error(_("Cholesky object must be a square matrix"));
X = REAL(GET_SLOT(x, lme4_xSym));
factors = GET_SLOT(x, install("factors"));
if (LENGTH(factors) && !isNewList(factors))
error(_("\"factors\" slot should be a list"));
}
SEXP R_copyTruncate(SEXP x, SEXP R_n) {
if (isNull(x) || TYPEOF(x) != VECSXP)
error("'x' not of type list");
if (isNull(R_n) || TYPEOF(R_n) != INTSXP)
error("'n' not of type integer");
int i, k, n;
SEXP s, r, t = 0;
n = INTEGER(R_n)[0];
if (n < 0)
error("'n' invalid value");
r = PROTECT(allocVector(VECSXP, LENGTH(x)));
for (i = 0; i < LENGTH(x); i++) {
s = VECTOR_ELT(x, i);
if (TYPEOF(s) != STRSXP)
error("component not of type character");
if (LENGTH(s) > n) {
SET_VECTOR_ELT(r, i, (t = allocVector(STRSXP, n)));
for (k = 0; k < n; k++)
SET_STRING_ELT(t, k, STRING_ELT(s, k));
copyMostAttrib(t, s);
if ((s = getAttrib(s, R_NamesSymbol)) != R_NilValue) {
SEXP v;
setAttrib(t, R_NamesSymbol, (v = allocVector(STRSXP, n)));
for (k = 0; k < n; k++)
SET_STRING_ELT(v, k, STRING_ELT(s, k));
}
} else
SET_VECTOR_ELT(r, i, s);
}
UNPROTECT(1);
if (!t)
return x;
SET_ATTRIB(r, ATTRIB(x));
SET_OBJECT(r, OBJECT(x));
if (IS_S4_OBJECT(x))
SET_S4_OBJECT(r);
return r;
}
/* version that does not preserve ts information, for subsetting */
void copyMostAttribNoTs(SEXP inp, SEXP ans)
{
SEXP s;
if (ans == R_NilValue)
error(_("attempt to set an attribute on NULL"));
PROTECT(ans);
PROTECT(inp);
for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
if ((TAG(s) != R_NamesSymbol) &&
(TAG(s) != R_ClassSymbol) &&
(TAG(s) != R_TspSymbol) &&
(TAG(s) != R_DimSymbol) &&
(TAG(s) != R_DimNamesSymbol)) {
installAttrib(ans, TAG(s), CAR(s));
} else if (TAG(s) == R_ClassSymbol) {
SEXP cl = CAR(s);
int i;
Rboolean ists = FALSE;
for (i = 0; i < LENGTH(cl); i++)
if (strcmp(CHAR(STRING_ELT(cl, i)), "ts") == 0) { /* ASCII */
ists = TRUE;
break;
}
if (!ists) installAttrib(ans, TAG(s), cl);
else if(LENGTH(cl) <= 1) {
} else {
SEXP new_cl;
int i, j, l = LENGTH(cl);
PROTECT(new_cl = allocVector(STRSXP, l - 1));
for (i = 0, j = 0; i < l; i++)
if (strcmp(CHAR(STRING_ELT(cl, i)), "ts")) /* ASCII */
SET_STRING_ELT(new_cl, j++, STRING_ELT(cl, i));
installAttrib(ans, TAG(s), new_cl);
UNPROTECT(1);
}
}
}
SET_OBJECT(ans, OBJECT(inp));
IS_S4_OBJECT(inp) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
UNPROTECT(2);
}
void copyMostAttrib(SEXP inp, SEXP ans)
{
SEXP s;
if (ans == R_NilValue)
error(_("attempt to set an attribute on NULL"));
PROTECT(ans);
PROTECT(inp);
for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
if ((TAG(s) != R_NamesSymbol) &&
(TAG(s) != R_DimSymbol) &&
(TAG(s) != R_DimNamesSymbol)) {
installAttrib(ans, TAG(s), CAR(s));
}
}
SET_OBJECT(ans, OBJECT(inp));
IS_S4_OBJECT(inp) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
UNPROTECT(2);
}
/* used in eval.c */
SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call)
{
SEXP y, nlist;
size_t slen;
PROTECT(input);
PROTECT(x);
/* Optimisation to prevent repeated recalculation */
slen = strlen(translateChar(input));
/* The mechanism to allow a class extending "environment" */
if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, "$ operator not defined for this S4 class");
}
UNPROTECT(1); /* x */
PROTECT(x);
/* If this is not a list object we return NULL. */
if (isPairList(x)) {
SEXP xmatch = R_NilValue;
int havematch;
UNPROTECT(2); /* input, x */
havematch = 0;
for (y = x ; y != R_NilValue ; y = CDR(y)) {
switch(pstrmatch(TAG(y), input, slen)) {
case EXACT_MATCH:
y = CAR(y);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
xmatch = y;
break;
case NO_MATCH:
break;
}
}
if (havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = TAG(xmatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = CAR(xmatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if (isVectorList(x)) {
R_xlen_t i, n, imatch = -1;
int havematch;
nlist = getAttrib(x, R_NamesSymbol);
UNPROTECT(2); /* input, x */
n = xlength(nlist);
havematch = 0;
for (i = 0 ; i < n ; i = i + 1) {
switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {
case EXACT_MATCH:
y = VECTOR_ELT(x, i);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
if (havematch == 1) {
/* partial matches can cause aliasing in eval.c:evalseq
This is overkill, but alternative ways to prevent
the aliasing appear to be even worse */
y = VECTOR_ELT(x,i);
SET_NAMED(y,2);
SET_VECTOR_ELT(x,i,y);
}
imatch = i;
break;
case NO_MATCH:
break;
}
}
if(havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = STRING_ELT(nlist, imatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = VECTOR_ELT(x, imatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if( isEnvironment(x) ){
y = findVarInFrame(x, installTrChar(input));
if( TYPEOF(y) == PROMSXP ) {
PROTECT(y);
y = eval(y, R_GlobalEnv);
UNPROTECT(1); /* y */
}
UNPROTECT(2); /* input, x */
if( y != R_UnboundValue ) {
if (NAMED(y))
SET_NAMED(y, 2);
else if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return(y);
}
return R_NilValue;
}
else if( isVectorAtomic(x) ){
errorcall(call, "$ operator is invalid for atomic vectors");
}
else /* e.g. a function */
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
UNPROTECT(2); /* input, x */
return R_NilValue;
}
/* Convert an R value to a GenericValue based on the type expected, given by type. */
bool
convertRToGenericValue(llvm::GenericValue *rv, SEXP rval, const llvm::Type *type)
{
llvm::Type::TypeID ty;
if(!type) {
REprintf("var arg %d\n", TYPEOF(rval));
rv->IntVal = INTEGER(rval)[0];
// rv->IntVal = llvm::APInt((unsigned) 32, INTEGER(rval)[0]);
return(true);
}
// FIX - enhance to cover more situations.
if(type->isPointerTy()) {
const llvm::Type *elType = ((const llvm::PointerType*) type)->getElementType();
ty = elType->getTypeID();
bool ok = true;
switch(ty) {
case llvm::Type::IntegerTyID:
if(elType->isIntegerTy(8)) {
if(TYPEOF(rval) == STRSXP) {
rv->PointerVal = Rf_length(rval) ? (void*) CHAR(STRING_ELT(rval, 0)) : (void *) NULL;
} else if(TYPEOF(rval) == NILSXP) {
rv->PointerVal = (void*) NULL;
} else
ok = false;
} else if(TYPEOF(rval) == INTSXP)
rv->PointerVal = INTEGER(rval);
else
ok = false;
break;
case llvm::Type::DoubleTyID:
if(TYPEOF(rval) == REALSXP)
rv->PointerVal = REAL(rval);
else
ok = false;
break;
case llvm::Type::PointerTyID:
if(TYPEOF(rval) == STRSXP) {
rv->PointerVal = Rf_length(rval) ? (void*) CHAR(STRING_ELT(rval, 0)) : (void *) NULL;
} if(TYPEOF(rval) == NILSXP || rval == R_NilValue) {
rv->PointerVal = (void*) NULL;
} else if(TYPEOF(rval) == RAWSXP)
rv->PointerVal = (void*) RAW(rval);
else
ok = false;
break;
case llvm::Type::VoidTyID:
if(rval == R_NilValue)
rv->PointerVal = (void*) NULL;
else if(TYPEOF(rval) == RAWSXP)
rv->PointerVal = (void*) RAW(rval);
break;
default:
ok = false;
}
if(ok == false) {
int rtype = isSEXPType(type);
if(rtype > 0) {
rv->PointerVal = rval;
ok = true;
}
}
if(ok == false && TYPEOF(rval) == EXTPTRSXP) {
rv->PointerVal = R_ExternalPtrAddr(rval);
ok = true;
}
/* See if this is an S4 object with a "ref" slot that is an external pointer */
SEXP refRVal = NULL;
if(ok == false && IS_S4_OBJECT(rval) && (refRVal = GET_SLOT(rval, Rf_install("ref")))
&& refRVal != R_NilValue && TYPEOF(refRVal) == EXTPTRSXP) {
rv->PointerVal = R_ExternalPtrAddr(refRVal);
ok = true;
}
if(ok == false) {
PROBLEM "no method to convert R object of R type %d to LLVM pointer to type %d", TYPEOF(rval), ty
WARN;
}
return(ok);
}
ty = type->getTypeID();
switch(ty) {
case llvm::Type::IntegerTyID: {
uint64_t val = asInteger(rval);
unsigned BitWidth = llvm::cast<llvm::IntegerType>(type)->getBitWidth();
rv->IntVal = llvm::APInt(BitWidth, val);
return rv;
}
break;
case llvm::Type::DoubleTyID: {
rv->DoubleVal = Rf_asReal(rval);
}
break;
case llvm::Type::FloatTyID: {
rv->FloatVal = Rf_asReal(rval);
}
break;
default:
PROBLEM "no code yet for converting R to GV for type %d", (int) ty
ERROR;
}
return(true);
}
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;
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
SEXP zoo_lag (SEXP x, SEXP _k, SEXP _pad)
{
#ifdef ZOO_DEBUG
Rprintf("zoo_lag\n");
#endif
SEXP result;
int i,j;
double *result_real=NULL;
int *result_int=NULL;
int k=INTEGER(_k)[0] * -1; /* -1 is zoo convention */
int k_positive = (k > 0) ? 1 : 0;
int nr = nrows(x);
int nc = ncols(x);
int P=0;
int PAD = INTEGER(coerceVector(_pad,INTSXP))[0];
if(k > nr)
error("abs(k) must be less than nrow(x)");
if(k < 0 && -1*k > nr)
error("abs(k) must be less than nrow(x)");
PROTECT(result = allocVector(TYPEOF(x),
length(x) - (PAD ? 0 : abs(k)*nc))); P++;
int nrr;
if(length(result) > 0)
nrr = (int)(length(result)/nc);
else /* handle zero-length objects */
nrr = nr - (PAD ? 0 : abs(k));
if(k_positive) {
switch(TYPEOF(x)) {
case REALSXP:
result_real = REAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_real[i+(j*nrr)] = NA_REAL;
memcpy(&REAL(result)[k+(j*nrr)],
&REAL(x)[(j*nrr)],
(nrr-k) * sizeof(double));
} else {
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[(j*nr)], /* original data need the original 'nr' offset */
nrr * sizeof(double));
}
}
break;
case INTSXP:
result_int = INTEGER(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&INTEGER(result)[k+(j*nrr)],
&INTEGER(x)[(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[(j*nr)],
nrr * sizeof(int));
}
}
break;
case LGLSXP:
result_int = LOGICAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&LOGICAL(result)[k+(j*nrr)],
&LOGICAL(x)[(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[(j*nr)],
nrr * sizeof(int));
}
}
break;
case CPLXSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++) {
COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
}
memcpy(&COMPLEX(result)[k+(j*nrr)],
&COMPLEX(x)[(j*nrr)],
(nrr-k) * sizeof(Rcomplex));
} else {
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[(j*nr)],
nrr * sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
RAW(result)[i+(j*nrr)] = (Rbyte) 0;
memcpy(&RAW(result)[k+(j*nrr)],
&RAW(x)[(j*nrr)],
(nrr-k) * sizeof(Rbyte));
} else {
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[(j*nr)],
nrr * sizeof(Rbyte));
}
}
break;
case STRSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
for(i = 0; i < nrr-k; i++)
SET_STRING_ELT(result, k+i+j*nrr, STRING_ELT(x, i+j*nrr));
} else {
for(i = 0; i < nrr; i++)
SET_STRING_ELT(result, i+j*nrr, STRING_ELT(x, i+j*nr));
}
}
break;
default:
error("unsupported type");
break;
}
} else
if(!k_positive) {
k = abs(k);
switch(TYPEOF(x)) {
case REALSXP:
result_real = REAL(result);
for(j =0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_real[i+(j*nrr)] = NA_REAL;
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[k+(j*nrr)],
(nrr-k) * sizeof(double));
} else {
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[k+(j*nr)],
nrr * sizeof(double));
}
}
break;
case INTSXP:
result_int = INTEGER(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[k+(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[k+(j*nr)],
nrr * sizeof(int));
}
}
break;
case LGLSXP:
result_int = LOGICAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[k+(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[k+(j*nr)],
nrr * sizeof(int));
}
}
break;
case CPLXSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++) {
COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
}
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[k+(j*nrr)],
(nrr-k) * sizeof(Rcomplex));
} else {
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[k+(j*nr)],
nrr * sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
RAW(result)[i+(j*nrr)] = (Rbyte) 0;
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[k+(j*nrr)],
(nrr-k) * sizeof(Rbyte));
} else {
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[k+(j*nr)],
nrr * sizeof(Rbyte));
}
}
break;
case STRSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
for(i = 0; i < nrr-k; i++)
SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nrr)));
} else {
for(i = 0; i < nr-k; i++)
SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nr)));
}
}
break;
default:
error("unsupported type");
break;
}
}
copyMostAttrib(x,result);
if(!PAD) {
// likely unneeded as copyMostAttrib will cover
// setAttrib(result, install("index"), getAttrib(x, install("index")));
//} else {
SEXP index, newindex;
PROTECT(index = getAttrib(x, install("index"))); P++;
if(IS_S4_OBJECT(index)) {
/* should make this
1) generic for any S4 object if possible
2) test for timeDate as this is important
*/
if(STRING_ELT(getAttrib(index, R_ClassSymbol),0)!=mkChar("timeDate"))
error("'S4' objects must be of class 'timeDate'");
index = GET_SLOT(index, install("Data"));
}
PROTECT(newindex = allocVector(TYPEOF(index), nrr)); P++;
switch(TYPEOF(index)) {
case REALSXP:
if(k_positive) {
memcpy(REAL(newindex), &REAL(index)[k], nrr * sizeof(double));
} else {
memcpy(REAL(newindex), REAL(index), nrr * sizeof(double));
}
break;
case INTSXP:
if(k_positive) {
memcpy(INTEGER(newindex), &INTEGER(index)[k], nrr * sizeof(int));
} else {
memcpy(INTEGER(newindex), INTEGER(index), nrr * sizeof(int));
}
break;
default:
break;
}
if(IS_S4_OBJECT(getAttrib(x, install("index")))) {
/* need to assure that this is timeDate */
SEXP tmp = PROTECT(getAttrib(x, install("index"))); P++;
SEXP class = PROTECT(MAKE_CLASS("timeDate")); P++;
SEXP timeDate = PROTECT(NEW_OBJECT(class)); P++;
copyMostAttrib(index,newindex);
SET_SLOT(timeDate,install("Data"),newindex);
SEXP format = PROTECT(GET_SLOT(tmp, install("format"))); P++;
SET_SLOT(timeDate,install("format"), format);
SEXP finCenter = PROTECT(GET_SLOT(tmp, install("FinCenter"))); P++;
SET_SLOT(timeDate,install("FinCenter"), finCenter);
setAttrib(result, install("index"), timeDate);
} else {
void *
convertToNative(void **val, SEXP r_val, ffi_type *type) /* need something about copying, to control memory recollection*/
{
void *ans = NULL;
if(type == &ffi_type_sexp) {
SEXP *p = (SEXP *) R_alloc(sizeof(SEXP), 1);
*p = r_val;
ans = p;
} else if(type == &ffi_type_pointer) {
SEXPREC_ALIGN *p;
if(r_val == R_NilValue)
ans = NULL;
else if(IS_S4_OBJECT(r_val) && R_is(r_val, "AddressOf")) {
ans = getAddressOfExtPtr(GET_SLOT(r_val, Rf_install("ref")));
}
else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) {
ans = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref")));
} else {
/* Should be looking at the element type, not at r_val. */
switch(TYPEOF(r_val)) {
case INTSXP:
case LGLSXP:
{
p = ((SEXPREC_ALIGN *) r_val) + 1;
ans = p;
/* ans = &r_val + sizeof(SEXPREC_ALIGN*); */ /* INTEGER(r_val); */
}
break;
case REALSXP:
p = ((SEXPREC_ALIGN *) r_val) + 1;
ans = p; /* REAL(r_val); */
break;
case STRSXP: /*XXX What should happen is not clear here. The char ** or the single */
ans = Rf_length(r_val) ? CHAR(STRING_ELT(r_val, 0)) : NULL;
break;
case EXTPTRSXP:
ans = R_ExternalPtrAddr(r_val);
break;
case CLOSXP:
ans = r_val;
break;
case RAWSXP:
ans = RAW(r_val);
break;
default:
PROBLEM "unhandled conversion from R type (%d) to native FFI type", TYPEOF(r_val)
ERROR;
break;
}
}
} else {
if(type->type == FFI_TYPE_STRUCT) {
ans = convertRToStruct(r_val, type);
} else if(type == &ffi_type_string) {
const char * * tmp;
tmp = (const char * * ) R_alloc(sizeof(char *), 1);
if(r_val == R_NilValue)
*tmp = NULL;
else
*tmp = CHAR(STRING_ELT(r_val, 0));
ans = tmp;
} else if(type == &ffi_type_double) {
ans = REAL(r_val);
} else if(type == &ffi_type_float) {
/* We allocate a float, populate it with the value and return
a pointer to that new float. It is released when we return from the .Call(). */
float *tmp = (float *) R_alloc(sizeof(float), 1);
*tmp = REAL(r_val)[0];
ans = tmp;
} else if(type == &ffi_type_sint32) {
#if 1
/*experiment*/
if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) {
void **tmp = (void **) malloc(sizeof(void *));
*tmp = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))) ;
return(tmp);
}
#endif
if(TYPEOF(r_val) == INTSXP) {
ans = INTEGER(r_val);
} else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) {
ans = (int *) R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref")));
} else {
int *i = (int *) R_alloc(sizeof(int), 1);
i[0] = INTEGER(coerceVector(r_val, INTSXP))[0];
ans = i;
}
} else if(type == &ffi_type_sint16) {
short *s = (short *) R_alloc(1, 16);
*s = INTEGER(coerceVector(r_val, INTSXP))[0];
ans = s;
} else if(type == &ffi_type_uint32) {
unsigned int *tmp = (unsigned int *) R_alloc(sizeof(unsigned int), 1);
*tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0];
ans = tmp;
} else if(type == &ffi_type_uint16) {
unsigned short *tmp = (unsigned short *) R_alloc(sizeof(unsigned short), 1);
*tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0];
ans = tmp;
}
}
/* Rprintf("convert->native: %p\n", ans); */
return(ans);
}
/* This is for all cases with a single index, including 1D arrays and
matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
R_xlen_t n;
int mode;
R_xlen_t stretch = 1;
SEXP indx, result, attrib, nattrib;
if (s == R_MissingArg) return duplicate(x);
PROTECT(s);
attrib = getAttrib(x, R_DimSymbol);
/* Check to see if we have special matrix subscripting. */
/* If we do, make a real subscript vector and protect it. */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
if (isString(s)) {
s = strmat2intmat(s, GetArrayDimnames(x), call);
UNPROTECT(1);
PROTECT(s);
}
if (isInteger(s) || isReal(s)) {
s = mat2indsub(attrib, s, call);
UNPROTECT(1);
PROTECT(s);
}
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch, call));
n = XLENGTH(indx);
/* Allocate the result. */
mode = TYPEOF(x);
/* No protection needed as ExtractSubset does not allocate */
result = allocVector(mode, n);
if (mode == VECSXP || mode == EXPRSXP)
/* we do not duplicate the values when extracting the subset,
so to be conservative mark the result as NAMED = 2 */
SET_NAMED(result, 2);
PROTECT(result = ExtractSubset(x, result, indx, call));
if (result != R_NilValue) {
if (
((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
( /* here we might have an array. Use row names if 1D */
isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
(attrib = GetRowNames(attrib)) != R_NilValue
)
) {
PROTECT(attrib);
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(2); /* attrib, nattrib */
}
if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
TYPEOF(attrib) == VECSXP) {
nattrib = allocVector(VECSXP, n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_SrcrefSymbol, nattrib);
UNPROTECT(1);
}
/* FIXME: this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SET_S4_OBJECT(result);
}
#endif
}
UNPROTECT(3);
return result;
}
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */
SEXP attribute_hidden do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int ldx, ldy, nrx, ncx, nry, ncy, mode;
SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans;
Rboolean sym;
if (PRIMVAL(op) == 0 && /* %*% is primitive, the others are .Internal() */
(IS_S4_OBJECT(x) || IS_S4_OBJECT(y))
&& R_has_methods(op)) {
SEXP s, value;
/* Remove argument names to ensure positional matching */
for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
value = R_possible_dispatch(call, op, args, rho, FALSE);
if (value) return value;
}
sym = isNull(y);
if (sym && (PRIMVAL(op) > 0)) y = x;
if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
errorcall(call, _("requires numeric/complex matrix/vector arguments"));
xdims = getAttrib(x, R_DimSymbol);
ydims = getAttrib(y, R_DimSymbol);
ldx = length(xdims);
ldy = length(ydims);
if (ldx != 2 && ldy != 2) { /* x and y non-matrices */
// for crossprod, allow two cases: n x n ==> (1,n) x (n,1); 1 x n = (n, 1) x (1, n)
if (PRIMVAL(op) == 1 && LENGTH(x) == 1) {
nrx = ncx = nry = 1;
ncy = LENGTH(y);
}
else {
nry = LENGTH(y);
ncy = 1;
if (PRIMVAL(op) == 0) {
nrx = 1;
ncx = LENGTH(x);
if(ncx == 1) { // y as row vector
ncy = nry;
nry = 1;
}
}
else {
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldx != 2) { /* x not a matrix */
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
nrx = 0;
ncx = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(x) == nry) { /* x as row vector */
nrx = 1;
ncx = nry; /* == LENGTH(x) */
}
else if (nry == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(x) == nry) { /* x is a col vector */
nrx = nry; /* == LENGTH(x) */
ncx = 1;
}
/* else if (nry == 1) ... not being too tolerant
to treat x as row vector, as t(x) *is* row vector */
}
else { /* tcrossprod */
if (LENGTH(x) == ncy) { /* x as row vector */
nrx = 1;
ncx = ncy; /* == LENGTH(x) */
}
else if (ncy == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldy != 2) { /* y not a matrix */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = 0;
ncy = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(y) == ncx) { /* y as col vector */
nry = ncx;
ncy = 1;
}
else if (ncx == 1) { /* y as row vector */
nry = 1;
ncy = LENGTH(y);
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(y) == nrx) { /* y is a col vector */
nry = nrx;
ncy = 1;
} else if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
}
else { // tcrossprod
if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
else { // y is a col vector
nry = LENGTH(y);
ncy = 1;
}
}
}
else { /* x and y matrices */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
}
/* nr[ow](.) and nc[ol](.) are now defined for x and y */
if (PRIMVAL(op) == 0) {
/* primitive, so use call */
if (ncx != nry)
errorcall(call, _("non-conformable arguments"));
}
else if (PRIMVAL(op) == 1) {
if (nrx != nry)
error(_("non-conformable arguments"));
}
else {
if (ncx != ncy)
error(_("non-conformable arguments"));
}
if (isComplex(CAR(args)) || isComplex(CADR(args)))
mode = CPLXSXP;
else
mode = REALSXP;
SETCAR(args, coerceVector(CAR(args), mode));
SETCADR(args, coerceVector(CADR(args), mode));
if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */
PROTECT(ans = allocMatrix(mode, nrx, ncy));
if (mode == CPLXSXP)
cmatprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else
matprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2 || ncx == 1) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
#define YDIMS_ET_CETERA \
if (ydims != R_NilValue) { \
if (ldy == 2) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \
} else if (nry == 1) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \
} \
} \
\
/* We sometimes attach a dimnames attribute \
* whose elements are all NULL ... \
* This is ugly but causes no real damage. \
* Now (2.1.0 ff), we don't anymore: */ \
if (VECTOR_ELT(dimnames,0) != R_NilValue || \
VECTOR_ELT(dimnames,1) != R_NilValue) { \
if (dnx != R_NilValue || dny != R_NilValue) \
setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \
setAttrib(ans, R_DimNamesSymbol, dimnames); \
} \
UNPROTECT(2)
YDIMS_ET_CETERA;
}
}
else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */
PROTECT(ans = allocMatrix(mode, ncx, ncy));
if (mode == CPLXSXP)
if(sym)
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
crossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
}
}
YDIMS_ET_CETERA;
}
}
else { /* op == 2: tcrossprod() */
PROTECT(ans = allocMatrix(mode, nrx, nry));
if (mode == CPLXSXP)
if(sym)
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symtcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
tcrossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
if (ydims != R_NilValue) {
if (ldy == 2) {
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0));
dny = getAttrib(ydims, R_NamesSymbol);
if(!isNull(dny))
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0));
}
}
if (VECTOR_ELT(dimnames,0) != R_NilValue ||
VECTOR_ELT(dimnames,1) != R_NilValue) {
if (dnx != R_NilValue || dny != R_NilValue)
setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
setAttrib(ans, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
}
UNPROTECT(3);
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;
}
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
right, max, useS4)) */
SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, naprint;
int tryS4;
Rboolean callShow = FALSE;
checkArity(op, args);
PrintDefaults();
x = CAR(args); args = CDR(args);
if(!isNull(CAR(args))) {
R_print.digits = asInteger(CAR(args));
if (R_print.digits == NA_INTEGER ||
R_print.digits < R_MIN_DIGITS_OPT ||
R_print.digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
}
args = CDR(args);
R_print.quote = asLogical(CAR(args));
if(R_print.quote == NA_LOGICAL)
error(_("invalid '%s' argument"), "quote");
args = CDR(args);
naprint = CAR(args);
if(!isNull(naprint)) {
if(!isString(naprint) || LENGTH(naprint) < 1)
error(_("invalid 'na.print' specification"));
R_print.na_string = R_print.na_string_noquote = STRING_ELT(naprint, 0);
R_print.na_width = R_print.na_width_noquote =
(int) strlen(CHAR(R_print.na_string));
}
args = CDR(args);
if(!isNull(CAR(args))) {
R_print.gap = asInteger(CAR(args));
if (R_print.gap == NA_INTEGER || R_print.gap < 0)
error(_("'gap' must be non-negative integer"));
}
args = CDR(args);
R_print.right = (Rprt_adj) asLogical(CAR(args)); /* Should this be asInteger()? */
if(R_print.right == NA_LOGICAL)
error(_("invalid '%s' argument"), "right");
args = CDR(args);
if(!isNull(CAR(args))) {
R_print.max = asInteger(CAR(args));
if(R_print.max == NA_INTEGER || R_print.max < 0)
error(_("invalid '%s' argument"), "max");
else if(R_print.max == INT_MAX) R_print.max--; // so we can add
}
args = CDR(args);
R_print.useSource = asLogical(CAR(args));
if(R_print.useSource == NA_LOGICAL)
error(_("invalid '%s' argument"), "useSource");
if(R_print.useSource) R_print.useSource = USESOURCE;
args = CDR(args);
tryS4 = asLogical(CAR(args));
if(tryS4 == NA_LOGICAL)
error(_("invalid 'tryS4' internal argument"));
if(tryS4 && IS_S4_OBJECT(x) && isMethodsDispatchOn())
callShow = TRUE;
if(callShow) {
/* we need to get show from the methods namespace if it is
not visible on the search path. */
SEXP call, showS;
showS = findVar(install("show"), rho);
if(showS == R_UnboundValue) {
SEXP methodsNS = R_FindNamespace(mkString("methods"));
if(methodsNS == R_UnboundValue)
error("missing methods namespace: this should not happen");
PROTECT(methodsNS);
showS = findVarInFrame3(methodsNS, install("show"), TRUE);
UNPROTECT(1);
if(showS == R_UnboundValue)
error("missing show() in methods namespace: this should not happen");
}
PROTECT(call = lang2(showS, x));
eval(call, rho);
UNPROTECT(1);
} else {
CustomPrintValue(x, rho);
}
PrintDefaults(); /* reset, as na.print etc may have been set */
return x;
}/* do_printdefault */
