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() */
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); }
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; }
/* 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; }
//---------------------------------------------------------------------------- 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); }
//---------------------------------------------------------------------------- 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); }
//---------------------------------------------------------------------------- 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); }
//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; }
static SEXP _tmpl_strand() { SEXP strand = PROTECT(NEW_INTEGER(0)); _as_strand(strand); UNPROTECT(1); return strand; }
/* * 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; }
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); }
/* --- .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; }
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() */
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); }
void CRF::Init_Labels() { PROTECT(_labels = NEW_INTEGER(nNodes)); labels = INTEGER_POINTER(_labels); SetValues(_labels, labels, 1); numProtect++; }
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); }