SEXP do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
if (isFactor(CAR(args)) && isFactor(CADR(args))) {
if (length(CAR(args)) != length(CADR(args)))
errorcall(call, _("unequal factor lengths"));
return(cross(CAR(args), CADR(args)));
}
return seq(call, CAR(args), CADR(args));
}
int numDivisors(int num)
{
int i, numdivs, midpt;
numdivs = 0;
midpt = sqrt(num);
for(i=1; i<=midpt; i++)
if (isFactor(i, num))
numdivs++;
numdivs *= 2;
if(isFactor(midpt,num))
numdivs--;
return numdivs;
}
// [[register]]
SEXP factor_to_char( SEXP X_, SEXP inplace_ ) {
int inplace = asInteger(inplace_);
int numprotect = 0;
SEXP X;
if (inplace) {
X = X_;
} else {
PROTECT( X = duplicate(X_) );
++numprotect;
}
if( TYPEOF(X) == VECSXP ) {
SEXP out = recurse_factor_to_char( X, X, 0);
UNPROTECT(numprotect);
return out;
} else {
if( isFactor(X) ) {
SEXP out = asCharacterFactor(X);
UNPROTECT(numprotect);
return out;
} else {
warning("X is neither a list nor a factor; no change done");
UNPROTECT(numprotect);
return X;
}
}
}
/* NumberTextCtrl::getNumber
* Returns the number currently entered. If it's an incrememt or
* decrement, returns [base] incremented/decremented by the number
*******************************************************************/
int NumberTextCtrl::getNumber(int base)
{
string val = GetValue();
// Get integer value
long lval;
if (val.IsEmpty())
return 0;
else if (val.StartsWith("--") || val.StartsWith("++") || val.StartsWith("**") || val.StartsWith("//"))
val = val.Mid(2);
else if (val.StartsWith("+") || val.StartsWith("*") || val.StartsWith("/"))
val = val.Mid(1);
val.ToLong(&lval);
// Return it (incremented/decremented based on [base])
if (isIncrement())
return base + lval;
else if (isDecrement())
return base - lval;
else if (isFactor())
return base * lval;
else if (isDivisor())
return base / lval;
else
return lval;
}
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP d, s, x, stype;
int nargs = length(args);
#ifdef R_version_3_4_or_so
checkArity(op, args);
#else
// will work also for code byte-compiled *before* 'keepNA' was introduced
if (nargs < 3 || nargs > 4)
errorcall(call,
ngettext("%d argument passed to '%s' which requires %d to %d",
"%d arguments passed to '%s' which requires %d to %d",
(unsigned long) nargs),
nargs, PRIMNAME(op), 3, 4);
#endif
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nchar()");
R_xlen_t len = XLENGTH(x);
stype = CADR(args);
if (!isString(stype) || LENGTH(stype) != 1)
error(_("invalid '%s' argument"), "type");
const char *type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
size_t ntype = strlen(type);
if (ntype == 0) error(_("invalid '%s' argument"), "type");
nchar_type type_;
if (strncmp(type, "bytes", ntype) == 0) type_ = Bytes;
else if (strncmp(type, "chars", ntype) == 0) type_ = Chars;
else if (strncmp(type, "width", ntype) == 0) type_ = Width;
else error(_("invalid '%s' argument"), "type");
int allowNA = asLogical(CADDR(args));
if (allowNA == NA_LOGICAL) allowNA = 0;
int keepNA;
if(nargs >= 4) {
keepNA = asLogical(CADDDR(args));
if (keepNA == NA_LOGICAL) // default
keepNA = (type_ == Width) ? FALSE : TRUE;
} else keepNA = FALSE; // default
PROTECT(s = allocVector(INTSXP, len));
int *s_ = INTEGER(s);
for (R_xlen_t i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
char msg_i[20]; sprintf(msg_i, "element %ld", (long)i+1);
s_[i] = R_nchar(sxi, type_, allowNA, keepNA, msg_i);
}
R_FreeStringBufferL(&cbuff);
if ((d = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(s, R_NamesSymbol, d);
if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
setAttrib(s, R_DimSymbol, d);
if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(s, R_DimNamesSymbol, d);
UNPROTECT(2);
return s;
}
SEXP c_check_factor(SEXP x, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isFactor(x) && !all_missing_atomic(x))
return make_type_error(x, "factor");
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);
}
// Returns the proper integer chrom target (as is or through factor levels)
// Negative values should skip further treatments (level not found in factor)
int chromTarget(SEXP chrom, SEXP targetChrom) {
int output;
if(isFactor(chrom)) {
// Convert 'targetChrom' to a character vector
if(isFactor(targetChrom)) { targetChrom = PROTECT(asCharacterFactor(targetChrom));
} else { targetChrom = PROTECT(coerceVector(targetChrom, STRSXP));
}
if(LENGTH(targetChrom) != 1 || STRING_ELT(targetChrom, 0) == NA_STRING) {
error("As 'chrom' is factor, target 'chrom' must be a single non-NA character-coercible value");
}
// From character to integer position in the index (0+)
SEXP levels = PROTECT(getAttrib(chrom, R_LevelsSymbol));
for(int i = 0; i < LENGTH(levels); i++) {
if(strcmp(CHAR(STRING_ELT(levels, i)), CHAR(STRING_ELT(targetChrom, 0))) == 0) {
// Early exit when found
output = i;
UNPROTECT(2);
return output;
}
}
// Was not found in levels
output = -1;
UNPROTECT(2);
} else {
// Integer chrom
targetChrom = PROTECT(coerceVector(targetChrom, INTSXP));
if(LENGTH(targetChrom) != 1 || INTEGER(targetChrom)[0] == NA_INTEGER || INTEGER(targetChrom)[0] < 0) {
error("As 'chrom' is integer, target 'chrom' must be a single non-NA integer-coercible strictly positive value");
}
// Position in the index (0+)
output = INTEGER(targetChrom)[0] - 1;
UNPROTECT(1);
}
return output;
}
SEXP recurse_factor_to_char( SEXP X, SEXP parent, int i ) {
if( TYPEOF(X) == VECSXP ) {
for( int j=0; j < length(X); ++j ) {
recurse_factor_to_char( VECTOR_ELT(X, j), X, j );
}
} else {
if( isFactor(X) ) {
SET_VECTOR_ELT( parent, i, asCharacterFactor(X) );
}
}
return X;
}
bool isPrime(int num)
{
int i = sqrt(num);
if(num == 1) return false;
while(i>0)
{
if(isFactor(i, num))
break;
i--;
}
return i==1;
}
static Rboolean islistfactor(SEXP X)
{
int i, n = length(X);
switch(TYPEOF(X)) {
case VECSXP:
case EXPRSXP:
if(n == 0) return NA_LOGICAL;
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(VECTOR_ELT(X, i))) return FALSE;
return TRUE;
break;
}
return isFactor(X);
}
SEXP attribute_hidden do_islistfactor(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP X;
Rboolean lans = TRUE, recursive;
int i, n;
checkArity(op, args);
X = CAR(args);
recursive = CXXRCONSTRUCT(Rboolean, asLogical(CADR(args)));
n = length(X);
if(n == 0 || !isVectorList(X)) {
lans = FALSE;
goto do_ans;
}
if(!recursive) {
for(i = 0; i < LENGTH(X); i++)
if(!isFactor(VECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
} else {
switch(TYPEOF(X)) {
case VECSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(VECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
break;
case EXPRSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(XVECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
break;
default:
break;
}
}
do_ans:
return ScalarLogical(lans);
}
char max_type1(SEXP x) {
if (TYPEOF(x) != VECSXP) {
error("Expected a VECSXP but got a '%s'", type2char(TYPEOF(x)));
}
int n = length(x);
char max_type = -1;
char tmp = -1;
for (int i = 0; i < n; ++i) {
// factors should mean we coerce to string
if (isFactor(VECTOR_ELT(x, i))) {
if (STRSXP > max_type) {
max_type = STRSXP;
}
} else if ((tmp = TYPEOF(VECTOR_ELT(x, i))) > max_type) {
max_type = tmp;
}
}
return max_type;
}
long long int sumPrimes(int max)
{
int i, j, maxj, count;
int bound = (max/log(max))*(1 + 1.2762/log(max));
long long int sum;
int primes[bound];
// insert 2 into primes[]
primes[0] = 2;
sum = 2;
count = 1;
i = 3;
while(i<max)
{
j = 0;
maxj = sqrt(i);
//is prime[j] a factor of i
while(j<count)
{
if (primes[j] > maxj)
{
j = count;
break;
}
if(isFactor(primes[j],i))
{
break;
}
j++;
}
if(j==count)
{
primes[count] = i;
sum += i;
count++;
}
i += 2;
}
return sum;
}
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
int i, len;
checkArity(op, args);
check1arg(args, call, "x");
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nzchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nzchar()");
len = LENGTH(x);
PROTECT(ans = allocVector(LGLSXP, len));
for (i = 0; i < len; i++)
LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
UNPROTECT(2);
return ans;
}
static Rboolean islistfactor(SEXP X)
{
int i, n = length(X);
if(n == 0) return FALSE;
switch(TYPEOF(X)) {
case VECSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(VECTOR_ELT(X, i))) return FALSE;
return TRUE;
break;
case EXPRSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(XVECTOR_ELT(X, i))) return FALSE;
return TRUE;
break;
default: // -Wswitch
break;
}
return isFactor(X);
}
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
int nargs = length(args);
// checkArity(op, args); .Primitive() & may have 1 or 2 args now
if (nargs < 1 || nargs > 2)
errorcall(call,
ngettext("%d argument passed to '%s' which requires %d to %d",
"%d arguments passed to '%s' which requires %d to %d",
(unsigned long) nargs),
nargs, PRIMNAME(op), 1, 2);
check1arg(args, call, "x");
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nzchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nzchar()");
int keepNA = FALSE; // the default
if(nargs > 1) {
keepNA = asLogical(CADR(args));
if (keepNA == NA_LOGICAL) keepNA = FALSE;
}
R_xlen_t i, len = XLENGTH(x);
PROTECT(ans = allocVector(LGLSXP, len));
if (keepNA)
for (i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
LOGICAL(ans)[i] = (sxi == NA_STRING) ? NA_LOGICAL : LENGTH(sxi) > 0;
}
else
for (i = 0; i < len; i++)
LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
UNPROTECT(2);
return ans;
}
INLINE_FUN int nlevels(SEXP f)
{
if (!isFactor(f))
return 0;
return LENGTH(getAttrib(f, R_LevelsSymbol));
}
SEXP melt_dataframe( SEXP x, SEXP id_ind_, SEXP val_ind_, SEXP variable_name, SEXP value_name ) {
if (length(x) == 0) {
error("Can't melt a data.frame with 0 columns");
}
if (length(VECTOR_ELT(x, 0)) == 0) {
error("Can't melt a data.frame with 0 rows");
}
int* id_ind = INTEGER(id_ind_);
int* val_ind = INTEGER(val_ind_);
int nColStack = length(id_ind_);
int nColRep = length(val_ind_);
int nRow = length( VECTOR_ELT(x, 0) );
int out_nRow = nRow * nColRep;
int out_nCol = nColStack + 2;
char mt = max_type(x, val_ind_);
if (mt > STRSXP) {
error("Error: cannot melt data.frames w/ elements of type '%s'", CHAR(type2str(mt)));
}
if (diff_types(x, val_ind_)) {
warning("Coercing type of 'value' variables to '%s'", CHAR(type2str(mt)));
}
SEXP out;
PROTECT(out = allocVector( VECSXP, out_nCol ));
// populate the value array
SEXP value_SEXP;
#define HANDLE_CASE( RTYPE, CTYPE ) \
case RTYPE: { \
PROTECT( value_SEXP = allocVector( RTYPE, value_len ) ); \
SEXP tmp; \
for( int i=0; i < nColRep; ++i ) { \
if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) { \
tmp = PROTECT( coerceVector( VECTOR_ELT(x, val_ind[i]), mt ) ); \
} else { \
tmp = VECTOR_ELT(x, val_ind[i]); \
} \
memcpy( \
(char*) DATAPTR(value_SEXP) + (i*nRow*sizeof(CTYPE)), \
(char*) DATAPTR(tmp), \
nRow * sizeof(CTYPE) \
); \
if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) { \
UNPROTECT(1); \
} \
} \
break; \
} \
int value_len = nColRep * nRow;
int value_type = mt;
switch( value_type ) {
HANDLE_CASE( INTSXP, int );
HANDLE_CASE( REALSXP, double );
HANDLE_CASE( LGLSXP, int );
case STRSXP: {
int counter = 0;
SEXP* curr_str_vec_ptr;
SEXP tmp;
PROTECT( value_SEXP = allocVector( STRSXP, value_len ) );
for( int i=0; i < nColRep; ++i ) {
#define curr_str_vec (VECTOR_ELT(x, val_ind[i]))
if (TYPEOF(curr_str_vec) != STRSXP) {
if (isFactor(curr_str_vec)) {
PROTECT(tmp = asCharacterFactor(curr_str_vec));
} else {
PROTECT(tmp = coerceVector(curr_str_vec, STRSXP));
}
curr_str_vec_ptr = STRING_PTR(tmp);
} else {
curr_str_vec_ptr = STRING_PTR(curr_str_vec);
}
#undef curr_str_vec
SEXP* value_SEXP_ptr = STRING_PTR( value_SEXP );
for( int j=0; j < nRow; ++j ) {
value_SEXP_ptr[counter] = curr_str_vec_ptr[j];
++counter;
}
if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) {
UNPROTECT(1);
}
}
break;
}
default:
error("Unsupported RTYPE encountered");
}
#undef HANDLE_CASE
// generate the id variables, and assign them on generation
// we need to convert factors if necessary
for( int i=0; i < nColStack; ++i ) {
SET_VECTOR_ELT( out, i, stack_vector( VECTOR_ELT( x, id_ind[i] ), nColRep ));
if (isFactor( VECTOR_ELT(x, id_ind[i]) )) {
setAttrib( VECTOR_ELT(out, i), R_ClassSymbol, mkString("factor") );
setAttrib( VECTOR_ELT(out, i), R_LevelsSymbol, getAttrib( VECTOR_ELT(x, id_ind[i]), R_LevelsSymbol ) );
}
}
// assign the names, values
SET_VECTOR_ELT( out, nColStack, rep_each_char( getAttrib( x, R_NamesSymbol ), val_ind_, nRow ) );
SET_VECTOR_ELT( out, nColStack+1, value_SEXP );
UNPROTECT(1); // value_SEXP
// set the row names
SEXP row_names;
PROTECT( row_names = allocVector(INTSXP, out_nRow) );
int* row_names_ptr = INTEGER(row_names);
for( int i=0; i < out_nRow; ++i ) {
row_names_ptr[i] = i+1;
}
setAttrib( out, R_RowNamesSymbol, row_names );
UNPROTECT(1); // row_names
// set the class to data.frame
setAttrib(out, R_ClassSymbol, mkString("data.frame"));
// set the names
SEXP names = getAttrib(x, R_NamesSymbol);
SEXP names_out;
PROTECT(names_out = allocVector( STRSXP, out_nCol ));
SEXP* names_ptr = STRING_PTR(names);
SEXP* names_out_ptr = STRING_PTR(names_out);
for (int i=0; i < nColStack; ++i) {
names_out_ptr[i] = names_ptr[ id_ind[i] ];
}
SET_STRING_ELT( names_out, nColStack, STRING_ELT(variable_name, 0) );
SET_STRING_ELT( names_out, nColStack+1, STRING_ELT(value_name, 0) );
setAttrib( out, R_NamesSymbol, names_out );
UNPROTECT(1); // names_out
UNPROTECT(1); // out
return out;
}
SEXP attribute_hidden do_split(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
SEXP x, f, counts, vec, nm, nmj;
Rboolean have_names;
op->checkNumArgs(num_args, call);
x = args[0];
f = args[1];
if (!isVector(x))
error(_("first argument must be a vector"));
if (!isFactor(f))
error(_("second argument must be a factor"));
int nlevs = nlevels(f);
R_xlen_t nfac = XLENGTH(args[1]);
R_xlen_t nobs = XLENGTH(args[0]);
if (nfac <= 0 && nobs > 0)
error(_("group length is 0 but data length > 0"));
if (nfac > 0 && (nobs % nfac) != 0)
warning(_("data length is not a multiple of split variable"));
nm = getAttrib(x, R_NamesSymbol);
have_names = CXXRCONSTRUCT(Rboolean, nm != nullptr);
PROTECT(counts = allocVector(INTSXP, nlevs));
for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
for (R_xlen_t i = 0; i < nobs; i++) {
int j = INTEGER(f)[i % nfac];
if (j != NA_INTEGER) {
/* protect against malformed factors */
if (j > nlevs || j < 1) error(_("factor has bad level"));
INTEGER(counts)[j - 1]++;
}
}
/* Allocate a generic vector to hold the results. */
/* The i-th element will hold the split-out data */
/* for the ith group. */
PROTECT(vec = allocVector(VECSXP, nlevs));
for (R_xlen_t i = 0; i < nlevs; i++) {
SET_VECTOR_ELT(vec, i, allocVector(TYPEOF(x), INTEGER(counts)[i]));
setAttrib(VECTOR_ELT(vec, i), R_LevelsSymbol,
getAttrib(x, R_LevelsSymbol));
if(have_names)
setAttrib(VECTOR_ELT(vec, i), R_NamesSymbol,
allocVector(STRSXP, INTEGER(counts)[i]));
}
for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
for (R_xlen_t i = 0; i < nobs; i++) {
int j = INTEGER(f)[i % nfac];
if (j != NA_INTEGER) {
int k = INTEGER(counts)[j - 1];
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(VECTOR_ELT(vec, j - 1))[k] = INTEGER(x)[i];
break;
case REALSXP:
REAL(VECTOR_ELT(vec, j - 1))[k] = REAL(x)[i];
break;
case CPLXSXP:
COMPLEX(VECTOR_ELT(vec, j - 1))[k] = COMPLEX(x)[i];
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(vec, j - 1), k, STRING_ELT(x, i));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(vec, j - 1), k, VECTOR_ELT(x, i));
break;
case RAWSXP:
RAW(VECTOR_ELT(vec, j - 1))[k] = RAW(x)[i];
break;
default:
UNIMPLEMENTED_TYPE("split", x);
}
if(have_names) {
nmj = getAttrib(VECTOR_ELT(vec, j - 1), R_NamesSymbol);
SET_STRING_ELT(nmj, k, STRING_ELT(nm, i));
}
INTEGER(counts)[j - 1] += 1;
}
}
setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
UNPROTECT(2);
return vec;
}
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP d, s, x, stype;
int i, len, allowNA;
size_t ntype;
int nc;
const char *type;
const char *xi;
wchar_t *wc;
const void *vmax;
checkArity(op, args);
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nchar()");
len = LENGTH(x);
stype = CADR(args);
if (!isString(stype) || LENGTH(stype) != 1)
error(_("invalid '%s' argument"), "type");
type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
ntype = strlen(type);
if (ntype == 0) error(_("invalid '%s' argument"), "type");
allowNA = asLogical(CADDR(args));
if (allowNA == NA_LOGICAL) allowNA = 0;
PROTECT(s = allocVector(INTSXP, len));
vmax = vmaxget();
for (i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
if (sxi == NA_STRING) {
INTEGER(s)[i] = 2;
continue;
}
if (strncmp(type, "bytes", ntype) == 0) {
INTEGER(s)[i] = LENGTH(sxi);
} else if (strncmp(type, "chars", ntype) == 0) {
if (IS_UTF8(sxi)) { /* assume this is valid */
const char *p = CHAR(sxi);
nc = 0;
for( ; *p; p += utf8clen(*p)) nc++;
INTEGER(s)[i] = nc;
} else if (IS_BYTES(sxi)) {
if (!allowNA) /* could do chars 0 */
error(_("number of characters is not computable for element %d in \"bytes\" encoding"), i+1);
INTEGER(s)[i] = NA_INTEGER;
} else if (mbcslocale) {
nc = mbstowcs(NULL, translateChar(sxi), 0);
if (!allowNA && nc < 0)
error(_("invalid multibyte string %d"), i+1);
INTEGER(s)[i] = nc >= 0 ? nc : NA_INTEGER;
} else
INTEGER(s)[i] = strlen(translateChar(sxi));
} else if (strncmp(type, "width", ntype) == 0) {
if (IS_UTF8(sxi)) { /* assume this is valid */
const char *p = CHAR(sxi);
wchar_t wc1;
nc = 0;
for( ; *p; p += utf8clen(*p)) {
utf8toucs(&wc1, p);
nc += Ri18n_wcwidth(wc1);
}
INTEGER(s)[i] = nc;
} else if (IS_BYTES(sxi)) {
if (!allowNA) /* could do width 0 */
error(_("width is not computable for element %d in \"bytes\" encoding"), i+1);
INTEGER(s)[i] = NA_INTEGER;
} else if (mbcslocale) {
xi = translateChar(sxi);
nc = mbstowcs(NULL, xi, 0);
if (nc >= 0) {
wc = (wchar_t *) R_AllocStringBuffer((nc+1)*sizeof(wchar_t), &cbuff);
mbstowcs(wc, xi, nc + 1);
INTEGER(s)[i] = Ri18n_wcswidth(wc, 2147483647);
if (INTEGER(s)[i] < 1) INTEGER(s)[i] = nc;
} else if (allowNA)
error(_("invalid multibyte string %d"), i+1);
else
INTEGER(s)[i] = NA_INTEGER;
} else
INTEGER(s)[i] = strlen(translateChar(sxi));
} else
error(_("invalid '%s' argument"), "type");
vmaxset(vmax);
}
R_FreeStringBufferL(&cbuff);
if ((d = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(s, R_NamesSymbol, d);
if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
setAttrib(s, R_DimSymbol, d);
if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(s, R_DimNamesSymbol, d);
UNPROTECT(2);
return s;
}
SEXP foreach_bed(SEXP bed, SEXP function, SEXP envir) {
SEXP chroms, starts, ends, strands = R_NilValue;
SEXP arg_idx, arg_chrom, arg_start, arg_end, arg_strand;
SEXP fcall;
int has_strand = 0;
int i, N;
PROTECT(bed);
if(!isEnvironment(envir))
error("'envir' should be an environment");
chroms = VECTOR_ELT(bed, 0);
if (!isFactor(chroms) && TYPEOF(chroms) != STRSXP)
error("first column of bed file must be a factor or character vector");
PROTECT(starts = AS_INTEGER(VECTOR_ELT(bed, 1)));
PROTECT(ends = AS_INTEGER(VECTOR_ELT(bed, 2)));
if (length(bed) >= 6) {
has_strand = 1;
strands = VECTOR_ELT(bed, 5);
if (!isFactor(strands) && TYPEOF(strands) != STRSXP)
error("sixth column of bed file must be a factor or character vector");
}
/* build function call */
PROTECT(arg_idx = NEW_INTEGER(1));
PROTECT(arg_chrom = allocVector(STRSXP, 1));
PROTECT(arg_start = NEW_INTEGER(1));
PROTECT(arg_end = NEW_INTEGER(1));
PROTECT(arg_strand = allocVector(STRSXP, 1));
if (has_strand == 0)
SET_STRING_ELT(arg_strand, 0, NA_STRING);
PROTECT(fcall = lang6(function, arg_idx, arg_chrom, arg_start, arg_end, arg_strand));
/* run loop */
N = length(chroms);
for (i = 0; i < N; ++i) {
INTEGER(arg_idx)[0] = i + 1;
INTEGER(arg_start)[0] = INTEGER(starts)[i];
INTEGER(arg_end)[0] = INTEGER(ends)[i];
/* chrom */
if (isFactor(chroms)) {
int idx = INTEGER(chroms)[i] - 1;
SET_STRING_ELT(arg_chrom, 0, STRING_ELT(GET_LEVELS(chroms), idx));
} else
SET_STRING_ELT(arg_chrom, 0, STRING_ELT(chroms, i));
/* strand */
if (has_strand == 1) {
if (isFactor(strands)) {
int idx = INTEGER(strands)[i] - 1;
SET_STRING_ELT(arg_strand, 0, STRING_ELT(GET_LEVELS(strands), idx));
} else
SET_STRING_ELT(arg_strand, 0, STRING_ELT(strands, i));
}
/* eval and ignore result */
eval(fcall, envir);
/* check for interrupts */
R_CheckUserInterrupt();
}
/* clean up */
UNPROTECT(9);
return R_NilValue;
}
SEXP fmelt(SEXP DT, SEXP id, SEXP measure, SEXP varfactor, SEXP valfactor, SEXP var_name, SEXP val_name, SEXP na_rm, SEXP drop_levels, SEXP print_out) {
int i, j, k, nrow, ncol, protecti=0, lids=-1, lvalues=-1, totlen=0, counter=0, thislen=0;
SEXP thiscol, ans, dtnames, ansnames, idcols, valuecols, levels, factorLangSxp;
SEXP vars, target, idxkeep = R_NilValue, thisidx = R_NilValue;
Rboolean isfactor=FALSE, isidentical=TRUE, narm = FALSE, droplevels=FALSE, verbose=FALSE;
SEXPTYPE valtype=NILSXP;
size_t size;
if (TYPEOF(DT) != VECSXP) error("Input is not of type VECSXP, expected a data.table, data.frame or list");
if (TYPEOF(valfactor) != LGLSXP) error("Argument 'value.factor' should be logical TRUE/FALSE");
if (TYPEOF(varfactor) != LGLSXP) error("Argument 'variable.factor' should be logical TRUE/FALSE");
if (TYPEOF(na_rm) != LGLSXP) error("Argument 'na.rm' should be logical TRUE/FALSE");
if (LOGICAL(na_rm)[0] == TRUE) narm = TRUE;
if (TYPEOF(print_out) != LGLSXP) error("Argument 'verbose' should be logical TRUE/FALSE");
if (LOGICAL(print_out)[0] == TRUE) verbose = TRUE;
// check for var and val names
if (TYPEOF(var_name) != STRSXP || length(var_name) != 1) error("Argument 'variable.name' must be a character vector of length 1");
if (TYPEOF(val_name) != STRSXP || length(val_name) != 1) error("Argument 'value.name' must be a character vector of length 1");
// droplevels future feature request, maybe... should ask on data.table-help
// if (!isLogical(drop_levels)) error("Argument 'drop.levels' should be logical TRUE/FALSE");
// if (LOGICAL(drop_levels)[0] == TRUE) droplevels = TRUE;
// if (droplevels && !narm) warning("Ignoring argument 'drop.levels'. 'drop.levels' should be set to remove any unused levels as a result of setting 'na.rm=TRUE'. Here there is nothing to do because 'na.rm=FALSE'");
ncol = LENGTH(DT);
nrow = length(VECTOR_ELT(DT, 0));
if (ncol <= 0) {
warning("ncol(data) is 0. Nothing to do, returning original data.table.");
return(DT);
}
PROTECT(dtnames = getAttrib(DT, R_NamesSymbol)); protecti++;
if (isNull(dtnames)) error("names(data) is NULL. Please report to data.table-help");
vars = checkVars(DT, id, measure, verbose);
PROTECT(idcols = VECTOR_ELT(vars, 0)); protecti++;
PROTECT(valuecols = VECTOR_ELT(vars, 1)); protecti++; // <~~~ not protecting vars leads to segfault (on big data)
lids = length(idcols);
lvalues = length(valuecols);
// edgecase where lvalues = 0 and lids > 0
if (lvalues == 0 && lids > 0) {
if (verbose) Rprintf("length(measure.var) is 0. Edge case detected. Nothing to melt. Returning data.table with all 'id.vars' which are columns %s\n", CHAR(STRING_ELT(concat(dtnames, idcols), 0)));
PROTECT(ansnames = allocVector(STRSXP, lids)); protecti++;
PROTECT(ans = allocVector(VECSXP, lids)); protecti++;
for (i=0; i<lids; i++) {
SET_VECTOR_ELT(ans, i, VECTOR_ELT(DT, INTEGER(idcols)[i]-1));
SET_STRING_ELT(ansnames, i, STRING_ELT(dtnames, INTEGER(idcols)[i]-1));
}
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(protecti);
return(ans);
}
if (lvalues == 0 && lids == 0 && verbose)
Rprintf("length(measure.var) and length(id.var) are both 0. Edge case detected. Nothing to melt.\n"); // <~~ don't think this will ever happen though with all the checks
// set names for 'ans' - the output list
PROTECT(ansnames = allocVector(STRSXP, lids+2)); protecti++;
for (i=0; i<lids; i++) {
SET_STRING_ELT(ansnames, i, STRING_ELT(dtnames, INTEGER(idcols)[i]-1));
}
SET_STRING_ELT(ansnames, lids, mkChar(CHAR(STRING_ELT(var_name, 0)))); // mkChar("variable")
SET_STRING_ELT(ansnames, lids+1, mkChar(CHAR(STRING_ELT(val_name, 0)))); // mkChar("value")
// get "value" column
for (i=0; i<lvalues; i++) {
thiscol = VECTOR_ELT(DT, INTEGER(valuecols)[i]-1);
if (!isfactor && isFactor(thiscol)) isfactor = TRUE;
if (TYPEOF(thiscol) > valtype) valtype = TYPEOF(thiscol);
}
if (isfactor && valtype != VECSXP) valtype = STRSXP;
for (i=0; i<lvalues; i++) {
thiscol = VECTOR_ELT(DT, INTEGER(valuecols)[i]-1);
if (TYPEOF(thiscol) != valtype && isidentical) {
if (!(isFactor(thiscol) && valtype == STRSXP)) {
isidentical = FALSE; // for Date like column (not implemented for now)
warning("All 'measure.vars are NOT of the SAME type. By order of hierarchy, the molten data value column will be of type '%s'. Therefore all measure variables that are not of type '%s' will be coerced to. Check the DETAILS section of ?melt.data.table for more on coercion.\n", type2char(valtype), type2char(valtype));
break;
}
}
}
if (valtype == VECSXP && narm) {
narm = FALSE;
if (verbose) Rprintf("The molten data value type is a list. 'na.rm=TRUE' is therefore ignored.\n");
}
if (narm) {
PROTECT(idxkeep = allocVector(VECSXP, lvalues)); protecti++;
for (i=0; i<lvalues; i++) {
SET_VECTOR_ELT(idxkeep, i, which_notNA(VECTOR_ELT(DT, INTEGER(valuecols)[i]-1)));
totlen += length(VECTOR_ELT(idxkeep, i));
}
} else
totlen = nrow * lvalues;
PROTECT(ans = allocVector(VECSXP, lids + 2)); protecti++;
target = PROTECT(allocVector(valtype, totlen));
for (i=0; i<lvalues; i++) {
thiscol = VECTOR_ELT(DT, INTEGER(valuecols)[i]-1);
if (isFactor(thiscol))
thiscol = asCharacterFactor(thiscol);
if (TYPEOF(thiscol) != valtype && !isFactor(thiscol)) {
// thiscol = valtype == STRSXP ? PROTECT(coerce_to_char(thiscol, R_GlobalEnv)) : PROTECT(coerceVector(thiscol, valtype));
// protecti++; // for now, no preserving of class attributes
thiscol = PROTECT(coerceVector(thiscol, valtype)); protecti++;
}
size = SIZEOF(thiscol);
if (narm) {
thisidx = VECTOR_ELT(idxkeep, i);
thislen = length(thisidx);
}
switch(valtype) {
case VECSXP :
if (narm) {
for (j=0; j<thislen; j++)
SET_VECTOR_ELT(target, counter + j, VECTOR_ELT(thiscol, INTEGER(thisidx)[j]-1));
} else {
for (j=0; j<nrow; j++) SET_VECTOR_ELT(target, i*nrow + j, VECTOR_ELT(thiscol, j));
}
break;
case STRSXP :
if (narm) {
for (j=0; j<thislen; j++)
SET_STRING_ELT(target, counter + j, STRING_ELT(thiscol, INTEGER(thisidx)[j]-1));
} else {
for (j=0; j<nrow; j++) SET_STRING_ELT(target, i*nrow + j, STRING_ELT(thiscol, j));
}
break;
case REALSXP :
if (narm) {
for (j=0; j<thislen; j++)
REAL(target)[counter + j] = REAL(thiscol)[INTEGER(thisidx)[j]-1];
} else {
memcpy((char *)DATAPTR(target)+i*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case INTSXP :
if (narm) {
for (j=0; j<thislen; j++)
INTEGER(target)[counter + j] = INTEGER(thiscol)[INTEGER(thisidx)[j]-1];
} else {
memcpy((char *)DATAPTR(target)+i*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case LGLSXP :
if (narm) {
for (j=0; j<thislen; j++)
LOGICAL(target)[counter + j] = LOGICAL(thiscol)[INTEGER(thisidx)[j]-1];
} else {
memcpy((char *)DATAPTR(target)+i*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
default : error("Unknown column type '%s' for column '%s' in 'data'", type2char(TYPEOF(thiscol)), CHAR(STRING_ELT(dtnames, INTEGER(valuecols)[i]-1)));
}
if (narm) counter += thislen;
// if (isidentical && valtype != VECSXP) // for now, no preserving of class attributes
// setAttrib(target, R_ClassSymbol, getAttrib(VECTOR_ELT(DT, INTEGER(valuecols)[0]-1), R_ClassSymbol)); // for Date like column
}
// check for factor
if (LOGICAL(valfactor)[0] == TRUE && valtype == VECSXP) warning("argument 'value.factor' ignored because 'value' column is a list\n");
if (LOGICAL(valfactor)[0] == TRUE && valtype != VECSXP) {
PROTECT(factorLangSxp = allocList(2));
SET_TYPEOF(factorLangSxp, LANGSXP);
SETCAR(factorLangSxp, install("factor"));
SETCAR(CDR(factorLangSxp), target);
SET_VECTOR_ELT(ans, lids+1, eval(factorLangSxp, R_GlobalEnv)); // last column
UNPROTECT(1); // factorLangSxp
} else
SET_VECTOR_ELT(ans, lids+1, target);
UNPROTECT(1); // target
// get "variable" column
counter = 0, i=0;
target = PROTECT(allocVector(INTSXP, totlen));
for (j=0; j<lvalues; j++) {
if (narm) {
thislen = length(VECTOR_ELT(idxkeep, j));
for (k=0; k<thislen; k++)
INTEGER(target)[counter + k] = i+1;
counter += thislen;
if (thislen > 0 || !droplevels) i++;
} else {
for (k=0; k<nrow; k++)
INTEGER(target)[nrow*j + k] = j+1;
}
}
setAttrib(target, R_ClassSymbol, mkString("factor"));
if (narm && droplevels) {
counter = 0;
for (j=0; j<lvalues; j++) {
if (length(VECTOR_ELT(idxkeep, j)) > 0) counter++;
}
} else counter = lvalues;
levels = PROTECT(allocVector(STRSXP, counter));
i = 0;
for (j=0; j<lvalues; j++) {
if (narm && droplevels) {
if (length(VECTOR_ELT(idxkeep, j)) > 0)
SET_STRING_ELT(levels, i++, STRING_ELT(dtnames, INTEGER(valuecols)[j]-1));
} else
SET_STRING_ELT(levels, j, STRING_ELT(dtnames, INTEGER(valuecols)[j]-1));
}
setAttrib(target, R_LevelsSymbol, levels);
UNPROTECT(1); // levels
if (LOGICAL(varfactor)[0] == FALSE)
target = asCharacterFactor(target);
SET_VECTOR_ELT(ans, lids, target);
UNPROTECT(1); // target
// generate idcols (left part)
for (i=0; i<lids; i++) {
counter = 0;
thiscol = VECTOR_ELT(DT, INTEGER(idcols)[i]-1);
size = SIZEOF(thiscol);
target = PROTECT(allocVector(TYPEOF(thiscol), totlen));
switch(TYPEOF(thiscol)) {
case REALSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
REAL(target)[counter + k] = REAL(thiscol)[INTEGER(thisidx)[k]-1];
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
for (j=0; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case INTSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
INTEGER(target)[counter + k] = INTEGER(thiscol)[INTEGER(thisidx)[k]-1];
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
for (j=0; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case LGLSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
LOGICAL(target)[counter + k] = LOGICAL(thiscol)[INTEGER(thisidx)[k]-1];
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
for (j=0; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(thiscol), nrow*size);
}
break;
case STRSXP :
if (narm) {
for (j=0; j<lvalues; j++) {
thisidx = PROTECT(VECTOR_ELT(idxkeep, j));
thislen = length(thisidx);
for (k=0; k<thislen; k++)
SET_STRING_ELT(target, counter + k, STRING_ELT(thiscol, INTEGER(thisidx)[k]-1));
counter += thislen;
UNPROTECT(1); // thisidx
}
} else {
// SET_STRING_ELT for j=0 and memcpy for j>0, WHY?
// From assign.c's memcrecycle - only one SET_STRING_ELT per RHS item is needed to set generations (overhead)
for (k=0; k<nrow; k++) SET_STRING_ELT(target, k, STRING_ELT(thiscol, k));
for (j=1; j<lvalues; j++)
memcpy((char *)DATAPTR(target)+j*nrow*size, (char *)DATAPTR(target), nrow*size);
}
break;
case VECSXP :
for (j=0; j<lvalues; j++) {
for (k=0; k<nrow; k++) {
SET_VECTOR_ELT(target, j*nrow + k, VECTOR_ELT(thiscol, k));
}
}
break;
default : error("Unknown column type '%s' for column '%s' in 'data'", type2char(TYPEOF(thiscol)), CHAR(STRING_ELT(dtnames, INTEGER(idcols)[i]-1)));
}
copyMostAttrib(thiscol, target); // all but names,dim and dimnames. And if so, we want a copy here, not keepattr's SET_ATTRIB.
SET_VECTOR_ELT(ans, i, target);
UNPROTECT(1); // target
}
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(protecti);
return(ans);
}
SEXP attribute_hidden do_switch(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int argval, nargs = length(args);
SEXP x, y, z, w, ans, dflt = NULL;
if (nargs < 1) errorcall(call, _("'EXPR' is missing"));
check1arg(args, call, "EXPR");
PROTECT(x = eval(CAR(args), rho));
if (!isVector(x) || length(x) != 1)
errorcall(call, _("EXPR must be a length 1 vector"));
if (isFactor(x))
warningcall(call,
_("EXPR is a \"factor\", treated as integer.\n"
" Consider using '%s' instead."),
"switch(as.character( * ), ...)");
if (nargs > 1) {
/* There is a complication: if called from lapply
there may be a ... argument */
PROTECT(w = expandDots(CDR(args), rho));
if (isString(x)) {
for (y = w; y != R_NilValue; y = CDR(y)) {
if (TAG(y) != R_NilValue) {
if (pmatch(STRING_ELT(x, 0), TAG(y), 1 /* exact */)) {
/* Find the next non-missing argument.
(If there is none, return NULL.) */
while (CAR(y) == R_MissingArg) {
y = CDR(y);
if (y == R_NilValue) break;
if (TAG(y) == R_NilValue) dflt = setDflt(y, dflt);
}
if (y == R_NilValue) {
R_Visible = FALSE;
UNPROTECT(2);
return R_NilValue;
}
/* Check for multiple defaults following y. This loop
is not necessary to determine the value of the
switch(), but it should be fast and will detect
typos. */
for (z = CDR(y); z != R_NilValue; z = CDR(z))
if (TAG(z) == R_NilValue) dflt = setDflt(z, dflt);
ans = eval(CAR(y), rho);
UNPROTECT(2);
return ans;
}
} else
dflt = setDflt(y, dflt);
}
if (dflt) {
ans = eval(dflt, rho);
UNPROTECT(2);
return ans;
}
/* fall through to error */
} else { /* Treat as numeric */
argval = asInteger(x);
if (argval != NA_INTEGER && argval >= 1 && argval <= length(w)) {
SEXP alt = CAR(nthcdr(w, argval - 1));
if (alt == R_MissingArg)
error("empty alternative in numeric switch");
ans = eval(alt, rho);
UNPROTECT(2);
return ans;
}
/* fall through to error */
}
UNPROTECT(1); /* w */
}
/* an error */
UNPROTECT(1); /* x */
R_Visible = FALSE;
return R_NilValue;
}
bool isSquare(int num)
{
int midpt = sqrt(num);
return isFactor(midpt,num);
}
SEXP checkVars(SEXP DT, SEXP id, SEXP measure, Rboolean verbose) {
int i, ncol=LENGTH(DT), targetcols=0, protecti=0, u=0, v=0;
SEXP thiscol, idcols = R_NilValue, valuecols = R_NilValue, tmp, booltmp, unqtmp, ans;
SEXP dtnames = getAttrib(DT, R_NamesSymbol);
if (isNull(id) && isNull(measure)) {
for (i=0; i<ncol; i++) {
thiscol = VECTOR_ELT(DT, i);
if ((isInteger(thiscol) || isNumeric(thiscol) || isLogical(thiscol)) && !isFactor(thiscol)) targetcols++;
}
PROTECT(idcols = allocVector(INTSXP, ncol-targetcols)); protecti++;
PROTECT(valuecols = allocVector(INTSXP, targetcols)); protecti++;
for (i=0; i<ncol; i++) {
thiscol = VECTOR_ELT(DT, i);
if ((isInteger(thiscol) || isNumeric(thiscol) || isLogical(thiscol)) && !isFactor(thiscol)) {
INTEGER(valuecols)[u++] = i+1;
} else
INTEGER(idcols)[v++] = i+1;
}
warning("To be consistent with reshape2's melt, id.vars and measure.vars are internally guessed when both are 'NULL'. All non-numeric/integer/logical type columns are conisdered id.vars, which in this case are columns '%s'. Consider providing at least one of 'id' or 'measure' vars in future.", CHAR(STRING_ELT(concat(dtnames, idcols), 0)));
} else if (!isNull(id) && isNull(measure)) {
switch(TYPEOF(id)) {
case STRSXP : PROTECT(tmp = chmatch(id, dtnames, 0, FALSE)); protecti++; break;
case REALSXP : PROTECT(tmp = coerceVector(id, INTSXP)); protecti++; break;
case INTSXP : PROTECT(tmp = id); protecti++; break;
default : error("Unknown 'id.var' type %s, must be character or integer vector", type2char(TYPEOF(id)));
}
PROTECT(booltmp = duplicated(tmp, FALSE)); protecti++;
for (i=0; i<length(tmp); i++) {
if (INTEGER(tmp)[i] <= 0) error("Column '%s' not found in 'data'", CHAR(STRING_ELT(id, i)));
else if (INTEGER(tmp)[i] > ncol) error("id.var value exceeds ncol(data)");
else if (!LOGICAL(booltmp)[i]) targetcols++;
else continue;
}
PROTECT(unqtmp = allocVector(INTSXP, targetcols)); protecti++;
u = 0;
for (i=0; i<length(booltmp); i++) {
if (!LOGICAL(booltmp)[i]) {
INTEGER(unqtmp)[u++] = INTEGER(tmp)[i];
}
}
PROTECT(valuecols = set_diff(unqtmp, ncol)); protecti++;
PROTECT(idcols = tmp); protecti++;
if (verbose) Rprintf("'measure.var' is missing. Assigning all columns other than 'id.var' columns which are %s as 'measure.var'.\n", CHAR(STRING_ELT(concat(dtnames, idcols), 0)));
} else if (isNull(id) && !isNull(measure)) {
switch(TYPEOF(measure)) {
case STRSXP : PROTECT(tmp = chmatch(measure, dtnames, 0, FALSE)); protecti++; break;
case REALSXP : PROTECT(tmp = coerceVector(measure, INTSXP)); protecti++; break;
case INTSXP : PROTECT(tmp = measure); protecti++; break;
default : error("Unknown 'measure.var' type %s, must be character or integer vector", type2char(TYPEOF(measure)));
}
PROTECT(booltmp = duplicated(tmp, FALSE)); protecti++;
for (i=0; i<length(tmp); i++) {
if (INTEGER(tmp)[i] <= 0) error("Column '%s' not found in 'data'", CHAR(STRING_ELT(id, i)));
else if (INTEGER(tmp)[i] > ncol) error("measure.var value exceeds ncol(data)");
else if (!LOGICAL(booltmp)[i]) targetcols++;
else continue;
}
PROTECT(unqtmp = allocVector(INTSXP, targetcols)); protecti++;
u = 0;
for (i=0; i<length(booltmp); i++) {
if (!LOGICAL(booltmp)[i]) {
INTEGER(unqtmp)[u++] = INTEGER(tmp)[i];
}
}
PROTECT(idcols = set_diff(unqtmp, ncol)); protecti++;
PROTECT(valuecols = tmp); protecti++;
if (verbose) Rprintf("'id.var' is missing. Assigning all columns other than 'measure.var' columns as 'id.var'. Assigned 'id.var's are %s.\n", CHAR(STRING_ELT(concat(dtnames, idcols), 0)));
} else if (!isNull(id) && !isNull(measure)) {
switch(TYPEOF(id)) {
case STRSXP : PROTECT(tmp = chmatch(id, dtnames, 0, FALSE)); protecti++; break;
case REALSXP : PROTECT(tmp = coerceVector(id, INTSXP)); protecti++; break;
case INTSXP : PROTECT(tmp = id); protecti++; break;
default : error("Unknown 'id.var' type %s, must be character or integer vector", type2char(TYPEOF(id)));
}
for (i=0; i<length(tmp); i++) {
if (INTEGER(tmp)[i] <= 0) error("Column '%s' or not found in 'data'", CHAR(STRING_ELT(id, i)));
else if (INTEGER(tmp)[i] > ncol) error("measure.var value exceeds ncol(data)");
}
PROTECT(idcols = allocVector(INTSXP, length(tmp))); protecti++;
idcols = tmp;
switch(TYPEOF(measure)) {
case STRSXP : PROTECT(tmp = chmatch(measure, dtnames, 0, FALSE)); protecti++; break;
case REALSXP : PROTECT(tmp = coerceVector(measure, INTSXP)); protecti++; break;
case INTSXP : PROTECT(tmp = measure); protecti++; break;
default : error("Unknown 'measure.var' type %s, must be character or integer vector", type2char(TYPEOF(measure)));
}
for (i=0; i<length(tmp); i++) {
if (INTEGER(tmp)[i] <= 0) error("Column '%s' not found in 'data'", CHAR(STRING_ELT(id, i)));
else if (INTEGER(tmp)[i] > ncol) error("measure.var value exceeds ncol(data)");
}
PROTECT(valuecols = allocVector(INTSXP, length(measure))); protecti++;
valuecols = tmp;
}
PROTECT(ans = allocVector(VECSXP, 2)); protecti++;
SET_VECTOR_ELT(ans, 0, idcols);
SET_VECTOR_ELT(ans, 1, valuecols);
UNPROTECT(protecti);
return(ans);
}
/* NOTE: R vectors of length 1 will yield a python list of length 1*/
int
to_Pyobj_vector(SEXP robj, PyObject **obj, int mode)
{
PyObject *it, *tmp;
SEXP names, dim;
int len, *integers, i, type;
const char *strings, *thislevel;
double *reals;
Rcomplex *complexes;
#ifdef WITH_NUMERIC
PyObject *array;
#endif
if (!robj)
{
// return -1; /* error */
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "robj does not exist"));
// PyObject_CallObject(my_callback, argslist);
// }
return 1;
}
if (robj == R_NilValue) {
Py_INCREF(Py_None);
*obj = Py_None;
return 1; /* succeed */
}
len = GET_LENGTH(robj);
tmp = PyList_New(len);
type = TYPEOF(robj);
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(si)", "robj length is ", len));
// PyObject_CallObject(my_callback, argslist);
// }
/// break for checking the R length and other aspects
for (i=0; i<len; i++) {
switch (type)
{
case LGLSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In LGLSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
integers = INTEGER(robj);
if(integers[i]==NA_INTEGER) /* watch out for NA's */
{
if (!(it = PyInt_FromLong(integers[i])))
//return -1;
tmp = Py_BuildValue("s", "failed in the PyInt_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//it = Py_None;
}
else if (!(it = PyBool_FromLong(integers[i])))
{
tmp = Py_BuildValue("s", "failed in the PyBool_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//return -1;
}
break;
case INTSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In INTSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
integers = INTEGER(robj);
if(isFactor(robj)) {
/* Watch for NA's! */
if(integers[i]==NA_INTEGER)
it = PyString_FromString(CHAR(NA_STRING));
else
{
thislevel = CHAR(STRING_ELT(GET_LEVELS(robj), integers[i]-1));
if (!(it = PyString_FromString(thislevel)))
{
tmp = Py_BuildValue("s", "failed in the PyString_FromString"); // we are at least getting an robj
*obj = tmp;
return 1;
}
//return -1;
}
}
else {
if (!(it = PyInt_FromLong(integers[i])))
{
tmp = Py_BuildValue("s", "failed in the PyInt_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//return -1;
}
}
break;
case REALSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In REALSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
reals = REAL(robj);
if (!(it = PyFloat_FromDouble(reals[i])))
{
// tmp = Py_BuildValue("s", "failed in the PyFloat_FromDouble"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case CPLXSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In CPLXSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
complexes = COMPLEX(robj);
if (!(it = PyComplex_FromDoubles(complexes[i].r,
complexes[i].i)))
{
// tmp = Py_BuildValue("s", "failed in PyComplex_FromDoubles!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case STRSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In STRSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if(STRING_ELT(robj, i)==R_NaString)
it = PyString_FromString(CHAR(NA_STRING));
else
{
strings = CHAR(STRING_ELT(robj, i));
if (!(it = PyString_FromString(strings)))
{
// tmp = Py_BuildValue("s", "failed in PyString_FromString!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
}
break;
case LISTSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In LISTSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if (!(it = to_Pyobj_with_mode(elt(robj, i), mode)))
{
// tmp = Py_BuildValue("s", "failed in to_Pyobj_with_mode LISTSXP!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case VECSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In VECSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if (!(it = to_Pyobj_with_mode(VECTOR_ELT(robj, i), mode)))
{
return -1;
}
break;
default:
Py_DECREF(tmp);
return 0; /* failed */
}
if (PyList_SetItem(tmp, i, it) < 0) // there was a failure in setting the item
{
// tmp = Py_BuildValue("s", "failed in PyList_SetItem!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
}
dim = GET_DIM(robj);
if (dim != R_NilValue) {
// #ifdef WITH_NUMERIC
// if(use_numeric)
// {
// array = to_PyNumericArray(tmp, dim);
// if (array) { /* If the conversion to Numeric succeed.. */
// *obj = array; /* we are done */
// Py_DECREF(tmp);
// return 1;
// }
// PyErr_Clear();
// }
// #endif
len = GET_LENGTH(dim);
*obj = to_PyArray(tmp, INTEGER(dim), len);
Py_DECREF(tmp);
return 1;
}
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(O)", tmp));
// PyObject_CallObject(my_callback, argslist);
// }
names = GET_NAMES(robj);
if (names == R_NilValue)
{
*obj = tmp;
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "returning as list (of lists)"));
// PyObject_CallObject(my_callback, argslist);
// }
}
else {
*obj = to_PyDict(tmp, names);
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "returning as dict"));
// PyObject_CallObject(my_callback, argslist);
// }
Py_DECREF(tmp);
}
return 1;
}
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);
}
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;
}