static msg_t check_storage(SEXP x, SEXP mode) {
if (!isNull(mode)) {
const char * const storage = asString(mode, "mode");
if (strcmp(storage, "logical") == 0) {
if (!isLogical(x))
return make_msg("Must store logicals");
} else if (strcmp(storage, "integer") == 0) {
if (!isInteger(x))
return make_msg("Must store integers");
} else if (strcmp(storage, "double") == 0) {
if (!isReal(x))
return make_msg("Must store doubles");
} else if (strcmp(storage, "numeric") == 0) {
if (!isStrictlyNumeric(x))
return make_msg("Must store numerics");
} else if (strcmp(storage, "complex") == 0) {
if (!isComplex(x))
return make_msg("Must store complexs");
} else if (strcmp(storage, "character") == 0) {
if (!isString(x))
return make_msg("Must store characters");
} else if (strcmp(storage, "list") == 0) {
if (!isRList(x))
return make_msg("Must store a list");
} else if (strcmp(storage, "atomic") == 0) {
if (!isVectorAtomic(x))
return make_msg("Must be atomic");
} else {
error("Invalid argument 'mode'. Must be one of 'logical', 'integer', 'double', 'numeric', 'complex', 'character', 'list' or 'atomic'");
}
}
return MSGT;
}
attribute_hidden
R_xlen_t asVecSize(SEXP x)
{
if (isVectorAtomic(x) && LENGTH(x) >= 1) {
switch (TYPEOF(x)) {
case INTSXP:
{
int res = INTEGER(x)[0];
if(res == NA_INTEGER) error(_("vector size cannot be NA"));
return (R_xlen_t) res;
}
case REALSXP:
{
double d = REAL(x)[0];
if(ISNAN(d)) error(_("vector size cannot be NA/NaN"));
if(!R_FINITE(d)) error(_("vector size cannot be infinite"));
if(d > R_XLEN_T_MAX) error(_("vector size specified is too large"));
return (R_xlen_t) d;
}
case STRSXP:
{
double d = asReal(x);
if(ISNAN(d)) error(_("vector size cannot be NA/NaN"));
if(!R_FINITE(d)) error(_("vector size cannot be infinite"));
if(d > R_XLEN_T_MAX) error(_("vector size specified is too large"));
return (R_xlen_t) d;
}
default:
break;
}
}
return -999; /* which gives error in the caller */
}
SEXP gsum(SEXP x, SEXP narm)
{
if (!isLogical(narm) || LENGTH(narm)!=1 || LOGICAL(narm)[0]==NA_LOGICAL) error("na.rm must be TRUE or FALSE");
if (!isVectorAtomic(x)) error("GForce sum can only be applied to columns, not .SD or similar. To sum all items in a list such as .SD, either add the prefix base::sum(.SD) or turn off GForce optimization using options(datatable.optimize=1). More likely, you may be looking for 'DT[,lappy(.SD,sum),by=,.SDcols=]'");
int i, thisgrp;
int n = LENGTH(x);
//clock_t start = clock();
SEXP ans;
if (grpn != length(x)) error("grpn [%d] != length(x) [%d] in gsum", grpn, length(x));
long double *s = malloc(ngrp * sizeof(long double));
if (!s) error("Unable to allocate %d * %d bytes for gsum", ngrp, sizeof(long double));
memset(s, 0, ngrp * sizeof(long double)); // all-0 bits == (long double)0, checked in init.c
switch(TYPEOF(x)) {
case LGLSXP: case INTSXP:
for (i=0; i<n; i++) {
thisgrp = grp[i];
if(INTEGER(x)[i] == NA_INTEGER) {
if (!LOGICAL(narm)[0]) s[thisgrp] = NA_REAL; // Let NA_REAL propogate from here. R_NaReal is IEEE.
continue;
}
s[thisgrp] += INTEGER(x)[i]; // no under/overflow here, s is long double (like base)
}
ans = PROTECT(allocVector(INTSXP, ngrp));
for (i=0; i<ngrp; i++) {
if (s[i] > INT_MAX || s[i] < INT_MIN) {
warning("Group %d summed to more than type 'integer' can hold so the result has been coerced to 'numeric' automatically, for convenience.", i+1);
UNPROTECT(1);
ans = PROTECT(allocVector(REALSXP, ngrp));
for (i=0; i<ngrp; i++) REAL(ans)[i] = (double)s[i];
break;
} else if (ISNA(s[i])) {
INTEGER(ans)[i] = NA_INTEGER;
} else {
INTEGER(ans)[i] = (int)s[i];
}
}
break;
case REALSXP:
ans = PROTECT(allocVector(REALSXP, ngrp));
for (i=0; i<n; i++) {
thisgrp = grp[i];
if(ISNAN(REAL(x)[i]) && LOGICAL(narm)[0]) continue; // else let NA_REAL propogate from here
s[thisgrp] += REAL(x)[i]; // done in long double, like base
}
for (i=0; i<ngrp; i++) {
if (s[i] > DBL_MAX) REAL(ans)[i] = R_PosInf;
else if (s[i] < -DBL_MAX) REAL(ans)[i] = R_NegInf;
else REAL(ans)[i] = (double)s[i];
}
break;
default:
free(s);
error("Type '%s' not supported by GForce sum (gsum). Either add the prefix base::sum(.) or turn off GForce optimization using options(datatable.optimize=1)", type2char(TYPEOF(x)));
}
free(s);
UNPROTECT(1);
// Rprintf("this gsum took %8.3f\n", 1.0*(clock()-start)/CLOCKS_PER_SEC);
return(ans);
}
SEXP c_check_scalar(SEXP x, SEXP na_ok) {
Rboolean is_na = is_scalar_na(x);
if (xlength(x) != 1 || (!is_na && !isVectorAtomic(x)))
return make_type_error(x, "atomic scalar");
if (is_na && !asFlag(na_ok, "na.ok"))
return make_result("May not be NA");
return ScalarLogical(TRUE);
}
SEXP c_check_atomic_vector(SEXP x, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isVectorAtomic(x))
return make_type_error(x, "atomic vector");
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_vector_unique(x, unique));
return ScalarLogical(TRUE);
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names, X, XX, FUN;
R_xlen_t i, n;
PROTECT_INDEX px;
checkArity(op, args);
PROTECT_WITH_INDEX(X = CAR(args), &px);
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
tmp = eval(R_fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(3);
}
UNPROTECT(3); /* X, XX, ans */
return ans;
}
/* 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;
}
// gmax
SEXP gmax(SEXP x, SEXP narm)
{
if (!isLogical(narm) || LENGTH(narm)!=1 || LOGICAL(narm)[0]==NA_LOGICAL) error("na.rm must be TRUE or FALSE");
if (!isVectorAtomic(x)) error("GForce max can only be applied to columns, not .SD or similar. To find max of all items in a list such as .SD, either add the prefix base::max(.SD) or turn off GForce optimization using options(datatable.optimize=1). More likely, you may be looking for 'DT[,lappy(.SD,max),by=,.SDcols=]'");
R_len_t i, thisgrp=0;
int n = LENGTH(x);
//clock_t start = clock();
SEXP ans;
if (grpn != length(x)) error("grpn [%d] != length(x) [%d] in gmax", grpn, length(x));
char *update = Calloc(ngrp, char);
if (update == NULL) error("Unable to allocate %d * %d bytes for gmax", ngrp, sizeof(char));
switch(TYPEOF(x)) {
case LGLSXP: case INTSXP:
ans = PROTECT(allocVector(INTSXP, ngrp));
for (i=0; i<ngrp; i++) INTEGER(ans)[i] = 0;
if (!LOGICAL(narm)[0]) { // simple case - deal in a straightforward manner first
for (i=0; i<n; i++) {
thisgrp = grp[i];
if (INTEGER(x)[i] != NA_INTEGER && INTEGER(ans)[thisgrp] != NA_INTEGER) {
if ( update[thisgrp] != 1 || INTEGER(ans)[thisgrp] < INTEGER(x)[i] ) {
INTEGER(ans)[thisgrp] = INTEGER(x)[i];
if (update[thisgrp] != 1) update[thisgrp] = 1;
}
} else INTEGER(ans)[thisgrp] = NA_INTEGER;
}
} else {
for (i=0; i<n; i++) {
thisgrp = grp[i];
if (INTEGER(x)[i] != NA_INTEGER) {
if ( update[thisgrp] != 1 || INTEGER(ans)[thisgrp] < INTEGER(x)[i] ) {
INTEGER(ans)[thisgrp] = INTEGER(x)[i];
if (update[thisgrp] != 1) update[thisgrp] = 1;
}
} else {
if (update[thisgrp] != 1) {
INTEGER(ans)[thisgrp] = NA_INTEGER;
}
}
}
for (i=0; i<ngrp; i++) {
if (update[i] != 1) {// equivalent of INTEGER(ans)[thisgrp] == NA_INTEGER
warning("No non-missing values found in at least one group. Coercing to numeric type and returning 'Inf' for such groups to be consistent with base");
UNPROTECT(1);
ans = PROTECT(coerceVector(ans, REALSXP));
for (i=0; i<ngrp; i++) {
if (update[i] != 1) REAL(ans)[i] = -R_PosInf;
}
}
}
}
break;
case REALSXP:
ans = PROTECT(allocVector(REALSXP, ngrp));
for (i=0; i<ngrp; i++) REAL(ans)[i] = 0;
if (!LOGICAL(narm)[0]) {
for (i=0; i<n; i++) {
thisgrp = grp[i];
if ( !ISNA(REAL(x)[i]) && !ISNA(REAL(ans)[thisgrp]) ) {
if ( update[thisgrp] != 1 || REAL(ans)[thisgrp] < REAL(x)[i] ) {
REAL(ans)[thisgrp] = REAL(x)[i];
if (update[thisgrp] != 1) update[thisgrp] = 1;
}
} else REAL(ans)[thisgrp] = NA_REAL;
}
} else {
for (i=0; i<n; i++) {
thisgrp = grp[i];
if ( !ISNA(REAL(x)[i]) ) {
if ( update[thisgrp] != 1 || REAL(ans)[thisgrp] < REAL(x)[i] ) {
REAL(ans)[thisgrp] = REAL(x)[i];
if (update[thisgrp] != 1) update[thisgrp] = 1;
}
} else {
if (update[thisgrp] != 1) {
REAL(ans)[thisgrp] = -R_PosInf;
}
}
}
// everything taken care of already. Just warn if all NA groups have occurred at least once
for (i=0; i<ngrp; i++) {
if (update[i] != 1) { // equivalent of REAL(ans)[thisgrp] == -R_PosInf
warning("No non-missing values found in at least one group. Returning '-Inf' for such groups to be consistent with base");
break;
}
}
}
break;
default:
error("Type '%s' not supported by GForce max (gmax). Either add the prefix base::max(.) or turn off GForce optimization using options(datatable.optimize=1)", type2char(TYPEOF(x)));
}
copyMostAttrib(x, ans); // all but names,dim and dimnames. And if so, we want a copy here, not keepattr's SET_ATTRIB.
UNPROTECT(1);
Free(update);
// Rprintf("this gmax took %8.3f\n", 1.0*(clock()-start)/CLOCKS_PER_SEC);
return(ans);
}
SEXP gmean(SEXP x, SEXP narm)
{
SEXP ans;
int i, protecti=0, thisgrp, n;
//clock_t start = clock();
if (!isLogical(narm) || LENGTH(narm)!=1 || LOGICAL(narm)[0]==NA_LOGICAL) error("na.rm must be TRUE or FALSE");
if (!isVectorAtomic(x)) error("GForce mean can only be applied to columns, not .SD or similar. Likely you're looking for 'DT[,lapply(.SD,mean),by=,.SDcols=]'. See ?data.table.");
if (!LOGICAL(narm)[0]) {
ans = PROTECT(gsum(x,narm)); protecti++;
switch(TYPEOF(ans)) {
case LGLSXP: case INTSXP:
ans = PROTECT(coerceVector(ans, REALSXP)); protecti++;
case REALSXP:
for (i=0; i<ngrp; i++) REAL(ans)[i] /= grpsize[i]; // let NA propogate
break;
default :
error("Internal error: gsum returned type '%s'. typeof(x) is '%s'", type2char(TYPEOF(ans)), type2char(TYPEOF(x)));
}
UNPROTECT(protecti);
return(ans);
}
// na.rm=TRUE. Similar to gsum, but we need to count the non-NA as well for the divisor
n = LENGTH(x);
if (grpn != n) error("grpn [%d] != length(x) [%d] in gsum", grpn, length(x));
long double *s = malloc(ngrp * sizeof(long double));
if (!s) error("Unable to allocate %d * %d bytes for sum in gmean na.rm=TRUE", ngrp, sizeof(long double));
memset(s, 0, ngrp * sizeof(long double)); // all-0 bits == (long double)0, checked in init.c
int *c = malloc(ngrp * sizeof(int));
if (!c) error("Unable to allocate %d * %d bytes for counts in gmean na.rm=TRUE", ngrp, sizeof(int));
memset(c, 0, ngrp * sizeof(int)); // all-0 bits == (int)0, checked in init.c
switch(TYPEOF(x)) {
case LGLSXP: case INTSXP:
for (i=0; i<n; i++) {
thisgrp = grp[i];
if(INTEGER(x)[i] == NA_INTEGER) continue;
s[thisgrp] += INTEGER(x)[i]; // no under/overflow here, s is long double
c[thisgrp]++;
}
break;
case REALSXP:
for (i=0; i<n; i++) {
thisgrp = grp[i];
if (ISNAN(REAL(x)[i])) continue;
s[thisgrp] += REAL(x)[i];
c[thisgrp]++;
}
break;
default:
free(s); free(c);
error("Type '%s' not supported by GForce mean (gmean) na.rm=TRUE. Either add the prefix base::mean(.) or turn off GForce optimization using options(datatable.optimize=1)", type2char(TYPEOF(x)));
}
ans = PROTECT(allocVector(REALSXP, ngrp));
for (i=0; i<ngrp; i++) {
if (c[i]==0) { REAL(ans)[i] = R_NaN; continue; } // NaN to follow base::mean
s[i] /= c[i];
if (s[i] > DBL_MAX) REAL(ans)[i] = R_PosInf;
else if (s[i] < -DBL_MAX) REAL(ans)[i] = R_NegInf;
else REAL(ans)[i] = (double)s[i];
}
free(s); free(c);
UNPROTECT(1);
// Rprintf("this gmean na.rm=TRUE took %8.3f\n", 1.0*(clock()-start)/CLOCKS_PER_SEC);
return(ans);
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; // -Wall
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
dim_v = getAttrib(value, R_DimSymbol);
array_value = CXXRCONSTRUCT(Rboolean, (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1));
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
val = eval(R_fcall, rho);
if (NAMED(val))
val = duplicate(val);
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
bool okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
default:
Rf_error(_("Internal error: unexpected SEXPTYPE"));
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
for (int j = 0; j < commonLen; j++) {
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break;
case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break;
case INTSXP: INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break;
case LGLSXP: LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break;
case RAWSXP: RAW(ans)[i*commonLen + j] = RAW(val)[j]; break;
case STRSXP: SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break;
case VECSXP: SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break;
default:
error(_("type '%s' is not supported"), type2char(commonType));
}
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = int( n); // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
SEXP transpose(SEXP l, SEXP fill, SEXP ignoreArg) {
R_len_t i, j, k=0, maxlen=0, zerolen=0, anslen;
SEXP li, thisi, ans;
SEXPTYPE type, maxtype=0;
Rboolean coerce = FALSE;
if (!isNewList(l))
error("l must be a list.");
if (!length(l))
return(duplicate(l));
if (!isLogical(ignoreArg) || LOGICAL(ignoreArg)[0] == NA_LOGICAL)
error("ignore.empty should be logical TRUE/FALSE.");
if (length(fill) != 1)
error("fill must be NULL or length=1 vector.");
R_len_t ln = LENGTH(l);
Rboolean ignore = LOGICAL(ignoreArg)[0];
// preprocessing
R_len_t *len = (R_len_t *)R_alloc(ln, sizeof(R_len_t));
for (i=0; i<ln; i++) {
li = VECTOR_ELT(l, i);
if (!isVectorAtomic(li) && !isNull(li))
error("Item %d of list input is not an atomic vector", i+1);
len[i] = length(li);
if (len[i] > maxlen)
maxlen = len[i];
zerolen += (len[i] == 0);
if (isFactor(li)) {
maxtype = STRSXP;
} else {
type = TYPEOF(li);
if (type > maxtype)
maxtype = type;
}
}
// coerce fill to maxtype
fill = PROTECT(coerceVector(fill, maxtype));
// allocate 'ans'
ans = PROTECT(allocVector(VECSXP, maxlen));
anslen = (!ignore) ? ln : (ln - zerolen);
for (i=0; i<maxlen; i++) {
SET_VECTOR_ELT(ans, i, thisi=allocVector(maxtype, anslen) );
}
// transpose
for (i=0; i<ln; i++) {
if (ignore && !len[i]) continue;
li = VECTOR_ELT(l, i);
if (TYPEOF(li) != maxtype) {
coerce = TRUE;
if (!isFactor(li)) li = PROTECT(coerceVector(li, maxtype));
else li = PROTECT(asCharacterFactor(li));
}
switch (maxtype) {
case INTSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
INTEGER(thisi)[k] = (j < len[i]) ? INTEGER(li)[j] : INTEGER(fill)[0];
}
break;
case LGLSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
LOGICAL(thisi)[k] = (j < len[i]) ? LOGICAL(li)[j] : LOGICAL(fill)[0];
}
break;
case REALSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
REAL(thisi)[k] = (j < len[i]) ? REAL(li)[j] : REAL(fill)[0];
}
break;
case STRSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
SET_STRING_ELT(thisi, k, (j < len[i]) ? STRING_ELT(li, j) : STRING_ELT(fill, 0));
}
break;
default :
error("Unsupported column type '%s'", type2char(maxtype));
}
if (coerce) {
coerce = FALSE;
UNPROTECT(1);
}
k++;
}
UNPROTECT(2);
return(ans);
}
/*
Compares dimensions, but detects implicit classes by checking if atomic and
having dimensions and reports error as such if that is the case.
If there is an implicit class error res.lvl will be set to 1
tar_obj and cur_obj are the objects the dimensions are the attributes off.
*/
struct ALIKEC_res_sub ALIKEC_compare_dims(
SEXP target, SEXP current, SEXP tar_obj, SEXP cur_obj,
struct ALIKEC_settings set
) {
// Invalid dims
if(
(TYPEOF(target) != INTSXP && target != R_NilValue) ||
(TYPEOF(current) != INTSXP && current != R_NilValue)
)
return ALIKEC_alike_attr(target, current, R_DimSymbol, set, 0);
// Dims -> implicit class
R_xlen_t target_len = xlength(target), target_len_cap;
target_len_cap = target_len > (R_xlen_t) 3 ? (R_xlen_t) 3 : target_len;
R_xlen_t current_len = xlength(current), current_len_cap;
current_len_cap = current_len > (R_xlen_t) 3 ? (R_xlen_t) 3 : current_len;
struct ALIKEC_res_sub res = ALIKEC_res_sub_def();
const char * class_err_target = "";
const char * class_err_actual = "";
if(target_len_cap > 1 && isVectorAtomic(tar_obj)) {
if(current == R_NilValue) { // current should be matrix/array
class_err_target = target_len_cap > 2 ? "array" : "matrix";
class_err_actual = CHAR(asChar(ALIKEC_mode(cur_obj)));
} else if(isVectorAtomic(cur_obj) && current_len_cap != target_len_cap) {
// target is matrix/array
class_err_target = target_len_cap > 2 ? "array" : "matrix";
class_err_actual = current_len_cap == 2 ?
"matrix" : (current_len_cap == 1 ? "vector" : "array");
} else if(!isVectorAtomic(cur_obj)) {
// In this case, target is atomic, but current is not, would normally be
// caught by earlier type comparisons so shouldn't get here unless testing
// explicitly
class_err_target = CHAR(asChar(ALIKEC_mode(tar_obj)));
class_err_actual = type2char(TYPEOF(cur_obj));
}
} else if (current_len_cap > 1 && isVectorAtomic(cur_obj)) {
if(isVectorAtomic(tar_obj)) {
class_err_target = CHAR(asChar(ALIKEC_mode(tar_obj)));
class_err_actual = current_len_cap == 2 ? "matrix" : "array";
} else {
class_err_target = CHAR(asChar(ALIKEC_mode(tar_obj)));
class_err_actual = CHAR(asChar(ALIKEC_mode(cur_obj)));
}
}
if(class_err_target[0]) {
res.success = 0;
res.lvl = 1;
res.message = ALIKEC_res_msg_def(
"be",
CSR_smprintf4(ALIKEC_MAX_CHAR, "\"%s\"", class_err_target, "", "", ""),
"is",
CSR_smprintf4(ALIKEC_MAX_CHAR, "\"%s\"", class_err_actual, "", "", "")
);
return res;
}
// Normal dim checking
if(current == R_NilValue) {
res.success = 0;
res.message = ALIKEC_res_msg_def("have", "a \"dim\" attribute", "", "");
return res;
}
if(target_len != current_len) {
res.success = 0;
res.message = ALIKEC_res_msg_def(
"have",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "%s dimension%s",
CSR_len_as_chr(target_len), target_len == (R_xlen_t) 1 ? "" : "s",
"", ""
),
"has",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "%s", CSR_len_as_chr(current_len), "", "", ""
));
return res;
}
R_xlen_t attr_i;
int tar_dim_val;
for(attr_i = (R_xlen_t)0; attr_i < target_len; attr_i++) {
tar_dim_val = INTEGER(target)[attr_i];
const char * tar_dim_chr = CSR_len_as_chr((R_xlen_t)tar_dim_val);
char * err_dim1, * err_dim2;
if(tar_dim_val && tar_dim_val != INTEGER(current)[attr_i]) {
if(target_len == 2) { // Matrix
err_dim1 = "";
const char * err_dimtmp;
switch(attr_i) {
case (R_xlen_t) 0: err_dimtmp = "row%s"; break;
case (R_xlen_t) 1: err_dimtmp = "column%s"; break;
default:
// nocov start
error(
"%s%s",
"Internal Error: inconsistent matrix dimensions; contact ",
"maintainer."
);
// nocov end
}
err_dim2 = (char *) CSR_smprintf4(
ALIKEC_MAX_CHAR, err_dimtmp, tar_dim_val == 1 ? "" : "s", "", "", ""
);
} else {
err_dim1 = "size ";
err_dim2 = (char *) CSR_smprintf4(
ALIKEC_MAX_CHAR, "at dimension %s",
CSR_len_as_chr((R_xlen_t)(attr_i + 1)), "", "", ""
);}
res.success = 0;
res.message = ALIKEC_res_msg_def(
"have",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "%s%s %s",
(const char *) err_dim1, tar_dim_chr, (const char *) err_dim2, ""
),
"has",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "%s",
CSR_len_as_chr((R_xlen_t)(INTEGER(current)[attr_i])), "", "", ""
));
return res;
} }
return ALIKEC_alike_attr(target, current, R_DimSymbol, set, 1);
}
SEXP writetable(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, sep, rnames, eol, na, dec, quote, xj;
int nr, nc, i, j, qmethod;
Rboolean wasopen, quote_rn = FALSE, *quote_col;
Rconnection con;
const char *csep, *ceol, *cna, *sdec, *tmp=NULL /* -Wall */;
char cdec;
SEXP *levels;
R_StringBuffer strBuf = {NULL, 0, MAXELTSIZE};
wt_info wi;
RCNTXT cntxt;
args = CDR(args);
x = CAR(args); args = CDR(args);
/* this is going to be a connection open or openable for writing */
if(!inherits(CAR(args), "connection"))
error(_("'file' is not a connection"));
con = getConnection(asInteger(CAR(args))); args = CDR(args);
if(!con->canwrite)
error(_("cannot write to this connection"));
wasopen = con->isopen;
if(!wasopen) {
strcpy(con->mode, "wt");
if(!con->open(con)) error(_("cannot open the connection"));
}
nr = asInteger(CAR(args)); args = CDR(args);
nc = asInteger(CAR(args)); args = CDR(args);
rnames = CAR(args); args = CDR(args);
sep = CAR(args); args = CDR(args);
eol = CAR(args); args = CDR(args);
na = CAR(args); args = CDR(args);
dec = CAR(args); args = CDR(args);
quote = CAR(args); args = CDR(args);
qmethod = asLogical(CAR(args));
if(nr == NA_INTEGER) error(_("invalid '%s' argument"), "nr");
if(nc == NA_INTEGER) error(_("invalid '%s' argument"), "nc");
if(!isNull(rnames) && !isString(rnames))
error(_("invalid '%s' argument"), "rnames");
if(!isString(sep)) error(_("invalid '%s' argument"), "sep");
if(!isString(eol)) error(_("invalid '%s' argument"), "eol");
if(!isString(na)) error(_("invalid '%s' argument"), "na");
if(!isString(dec)) error(_("invalid '%s' argument"), "dec");
if(qmethod == NA_LOGICAL) error(_("invalid '%s' argument"), "qmethod");
csep = translateChar(STRING_ELT(sep, 0));
ceol = translateChar(STRING_ELT(eol, 0));
cna = translateChar(STRING_ELT(na, 0));
sdec = translateChar(STRING_ELT(dec, 0));
if(strlen(sdec) != 1)
error(_("'dec' must be a single character"));
cdec = sdec[0];
quote_col = (Rboolean *) R_alloc(nc, sizeof(Rboolean));
for(j = 0; j < nc; j++) quote_col[j] = FALSE;
for(i = 0; i < length(quote); i++) { /* NB, quote might be NULL */
int this = INTEGER(quote)[i];
if(this == 0) quote_rn = TRUE;
if(this > 0) quote_col[this - 1] = TRUE;
}
R_AllocStringBuffer(0, &strBuf);
PrintDefaults();
wi.savedigits = R_print.digits; R_print.digits = DBL_DIG;/* MAX precision */
wi.con = con;
wi.wasopen = wasopen;
wi.buf = &strBuf;
begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &wt_cleanup;
cntxt.cenddata = &wi;
if(isVectorList(x)) { /* A data frame */
/* handle factors internally, check integrity */
levels = (SEXP *) R_alloc(nc, sizeof(SEXP));
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(LENGTH(xj) != nr)
error(_("corrupt data frame -- length of column %d does not not match nrows"), j+1);
if(inherits(xj, "factor")) {
levels[j] = getAttrib(xj, R_LevelsSymbol);
} else levels[j] = R_NilValue;
}
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(xj, i)) tmp = cna;
else {
if(!isNull(levels[j])) {
/* We do not assume factors have integer levels,
although they should. */
if(TYPEOF(xj) == INTSXP)
tmp = EncodeElement2(levels[j], INTEGER(xj)[i] - 1,
quote_col[j], qmethod,
&strBuf, cdec);
else if(TYPEOF(xj) == REALSXP)
tmp = EncodeElement2(levels[j],
(int) (REAL(xj)[i] - 1),
quote_col[j], qmethod,
&strBuf, cdec);
else
error("column %s claims to be a factor but does not have numeric codes", j+1);
} else {
tmp = EncodeElement2(xj, i, quote_col[j], qmethod,
&strBuf, cdec);
}
/* if(cdec) change_dec(tmp, cdec, TYPEOF(xj)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
} else { /* A matrix */
if(!isVectorAtomic(x))
UNIMPLEMENTED_TYPE("write.table, matrix method", x);
/* quick integrity check */
if(LENGTH(x) != nr * nc)
error(_("corrupt matrix -- dims not not match length"));
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(x, i + j*nr)) tmp = cna;
else {
tmp = EncodeElement2(x, i + j*nr, quote_col[j], qmethod,
&strBuf, cdec);
/* if(cdec) change_dec(tmp, cdec, TYPEOF(x)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
}
endcontext(&cntxt);
wt_cleanup(&wi);
return R_NilValue;
}
SEXP attribute_hidden do_cat(SEXP call, SEXP op, SEXP args, SEXP rho)
{
cat_info ci;
RCNTXT cntxt;
SEXP objs, file, fill, sepr, labs, s;
int ifile;
Rconnection con;
int append;
int i, iobj, n, nobjs, pwidth, width, sepw, lablen, ntot, nlsep, nlines;
char buf[512];
const char *p = "";
checkArity(op, args);
/* Use standard printing defaults */
PrintDefaults();
objs = CAR(args);
args = CDR(args);
file = CAR(args);
ifile = asInteger(file);
con = getConnection(ifile);
if(!con->canwrite) /* if it is not open, we may not know yet */
error(_("cannot write to this connection"));
args = CDR(args);
sepr = CAR(args);
if (!isString(sepr))
error(_("invalid '%s' specification"), "sep");
nlsep = 0;
for (i = 0; i < LENGTH(sepr); i++)
if (strstr(CHAR(STRING_ELT(sepr, i)), "\n")) nlsep = 1; /* ASCII */
args = CDR(args);
fill = CAR(args);
if ((!isNumeric(fill) && !isLogical(fill)) || (length(fill) != 1))
error(_("invalid '%s' argument"), "fill");
if (isLogical(fill)) {
if (asLogical(fill) == 1)
pwidth = R_print.width;
else
pwidth = INT_MAX;
}
else pwidth = asInteger(fill);
if(pwidth <= 0) {
warning(_("non-positive 'fill' argument will be ignored"));
pwidth = INT_MAX;
}
args = CDR(args);
labs = CAR(args);
if (!isString(labs) && labs != R_NilValue)
error(_("invalid '%s' argument"), "labels");
lablen = length(labs);
args = CDR(args);
append = asLogical(CAR(args));
if (append == NA_LOGICAL)
error(_("invalid '%s' specification"), "append");
ci.wasopen = con->isopen;
ci.changedcon = switch_stdout(ifile, 0);
/* will open new connection if required, and check for writeable */
#ifdef Win32
/* do this after re-sinking output */
WinCheckUTF8();
#endif
ci.con = con;
/* set up a context which will close the connection if there is an error */
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &cat_cleanup;
cntxt.cenddata = &ci;
nobjs = length(objs);
width = 0;
ntot = 0;
nlines = 0;
for (iobj = 0; iobj < nobjs; iobj++) {
s = VECTOR_ELT(objs, iobj);
if (iobj != 0 && !isNull(s))
cat_printsep(sepr, ntot++);
n = length(s);
/* 0-length objects are ignored */
if (n > 0) {
if (labs != R_NilValue && (iobj == 0)
&& (asInteger(fill) > 0)) {
Rprintf("%s ", trChar(STRING_ELT(labs, nlines % lablen)));
/* FIXME -- Rstrlen allows for double-width chars */
width += Rstrlen(STRING_ELT(labs, nlines % lablen), 0) + 1;
nlines++;
}
if (isString(s))
p = trChar(STRING_ELT(s, 0));
else if (isSymbol(s)) /* length 1 */
p = CHAR(PRINTNAME(s));
else if (isVectorAtomic(s)) {
/* Not a string, as that is covered above.
Thus the maximum size is about 60.
The copy is needed as cat_newline might reuse the buffer.
Use strncpy is in case these assumptions change.
*/
p = EncodeElement0(s, 0, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
#ifdef fixed_cat
else if (isVectorList(s)) {
/* FIXME: call EncodeElement() for every element of s.
Real Problem: `s' can be large;
should do line breaking etc.. (buf is of limited size)
*/
}
#endif
else
errorcall(call,
_("argument %d (type '%s') cannot be handled by 'cat'"),
1+iobj, type2char(TYPEOF(s)));
/* FIXME : cat(...) should handle ANYTHING */
size_t w = strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
if ((iobj > 0) && (width + w + sepw > pwidth)) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
for (i = 0; i < n; i++, ntot++) {
Rprintf("%s", p);
width += (int)(w + sepw);
if (i < (n - 1)) {
cat_printsep(sepr, ntot);
if (isString(s))
p = trChar(STRING_ELT(s, i+1));
else {
p = EncodeElement0(s, i+1, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
w = (int) strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
/* This is inconsistent with the version above.
As from R 2.3.0, fill <= 0 is ignored. */
if ((width + w + sepw > pwidth) && pwidth) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
} else ntot--; /* we don't print sep after last, so don't advance */
}
}
}
if ((pwidth != INT_MAX) || nlsep)
Rprintf("\n");
/* end the context after anything that could raise an error but before
doing the cleanup so the cleanup doesn't get done twice */
endcontext(&cntxt);
cat_cleanup(&ci);
return R_NilValue;
}
SEXP shift(SEXP obj, SEXP k, SEXP fill, SEXP type) {
size_t size;
int protecti=0;
SEXP x, tmp=R_NilValue, elem, ans, thisfill, klass;
unsigned long long *dthisfill;
enum {LAG, LEAD/*, SHIFT, CYCLIC*/} stype = LAG; // currently SHIFT maps to LAG and CYCLIC is unimplemented (see comments in #1708)
if (!xlength(obj)) return(obj); // NULL, list()
if (isVectorAtomic(obj)) {
x = PROTECT(allocVector(VECSXP, 1)); protecti++;
SET_VECTOR_ELT(x, 0, obj);
} else x = obj;
if (!isNewList(x))
error("x must be a list, data.frame or data.table");
if (length(fill) != 1)
error("fill must be a vector of length 1");
// the following two errors should be caught by match.arg() at the R level
if (!isString(type) || length(type) != 1)
error("Internal error: invalid type for shift(), should have been caught before. please report to data.table issue tracker"); // # nocov
if (!strcmp(CHAR(STRING_ELT(type, 0)), "lag")) stype = LAG;
else if (!strcmp(CHAR(STRING_ELT(type, 0)), "lead")) stype = LEAD;
else if (!strcmp(CHAR(STRING_ELT(type, 0)), "shift")) stype = LAG; // when we get rid of nested if branches we can use SHIFT, for now it maps to LAG
else error("Internal error: invalid type for shift(), should have been caught before. please report to data.table issue tracker"); // # nocov
int nx = length(x), nk = length(k);
if (!isInteger(k)) error("Internal error: k must be integer"); // # nocov
const int *kd = INTEGER(k);
for (int i=0; i<nk; i++) if (kd[i]==NA_INTEGER) error("Item %d of n is NA", i+1); // NA crashed (#3354); n is called k at C level
ans = PROTECT(allocVector(VECSXP, nk * nx)); protecti++;
for (int i=0; i<nx; i++) {
elem = VECTOR_ELT(x, i);
size = SIZEOF(elem);
R_xlen_t xrows = xlength(elem);
switch (TYPEOF(elem)) {
case INTSXP :
thisfill = PROTECT(coerceVector(fill, INTSXP)); protecti++;
int ifill = INTEGER(thisfill)[0];
for (int j=0; j<nk; j++) {
R_xlen_t thisk = MIN(abs(kd[j]), xrows);
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(INTSXP, xrows) );
int *itmp = INTEGER(tmp);
size_t tailk = xrows-thisk;
if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
// LAG when type = 'lag' and n >= 0 _or_ type = 'lead' and n < 0
if (tailk > 0) memmove(itmp+thisk, INTEGER(elem), tailk*size);
for (int m=0; m<thisk; m++) itmp[m] = ifill;
} else {
// only two possibilities left: type = 'lead', n>=0 _or_ type = 'lag', n<0
if (tailk > 0) memmove(itmp, INTEGER(elem)+thisk, tailk*size);
for (int m=xrows-thisk; m<xrows; m++) itmp[m] = ifill;
}
copyMostAttrib(elem, tmp);
if (isFactor(elem)) setAttrib(tmp, R_LevelsSymbol, getAttrib(elem, R_LevelsSymbol));
}
break;
case REALSXP :
klass = getAttrib(elem, R_ClassSymbol);
if (isString(klass) && STRING_ELT(klass, 0) == char_integer64) {
thisfill = PROTECT(allocVector(REALSXP, 1)); protecti++;
dthisfill = (unsigned long long *)REAL(thisfill);
if (INTEGER(fill)[0] == NA_INTEGER)
dthisfill[0] = NA_INT64_LL;
else dthisfill[0] = (unsigned long long)INTEGER(fill)[0];
} else {
thisfill = PROTECT(coerceVector(fill, REALSXP)); protecti++;
}
double dfill = REAL(thisfill)[0];
for (int j=0; j<nk; j++) {
R_xlen_t thisk = MIN(abs(kd[j]), xrows);
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(REALSXP, xrows) );
double *dtmp = REAL(tmp);
size_t tailk = xrows-thisk;
if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
if (tailk > 0) memmove(dtmp+thisk, REAL(elem), tailk*size);
for (int m=0; m<thisk; m++) dtmp[m] = dfill;
} else {
if (tailk > 0) memmove(dtmp, REAL(elem)+thisk, tailk*size);
for (int m=tailk; m<xrows; m++) dtmp[m] = dfill;
}
copyMostAttrib(elem, tmp);
}
break;
case LGLSXP :
thisfill = PROTECT(coerceVector(fill, LGLSXP)); protecti++;
int lfill = LOGICAL(thisfill)[0];
for (int j=0; j<nk; j++) {
R_xlen_t thisk = MIN(abs(kd[j]), xrows);
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(LGLSXP, xrows) );
int *ltmp = LOGICAL(tmp);
size_t tailk = xrows-thisk;
if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
if (tailk > 0) memmove(ltmp+thisk, LOGICAL(elem), tailk*size);
for (int m=0; m<thisk; m++) ltmp[m] = lfill;
} else {
if (tailk > 0) memmove(ltmp, LOGICAL(elem)+thisk, tailk*size);
for (int m=tailk; m<xrows; m++) ltmp[m] = lfill;
}
copyMostAttrib(elem, tmp);
}
break;
case STRSXP :
thisfill = PROTECT(coerceVector(fill, STRSXP)); protecti++;
for (int j=0; j<nk; j++) {
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(STRSXP, xrows) );
int thisk = abs(kd[j]);
if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
for (int m=0; m<xrows; m++) SET_STRING_ELT(tmp, m, (m < thisk) ? STRING_ELT(thisfill, 0) : STRING_ELT(elem, m - thisk));
} else {
for (int m=0; m<xrows; m++) SET_STRING_ELT(tmp, m, (xrows-m <= thisk) ? STRING_ELT(thisfill, 0) : STRING_ELT(elem, m + thisk));
}
copyMostAttrib(elem, tmp);
}
break;
case VECSXP :
thisfill = PROTECT(coerceVector(fill, VECSXP)); protecti++;
for (int j=0; j<nk; j++) {
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(VECSXP, xrows) );
int thisk = abs(kd[j]);
if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
for (int m=0; m<xrows; m++) SET_VECTOR_ELT(tmp, m, (m < thisk) ? VECTOR_ELT(thisfill, 0) : VECTOR_ELT(elem, m - thisk));
} else {
for (int m=0; m<xrows; m++) SET_VECTOR_ELT(tmp, m, (xrows-m <= thisk) ? VECTOR_ELT(thisfill, 0) : VECTOR_ELT(elem, m + thisk));
}
copyMostAttrib(elem, tmp);
}
break;
default :
error("Unsupported type '%s'", type2char(TYPEOF(elem)));
}
}
UNPROTECT(protecti);
return isVectorAtomic(obj) && length(ans) == 1 ? VECTOR_ELT(ans, 0) : ans;
}
