SEXP data_type(SEXP data) {
int i = 0, numeric = 0, categorical = 0, ordinal = 0, ncol = length(data);
SEXP column, nodes = getAttrib(data, R_NamesSymbol);
for (i = 0; i < ncol; i++) {
column = VECTOR_ELT(data, i);
switch(TYPEOF(column)) {
case REALSXP:
numeric++;
break;
case INTSXP:
if (c_is(column, "ordered"))
ordinal++;
else if (c_is(column, "factor"))
categorical++;
else
error("variable %s is not supported in bnlearn (type: %s).",
NODE(i), type2char(TYPEOF(column)));
break;
default:
error("variable %s is not supported in bnlearn (type: %s).",
NODE(i), type2char(TYPEOF(column)));
}/*SWITCH*/
}/*FOR*/
if (numeric > 0) {
if ((categorical == 0) && (ordinal == 0))
return mkString("continuous");
else
return mkString("mixed-cg");
}/*THEN*/
else {
if ((categorical == 0) && (ordinal > 0))
return mkString("ordered");
else if ((categorical > 0) && (ordinal == 0))
return mkString("factor");
else
return mkString("mixed-do");
}/*ELSE*/
}/*DATA_TYPE*/
/* Convert a DOTSXP into a list of raw promise objects. */
SEXP _dotslist_to_list(SEXP x) {
int i;
SEXP output, names;
int len = length(x);
PROTECT(output = allocVector(VECSXP, len));
PROTECT(names = allocVector(STRSXP, len));
if (len > 0) {
if (TYPEOF(x) != DOTSXP)
error("Expected a ..., got %s", type2char(TYPEOF(x)));
}
for (i = 0; i < len; x=CDR(x), i++) {
if (CAR(x) == R_MissingArg) {
SET_VECTOR_ELT(output, i, emptypromise());
} else {
SET_VECTOR_ELT(output, i, CAR(x));
}
SET_STRING_ELT(names, i, isNull(TAG(x)) ? R_BlankString : PRINTNAME(TAG(x)));
}
if (len > 0) {
setAttrib(output, R_NamesSymbol, names);
}
UNPROTECT(2);
return output;
}
void _vcftype_free(struct vcftype_t *vcftype)
{
if (NULL == vcftype)
return;
int sz = vcftype->nrow * (0 == vcftype->ncol ? 1 : vcftype->ncol);
switch (vcftype->type) {
case NILSXP:
break;
case LGLSXP:
Free(vcftype->u.logical);
break;
case INTSXP:
Free(vcftype->u.integer);
break;
case REALSXP:
Free(vcftype->u.numeric);
break;
case STRSXP:
for (int i = 0; i < sz; ++i)
Free(vcftype->u.character[i]);
Free(vcftype->u.character);
break;
case VECSXP:
for (int i = 0; i < sz; ++i)
_vcftype_free(vcftype->u.list[i]);
Free(vcftype->u.list);
break;
default:
Rf_error("(internal) unhandled type '%s'",
type2char(vcftype->type));
}
Free(vcftype);
}
static int vfw_debug(void *handle,
int opt,
void *param1,
void *param2)
{
switch (opt) {
case XVID_PLG_CREATE:
*((void**)param2) = NULL;
case XVID_PLG_INFO:
case XVID_PLG_DESTROY:
case XVID_PLG_BEFORE:
return 0;
case XVID_PLG_AFTER:
{
xvid_plg_data_t *data = (xvid_plg_data_t *) param1;
/* We don't use DPRINTF here because it's active only for _DEBUG
* builds and that activates lot of other debug printfs. We only
* want these all the time */
char buf[1024];
sprintf(buf, "[%6i] type=%c Q:%2i length:%6i",
data->frame_num,
type2char(data->type),
data->quant,
data->length);
OutputDebugString(buf);
return 0;
}
}
return XVID_ERR_FAIL;
}
void InstructionPrinter::do_LoadIndexed(LoadIndexed* x) {
print_indexed(x);
output()->print(" (%c)", type2char(x->elt_type()));
if (x->check_flag(Instruction::NeedsRangeCheckFlag)) {
output()->print(" [rc]");
}
}
void InstructionPrinter::do_StoreField(StoreField* x) {
print_field(x);
output()->print(" := ");
print_value(x->value());
output()->print(" (%c)", type2char(x->field()->type()->basic_type()));
output()->print(" %s", x->field()->name()->as_utf8());
}
// [[register]]
SEXP any_na( SEXP x ) {
SEXP out;
PROTECT(out = allocVector(LGLSXP, 1));
int len = length(x);
switch( TYPEOF(x) ) {
case REALSXP: {
double* ptr = REAL(x);
for( int i=0; i < len; ++i ) {
if( ISNA( ptr[i] ) || ISNAN( ptr[i] ) ) {
LOGICAL(out)[0] = TRUE;
UNPROTECT(1);
return out;
}
}
LOGICAL(out)[0] = FALSE;
UNPROTECT(1);
return out;
}
case INTSXP: {
int* ptr = INTEGER(x);
for( int i=0; i < len; ++i ) {
if( ptr[i] == NA_INTEGER ) {
LOGICAL(out)[0] = TRUE;
UNPROTECT(1);
return out;
}
}
LOGICAL(out)[0] = FALSE;
UNPROTECT(1);
return out;
}
case LGLSXP: {
int* ptr = LOGICAL(x);
for( int i=0; i < len; ++i ) {
if( ptr[i] == NA_LOGICAL ) {
LOGICAL(out)[0] = TRUE;
UNPROTECT(1);
return out;
}
}
LOGICAL(out)[0] = FALSE;
UNPROTECT(1);
return out;
}
case STRSXP: {
for( int i=0; i < len; ++i ) {
if( STRING_ELT(x, i) == NA_STRING ) {
LOGICAL(out)[0] = TRUE;
UNPROTECT(1);
return out;
}
}
LOGICAL(out)[0] = FALSE;
UNPROTECT(1);
return out;
}
}
error("argument is of incompatible type '%s'", type2char( TYPEOF(x) ) );
return x;
}
// DONE: return 'uniqlist' as a vector (same as duplist) and write a separate function to get group sizes
// Also improvements for numeric type with a hack of checking unsigned int (to overcome NA/NaN/Inf/-Inf comparisons) (> 2x speed-up)
SEXP uniqlist(SEXP l, SEXP order)
{
// This works like UNIX uniq as referred to by ?base::unique; i.e., it
// drops immediately repeated rows but doesn't drop duplicates of any
// previous row. Unless, order is provided, then it also drops any previous
// row. l must be a list of same length vectors ans is allocated first
// (maximum length the number of rows) and the length returned in anslen.
// DONE: ans is now grown
Rboolean b, byorder;
unsigned long long *ulv; // for numeric check speed-up
SEXP v, ans, class;
R_len_t i, j, nrow, ncol, len, thisi, previ, isize=1000;
int *iidx = Calloc(isize, int); // for 'idx'
int *n_iidx; // to catch allocation errors using Realloc!
if (NA_INTEGER != NA_LOGICAL || sizeof(NA_INTEGER)!=sizeof(NA_LOGICAL))
error("Have assumed NA_INTEGER == NA_LOGICAL (currently R_NaInt). If R changes this in future (seems unlikely), an extra case is required; a simple change.");
ncol = length(l);
nrow = length(VECTOR_ELT(l,0));
len = 1;
iidx[0] = 1; // first row is always the first of the first group
byorder = INTEGER(order)[0] != -1;
// Using MISSING() does not seem stable under windows. Always having arguments passed in seems a good idea anyway.
thisi = byorder ? INTEGER(order)[0]-1 : 0;
for (i=1; i<nrow; i++) {
previ = thisi;
thisi = byorder ? INTEGER(order)[i]-1 : i;
j = ncol; // the last column varies the most frequently so check that first and work backwards
b = TRUE;
while (--j>=0 && b) {
v=VECTOR_ELT(l,j);
switch (TYPEOF(v)) {
case INTSXP : case LGLSXP :
b=INTEGER(v)[thisi]==INTEGER(v)[previ]; break;
case STRSXP :
// fix for #469, when key is set, duplicated calls uniqlist, where encoding
// needs to be taken care of.
b=ENC2UTF8(STRING_ELT(v,thisi))==ENC2UTF8(STRING_ELT(v,previ)); break; // marked non-utf8 encodings are converted to utf8 so as to match properly when inputs are of different encodings.
case REALSXP :
ulv = (unsigned long long *)REAL(v);
b = ulv[thisi] == ulv[previ]; // (gives >=2x speedup)
if (!b) {
class = getAttrib(v, R_ClassSymbol);
twiddle = (isString(class) && STRING_ELT(class, 0)==char_integer64) ? &i64twiddle : &dtwiddle;
b = twiddle(ulv, thisi, 1) == twiddle(ulv, previ, 1);
}
break;
// TO DO: store previ twiddle call, but it'll need to be vector since this is in a loop through columns. Hopefully the first == will short circuit most often
default :
error("Type '%s' not supported", type2char(TYPEOF(v)));
}
}
if (!b) iidx[len++] = i+1;
if (len >= isize) {
isize = 1.1*isize*nrow/i;
n_iidx = Realloc(iidx, isize, int);
if (n_iidx != NULL) iidx = n_iidx; else error("Error in reallocating memory in 'uniqlist'\n");
}
}
SEXP attribute_hidden count_not_missing(SEXP x) {
switch(TYPEOF(x)) {
case LGLSXP: return ScalarInteger(count_not_missing_logical(x));
case INTSXP: return ScalarInteger(count_not_missing_integer(x));
case REALSXP: return ScalarInteger(count_not_missing_double(x));
case STRSXP: return ScalarInteger(count_not_missing_string(x));
case VECSXP: return ScalarInteger(count_not_missing_list(x));
case NILSXP: return ScalarInteger(0);
default: error("Object of type '%s' not supported", type2char(TYPEOF(x)));
}
}
/*
* Initialize settings with default values; why did we end up deciding to use
* all the 2^n - 1 values?
*/
struct VALC_settings VALC_settings_init() {
return (struct VALC_settings) {
.type_mode = 0,
.attr_mode = 0,
.lang_mode = 0,
.fun_mode = 0,
.fuzzy_int_max_len = 100,
.suppress_warnings = 0,
.in_attr = 0,
.env = R_NilValue,
.width = -1,
.env_depth_max = 65535L,
.symb_sub_depth_max = 65535L,
.nchar_max = 65535L,
.symb_size_max = 15000L,
.track_hash_content_size = 63L,
.result_list_size_init = 64L,
.result_list_size_max = 2048L
};
}
/*
* Check that a SEXP could pass as a scalar integer and return it as a long
*/
static long VALC_is_scalar_int(
SEXP x, const char * x_name, int x_min, int x_max
) {
SEXPTYPE x_type = TYPEOF(x);
if(x_type != REALSXP && x_type != INTSXP)
error(
"Setting `%s` must be integer-like (is %s).", x_name, type2char(x_type)
);
// Despite L notation, R integers are just ints, but there are checks to
// ensure ints are 32 bits on compilation and such
int x_int = asInteger(x);
if(xlength(x) != 1)
error(
"Setting `%s` must be scalar integer (is length %zu).", x_name,
xlength(x)
);
if(x_int == NA_INTEGER) error("Setting `%s` may not be NA.", x_name);
if(TYPEOF(x) == REALSXP) {
if(x_int != asReal(x)) error("Setting `%s` must be integer like.", x_name);
}
if(x_int < x_min || x_int > x_max)
error(
"Setting `%s` must be scalar integer between %d and %d (is %d).",
x_name, x_min, x_max, x_int
);
return x_int;
}
// [[register]]
SEXP charlist_transpose_to_df( SEXP x, SEXP names ) {
if( TYPEOF(x) != VECSXP ) {
error("argument must be a list; type is '%s'", type2char( TYPEOF(x)));
}
int out_nRow = length(x);
int out_nCol = length( VECTOR_ELT(x, 0) );
for (int i=0; i < out_nRow; ++i) {
if (length( VECTOR_ELT(x, i)) != out_nCol) {
error("each column of 'x' must be of equal length");
}
}
SEXP out = PROTECT( allocVector( VECSXP, out_nCol ) );
for( int j=0; j < out_nCol; ++j ) {
SEXP tmp = PROTECT( allocVector( STRSXP, out_nRow ) );
for( int i=0; i < out_nRow; ++i ) {
SET_STRING_ELT( tmp, i, STRING_ELT( VECTOR_ELT( x, i ), j ) );
}
SET_VECTOR_ELT( out, j, tmp );
UNPROTECT(1);
}
SEXP row_names = PROTECT( 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_ClassSymbol, mkString("data.frame"));
setAttrib(out, R_RowNamesSymbol, row_names);
// make the names
#define m out_nCol
if (isNull(names)) {
SEXP nm = PROTECT( allocVector(STRSXP, out_nCol) );
char str[ (int) log10(m) + 3];
for (int i = 0; i < m; ++i) {
sprintf(str, "%s%i", "V", i + 1);
SET_STRING_ELT(nm, i, mkChar(str));
}
setAttrib(out, R_NamesSymbol, nm);
UNPROTECT(1);
} else {
setAttrib(out, R_NamesSymbol, names);
}
#undef m
UNPROTECT(2);
return out;
}
SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP s = CAR(args), ncopy = CADR(args);
R_xlen_t nc;
SEXP a;
if (!isVector(ncopy))
error(_("incorrect type for second argument"));
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate an object of type '%s'"),
type2char(TYPEOF(s)));
nc = xlength(ncopy); // might be 0
if (nc == xlength(s))
PROTECT(a = rep2(s, ncopy));
else {
if (nc != 1) error(_("invalid '%s' value"), "times");
#ifdef LONG_VECTOR_SUPPORT
double snc = asReal(ncopy);
if (!R_FINITE(snc) || snc < 0)
error(_("invalid '%s' value"), "times");
nc = (R_xlen_t) snc;
#else
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid '%s' value"), "times");
#endif
R_xlen_t ns = xlength(s);
PROTECT(a = rep3(s, ns, nc * ns));
}
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
SEXP dt_na(SEXP x, SEXP cols) {
int i, j, n=0, this;
double *dv;
SEXP v, ans, class;
if (!isNewList(x)) error("Internal error. Argument 'x' to Cdt_na is type '%s' not 'list'", type2char(TYPEOF(x)));
if (!isInteger(cols)) error("Internal error. Argument 'cols' to Cdt_na is type '%s' not 'integer'", type2char(TYPEOF(cols)));
for (i=0; i<LENGTH(cols); i++) {
this = INTEGER(cols)[i];
if (this<1 || this>LENGTH(x))
error("Item %d of 'cols' is %d which is outside 1-based range [1,ncol(x)=%d]", i+1, this, LENGTH(x));
if (!n) n = length(VECTOR_ELT(x, this-1));
}
ans = PROTECT(allocVector(LGLSXP, n));
for (i=0; i<n; i++) LOGICAL(ans)[i]=0;
for (i=0; i<LENGTH(cols); i++) {
v = VECTOR_ELT(x, INTEGER(cols)[i]-1);
if (!length(v) || isNewList(v) || isList(v)) continue; // like stats:::na.omit.data.frame, skip list/pairlist columns
if (n != length(v))
error("Column %d of input list x is length %d, inconsistent with first column of that item which is length %d.", i+1,length(v),n);
switch (TYPEOF(v)) {
case LGLSXP:
for (j=0; j<n; j++) LOGICAL(ans)[j] |= (LOGICAL(v)[j] == NA_LOGICAL);
break;
case INTSXP:
for (j=0; j<n; j++) LOGICAL(ans)[j] |= (INTEGER(v)[j] == NA_INTEGER);
break;
case STRSXP:
for (j=0; j<n; j++) LOGICAL(ans)[j] |= (STRING_ELT(v, j) == NA_STRING);
break;
case REALSXP:
class = getAttrib(v, R_ClassSymbol);
if (isString(class) && STRING_ELT(class, 0) == char_integer64) {
dv = (double *)REAL(v);
for (j=0; j<n; j++) {
u.d = dv[j];
LOGICAL(ans)[j] |= (u.ull == NAINT64);
}
} else {
for (j=0; j<n; j++) LOGICAL(ans)[j] |= ISNAN(REAL(v)[j]);
}
break;
case RAWSXP:
// no such thing as a raw NA
// vector already initialised to all 0's
break;
case CPLXSXP:
// taken from https://github.com/wch/r-source/blob/d75f39d532819ccc8251f93b8ab10d5b83aac89a/src/main/coerce.c
for (j=0; j<n; j++) LOGICAL(ans)[j] |= (ISNAN(COMPLEX(v)[j].r) || ISNAN(COMPLEX(v)[j].i));
break;
default:
error("Unknown column type '%s'", type2char(TYPEOF(v)));
}
}
bool any_special(SEXP x) {
const int rtype = TYPEOF(x);
bool res = false;
#ifdef DEBUG
Rprintf("Checking Rtype %s (%i)", type2char(rtype), rtype);
#endif
switch(rtype) {
case LGLSXP: res = any_na_logical(x); break;
case INTSXP: res = any_na_integer(x); break;
case REALSXP: res = any_special_real(x); break;
case STRSXP: res = any_na_string(x); break;
case CPLXSXP: res = any_special_complex(x); break;
case LISTSXP:
case VECSXP: res = any_na_list(x); break;
case RAWSXP: break;
default: error("[any_special] Data type: '%s' (%i) not supported", type2char(rtype), rtype);
}
return res;
}
/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, s, t, call2;
int narm, has_na = 0;
/* initialize for behavior on empty vector
all(logical(0)) -> TRUE
any(logical(0)) -> FALSE
*/
Rboolean val = PRIMVAL(op) == _OP_ALL ? TRUE : FALSE;
PROTECT(args = fixup_NaRm(args));
PROTECT(call2 = duplicate(call));
SETCDR(call2, args);
if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
UNPROTECT(2);
return(ans);
}
ans = matchArgExact(R_NaRmSymbol, &args);
narm = asLogical(ans);
for (s = args; s != R_NilValue; s = CDR(s)) {
t = CAR(s);
/* Avoid memory waste from coercing empty inputs, and also
avoid warnings with empty lists coming from sapply */
if(xlength(t) == 0) continue;
/* coerceVector protects its argument so this actually works
just fine */
if (TYPEOF(t) != LGLSXP) {
/* Coercion of integers seems reasonably safe, but for
other types it is more often than not an error.
One exception is perhaps the result of lapply, but
then sapply was often what was intended. */
if(TYPEOF(t) != INTSXP)
warningcall(call,
_("coercing argument of type '%s' to logical"),
type2char(TYPEOF(t)));
t = coerceVector(t, LGLSXP);
}
val = checkValues(PRIMVAL(op), narm, LOGICAL(t), XLENGTH(t));
if (val != NA_LOGICAL) {
if ((PRIMVAL(op) == _OP_ANY && val)
|| (PRIMVAL(op) == _OP_ALL && !val)) {
has_na = 0;
break;
}
} else has_na = 1;
}
UNPROTECT(2);
return has_na ? ScalarLogical(NA_LOGICAL) : ScalarLogical(val);
}
static int check_idx(SEXP idx, int n)
{
int i, this, ans=0;
if (!isInteger(idx)) error("Internal error. 'idx' is type '%s' not 'integer'", type2char(TYPEOF(idx)));
for (i=0; i<LENGTH(idx); i++) { // check idx once up front and count the non-0 so we know how long the answer will be
this = INTEGER(idx)[i];
if (this==0) continue;
if (this!=NA_INTEGER && this<0) error("Internal error: item %d of idx is %d. Negatives should have been dealt with earlier.", i+1, this);
// this>n is treated as NA for consistency with [.data.frame and things like cbind(DT[w],DT[w+1])
ans++;
}
return ans;
}
SEXP stack_vector( SEXP x, int times ) {
SEXP out;
int len = length(x);
switch( TYPEOF(x) ) {
HANDLE_CASE( INTSXP, int );
HANDLE_CASE( REALSXP, double );
HANDLE_CASE( LGLSXP, int );
HANDLE_CASE_STRING;
}
// if we've reached here, we have an unhandled / incompatible SEXP type
error("argument is of incompatible type '%s'", type2char(TYPEOF(x)));
return R_NilValue;
}
// checks if all values in a VECSXP x are of the same type
bool diff_types(SEXP x, SEXP val_ind_) {
if (TYPEOF(x) != VECSXP) {
error("Expected a VECSXP but got a '%s'", type2char(TYPEOF(x)));
}
int n = length(val_ind_);
int* val_ind = INTEGER(val_ind_);
char type = TYPEOF( VECTOR_ELT(x, val_ind[0]) );
for (int i=1; i < n; ++i) {
if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != type) {
return true;
}
}
return false;
}
static void checkNames(SEXP x, SEXP s)
{
if (isVector(x) || isList(x) || isLanguage(x)) {
if (!isVector(s) && !isList(s))
error(_("invalid type (%s) for 'names': must be vector"),
type2char(TYPEOF(s)));
if (xlength(x) != xlength(s))
error(_("'names' attribute [%d] must be the same length as the vector [%d]"), length(s), length(x));
}
else if(IS_S4_OBJECT(x)) {
/* leave validity checks to S4 code */
}
else error(_("names() applied to a non-vector"));
}
SEXP rmysql_fields_info(SEXP rsHandle) {
RS_DBI_resultSet* result = RS_DBI_getResultSet(rsHandle);
RMySQLFields* flds = result->fields;
int n = flds->num_fields;
// Allocate output
SEXP output = PROTECT(allocVector(VECSXP, 4));
SEXP output_nms = PROTECT(allocVector(STRSXP, 4));
SET_NAMES(output, output_nms);
UNPROTECT(1);
SET_STRING_ELT(output_nms, 0, mkChar("name"));
SEXP names = PROTECT(allocVector(STRSXP, n));
for (int j = 0; j < n; j++) {
SET_STRING_ELT(names, j, mkChar(flds->name[j]));
}
SET_VECTOR_ELT(output, 0, names);
UNPROTECT(1);
SET_STRING_ELT(output_nms, 1, mkChar("Sclass"));
SEXP sclass = PROTECT(allocVector(STRSXP, n));
for (int j = 0; j < n; j++) {
const char* type = type2char(flds->Sclass[j]);
SET_STRING_ELT(sclass, j, mkChar(type));
}
SET_VECTOR_ELT(output, 1, sclass);
UNPROTECT(1);
SET_STRING_ELT(output_nms, 2, mkChar("type"));
SEXP types = PROTECT(allocVector(STRSXP, n));
for (int j = 0; j < n; j++) {
char* type = rmysql_type(flds->type[j]);
SET_STRING_ELT(types, j, mkChar(type));
}
SET_VECTOR_ELT(output, 2, types);
UNPROTECT(1);
SET_STRING_ELT(output_nms, 3, mkChar("length"));
SEXP lens = PROTECT(allocVector(INTSXP, n));
for (int j = 0; j < n; j++) {
INTEGER(lens)[j] = flds->length[j];
}
SET_VECTOR_ELT(output, 3, lens);
UNPROTECT(1);
UNPROTECT(1);
return output;
}
int
_read5(Biobuf *bp, Prog *p)
{
int as, n;
Addr a;
as = BGETC(bp); /* as */
if(as < 0)
return 0;
p->kind = aNone;
p->sig = 0;
if(as == ANAME || as == ASIGNAME){
if(as == ASIGNAME){
Bread(bp, &p->sig, 4);
p->sig = leswal(p->sig);
}
p->kind = aName;
p->type = type2char(BGETC(bp)); /* type */
p->sym = BGETC(bp); /* sym */
n = 0;
for(;;) {
as = BGETC(bp);
if(as < 0)
return 0;
n++;
if(as == 0)
break;
}
p->id = malloc(n);
if(p->id == 0)
return 0;
Bseek(bp, -n, 1);
if(Bread(bp, p->id, n) != n)
return 0;
return 1;
}
if(as == ATEXT)
p->kind = aText;
else if(as == AGLOBL)
p->kind = aData;
skip(bp, 6); /* scond(1), reg(1), lineno(4) */
a = addr(bp);
addr(bp);
if(a.type != D_OREG || a.name != D_STATIC && a.name != D_EXTERN)
p->kind = aNone;
p->sym = a.sym;
return 1;
}
struct vcftype_t *_vcftype_grow(struct vcftype_t * vcftype, int nrow)
{
if (NULL == vcftype)
return vcftype;
int ncol = (0 == vcftype->ncol) ? 1 : vcftype->ncol;
int osz = vcftype->nrow * ncol, sz = nrow * ncol;
switch (vcftype->type) {
case NILSXP:
break;
case LGLSXP:
vcftype->u.logical = (int *)
vcf_Realloc(vcftype->u.logical, sz * sizeof(int));
for (int i = osz; i < sz; ++i)
vcftype->u.logical[i] = FALSE;
break;
case INTSXP:
vcftype->u.integer = (int *)
vcf_Realloc(vcftype->u.integer, sz * sizeof(int));
for (int i = osz; i < sz; ++i)
vcftype->u.integer[i] = R_NaInt;
break;
case REALSXP:
vcftype->u.numeric = (double *)
vcf_Realloc(vcftype->u.numeric, sz * sizeof(double));
for (int i = osz; i < sz; ++i)
vcftype->u.numeric[i] = R_NaReal;
break;
case STRSXP:
vcftype->u.character = (char **)
vcf_Realloc(vcftype->u.character, sz * sizeof(char *));
for (int i = osz; i < sz; ++i)
vcftype->u.character[i] = NULL;
break;
case VECSXP:
vcftype->u.list = (struct vcftype_t **)
vcf_Realloc(vcftype->u.list, sz * sizeof(struct vcftype_t *));
for (int i = osz; i < sz; ++i)
vcftype->u.list[i] = NULL;
break;
default:
Rf_error("(internal) unhandled type '%s'",
type2char(vcftype->type));
}
vcftype->nrow = nrow;
return vcftype;
}
/* The $ subset operator.
We need to be sure to only evaluate the first argument.
The second will be a symbol that needs to be matched, not evaluated.
*/
SEXP attribute_hidden do_subset3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP input, nlist, ans;
checkArity(op, args);
/* first translate CADR of args into a string so that we can
pass it down to DispatchorEval and have it behave correctly */
input = PROTECT(allocVector(STRSXP, 1));
nlist = CADR(args);
if (TYPEOF(nlist) == PROMSXP)
nlist = eval(nlist, env);
if(isSymbol(nlist) )
SET_STRING_ELT(input, 0, PRINTNAME(nlist));
else if(isString(nlist) )
SET_STRING_ELT(input, 0, STRING_ELT(nlist, 0));
else {
errorcall(call,_("invalid subscript type '%s'"),
type2char(TYPEOF(nlist)));
}
/* replace the second argument with a string */
/* Previously this was SETCADR(args, input); */
/* which could cause problems when nlist was */
/* ..., as in PR#8718 */
PROTECT(args = CONS(CAR(args), CONS(input, R_NilValue)));
/* If the first argument is an object and there is */
/* an approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall */
/* through to the generic code below. Note that */
/* evaluation retains any missing argument indicators. */
if(R_DispatchOrEvalSP(call, op, "$", args, env, &ans)) {
UNPROTECT(2); /* input, args */
if (NAMED(ans))
SET_NAMED(ans, 2);
return(ans);
}
UNPROTECT(2); /* input, args */
return R_subset3_dflt(CAR(ans), STRING_ELT(input, 0), call);
}
static SEXP row_names_gets(SEXP vec , SEXP val)
{
SEXP ans;
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if(isReal(val) && length(val) == 2 && ISNAN(REAL(val)[0]) ) {
/* This should not happen, but if a careless user dput()s a
data frame and sources the result, it will */
PROTECT(val = coerceVector(val, INTSXP));
ans = installAttrib(vec, R_RowNamesSymbol, val);
UNPROTECT(1);
return ans;
}
if(isInteger(val)) {
Rboolean OK_compact = TRUE;
int i, n = LENGTH(val);
if(n == 2 && INTEGER(val)[0] == NA_INTEGER) {
n = INTEGER(val)[1];
} else if (n > 2) {
for(i = 0; i < n; i++)
if(INTEGER(val)[i] != i+1) {
OK_compact = FALSE;
break;
}
} else OK_compact = FALSE;
if(OK_compact) {
/* we hide the length in an impossible integer vector */
PROTECT(val = allocVector(INTSXP, 2));
INTEGER(val)[0] = NA_INTEGER;
INTEGER(val)[1] = n;
ans = installAttrib(vec, R_RowNamesSymbol, val);
UNPROTECT(1);
return ans;
}
} else if(!isString(val))
error(_("row names must be 'character' or 'integer', not '%s'"),
type2char(TYPEOF(val)));
PROTECT(val);
ans = installAttrib(vec, R_RowNamesSymbol, val);
UNPROTECT(1);
return ans;
}
static void
status_debugoutput(status_t *s, int type, int length, int quant)
{
if (s->hDlg && IsDlgButtonChecked(s->hDlg,IDC_SHOWINTERNALS)==BST_CHECKED) {
LRESULT litem;
char buf[128];
sprintf(buf, "[%6d] ->%c q:%2d (%6d b)",
(unsigned int)(s->count[0]), type2char(type), quant, length);
SendDlgItemMessage (s->hDlg,IDC_DEBUGOUTPUT, LB_ADDSTRING, 0, (LPARAM)(LPSTR)buf);
litem = SendDlgItemMessage (s->hDlg, IDC_DEBUGOUTPUT, LB_GETCOUNT, 0, 0L);
if (litem > 12)
litem = SendDlgItemMessage (s->hDlg,IDC_DEBUGOUTPUT, LB_DELETESTRING, 0, 0L);
SendDlgItemMessage(s->hDlg,IDC_DEBUGOUTPUT, LB_SETCURSEL, (WORD)(litem-1), 0L);
}
}
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;
}
// reverse a vector - equivalent of rev(x) in base, but implemented in C and about 12x faster (on 1e8)
SEXP setrev(SEXP x) {
R_len_t j, n, len;
size_t size;
char *tmp, *xt;
if (TYPEOF(x) == VECSXP || isMatrix(x)) error("Input 'x' must be a vector");
len = length(x);
if (len <= 1) return(x);
size = SIZEOF(x);
if (!size) error("don't know how to reverse type '%s' of input 'x'.",type2char(TYPEOF(x)));
n = (int)(len/2);
xt = (char *)DATAPTR(x);
if (size==4) {
tmp = (char *)Calloc(1, int);
if (!tmp) error("unable to allocate temporary working memory for reordering x");
for (j=0;j<n;j++) {
*(int *)tmp = ((int *)xt)[j]; // just copies 4 bytes (pointers on 32bit too)
((int *)xt)[j] = ((int *)xt)[len-1-j];
((int *)xt)[len-1-j] = *(int *)tmp;
}
} else {
SEXP dim(SEXP x)
{
// fast implementation of dim.data.table
if (TYPEOF(x) != VECSXP) {
error("dim.data.table expects a data.table as input (which is a list), but seems to be of type %s",
type2char(TYPEOF(x)));
}
SEXP ans = allocVector(INTSXP, 2);
if(length(x) == 0) {
INTEGER(ans)[0] = 0;
INTEGER(ans)[1] = 0;
}
else {
INTEGER(ans)[0] = length(VECTOR_ELT(x, 0));
INTEGER(ans)[1] = length(x);
}
return ans;
}
// plucked and modified from base (coerce.c and summary.c).
// for melt's `na.rm=TRUE` option
SEXP which_notNA(SEXP x) {
SEXP v, ans;
int i, j=0, n = length(x), *buf;
PROTECT(v = allocVector(LGLSXP, n));
switch (TYPEOF(x)) {
case LGLSXP:
for (i = 0; i < n; i++) LOGICAL(v)[i] = (LOGICAL(x)[i] != NA_LOGICAL);
break;
case INTSXP:
for (i = 0; i < n; i++) LOGICAL(v)[i] = (INTEGER(x)[i] != NA_INTEGER);
break;
case REALSXP:
for (i = 0; i < n; i++) LOGICAL(v)[i] = !ISNAN(REAL(x)[i]);
break;
case STRSXP:
for (i = 0; i < n; i++) LOGICAL(v)[i] = (STRING_ELT(x, i) != NA_STRING);
break;
default:
error("%s() applied to non-(list or vector) of type '%s'",
"which_notNA", type2char(TYPEOF(x)));
}
buf = (int *) R_alloc(n, sizeof(int));
for (i = 0; i < n; i++) {
if (LOGICAL(v)[i] == TRUE) {
buf[j] = i + 1;
j++;
}
}
n = j;
PROTECT(ans = allocVector(INTSXP, n));
memcpy(INTEGER(ans), buf, sizeof(int) * n);
UNPROTECT(2);
return(ans);
}
/* Assert that some object is a type. */
void assert_type(SEXP x, SEXPTYPE type) {
if (TYPEOF(x) != type) {
error("Expected %s, got %s", type2char(type), type2char(TYPEOF(x)));
}
}
