SEXP coredata (SEXP x, SEXP copyAttr)
{
/* copyAttr is a LGLSXP flag to indicate whether all
attributes are to be left intact. This provides
compatability with xts, by stripping all attributes
if desired, without the overhead or adding then
removing
*/
SEXP result;
int i, j, ncs, nrs;
int P=0;
PROTECT(result = allocVector(TYPEOF(x), length(x))); P++;
switch( TYPEOF(x)) {
case REALSXP:
memcpy(REAL(result), REAL(x), length(result) * sizeof(double));
break;
case INTSXP:
memcpy(INTEGER(result), INTEGER(x), length(result) * sizeof(int));
break;
case LGLSXP:
memcpy(LOGICAL(result), LOGICAL(x), length(result) * sizeof(int));
break;
case CPLXSXP:
memcpy(COMPLEX(result), COMPLEX(x), length(result) * sizeof(Rcomplex));
break;
case STRSXP:
ncs = ncols(x); nrs = nrows(x);
for(j=0; j< ncs; j++)
for(i=0; i< nrs; i++)
SET_STRING_ELT(result, i+j*nrs, STRING_ELT(x, i+j*nrs));
break;
case RAWSXP:
memcpy(RAW(result), RAW(x), length(result) * sizeof(unsigned char));
break;
default:
error("currently unsupported data type");
break;
}
if( !isNull(getAttrib(x, R_DimSymbol))) {
setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
if( !isNull(getAttrib(x, R_DimNamesSymbol)) ) {
setAttrib(result, R_DimNamesSymbol, getAttrib(x,R_DimNamesSymbol));
}
} else {
setAttrib(result, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
if( asLogical(copyAttr)) {
copyMostAttrib(x,result);
setAttrib(result, R_ClassSymbol, getAttrib(x, install("oclass")));
}
setAttrib(result, xts_IndexSymbol, R_NilValue);
setAttrib(result, install("oclass"), R_NilValue);
setAttrib(result, install("frequency"), R_NilValue);
UNPROTECT(P);
return result;
}
SEXP rev (SEXP x) {
SEXP res;
int i, r, P=0;
PROTECT(res = allocVector(REALSXP, length(x))); P++;
for(i=length(x), r=0; i>0; i--, r++) {
REAL(res)[r] = REAL(x)[i-1];
}
copyMostAttrib(x, res);
UNPROTECT(P);
return res;
}
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;
}
// 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 attribute_hidden do_earg_transpose(SEXP call, SEXP op, SEXP arg_x, SEXP rho)
{
SEXP a, r, dims, dimnames, dimnamesnames = R_NilValue,
ndimnamesnames, rnames, cnames;
int ldim, ncol = 0, nrow = 0;
R_xlen_t len = 0;
a = arg_x;
if (isVector(a)) {
dims = getDimAttrib(a);
ldim = length(dims);
rnames = R_NilValue;
cnames = R_NilValue;
switch(ldim) {
case 0:
len = nrow = LENGTH(a);
ncol = 1;
rnames = getNamesAttrib(a);
dimnames = rnames;/* for isNull() below*/
break;
case 1:
len = nrow = LENGTH(a);
ncol = 1;
dimnames = getDimNamesAttrib(a);
if (dimnames != R_NilValue) {
rnames = VECTOR_ELT(dimnames, 0);
dimnamesnames = getNamesAttrib(dimnames);
}
break;
case 2:
ncol = ncols(a);
nrow = nrows(a);
len = XLENGTH(a);
dimnames = getDimNamesAttrib(a);
if (dimnames != R_NilValue) {
rnames = VECTOR_ELT(dimnames, 0);
cnames = VECTOR_ELT(dimnames, 1);
dimnamesnames = getNamesAttrib(dimnames);
}
break;
default:
goto not_matrix;
}
}
else
goto not_matrix;
PROTECT(r = allocVector(TYPEOF(a), len));
R_xlen_t i, j, l_1 = len-1;
switch (TYPEOF(a)) {
case LGLSXP:
case INTSXP:
// filling in columnwise, "accessing row-wise":
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
INTEGER(r)[i] = INTEGER(a)[j];
}
break;
case REALSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
REAL(r)[i] = REAL(a)[j];
}
break;
case CPLXSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
COMPLEX(r)[i] = COMPLEX(a)[j];
}
break;
case STRSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
SET_STRING_ELT(r, i, STRING_ELT(a,j));
}
break;
case VECSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
SET_VECTOR_ELT(r, i, VECTOR_ELT(a,j));
}
break;
case RAWSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
RAW(r)[i] = RAW(a)[j];
}
break;
default:
UNPROTECT(1);
goto not_matrix;
}
PROTECT(dims = allocVector(INTSXP, 2));
INTEGER(dims)[0] = ncol;
INTEGER(dims)[1] = nrow;
setAttrib(r, R_DimSymbol, dims);
UNPROTECT(1);
/* R <= 2.2.0: dropped list(NULL,NULL) dimnames :
* if(rnames != R_NilValue || cnames != R_NilValue) */
if(!isNull(dimnames)) {
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 0, cnames);
SET_VECTOR_ELT(dimnames, 1, rnames);
if(!isNull(dimnamesnames)) {
PROTECT(ndimnamesnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(ndimnamesnames, 1, STRING_ELT(dimnamesnames, 0));
SET_VECTOR_ELT(ndimnamesnames, 0,
(ldim == 2) ? STRING_ELT(dimnamesnames, 1):
R_BlankString);
setAttrib(dimnames, R_NamesSymbol, ndimnamesnames);
UNPROTECT(1);
}
setAttrib(r, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
copyMostAttrib(a, r);
UNPROTECT(1);
return r;
not_matrix:
error(_("argument is not a matrix"));
return call;/* never used; just for -Wall */
}
SEXP copyattr(SEXP from, SEXP to)
{
// for use by [.data.table to retain attribs such as "comments" when subsetting and j is missing
copyMostAttrib(from, to);
return(R_NilValue);
}
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 {
SEXP readSlicePorStream(SEXP porStream, SEXP what, SEXP s_vars, SEXP s_cases, SEXP s_types){
porStreamBuf *b = get_porStreamBuf(porStream);
PROTECT(s_vars = coerceVector(s_vars,LGLSXP));
PROTECT(s_cases = coerceVector(s_cases,LGLSXP));
PROTECT(s_types = coerceVector(s_types,INTSXP));
int nvar = length(s_types);
int ncases = length(s_cases);
int *types = INTEGER(s_types);
if(LENGTH(s_vars)!=nvar) error("\'s_vars\' argument has wrong length");
int ii,i,j,k, m=0, n = 0;
for(j = 0; j < nvar; j++) m+=LOGICAL(s_vars)[j];
for(i = 0; i < ncases; i++) n+=LOGICAL(s_cases)[i];
SEXP x, y, data;
char *charbuf;
int charbuflen = 0;
PROTECT(data = allocVector(VECSXP,m));
k = 0;
for(j = 0; j < nvar; j++){
if(types[j] > charbuflen) charbuflen = types[j];
if(LOGICAL(s_vars)[j]){
if(types[j]==0)
SET_VECTOR_ELT(data,k,allocVector(REALSXP,n));
else {
SET_VECTOR_ELT(data,k,allocVector(STRSXP,n));
}
k++;
}
}
charbuf = R_alloc(charbuflen+1,sizeof(char));
ii = 0;
for(i = 0; i < ncases; i++){
if(atEndPorStream(b) || (b->pos < 80 && b->buf[b->pos] == 'Z')){
int new_length = ii;
for(j = 0; j < m; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
if(LOGICAL(s_cases)[i]){
k = 0;
for(j = 0; j < nvar; j++){
if(atEndPorStream(b)) {
printPorStreamBuf(b);
warning("\nPremature end of data");
}
if(types[j]==0){
if(LOGICAL(s_vars)[j]){
REAL(VECTOR_ELT(data,k))[ii] = readDoublePorStream1(b);
k++;
}
else {
readDoublePorStream1(b);
}
}
else {
if(LOGICAL(s_vars)[j]){
SET_STRING_ELT(VECTOR_ELT(data,k), ii,
mkChar(readCHARPorStream(b,charbuf,types[j])));
k++;
}
else {
readCHARPorStream(b,charbuf,types[j]);
}
}
}
ii++;
}
else {
for(j = 0; j < nvar; j++){
if(atEndPorStream(b)) {
printPorStreamBuf(b);
error("\nPremature end of data");
}
if(types[j]==0) readDoublePorStream1(b);
else readCHARPorStream(b,charbuf,types[j]);
}
}
}
k = 0;
for(j = 0; j < nvar; j++){
if(LOGICAL(s_vars)[j]){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,k);
copyMostAttrib(x,y);
k++;
}
}
UNPROTECT(4);
return data;
}
//SEXP do_rbind_xts (SEXP x, SEXP y, SEXP env) {{{
SEXP do_rbind_xts (SEXP x, SEXP y, SEXP dup)
{
int nrx, ncx, nry, ncy, truelen, len;
int no_duplicate = LOGICAL(dup)[0];
int i, j, ij, ij_x, ij_y, xp=1, yp=1, add_y=0;
int P=0; // PROTECT counter
int mode;
SEXP result, xindex, yindex, newindex;
int *int_result=NULL, *int_x=NULL, *int_y=NULL;
int *int_newindex=NULL, *int_xindex=NULL, *int_yindex=NULL;
double *real_result=NULL, *real_x=NULL, *real_y=NULL;
double *real_newindex=NULL, *real_xindex=NULL, *real_yindex=NULL;
nrx = nrows(x);
ncx = ncols(x);
nry = nrows(y);
ncy = ncols(y);
truelen = len = nrx + nry;
if( isNull(x) || isNull(y) ) {
/* Handle NULL values by returning non-null object */
if(!isNull(x)) return x;
return y;
}
if( !isXts(x) ) {
PROTECT( x = tryXts(x) ); P++;
}
if( !isXts(y) ) {
PROTECT( y = tryXts(y) ); P++;
}
/* need to convert different types of x and y if needed */
if( TYPEOF(x) != TYPEOF(y) ) {
warning("mismatched types: converting objects to numeric"); // FIXME not working!!!????
PROTECT(x = coerceVector(x, REALSXP)); P++;
PROTECT(y = coerceVector(y, REALSXP)); P++;
}
mode = TYPEOF(x);
if(ncx != ncy)
error("data must have same number of columns to bind by row");
PROTECT(xindex = getAttrib(x, xts_IndexSymbol)); P++;
PROTECT(yindex = getAttrib(y, xts_IndexSymbol)); P++;
if( TYPEOF(xindex) != TYPEOF(yindex) )
{
PROTECT(xindex = coerceVector(xindex, REALSXP)); P++;
PROTECT(yindex = coerceVector(yindex, REALSXP)); P++;
}
#ifdef RBIND_APPEND
if(TYPEOF(xindex)==REALSXP) {
if(REAL(xindex)[length(xindex)-1] < REAL(yindex)[0]) {
UNPROTECT(P);
return rbind_append(x,y);
}
} else
if(TYPEOF(xindex)==INTSXP) {
if(INTEGER(xindex)[length(xindex)-1] < INTEGER(yindex)[0]) {
UNPROTECT(P);
return rbind_append(x,y);
}
}
#endif
PROTECT(newindex = allocVector(TYPEOF(xindex), len)); P++;
PROTECT(result = allocVector(TYPEOF(x), len * ncx)); P++;
copyMostAttrib(xindex, newindex);
switch( TYPEOF(x) ) {
case INTSXP:
int_x = INTEGER(x);
int_y = INTEGER(y);
int_result = INTEGER(result);
break;
case REALSXP:
real_x = REAL(x);
real_y = REAL(y);
real_result = REAL(result);
break;
default:
break;
}
/*
if( TYPEOF(xindex) == REALSXP ) {
if(REAL(xindex)[nrx-1] < REAL(yindex)[0]) {
memcpy(REAL(newindex), REAL(xindex), sizeof(double) * nrx);
memcpy(REAL(newindex)+nrx, REAL(yindex), sizeof(double) * nry);
switch(TYPEOF(x)) {
case INTSXP:
memcpy(INTEGER(result), INTEGER(x), sizeof(int) * (nrx*ncx));
memcpy(INTEGER(result)+(nrx*ncx), INTEGER(y), sizeof(int) * (nry*ncy));
break;
case REALSXP:
memcpy(REAL(result), REAL(x), sizeof(double) * (nrx*ncx));
memcpy(REAL(result)+(nrx*ncx), REAL(y), sizeof(double) * (nry*ncy));
break;
default:
break;
}
UNPROTECT(P);
return(result);
}
} else {
}
*/
/*
The main body of code to follow branches based on the type
of index, removing the need to test at each position.
*/
if( TYPEOF(xindex) == REALSXP ) {
real_newindex = REAL(newindex);
real_xindex = REAL(xindex);
real_yindex = REAL(yindex);
for( i = 0; i < len; i++ ) {
if( i >= truelen ) {
break;
} else
if( xp > nrx ) {
real_newindex[ i ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
} else
if( yp > nry ) {
real_newindex[ i ] = real_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( real_xindex[ xp-1 ] == real_yindex[ yp-1 ] ) {
if( real_xindex[ xp-1 ] < real_xindex[ xp ] )
add_y = 1; /* add y values only if next xindex is new */
if(no_duplicate) {
add_y = 0;
truelen--;
}
real_newindex[ i ] = real_xindex[ xp-1 ];
if(add_y) real_newindex[ i+ 1 ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
if(add_y) int_result[ ij+1 ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
if(add_y) real_result[ ij+1 ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
xp++;
if(no_duplicate || add_y) {
yp++;
if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values
add_y = 0;
}
} else
if( real_xindex[ xp-1 ] < real_yindex[ yp-1 ] ) {
real_newindex[ i ] = real_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( real_xindex[ xp-1 ] > real_yindex[ yp-1 ] ) {
real_newindex[ i ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
}
}
} else
if( TYPEOF(xindex) == INTSXP ) {
int_newindex = INTEGER(newindex);
int_xindex = INTEGER(xindex);
int_yindex = INTEGER(yindex);
for(i = 0; i < len; i++) {
/*Rprintf("xp:%i, yp:%i, i:%i\n",xp,yp,i);*/
if( i >= truelen ) {
break;
} else
if( xp > nrx ) {
int_newindex[ i ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
} else
if( yp > nry ) {
int_newindex[ i ] = int_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( int_xindex[ xp-1 ] == int_yindex[ yp-1 ] ) {
if( int_xindex[ xp-1 ] < int_xindex[ xp ] )
add_y = 1;
if(no_duplicate) {
add_y = 0;
truelen--;
}
int_newindex[ i ] = int_xindex[ xp-1 ];
if(add_y) int_newindex[ i+1 ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
if(add_y) int_result[ ij+1 ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
if(add_y) real_result[ ij+1 ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
xp++;
if(no_duplicate || add_y) {
yp++;
if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values
add_y = 0;
}
} else
if( int_xindex[ xp-1 ] < int_yindex[ yp-1 ] ) {
int_newindex[ i ] = int_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( int_xindex[ xp-1 ] > int_yindex[ yp-1 ] ) {
int_newindex[ i ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
}}
}
if(truelen != len) {
PROTECT(result = lengthgets(result, truelen * ncx)); P++; /* reset length */
}
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SEXP dim;
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = truelen;
INTEGER(dim)[1] = INTEGER(getAttrib(x, R_DimSymbol))[1];
UNPROTECT(1);
setAttrib(result, R_DimSymbol, dim);
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
if(truelen != len) {
PROTECT(newindex = lengthgets(newindex, truelen)); P++;
}
setAttrib(result, xts_IndexSymbol, newindex);
setAttrib(result, xts_IndexClassSymbol, getAttrib(x, xts_IndexClassSymbol));
setAttrib(result, xts_IndexTZSymbol, getAttrib(x, xts_IndexTZSymbol));
setAttrib(result, xts_IndexFormatSymbol, getAttrib(x, xts_IndexFormatSymbol));
setAttrib(result, xts_ClassSymbol, getAttrib(x, xts_ClassSymbol));
copy_xtsAttributes(x, result);
UNPROTECT(P);
return result;
} //}}}
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);
}
// TO DO: margins
SEXP fcast(SEXP lhs, SEXP val, SEXP nrowArg, SEXP ncolArg, SEXP idxArg, SEXP fill, SEXP fill_d, SEXP is_agg) {
int nrows=INTEGER(nrowArg)[0], ncols=INTEGER(ncolArg)[0];
int i,j,k, nlhs=length(lhs), nval=length(val), *idx = INTEGER(idxArg), thisidx;;
SEXP thiscol, target, ans, thisfill;
Rboolean isfill = TRUE, count;
ans = PROTECT(allocVector(VECSXP, nlhs + (nval * ncols)));
// set lhs cols
for (i=0; i < nlhs; i++) {
SET_VECTOR_ELT(ans, i, VECTOR_ELT(lhs, i));
}
// get val cols
for (i=0; i<nval; i++) {
thiscol = VECTOR_ELT(val, i);
thisfill = fill;
count = FALSE;
if (isNull(fill)) {
isfill = FALSE;
if (LOGICAL(is_agg)[0]) {
thisfill = PROTECT(allocNAVector(TYPEOF(thiscol), 1));
count = TRUE;
} else thisfill = VECTOR_ELT(fill_d, i);
}
if (isfill && TYPEOF(fill) != TYPEOF(thiscol)) {
thisfill = PROTECT(coerceVector(fill, TYPEOF(thiscol)));
count = TRUE;
}
switch (TYPEOF(thiscol)) {
case INTSXP:
for (j=0; j<ncols; j++) {
target = allocVector(TYPEOF(thiscol), nrows);
SET_VECTOR_ELT(ans, nlhs+j+i*ncols, target);
copyMostAttrib(thiscol, target);
for (k=0; k<nrows; k++) {
thisidx = idx[k*ncols + j];
INTEGER(target)[k] = (thisidx == NA_INTEGER) ? INTEGER(thisfill)[0] : INTEGER(thiscol)[thisidx-1];
}
}
break;
case REALSXP:
for (j=0; j<ncols; j++) {
target = allocVector(TYPEOF(thiscol), nrows);
SET_VECTOR_ELT(ans, nlhs+j+i*ncols, target);
copyMostAttrib(thiscol, target);
for (k=0; k<nrows; k++) {
thisidx = idx[k*ncols + j];
REAL(target)[k] = (thisidx == NA_INTEGER) ? REAL(thisfill)[0] : REAL(thiscol)[thisidx-1];
}
}
break;
case LGLSXP:
for (j=0; j<ncols; j++) {
target = allocVector(TYPEOF(thiscol), nrows);
SET_VECTOR_ELT(ans, nlhs+j+i*ncols, target);
copyMostAttrib(thiscol, target);
for (k=0; k<nrows; k++) {
thisidx = idx[k*ncols + j];
LOGICAL(target)[k] = (thisidx == NA_INTEGER) ? LOGICAL(thisfill)[0] : LOGICAL(thiscol)[thisidx-1];
}
}
break;
case STRSXP:
for (j=0; j<ncols; j++) {
target = allocVector(TYPEOF(thiscol), nrows);
SET_VECTOR_ELT(ans, nlhs+j+i*ncols, target);
copyMostAttrib(thiscol, target);
for (k=0; k<nrows; k++) {
thisidx = idx[k*ncols + j];
SET_STRING_ELT(target, k, (thisidx == NA_INTEGER) ? STRING_ELT(thisfill, 0) : STRING_ELT(thiscol, thisidx-1));
}
}
break;
case VECSXP:
for (j=0; j<ncols; j++) {
target = allocVector(TYPEOF(thiscol), nrows);
SET_VECTOR_ELT(ans, nlhs+j+i*ncols, target);
copyMostAttrib(thiscol, target);
for (k=0; k<nrows; k++) {
thisidx = idx[k*ncols + j];
SET_VECTOR_ELT(target, k, (thisidx == NA_INTEGER) ? VECTOR_ELT(thisfill, 0) : VECTOR_ELT(thiscol, thisidx-1));
}
}
break;
}
if (count) UNPROTECT(1);
}
UNPROTECT(1);
return(ans);
}
SEXP extract_col (SEXP x, SEXP j, SEXP drop, SEXP first_, SEXP last_) {
SEXP result, index, new_index;
int nrs, nrsx, i, ii, jj, first, last;
nrsx = nrows(x);
first = asInteger(first_)-1;
last = asInteger(last_)-1;
/* nrs = offset_end - offset_start - 1; */
nrs = last - first + 1;
PROTECT(result = allocVector(TYPEOF(x), nrs * length(j)));
switch(TYPEOF(x)) {
case REALSXP:
for(i=0; i<length(j); i++) {
/*
Rprintf("j + i*nrs + first=%i\n", (int)(INTEGER(j)[i]-1 + i*nrs + first));
Rprintf("i=%i, j=%i, nrs=%i, first=%i\n", i, INTEGER(j)[i]-1, nrs, first);
*/
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
REAL(result)[(i*nrs) + ii] = NA_REAL;
}
} else {
memcpy(&(REAL(result)[i*nrs]),
&(REAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(double));
}
}
break;
case INTSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
INTEGER(result)[(i*nrs) + ii] = NA_INTEGER;
}
} else {
memcpy(&(INTEGER(result)[i*nrs]),
&(INTEGER(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(int));
}
}
break;
case LGLSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
LOGICAL(result)[(i*nrs) + ii] = NA_LOGICAL;
}
} else {
memcpy(&(LOGICAL(result)[i*nrs]),
&(LOGICAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(int));
}
}
break;
case CPLXSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
COMPLEX(result)[(i*nrs) + ii].r = NA_REAL;
COMPLEX(result)[(i*nrs) + ii].i = NA_REAL;
}
} else {
memcpy(&(COMPLEX(result)[i*nrs]),
&(COMPLEX(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(i=0; i<length(j); i++) {
if(INTEGER(j)[i] == NA_INTEGER) {
for(ii=0; ii < nrs; ii++) {
RAW(result)[(i*nrs) + ii] = 0;
}
} else {
memcpy(&(RAW(result)[i*nrs]),
&(RAW(x)[(INTEGER(j)[i]-1)*nrsx + first]),
nrs*sizeof(Rbyte));
}
}
break;
case STRSXP:
for(jj=0; jj<length(j); jj++) {
if(INTEGER(j)[jj] == NA_INTEGER) {
for(i=0; i< nrs; i++)
SET_STRING_ELT(result, i+jj*nrs, NA_STRING);
} else {
for(i=0; i< nrs; i++)
SET_STRING_ELT(result, i+jj*nrs, STRING_ELT(x, i+(INTEGER(j)[jj]-1)*nrsx+first));
}
}
break;
default:
error("unsupported type");
}
if(nrs != nrows(x)) {
copyAttributes(x, result);
/* subset index */
index = getAttrib(x, install("index"));
PROTECT(new_index = allocVector(TYPEOF(index), nrs));
if(TYPEOF(index) == REALSXP) {
memcpy(REAL(new_index), &(REAL(index)[first]), nrs*sizeof(double));
} else { /* INTSXP */
memcpy(INTEGER(new_index), &(INTEGER(index)[first]), nrs*sizeof(int));
}
copyMostAttrib(index, new_index);
setAttrib(result, install("index"), new_index);
UNPROTECT(1);
} else {
copyMostAttrib(x, result); /* need an xts/zoo equal that skips 'index' */
}
if(!asLogical(drop)) { /* keep dimension and dimnames */
SEXP dim;
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = nrs;
INTEGER(dim)[1] = length(j);
setAttrib(result, R_DimSymbol, dim);
UNPROTECT(1);
SEXP dimnames, currentnames, newnames;
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(newnames = allocVector(STRSXP, length(j)));
currentnames = getAttrib(x, R_DimNamesSymbol);
if(!isNull(currentnames)) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(currentnames,0));
if(!isNull(VECTOR_ELT(currentnames,1))) {
/* if colnames isn't NULL set */
for(i=0; i<length(j); i++) {
SET_STRING_ELT(newnames, i, STRING_ELT(VECTOR_ELT(currentnames,1), INTEGER(j)[i]-1));
}
SET_VECTOR_ELT(dimnames, 1, newnames);
} else {
/* else set to NULL */
SET_VECTOR_ELT(dimnames, 1, R_NilValue);
}
setAttrib(result, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
UNPROTECT(1);
return result;
}
static SEXP subsetVectorRaw(SEXP x, SEXP idx, int l, int tl)
// Only for use by subsetDT() or subsetVector() below, hence static
// l is the count of non-zero (including NAs) in idx i.e. the length of the result
// tl is the amount to be allocated, tl>=l
// TO DO: if no 0 or NA detected up front in subsetDT() below, could switch to a faster subsetVectorRawNo0orNA()
{
int i, this, ansi=0, max=length(x), n=LENGTH(idx), *pidx=INTEGER(idx);
if (tl<l) error("Internal error: tl<n passed to subsetVectorRaw");
SEXP ans = PROTECT(allocVector(TYPEOF(x), tl));
SETLENGTH(ans, l);
SET_TRUELENGTH(ans, tl);
// Rprintf("l=%d, tl=%d, LENGTH(idx)=%d\n", l, tl, LENGTH(idx));
#ifdef _OPENMP
int *ctr = (int *)calloc(omp_get_max_threads()+1, sizeof(int));
#endif
switch(TYPEOF(x)) {
case INTSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads(); // local
// computing count indices correctly is tricky when there are 0-indices.
// 1. count number of non-0 'idx' for each thread
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0); // don't use ctr[ithread+1] here -- false sharing
// TODO: use SIMD here?
ctr[ithread+1] = tmp; // ctr[0]=0, rest contains count where iidx!=0,
// within each thread's range
#pragma omp barrier // wait for all threads, important
// 2. using that, set the starting index for each thread appropriately
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i]; // for each thread, compute the right starting point, by
// taking (non)0-count into account, computed above.
tmp = ctr[ithread]; // copy back from shared to thread's local var. All set.
#pragma omp barrier // wait for all threads, important
// 3. use old code, but with thread's local var with right start index as counter
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
// have to use 'tmp' here, and not ctr[ithread++] -- false sharing
INTEGER(ans)[tmp++] = (this==NA_INTEGER || this>max) ? NA_INTEGER : INTEGER(x)[this-1];
ansi++; // not required, but just to be sure
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
INTEGER(ans)[ansi++] = (this==NA_INTEGER || this>max) ? NA_INTEGER : INTEGER(x)[this-1];
}
#endif
break;
case REALSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
REAL(ans)[tmp++] = (this==NA_INTEGER || this>max) ? NA_REAL : REAL(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
REAL(ans)[ansi++] = (this==NA_INTEGER || this>max) ? NA_REAL : REAL(x)[this-1];
}
#endif
break;
case LGLSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
LOGICAL(ans)[tmp++] = (this==NA_INTEGER || this>max) ? NA_LOGICAL : LOGICAL(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
LOGICAL(ans)[ansi++] = (this==NA_INTEGER || this>max) ? NA_LOGICAL : LOGICAL(x)[this-1];
}
#endif
break;
case STRSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_STRING_ELT(ans, tmp++, (this==NA_INTEGER || this>max) ? NA_STRING : STRING_ELT(x, this-1));
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_STRING_ELT(ans, ansi++, (this==NA_INTEGER || this>max) ? NA_STRING : STRING_ELT(x, this-1));
}
#endif
break;
case VECSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_VECTOR_ELT(ans, tmp++, (this==NA_INTEGER || this>max) ? R_NilValue : VECTOR_ELT(x, this-1));
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
SET_VECTOR_ELT(ans, ansi++, (this==NA_INTEGER || this>max) ? R_NilValue : VECTOR_ELT(x, this-1));
}
#endif
break;
// Fix for #982
// source: https://github.com/wch/r-source/blob/fbf5cdf29d923395b537a9893f46af1aa75e38f3/src/main/subset.c
case CPLXSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
if (this == NA_INTEGER || this>max) {
COMPLEX(ans)[tmp].r = NA_REAL;
COMPLEX(ans)[tmp++].i = NA_REAL;
} else COMPLEX(ans)[tmp++] = COMPLEX(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this == 0) continue;
if (this == NA_INTEGER || this>max) {
COMPLEX(ans)[ansi].r = NA_REAL;
COMPLEX(ans)[ansi].i = NA_REAL;
} else COMPLEX(ans)[ansi] = COMPLEX(x)[this-1];
ansi++;
}
#endif
break;
case RAWSXP :
#ifdef _OPENMP
#pragma omp parallel
{
int tmp=0, ithread = omp_get_thread_num(), nthreads = omp_get_num_threads();
#pragma omp for
for (i=0; i<n; i++) tmp += (pidx[i] != 0);
ctr[ithread+1] = tmp;
#pragma omp barrier
#pragma omp single
for (i=0; i<nthreads; i++)
ctr[i+1] += ctr[i];
tmp = ctr[ithread];
#pragma omp barrier
#pragma omp for private(this) reduction(+:ansi)
for (i=0; i<n; i++) {
this = pidx[i];
if (this==0) continue;
RAW(ans)[tmp++] = (this == NA_INTEGER || this>max) ? (Rbyte) 0 : RAW(x)[this-1];
ansi++;
}
}
#else
for (i=0; i<n; i++) {
this = pidx[i];
if (this == 0) continue;
RAW(ans)[ansi++] = (this == NA_INTEGER || this>max) ? (Rbyte) 0 : RAW(x)[this-1];
}
#endif
break;
default :
error("Unknown column type '%s'", type2char(TYPEOF(x)));
}
#ifdef _OPENMP
free(ctr);
#endif
if (ansi != l) error("Internal error: ansi [%d] != l [%d] at the end of subsetVector", ansi, l);
copyMostAttrib(x, ans);
UNPROTECT(1);
return(ans);
}
SEXP rbind_append (SEXP x, SEXP y) {
/*
Provide fast row binding of xts objects if the
left-hand object (binding target) has a last
index value less than the right-hand object
(object to bind). This is an optimization to allow
for real-time updating of objects without having to
do much more than a memcpy of the two in coordinated
fashion
*/
/*Rprintf("rbind_append called\n");*/
SEXP result;
int nrs_x, nrs_y, ncs_x, ncs_y, nr;
int i;
ncs_x = ncols(x); ncs_y = ncols(y); nrs_x = nrows(x); nrs_y = nrows(y);
if(ncs_x != ncs_y)
error("objects must have the same number of columns"); /* FIXME */
PROTECT(result = allocVector(TYPEOF(x), (nrs_x + nrs_y) * ncs_x));
nr = nrs_x + nrs_y;
switch(TYPEOF(x)) {
case REALSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(REAL(result)[i*nr]),
&(REAL(x)[i*nrs_x]),
nrs_x*sizeof(double));
memcpy(&(REAL(result)[i*nr + nrs_x]),
&(REAL(y)[i*nrs_y]),
nrs_y*sizeof(double));
}
break;
case INTSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(INTEGER(result)[i*nr]),
&(INTEGER(x)[i*nrs_x]),
nrs_x*sizeof(int));
memcpy(&(INTEGER(result)[i*nr + nrs_x]),
&(INTEGER(y)[i*nrs_y]),
nrs_y*sizeof(int));
}
break;
case LGLSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(LOGICAL(result)[i*nr]),
&(LOGICAL(x)[i*nrs_x]),
nrs_x*sizeof(int));
memcpy(&(LOGICAL(result)[i*nr + nrs_x]),
&(LOGICAL(y)[i*nrs_y]),
nrs_y*sizeof(int));
}
break;
case CPLXSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(COMPLEX(result)[i*nr]),
&(COMPLEX(x)[i*nrs_x]),
nrs_x*sizeof(Rcomplex));
memcpy(&(COMPLEX(result)[i*nr + nrs_x]),
&(COMPLEX(y)[i*nrs_y]),
nrs_y*sizeof(Rcomplex));
}
break;
case RAWSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(RAW(result)[i*nr]),
&(RAW(x)[i*nrs_x]),
nrs_x*sizeof(Rbyte));
memcpy(&(RAW(result)[i*nr + nrs_x]),
&(RAW(y)[i*nrs_y]),
nrs_y*sizeof(Rbyte));
}
break;
case STRSXP:
/* this requires an explicit loop like rbind.c and
needs to be left with rbind.c
*/
break;
default:
error("unsupported type");
}
copyAttributes(x, result);
SEXP index, xindex, yindex;
xindex = getAttrib(x,install("index"));
yindex = getAttrib(y,install("index"));
int INDEXTYPE = TYPEOF(xindex);
if(INDEXTYPE != NILSXP) {
PROTECT(index = allocVector(INDEXTYPE, nr));
if(INDEXTYPE==REALSXP) {
memcpy(REAL(index), REAL(xindex), nrs_x * sizeof(double));
memcpy(&(REAL(index)[nrs_x]), REAL(yindex), nrs_y * sizeof(double));
} else
if(INDEXTYPE==INTSXP) {
memcpy(INTEGER(index), INTEGER(xindex), nrs_x * sizeof(int));
memcpy(&(INTEGER(index)[nrs_x]), INTEGER(yindex), nrs_y * sizeof(int));
}
copyMostAttrib(xindex, index);
setAttrib(result, install("index"), index);
UNPROTECT(1);
}
SEXP dim;
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = nr;
INTEGER(dim)[1] = ncs_x; /* should be the same */
setAttrib(result, R_DimSymbol, dim);
UNPROTECT(1);
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
/*
SEXP dimnames, currentnames, newnames;
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(newnames = allocVector(STRSXP, length(j)));
currentnames = getAttrib(x, R_DimNamesSymbol);
if(!isNull(currentnames)) {
SET_VECTOR_ELT(dimnames, 0, R_NilValue);
for(i=0; i<ncs_x; i++) {
SET_STRING_ELT(newnames, i, STRING_ELT(VECTOR_ELT(currentnames,1), i));
}
SET_VECTOR_ELT(dimnames, 1, newnames);
setAttrib(result, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
*/
UNPROTECT(1);
return result;
}
SEXP readfixedsubset(SEXP s_file, SEXP what, SEXP s_vars, SEXP s_cases, SEXP s_start, SEXP s_stop){
FILE *f = rofile_FILE(s_file);
PROTECT(s_vars = coerceVector(s_vars,LGLSXP));
PROTECT(s_cases = coerceVector(s_cases,LGLSXP));
PROTECT(s_start = coerceVector(s_start,INTSXP));
PROTECT(s_stop = coerceVector(s_stop,INTSXP));
if(LENGTH(s_start) != LENGTH(s_stop)) error("start and stop must have equal length");
if(LENGTH(s_vars) != LENGTH(s_stop)) error("vars argument has wrong length");
int m = 0, n = 0;
int nvar = LENGTH(what);
int ncases = LENGTH(s_cases);
int ii,i,j,k;
for(i = 0; i < LENGTH(s_cases); i++) n += LOGICAL(s_cases)[i];
for(j = 0; j < LENGTH(s_vars); j++) m += LOGICAL(s_vars)[j];
int *start = INTEGER(s_start);
int *stop = INTEGER(s_stop);
int max_lenline = stop[nvar-1];
char *buffer = R_alloc(max_lenline+3,1);
char *item, *currdata;
SEXP data;
PROTECT(data = allocVector(VECSXP,m));
SEXP x, y;
int *length = (int *) R_alloc(nvar,sizeof(int));
int maxlen = 0;
k = 0;
for(j = 0; j < nvar; j++){
length[j] = stop[j] - start[j] + 1;
if(LOGICAL(s_vars)[j]){
if(maxlen < length[j]) maxlen = length[j];
x = VECTOR_ELT(what,j);
SET_VECTOR_ELT(data,k,lengthgets(x,n));
k++;
}
}
item = R_alloc(maxlen+1,1);
ii = 0;
for(i = 0; i < ncases; i++){
memset(buffer,0,max_lenline+3);
buffer = fgets(buffer,max_lenline+3,f);
#ifdef DEBUG
Rprintf("Requested line length: %d\n",max_lenline);
Rprintf("Actual line length: %d\n",strlen(buffer));
Rprintf("Buffer: >>%s<<\n",buffer);
#endif
if(strlen(buffer)< max_lenline) {
int new_length = i;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
if(LOGICAL(s_cases)[i]){
currdata = buffer;
k = 0;
for(j = 0; j < nvar; j++){
currdata = buffer + start[j]-1;
if(LOGICAL(s_vars)[j]){
x = VECTOR_ELT(data,k);
memset(item,0,maxlen+1);
memcpy(item,currdata,length[j]);
trim(item,length[j]);
#ifdef DEBUG
Rprintf("Item: >>%s<<\n",item);
#endif
#undef DEBUG
if(TYPEOF(x)==INTSXP)
INTEGER(x)[ii] = _R_atoi(item);
else if (TYPEOF(x)==REALSXP)
REAL(x)[ii] = _R_atof(item);
else
SET_STRING_ELT(x,ii,mkChar(item));
k++;
}
}
ii++;
}
}
k = 0;
for(j = 0; j < nvar; j++){
if(LOGICAL(s_vars)[j]){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,k);
copyMostAttrib(x,y);
k++;
}
}
UNPROTECT(5);
return data;
}
SEXP fastmean(SEXP args)
{
long double s = 0., t = 0.;
R_len_t i, l = 0, n = 0;
SEXP x, ans, tmp;
Rboolean narm=FALSE;
x=CADR(args);
if (length(args)>2) {
tmp = CADDR(args);
if (!isLogical(tmp) || LENGTH(tmp)!=1 || LOGICAL(tmp)[0]==NA_LOGICAL)
error("narm should be TRUE or FALSE");
narm=LOGICAL(tmp)[0];
}
PROTECT(ans = allocNAVector(REALSXP, 1));
if (!isInteger(x) && !isReal(x) && !isLogical(x)) {
warning("argument is not numeric or logical: returning NA");
UNPROTECT(1);
return(ans);
}
l = LENGTH(x);
if (narm) {
switch(TYPEOF(x)) {
case LGLSXP:
case INTSXP:
for (i = 0; i<l; i++) {
if(INTEGER(x)[i] == NA_INTEGER) continue;
s += INTEGER(x)[i]; // no under/overflow here, s is long double not integer
n++;
}
if (n>0)
REAL(ans)[0] = (double) (s/n);
else
REAL(ans)[0] = R_NaN; // consistent with base: mean(NA,na.rm=TRUE)==NaN==mean(numeric(),na.rm=TRUE)
break;
case REALSXP:
for (i = 0; i<l; i++) {
if(ISNAN(REAL(x)[i])) continue; // TO DO: could drop this line and let NA propogate?
s += REAL(x)[i];
n++;
}
if (n==0) {
REAL(ans)[0] = R_NaN;
break;
}
s /= n;
if(R_FINITE((double)s)) {
for (i = 0; i<l; i++) {
if(ISNAN(REAL(x)[i])) continue;
t += (REAL(x)[i] - s);
}
s += t/n;
}
REAL(ans)[0] = (double) s;
break;
default:
error("Type '%s' not supported in fastmean", type2char(TYPEOF(x)));
}
} else { // narm==FALSE
switch(TYPEOF(x)) {
case LGLSXP:
case INTSXP:
for (i = 0; i<l; i++) {
if(INTEGER(x)[i] == NA_INTEGER) {UNPROTECT(1); return(ans);}
s += INTEGER(x)[i];
}
REAL(ans)[0] = (double) (s/l);
break;
case REALSXP:
for (i = 0; i<l; i++) {
if(ISNAN(REAL(x)[i])) {UNPROTECT(1); return(ans);}
s += REAL(x)[i];
}
s /= l;
if(R_FINITE((double)s)) {
for (i = 0; i<l; i++) {
// no NA if got this far
t += (REAL(x)[i] - s);
}
s += t/LENGTH(x);
}
REAL(ans)[0] = (double) s;
break;
default:
error("Type '%s' not supported in fastmean", type2char(TYPEOF(x)));
}
}
copyMostAttrib(x, ans);
UNPROTECT(1);
return(ans);
}
SEXP readfixed(SEXP s_file, SEXP what, SEXP s_nlines, SEXP s_start, SEXP s_stop){
PROTECT(s_start = coerceVector(s_start,INTSXP));
PROTECT(s_stop = coerceVector(s_stop,INTSXP));
FILE *f = rofile_FILE(s_file);
if(LENGTH(s_start) != LENGTH(s_stop)) error("start and stop must have equal length");
int n = asInteger(s_nlines);
int nvar = LENGTH(s_start);
int *start = INTEGER(s_start);
int *stop = INTEGER(s_stop);
int max_lenline = stop[nvar-1];
char *buffer = R_alloc(max_lenline+3,1);
char *item, *currdata;
SEXP data;
PROTECT(data=allocVector(VECSXP,nvar));
int i,j;
int *length = (int *) R_alloc(nvar,sizeof(int));
int maxlen = 0;
SEXP x,y;
for(j = 0; j < nvar; j++){
length[j] = stop[j] - start[j] + 1;
if(maxlen < length[j]) maxlen = length[j];
x = VECTOR_ELT(what,j);
SET_VECTOR_ELT(data,j,lengthgets(x,n));
}
item = R_alloc(maxlen+1,1);
#undef DEBUG
#ifdef DEBUG
Rprintf("Requested number of lines: %d\n",n);
#endif
for(i = 0; i < n; i++){
memset(buffer,0,max_lenline+3);
buffer = fgets(buffer,max_lenline+3,f);
#ifdef DEBUG
Rprintf("Requested line length: %d\n",max_lenline);
Rprintf("Actual line length: %d\n",strlen(buffer));
if(i == 0)
Rprintf("Buffer: >>%s<<\n",buffer);
#endif
if(strlen(buffer)< max_lenline) {
int new_length = i;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
currdata = buffer;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
currdata = buffer + start[j]-1;
memset(item,0,maxlen+1);
memcpy(item,currdata,length[j]);
trim(item,length[j]);
#undef DEBUG
if(TYPEOF(x)==INTSXP)
INTEGER(x)[i] = _R_atoi(item);
else if (TYPEOF(x)==REALSXP)
REAL(x)[i] = _R_atof(item);
else
SET_STRING_ELT(x,i,mkChar(item));
}
}
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,j);
copyMostAttrib(x,y);
}
UNPROTECT(3);
return data;
}
SEXP readDataPorStream(SEXP porStream, SEXP what, SEXP s_n, SEXP s_types){
#ifdef DEBUG
Rprintf("\n############################");
Rprintf("\n#readDataPorStream");
Rprintf("\n############################");
#endif
porStreamBuf *b = get_porStreamBuf(porStream);
int n = asInteger(s_n);
#ifdef DEBUG
Rprintf("\nRequired number of cases: %d",n);
Rprintf("\nBuffer contents: |%s|",b->buf);
Rprintf("\nLine: %d",b->line);
Rprintf("\nPosition: %d",b->pos);
Rprintf("\nBuffer remainder: %s",b->buf + b->pos);
#endif
PROTECT(s_types = coerceVector(s_types,INTSXP));
int nvar = length(s_types);
int *types = INTEGER(s_types);
SEXP x, y, data;
char *charbuf;
int charbuflen = 0;
PROTECT(data = allocVector(VECSXP,nvar));
int i,j;
for(j = 0; j < nvar; j++){
if(types[j]==0)
SET_VECTOR_ELT(data,j,allocVector(REALSXP,n));
else {
SET_VECTOR_ELT(data,j,allocVector(STRSXP,n));
if(types[j] > charbuflen) charbuflen = types[j];
}
}
charbuf = R_alloc(charbuflen+1,sizeof(char));
#ifdef DEBUG
// PrintValue(data);
#endif
for(i = 0; i < n; i++){
if(atEndPorStream(b) || (b->pos < 80 && b->buf[b->pos] == 'Z')){
#ifdef DEBUG
Rprintf("\nReached end of cases at i=%d",i);
#endif
int new_length = i;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
#ifdef DEBUG
Rprintf("\nCase number: %d\n",i);
#endif
for(j = 0; j < nvar; j++){
if(atEndPorStream(b)) {
printPorStreamBuf(b);
warning("\nPremature end of data");
break;
}
#ifdef DEBUG
PrintValue(VECTOR_ELT(data,j));
#endif
if(types[j]==0) REAL(VECTOR_ELT(data,j))[i] = readDoublePorStream1(b);
else SET_STRING_ELT(VECTOR_ELT(data,j), i,
mkChar(readCHARPorStream(b,charbuf,types[j])));
#ifdef DEBUG
if(i<3 && types[j]>0)
PrintValue(STRING_ELT(VECTOR_ELT(data,j),i));
#endif
}
}
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,j);
copyMostAttrib(x,y);
}
UNPROTECT(2);
return data;
}
SEXP attribute_hidden complex_binary(ARITHOP_TYPE code, SEXP s1, SEXP s2)
{
R_xlen_t i,i1, i2, n, n1, n2;
SEXP ans;
/* Note: "s1" and "s2" are protected in the calling code. */
n1 = XLENGTH(s1);
n2 = XLENGTH(s2);
/* S4-compatibility change: if n1 or n2 is 0, result is of length 0 */
if (n1 == 0 || n2 == 0) return(allocVector(CPLXSXP, 0));
n = (n1 > n2) ? n1 : n2;
ans = R_allocOrReuseVector(s1, s2, CPLXSXP, n);
PROTECT(ans);
switch (code) {
case PLUSOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
Rcomplex x1 = COMPLEX(s1)[i1], x2 = COMPLEX(s2)[i2];
COMPLEX(ans)[i].r = x1.r + x2.r;
COMPLEX(ans)[i].i = x1.i + x2.i;
}
break;
case MINUSOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
Rcomplex x1 = COMPLEX(s1)[i1], x2 = COMPLEX(s2)[i2];
COMPLEX(ans)[i].r = x1.r - x2.r;
COMPLEX(ans)[i].i = x1.i - x2.i;
}
break;
case TIMESOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_C99_COMPLEX(COMPLEX(ans), i,
C99_COMPLEX2(s1, i1) * C99_COMPLEX2(s2, i2));
}
break;
case DIVOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_C99_COMPLEX(COMPLEX(ans), i,
C99_COMPLEX2(s1, i1) / C99_COMPLEX2(s2, i2));
}
break;
case POWOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_C99_COMPLEX(COMPLEX(ans), i,
mycpow(C99_COMPLEX2(s1, i1), C99_COMPLEX2(s2, i2)));
}
break;
default:
error(_("unimplemented complex operation"));
}
UNPROTECT(1);
/* quick return if there are no attributes */
if (ATTRIB(s1) == R_NilValue && ATTRIB(s2) == R_NilValue)
return ans;
/* Copy attributes from longer argument. */
if (ans != s2 && n == n2 && ATTRIB(s2) != R_NilValue)
copyMostAttrib(s2, ans);
if (ans != s1 && n == n1 && ATTRIB(s1) != R_NilValue)
copyMostAttrib(s1, ans); /* Done 2nd so s1's attrs overwrite s2's */
return ans;
}
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;
}
