コード例 #1
0
ファイル: sanitization.c プロジェクト: cran/bnlearn
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*/
コード例 #2
0
ファイル: dots.c プロジェクト: crowding/fexpr
/* 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;
}
コード例 #3
0
ファイル: vcftype.c プロジェクト: Bioconductor/VCF_projects
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);
}
コード例 #4
0
ファイル: codec.c プロジェクト: 0xrofi/Aquaplus
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;
}
コード例 #5
0
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]");
  }
}
コード例 #6
0
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());
}
コード例 #7
0
ファイル: any_na.c プロジェクト: Libardo1/Kmisc
// [[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;
}
コード例 #8
0
ファイル: uniqlist.c プロジェクト: AbhishekKapoor/data.table
// 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");
        }
    }
コード例 #9
0
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)));
    }
}
コード例 #10
0
ファイル: settings.c プロジェクト: brodieG/validate
/*
 * 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;
}
コード例 #11
0
// [[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;
}
コード例 #12
0
ファイル: seq.c プロジェクト: kalibera/rexp
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;
}
コード例 #13
0
ファイル: frank.c プロジェクト: ChinWeiLu/data.table
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)));
        }
    }
コード例 #14
0
ファイル: any_special.c プロジェクト: 00tau/BBmisc
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;
}
コード例 #15
0
ファイル: logic.c プロジェクト: nirvananoob/r-source
/* 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);
}
コード例 #16
0
ファイル: subset.c プロジェクト: RTellis/data.table
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;
}
コード例 #17
0
ファイル: melt_dataframe.c プロジェクト: RGLab/LumiR
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;
}
コード例 #18
0
ファイル: melt_dataframe.c プロジェクト: RGLab/LumiR
// 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;
}
コード例 #19
0
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"));
}
コード例 #20
0
ファイル: fields.c プロジェクト: Hydrophile/RMySQL
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;
}
コード例 #21
0
ファイル: 5obj.c プロジェクト: cloudaice/golang
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;
}
コード例 #22
0
ファイル: vcftype.c プロジェクト: Bioconductor/VCF_projects
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;
}
コード例 #23
0
ファイル: subset.c プロジェクト: Maxsl/r-source
/* 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);
}
コード例 #24
0
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;
}
コード例 #25
0
ファイル: status.c プロジェクト: 0xrofi/Aquaplus
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);
	}
}
コード例 #26
0
ファイル: utils.c プロジェクト: Libardo1/COMPASS
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;
}
コード例 #27
0
ファイル: reorder.c プロジェクト: franknarf1/data.table
// 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 {
コード例 #28
0
ファイル: wrappers.c プロジェクト: AbhishekKapoor/data.table
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;
}
コード例 #29
0
ファイル: fmelt.c プロジェクト: kaybenleroll/datatable
// 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);
}
コード例 #30
0
ファイル: vadr.c プロジェクト: crowding/memo
/* 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)));
  }
}