C++ NEW_INTEGER函数代码示例

SEXP get_tol_data(SEXP directory, SEXP coverage, SEXP filename) 
{
	int i,n;
	void **pdata;
	char pathtofile[PATH];
	AVCTol *reg;
	AVCBinFile *file;
	SEXP *table, aux;


	strcpy(pathtofile, CHAR(STRING_ELT(directory,0)));
	complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)), 1);/*FIXME*/

	if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileTOL)))
		error("Error opening file");

	n=0;

	while(AVCBinReadNextTol(file)){n++;}

	Rprintf("Number of TOLERANCES:%d\n", n);
	
	table=calloc(3, sizeof(SEXP));
	pdata=calloc(3, sizeof(void *));

	PROTECT(table[0]=NEW_INTEGER(n));
	pdata[0]=INTEGER(table[0]);
	PROTECT(table[1]=NEW_INTEGER(n));
	pdata[1]=INTEGER(table[1]);
	PROTECT(table[2]=NEW_NUMERIC(n));
	pdata[2]=REAL(table[2]);

	if(AVCBinReadRewind(file))
		error("Rewind");

	for(i=0;i<n;i++)
	{
		if(!(reg=(AVCTol*)AVCBinReadNextTol(file)))
			error("Error while reading register");

		((int *)pdata[0])[i]=reg->nIndex;

		((int *)pdata[1])[i]=reg->nFlag;

		((double *)pdata[2])[i]=reg->dValue;
	}

	PROTECT(aux=NEW_LIST(3));
	for(i=0;i<3;i++)
		SET_VECTOR_ELT(aux, i, table[i]);

	UNPROTECT(4);

	free(table);
	free(pdata);

	return aux;
}

USER_OBJECT_
asRCairoPath(cairo_path_t *path)
{
	static gchar *pathNames[] = { "status", "data", NULL };
	
	cairo_path_data_t *data;
	gint i, j;
	USER_OBJECT_ s_path, s_data;
	
	PROTECT(s_path = NEW_LIST(2));
	SET_VECTOR_ELT(s_path, 0, asREnum(path->status, CAIRO_TYPE_STATUS));
	
	for (i = 0, j = 0; i < path->num_data; i++, j++) {
		i += path->data[i].header.length;
	}
	
	s_data = NEW_LIST(j);
	SET_VECTOR_ELT(s_path, 1, s_data);
	
	for (i = 0, j = 0; i < path->num_data; i+= data->header.length, j++) {
		USER_OBJECT_ s_data_el = NULL_USER_OBJECT;
		data = &path->data[i];
		switch(data->header.type) {
		case CAIRO_PATH_MOVE_TO:
		case CAIRO_PATH_LINE_TO:
			PROTECT(s_data_el = NEW_INTEGER(2));
			INTEGER_DATA(s_data_el)[0] = data[1].point.x;
			INTEGER_DATA(s_data_el)[1] = data[1].point.y;
		break;
		case CAIRO_PATH_CURVE_TO:
			PROTECT(s_data_el = NEW_INTEGER(6));
			INTEGER_DATA(s_data_el)[0] = data[1].point.x;
			INTEGER_DATA(s_data_el)[1] = data[1].point.y;
			INTEGER_DATA(s_data_el)[2] = data[2].point.x;
			INTEGER_DATA(s_data_el)[3] = data[2].point.y;
			INTEGER_DATA(s_data_el)[4] = data[3].point.x;
			INTEGER_DATA(s_data_el)[5] = data[3].point.y;
		break;
		case CAIRO_PATH_CLOSE_PATH:
			PROTECT(s_data_el = NEW_INTEGER(0));
		break;
		default:
			PROBLEM "Converting Cairo path: did not understand type %d", data->header.type
			ERROR;
		}
		setAttrib(s_data_el, install("type"), asRInteger(data->header.type));
		UNPROTECT(1);
		SET_VECTOR_ELT(s_data, j, s_data_el);
	}
	
	SET_NAMES(s_path, asRStringArray(pathNames));
	
	UNPROTECT(1);
	
	return(s_path);
}

/**
 * @brief Instantiate the 'swCarbon' class and copies the values of the C variable
 * 'SW_Carbon' into a R variable of the S4 'swCarbon' class.
 * @return An instance of the swCarbon class.
 */
SEXP onGet_SW_CARBON(void) {
  // Create access variables
  SEXP class, object,
    CarbonUseBio, CarbonUseWUE, Scenario, DeltaYear, CO2ppm, CO2ppm_Names,
    cCO2ppm_Names;
  char *cCO2ppm[] = {"Year", "CO2ppm"};
  char *cSW_CARBON[] = {"CarbonUseBio", "CarbonUseWUE", "Scenario", "DeltaYear", "CO2ppm"};
  int i, year, n_sim;
  double *vCO2ppm;

  SW_CARBON *c = &SW_Carbon;

  // Grab our S4 carbon class as an object
  PROTECT(class  = MAKE_CLASS("swCarbon"));
  PROTECT(object = NEW_OBJECT(class));

  // Copy values from C object 'SW_Carbon' into new S4 object
  PROTECT(CarbonUseBio = NEW_INTEGER(1));
  INTEGER(CarbonUseBio)[0] = c->use_bio_mult;
  SET_SLOT(object, install(cSW_CARBON[0]), CarbonUseBio);

  PROTECT(CarbonUseWUE = NEW_INTEGER(1));
  INTEGER(CarbonUseWUE)[0] = c->use_wue_mult;
  SET_SLOT(object, install(cSW_CARBON[1]), CarbonUseWUE);

  PROTECT(Scenario = NEW_STRING(1));
  SET_STRING_ELT(Scenario, 0, mkChar(c->scenario));
  SET_SLOT(object, install(cSW_CARBON[2]), Scenario);

  PROTECT(DeltaYear = NEW_INTEGER(1));
  INTEGER(DeltaYear)[0] = SW_Model.addtl_yr;
  SET_SLOT(object, install(cSW_CARBON[3]), DeltaYear);

  n_sim = SW_Model.endyr - SW_Model.startyr + 1;
  PROTECT(CO2ppm = allocMatrix(REALSXP, n_sim, 2));
  vCO2ppm = REAL(CO2ppm);
  for (i = 0, year = SW_Model.startyr; i < n_sim; i++, year++)
  {
    vCO2ppm[i + n_sim * 0] = year;
    vCO2ppm[i + n_sim * 1] = c->ppm[year];
  }
  PROTECT(CO2ppm_Names = allocVector(VECSXP, 2));
  PROTECT(cCO2ppm_Names = allocVector(STRSXP, 2));
  for (i = 0; i < 2; i++)
    SET_STRING_ELT(cCO2ppm_Names, i, mkChar(cCO2ppm[i]));
  SET_VECTOR_ELT(CO2ppm_Names, 1, cCO2ppm_Names);
  setAttrib(CO2ppm, R_DimNamesSymbol, CO2ppm_Names);
  SET_SLOT(object, install(cSW_CARBON[4]), CO2ppm);

  UNPROTECT(9);

  return object;
}

SEXP c_getMaxIndex(SEXP s_x, SEXP s_ties_method, SEXP s_na_rm) {
    if (length(s_x) == 0)
        return NEW_INTEGER(0);
    int ties_method = asInteger(s_ties_method);
    Rboolean na_rm = asInteger(s_na_rm);
    UNPACK_REAL_VECTOR(s_x, x, len_x);
    GetRNGstate();
    int index = get_max_index(x, len_x, 1, ties_method, na_rm);
    PutRNGstate();
    if (index == -1)
        return NEW_INTEGER(0);
    else
        return ScalarInteger(index);
}

SEXP scan_bam_template(SEXP rname, SEXP tag)
{
    if (R_NilValue != tag)
        if (!IS_CHARACTER(tag))
            Rf_error("'tag' must be NULL or 'character()'");
    SEXP tmpl = PROTECT(NEW_LIST(N_TMPL_ELTS));
    SET_VECTOR_ELT(tmpl, QNAME_IDX, NEW_CHARACTER(0));
    SET_VECTOR_ELT(tmpl, FLAG_IDX, NEW_INTEGER(0));
    SET_VECTOR_ELT(tmpl, RNAME_IDX, rname);
    SET_VECTOR_ELT(tmpl, STRAND_IDX, _tmpl_strand());
    SET_VECTOR_ELT(tmpl, POS_IDX, NEW_INTEGER(0));
    SET_VECTOR_ELT(tmpl, QWIDTH_IDX, NEW_INTEGER(0));
    SET_VECTOR_ELT(tmpl, MAPQ_IDX, NEW_INTEGER(0));
    SET_VECTOR_ELT(tmpl, CIGAR_IDX, NEW_CHARACTER(0));
    SET_VECTOR_ELT(tmpl, MRNM_IDX, rname);
    SET_VECTOR_ELT(tmpl, MPOS_IDX, NEW_INTEGER(0));
    SET_VECTOR_ELT(tmpl, ISIZE_IDX, NEW_INTEGER(0));
    SET_VECTOR_ELT(tmpl, SEQ_IDX, _tmpl_DNAStringSet());
    SET_VECTOR_ELT(tmpl, QUAL_IDX, _tmpl_PhredQuality());
    SET_VECTOR_ELT(tmpl, PARTITION_IDX, NEW_INTEGER(0));
    SET_VECTOR_ELT(tmpl, MATES_IDX, NEW_INTEGER(0));
    if (R_NilValue == tag) {
        SET_VECTOR_ELT(tmpl, TAG_IDX, R_NilValue);
    } else {
        SET_VECTOR_ELT(tmpl, TAG_IDX, NEW_LIST(LENGTH(tag)));
        SET_ATTR(VECTOR_ELT(tmpl, TAG_IDX), R_NamesSymbol, tag);
    }

    SEXP names = PROTECT(NEW_CHARACTER(N_TMPL_ELTS));
    for (int i = 0; i < N_TMPL_ELTS; ++i)
        SET_STRING_ELT(names, i, mkChar(TMPL_ELT_NMS[i]));
    SET_ATTR(tmpl, R_NamesSymbol, names);
    UNPROTECT(2);
    return tmpl;
}

/* --- .Call ENTRY POINT ---/
 * Same arguments as RangesList_encode_overlaps() plus:
 * 'query_hits', 'subject_hits': integer vectors of the same length.
 * 'flip_query': logical vector of the same length as 'query_hits'.
 */
SEXP Hits_encode_overlaps(SEXP query_starts, SEXP query_widths,
			  SEXP query_spaces, SEXP query_breaks,
			  SEXP subject_starts, SEXP subject_widths,
			  SEXP subject_spaces,
			  SEXP query_hits, SEXP subject_hits, SEXP flip_query)
{
	int q_len, s_len, ans_len, i, j, k;
	const int *q_hits, *s_hits;
	SEXP ans_Loffset, ans_Roffset, ans_encoding, ans_encoding_elt, ans;
	CharAE buf;

	/* TODO: Add some basic checking of the input values. */
	q_len = LENGTH(query_starts);
	s_len = LENGTH(subject_starts);
	ans_len = _check_integer_pairs(query_hits, subject_hits,
				       &q_hits, &s_hits,
				       "queryHits(hits)", "subjectHits(hits)");
	PROTECT(ans_Loffset = NEW_INTEGER(ans_len));
	PROTECT(ans_Roffset = NEW_INTEGER(ans_len));
	PROTECT(ans_encoding = NEW_CHARACTER(ans_len));
	buf = _new_CharAE(0);
	for (k = 0; k < ans_len; k++) {
		i = q_hits[k];
		j = s_hits[k];
		if (i == NA_INTEGER || i < 1 || i > q_len ||
		    j == NA_INTEGER || j < 1 || j > s_len) {
			UNPROTECT(3);
			error("'queryHits(hits)' or 'subjectHits(hits)' "
			      "contain invalid indices");
		}
		i--;
		j--;
		PROTECT(ans_encoding_elt = RangesList_encode_overlaps_ij(
				query_starts, query_widths,
				query_spaces, query_breaks,
				subject_starts, subject_widths, subject_spaces,
				i, j, LOGICAL(flip_query)[k],
				INTEGER(ans_Loffset) + k,
				INTEGER(ans_Roffset) + k,
				&buf));
		SET_STRING_ELT(ans_encoding, k, ans_encoding_elt);
		UNPROTECT(1);
		_CharAE_set_nelt(&buf, 0);
	}
	PROTECT(ans = make_LIST_from_ovenc_parts(ans_Loffset, ans_Roffset,
						 ans_encoding));
	UNPROTECT(4);
	return ans;
}

SEXP point_in_polygon(SEXP px, SEXP py, SEXP polx, SEXP poly) {
	int i;
	PLOT_POINT p;
	POLYGON pol;
	SEXP ret;

	S_EVALUATOR
	pol.lines = LENGTH(polx); /* check later that first == last */
	pol.p = (PLOT_POINT *) Calloc(pol.lines, PLOT_POINT); /* Calloc does error handling */
	for (i = 0; i < LENGTH(polx); i++) {
		pol.p[i].x = NUMERIC_POINTER(polx)[i];
		pol.p[i].y = NUMERIC_POINTER(poly)[i];
	}
    pol.close = (pol.p[0].x == pol.p[pol.lines - 1].x && 
			pol.p[0].y == pol.p[pol.lines - 1].y);
	setup_poly_minmax(&pol);

	PROTECT(ret = NEW_INTEGER(LENGTH(px)));
	for (i = 0; i < LENGTH(px); i++) {
		p.x = NUMERIC_POINTER(px)[i];
		p.y = NUMERIC_POINTER(py)[i];
		if ((p.x > pol.mbr.min.x) & (p.x <= pol.mbr.max.y) & (p.y > pol.mbr.min.y) & (p.y <= pol.mbr.max.y)) {
			INTEGER_POINTER(ret)[i] = InPoly(p, &pol);
		} else {
			INTEGER_POINTER(ret)[i] = 0;
		}
	}
	Free(pol.p);
	UNPROTECT(1);
	return(ret);
}

SEXP spOverlap(SEXP bbbi, SEXP bbbj) {

	int pc=0,overlap=1;
	double bbi[4], bbj[4];
	SEXP ans;

	PROTECT(ans = NEW_INTEGER(1)); pc++;
	bbi[0] = NUMERIC_POINTER(bbbi)[0];
	bbi[1] = NUMERIC_POINTER(bbbi)[1];
	bbi[2] = NUMERIC_POINTER(bbbi)[2];
	bbi[3] = NUMERIC_POINTER(bbbi)[3];
	bbj[0] = NUMERIC_POINTER(bbbj)[0];
	bbj[1] = NUMERIC_POINTER(bbbj)[1];
	bbj[2] = NUMERIC_POINTER(bbbj)[2];
	bbj[3] = NUMERIC_POINTER(bbbj)[3];

        if ((bbi[0]>bbj[2]) | (bbi[1]>bbj[3]) | 
		(bbi[2]<bbj[0]) | (bbi[3]<bbj[1]) ) {
		overlap=0;
	}

	INTEGER_POINTER(ans)[0] = overlap;		
	UNPROTECT(pc); /* ans */
	return(ans);
}

SEXP
R_copyIntArray(SEXP ref, SEXP rlen)
{
  int len = INTEGER(rlen)[0], i;
  SEXP ans;
  int *vals = (int *) R_ExternalPtrAddr(ref);
  if(!vals) 
      return(NEW_INTEGER(0));

  PROTECT(ans = NEW_INTEGER(len));
  for(i = 0; i < len; i++) 
      INTEGER(ans)[i] = vals[i];

  UNPROTECT(1);	
  return(ans);
}

USER_OBJECT_
asREnum(int value, GType etype)
{
    USER_OBJECT_ ans, names;
    GEnumValue *evalue;
    PROTECT(ans = NEW_INTEGER(1));
    INTEGER_DATA(ans)[0] = value;

    if (!(evalue = g_enum_get_value(g_type_class_ref(etype), value))) {
        PROBLEM "Unknown enum value %d", value
        ERROR;
    }

    PROTECT(names = NEW_CHARACTER(1));
    SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(evalue->value_name));
    SET_NAMES(ans, names);

    PROTECT(names = NEW_CHARACTER(2));
    SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(g_type_name(etype)));
    SET_STRING_ELT(names, 1, COPY_TO_USER_STRING("enum"));
    SET_CLASS(ans, names);

    UNPROTECT(3);

    return(ans);
}

SEXP rph_tree_summary_rchild(SEXP treeP) {
  TreeNode *tr = rph_tree_new(treeP), *node;
  int i, *rchild, nnode, *idmap;
  List *nodes = tr_preorder(tr);
  SEXP result;

  nnode = lst_size(nodes);
  result = PROTECT(NEW_INTEGER(nnode));
  rchild = INTEGER_POINTER(result);
  idmap = smalloc((nnode+1)*sizeof(int));
  for (i=0; i < nnode; i++) {
    node = (TreeNode*)lst_get_ptr(nodes, i);
    if (node->id > nnode || node->id < 0)
      die("invalid id (%i) in tree node\n", node->id);
    idmap[(int)node->id] = i;
  }
  for (i=0; i < nnode; i++) {
    node = (TreeNode*)lst_get_ptr(nodes, i);
    if (node->rchild == NULL)
      rchild[idmap[node->id]] = -1;
    else rchild[idmap[node->id]] = idmap[node->rchild->id] + 1;
  }
  UNPROTECT(1);
  return result;
}

/* --- .Call ENTRY POINT --- */
SEXP CompressedNormalIRangesList_max(SEXP x, SEXP use_names)
{
	SEXP ans, ans_names;
	cachedCompressedIRangesList cached_x;
	cachedIRanges cached_ir;
	int x_length, ir_length, i;
	int *ans_elt;

	cached_x = _cache_CompressedIRangesList(x);
	x_length = _get_cachedCompressedIRangesList_length(&cached_x);
	PROTECT(ans = NEW_INTEGER(x_length));
	for (i = 0, ans_elt = INTEGER(ans); i < x_length; i++, ans_elt++) {
		cached_ir = _get_cachedCompressedIRangesList_elt(&cached_x, i);
		ir_length = _get_cachedIRanges_length(&cached_ir);
		if (ir_length == 0) {
			*ans_elt = R_INT_MIN;
		} else {
			*ans_elt = _get_cachedIRanges_elt_end(&cached_ir, ir_length - 1);
		}
	}
	if (LOGICAL(use_names)[0]) {
		PROTECT(ans_names = duplicate(_get_CompressedList_names(x)));
		SET_NAMES(ans, ans_names);
		UNPROTECT(1);
	}
	UNPROTECT(1);
	return ans;
}

/* R   I N T E R F A C E */
SEXP add( SEXP Rp, SEXP Rq, SEXP Rn ) 
{
    /* D E C L     I N P U T */
    const int *p, *q, *n;

    /* D E C L     O U T P U T */
    int *res;
    SEXP Rres;

    /* D E C L     L O C A L */
    int i;

    /* I N I T     I N P U T */
    PROTECT(Rp = AS_INTEGER(Rp) );
    PROTECT(Rq = AS_INTEGER(Rq) );
    PROTECT(Rn = AS_INTEGER(Rn) );
    p = INTEGER_POINTER(Rp);
    q = INTEGER_POINTER(Rq);
    n = INTEGER_POINTER(Rn);

    /* I N I T     O U T P U T */
    PROTECT(Rres = NEW_INTEGER( (1<<(*n)) )); 
    res = INTEGER_POINTER(Rres);

    /* T H E   F U N C T I O N */
    for( i=0; i<(1<<(*n)); ++i ) 
        res[i] = ( p[i]+q[i] )%2;

    /* G O O D B Y E */
    UNPROTECT(4);
    return Rres;    
}

SEXP RS_DBI_createNamedList(char **names, SEXPTYPE *types, int *lengths, int  n) {
  SEXP output, output_names, obj = R_NilValue;
  int  num_elem;
  int   j;

  PROTECT(output = NEW_LIST(n));
  PROTECT(output_names = NEW_CHARACTER(n));
  for(j = 0; j < n; j++){
    num_elem = lengths[j];
    switch((int)types[j]){
    case LGLSXP:
      PROTECT(obj = NEW_LOGICAL(num_elem));
      break;
    case INTSXP:
      PROTECT(obj = NEW_INTEGER(num_elem));
      break;
    case REALSXP:
      PROTECT(obj = NEW_NUMERIC(num_elem));
      break;
    case STRSXP:
      PROTECT(obj = NEW_CHARACTER(num_elem));
      break;
    case VECSXP:
      PROTECT(obj = NEW_LIST(num_elem));
      break;
    default:
      error("unsupported data type");
    }
    SET_ELEMENT(output, (int)j, obj);
    SET_CHR_EL(output_names, j, mkChar(names[j]));
  }
  SET_NAMES(output, output_names);
  UNPROTECT(n+2);
  return(output);
}

SEXP R_RngStreams_GetIncreasedPrecis (SEXP R_stream)
     /*----------------------------------------------------------------------*/
     /* Get flag for increased precision in Stream object.                   */
     /*                                                                      */
     /* parameters:                                                          */
     /*   R_stream ... (pointer) ... pointer the Stream object               */
     /*                                                                      */
     /* return:                                                              */
     /*   increased precision flag                                           */
     /*----------------------------------------------------------------------*/
{
  SEXP R_incp;
  RngStream stream;
  int incp;

  /* check pointer */
  CHECK_STREAM_PTR(R_stream);

  /* Extract pointer to generator */
  stream = R_ExternalPtrAddr(R_stream);
  CHECK_NULL(stream);

  /* get data */
  incp = stream->IncPrec;

  PROTECT(R_incp = NEW_INTEGER(1));
  INTEGER_POINTER(R_incp)[0] = incp;
  UNPROTECT(1);

  return R_incp;

} /* end of R_RngStreams_GetIncreasedPrecis() */