Example #1
0
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;
}
Example #2
0
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;
}
Example #4
0
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);
}
Example #5
0
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;
}
Example #7
0
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);
}
Example #8
0
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);
}
Example #9
0
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);
}
Example #10
0
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);
}
Example #11
0
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;
}
Example #13
0
/* 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;    
}
Example #14
0
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);
}
Example #15
0
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() */
Example #16
0
File: utils.c Project: cran/rggobi
USER_OBJECT_
createFactor(USER_OBJECT_ vals, vartabled *vt, GGobiData *d, int which)
{
  USER_OBJECT_ labels, levels, ans, e;
  int i;

  PROTECT(levels = NEW_INTEGER(vt->nlevels));
  PROTECT(labels = NEW_CHARACTER(vt->nlevels));
  for(i = 0; i < vt->nlevels; i++) {
     INTEGER_DATA(levels)[i] = vt->level_values[i];
	 if (vt->level_names[i])
		 SET_STRING_ELT(labels, i, COPY_TO_USER_STRING(vt->level_names[i]));
  }

  PROTECT(e = allocVector(LANGSXP, 4));
  SETCAR(e, Rf_install("factor"));
  SETCAR(CDR(e), vals);
  SETCAR(CDR(CDR(e)), levels);
  SETCAR(CDR(CDR(CDR(e))), labels);

  ans = eval(e, R_GlobalEnv);

  UNPROTECT(3);
 
  return(ans);
}
Example #17
0
SEXP int_to_SEXP(int val) {
    SEXP ret_val;
    PROTECT(ret_val=NEW_INTEGER(1));
    INTEGER_POINTER(ret_val)[0]=val;
    UNPROTECT(1);
    return ret_val;
}
Example #18
0
/* Given sparse matrices A and B (sorted columns).
   Assume pattern of A is a subset of pattern of B.
   (This also includes cases where dimension of B larger than dim of A)
   Return integer vector p of same length as A@x such that
     " A@i == B@i[p] and A@j == B@j[p] "
*/
SEXP match_pattern(SEXP A_, SEXP B_){
  CHM_SP A=AS_CHM_SP(A_);
  CHM_SP B=AS_CHM_SP(B_);
  int *Ai=A->i, *Bi=B->i, *Ap=A->p, *Bp=B->p;
  int ncol=A->ncol,i,j,k;
  int index; // index match
  SEXP ans;
  if(A->ncol>B->ncol)error("Must have dim(A)<=dim(B)");
  PROTECT(ans=NEW_INTEGER(A->nzmax));
  int *pans=INTEGER(ans);
  for(j=0;j<ncol;j++){
    index=Bp[j]; // Start at top of B(:,j)
    for(k=Ap[j];k<Ap[j+1];k++){
      i=Ai[k];
      for(;Bi[index]!=i;index++){ // Find next match
	if(index>=Bp[j+1]){
	  UNPROTECT(1);
	  error("No match");
	}
      }
      *pans=index+1; pans++; // R-index !
    }  
  }
  UNPROTECT(1);
  return ans;
}
Example #19
0
//----------------------------------------------------------------------------
    SEXP pnlCreateDBN()
    {
        SEXP res;
        PROTECT(res = NEW_INTEGER(1));
        int * pres = INTEGER_POINTER(res);
        if (DBNCount == DBNCurrentSize)
        {
            DBNCurrentSize *= 2;
            DBN ** pDBN_new = new DBN * [DBNCurrentSize];
            for (int i=0; i < DBNCount; i++)
            {
                pDBN_new[i] = pDBNs[i];
            }
            delete [] pDBNs;
            pDBNs = pDBN_new;
        }
        pDBNs[DBNCount] = new DBN();

        if (pDBNs[DBNCount] != NULL)
        {
            pres[0] = DBNCount;
            DBNCount++;
        }
        else
        {
            pres[0] = -1;
        }
        UNPROTECT(1);
        return (res);
    }
Example #20
0
//----------------------------------------------------------------------------
	SEXP dbnGenerateEvidences(SEXP net, SEXP numSlices)
	{
        SEXP res;
        int flag = -1;

        PROTECT(net = AS_INTEGER(net));
        int NetNum = INTEGER_VALUE(net);

        PROTECT(numSlices = AS_CHARACTER(numSlices));
        char * arg1 = CHAR(asChar(numSlices));
        
        try
        {
			pDBNs[NetNum]->GenerateEvidences(arg1);
        }
        catch (pnl::CException &E)
        {
            ErrorString = E.GetMessage();
            flag = 1;
        }
        catch(...)
        {
            ErrorString = "Unrecognized exception during execution of GenerateEvidences function";
            flag = 1;
        }

        PROTECT(res = NEW_INTEGER(1));
        int * pres = INTEGER_POINTER(res);
        pres[0] = flag;
        
        UNPROTECT(3);
        return (res);

	}
Example #21
0
//----------------------------------------------------------------------------
	SEXP pnlSetLag(SEXP net, SEXP lag)
	{
        SEXP res;
		int flag = -1;

		PROTECT(net = AS_INTEGER(net));
        int NetNum = INTEGER_VALUE(net);

        PROTECT(lag = AS_INTEGER(lag));
        int LagNum = INTEGER_VALUE(lag);

		try
		{
			pDBNs[NetNum]->SetLag(LagNum);
		}
		catch(pnl::CException &E)
		{
            ErrorString = E.GetMessage();
            flag = 1;
		}
		catch(...)
		{
            ErrorString = "Unrecognized exception during execution of SetLag function";
            flag = 1;
		}

        PROTECT(res = NEW_INTEGER(1));
        int * pres = INTEGER_POINTER(res);
        pres[0] = flag;
       
        UNPROTECT(3);
        return (res);
	}
Example #22
0
//erzeugt und gibt eine Liste mit zwei Elemente zurück
SEXP setList() {
    int *p_myint, i;
    double *p_double;
    SEXP mydouble, myint, list, list_names;
    char *names[2] = {"integer", "numeric"};
    PROTECT(myint = NEW_INTEGER(5));
    p_myint = INTEGER_POINTER(myint);
    PROTECT(mydouble = NEW_NUMERIC(5));
    p_double = NUMERIC_POINTER(mydouble);

    for(i = 0; i < 5; i++) {
        p_double[i] = 1/(double)(i + 1);
        p_myint[i] = i + 1;
    }

    PROTECT(list_names = allocVector(STRSXP,2));

    for(i = 0; i < 2; i++)
        SET_STRING_ELT(list_names,i,mkChar(names[i]));

    PROTECT(list = allocVector(VECSXP, 2));

    SET_VECTOR_ELT(list, 0, myint);

    SET_VECTOR_ELT(list, 1, mydouble);

    setAttrib(list, R_NamesSymbol, list_names);
    UNPROTECT(4);
    return list;
}
Example #23
0
static SEXP _tmpl_strand()
{
    SEXP strand = PROTECT(NEW_INTEGER(0));
    _as_strand(strand);
    UNPROTECT(1);
    return strand;
}
Example #24
0
/*
 * Open a connection to an existing kdb+ process.
 *
 * If we just have a host and port we call khp from the kdb+ interface.
 * If we have a host, port, "username:password" we call instead khpu.
 */
SEXP kx_r_open_connection(SEXP whence)
{
	SEXP result;
	int connection, port;
	char *host;
	int length = GET_LENGTH(whence);
	if (length < 2)
		error("Can't connect with so few parameters..");

	port = INTEGER_POINTER (VECTOR_ELT(whence, 1))[0];
	host = (char*) CHARACTER_VALUE(VECTOR_ELT(whence, 0));

	if (2 == length)
		connection = khp(host, port);
	else {
		char *user = (char*) CHARACTER_VALUE(VECTOR_ELT (whence, 2));
		connection = khpu(host, port, user);
	}
        if (!connection)
          error("Could not authenticate");
        else if (connection < 0) {
#ifdef WIN32
          char buf[256];
          FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),
                        MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), buf, 256, NULL);
          error(buf);
#else
	  error(strerror(errno));
#endif
	}
	PROTECT(result = NEW_INTEGER(1));
	INTEGER_POINTER(result)[0] = connection;
	UNPROTECT(1);
	return result;
}
Example #25
0
static USER_OBJECT_ 
convertRegistryValueToS(BYTE *val, DWORD size, DWORD valType)
{
   USER_OBJECT_ ans = R_NilValue;;

   switch(valType) {
    case REG_DWORD:
       ans = NEW_INTEGER(1);
       INTEGER_DATA(ans)[0] = *((int *) val);
       break;
    case REG_SZ:
    case REG_EXPAND_SZ:
       PROTECT(ans = NEW_CHARACTER(1));
       SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING((char *) val));
       UNPROTECT(1);
       break;
   case REG_MULTI_SZ:
     fprintf(stderr, "Muti_sz entry\n");
     break;
   case REG_BINARY:
     fprintf(stderr, "Binary entry\n");
     break;
    default:
      PROBLEM "No such type %d", (int) valType
     ERROR;
   }
  return(ans);
}
Example #26
0
/* --- .Call ENTRY POINT --- */
SEXP fastq_geometry(SEXP filexp_list,
		SEXP nrec, SEXP skip, SEXP seek_first_rec)
{
	int nrec0, skip0, seek_rec0, i, recno;
	FASTQGEOM_loaderExt loader_ext;
	FASTQloader loader;
	const char *errmsg;
	SEXP filexp, ans;

	nrec0 = INTEGER(nrec)[0];
	skip0 = INTEGER(skip)[0];
	seek_rec0 = LOGICAL(seek_first_rec)[0];
	loader_ext = new_FASTQGEOM_loaderExt();
	loader = new_FASTQGEOM_loader(&loader_ext);
	recno = 0;
	for (i = 0; i < LENGTH(filexp_list); i++) {
		filexp = VECTOR_ELT(filexp_list, i);
		errmsg = parse_FASTQ_file(filexp, nrec0, skip0, seek_rec0,
					  &loader, &recno);
		if (errmsg != NULL)
			error("reading FASTQ file %s: %s",
			      CHAR(STRING_ELT(GET_NAMES(filexp_list), i)),
			      errmsg_buf);
	}
	PROTECT(ans = NEW_INTEGER(2));
	INTEGER(ans)[0] = loader.nrec;
	INTEGER(ans)[1] = loader_ext.width;
	UNPROTECT(1);
	return ans;
}
Example #27
0
SEXP R_RngStreams_GetAntithetic (SEXP R_stream)
     /*----------------------------------------------------------------------*/
     /* Get flag for antithetic random numbers in Stream object.             */
     /*                                                                      */
     /* parameters:                                                          */
     /*   R_stream ... (pointer) ... pointer the Stream object               */
     /*                                                                      */
     /* return:                                                              */
     /*   antithetic flag                                                    */
     /*----------------------------------------------------------------------*/
{
  SEXP R_anti;
  RngStream stream;
  int anti;

  /* check pointer */
  CHECK_STREAM_PTR(R_stream);

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

  /* get data */
  anti = stream->Anti;

  PROTECT(R_anti = NEW_INTEGER(1));
  INTEGER_POINTER(R_anti)[0] = anti;
  UNPROTECT(1);

  return R_anti;

} /* end of R_RngStreams_GetAntithetic() */
Example #28
0
USER_OBJECT_
RS_GGOBI(getDisplayVariables)(USER_OBJECT_ dpy)
{
  USER_OBJECT_ buttons, vars, ans;
  static gchar *button_names[] = { "X", "Y", "Z" };
  gint i;
  
  displayd *display = toDisplay(dpy);
  
  /* get the currently plotted variables */
  gint *plotted_vars = g_new (gint, display->d->ncols);
  gint nplotted_vars = GGOBI_EXTENDED_DISPLAY_GET_CLASS (display)->plotted_vars_get(
    display, plotted_vars, display->d, display->ggobi);
    
  PROTECT(ans = NEW_LIST(2));
  buttons = NEW_CHARACTER(nplotted_vars);
  SET_VECTOR_ELT(ans, 1, buttons);
  vars = NEW_INTEGER(nplotted_vars);
  SET_VECTOR_ELT(ans, 0, vars);
  
  for (i = 0; i < nplotted_vars; i++) {
    gint var = plotted_vars[i], j;
    for (j = 0; j < G_N_ELEMENTS(button_names); j++) {
      GtkWidget *wid = varpanel_widget_get_nth(j, var, display->d);
      if (gtk_toggle_button_get_active(GTK_TOGGLE_BUTTON(wid)))
        SET_STRING_ELT(buttons, i, mkChar(button_names[j]));
    }
    INTEGER_DATA(vars)[i] = var;
  }
  
  UNPROTECT(1);
  g_free(plotted_vars);
  
  return(ans);
}
Example #29
0
File: CRF.cpp Project: rforge/crf
void CRF::Init_Labels()
{
	PROTECT(_labels = NEW_INTEGER(nNodes));
	labels = INTEGER_POINTER(_labels);
	SetValues(_labels, labels, 1);
	numProtect++;
}
Example #30
0
SEXP 
GetRScalar(SV *val)
{
  dTHX;
  SEXP ans = NULL_USER_OBJECT;

  if(SvIOKp(val)) {
    PROTECT(ans = NEW_INTEGER(1));
    INTEGER_DATA(ans)[0] = SvIV(val);
    UNPROTECT(1);
  } else if(SvNOKp(val)) {
    PROTECT(ans = NEW_NUMERIC(1));
    NUMERIC_DATA(ans)[0] = SvNV(val);
    UNPROTECT(1);
  } else if(SvPOK(val)) {
    PROTECT(ans = NEW_CHARACTER(1));
    SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(SvPV(val, PL_na)));
    UNPROTECT(1);
  } else if(SvROK(val)) {
    fprintf(stderr, "Not handling nested references in conversion from Perl to R at present. Suggestions for semantics welcome!\n");fflush(stderr);
  } else if(SvTYPE(val) == SVt_PVMG) {
    /*XXX get more info about the type of the magic object. 
    struct magic *mg = SvMAGIC(val);
    */
    PROTECT(ans = createPerlReference(val));

    UNPROTECT(1);
  } else {
    fprintf(stderr, "Cannot deal currently with Perl types %d\n", SvTYPE(val));fflush(stderr);
  }

  return(ans);
}