/*=========================================================================== C-equivalent of R-function lagderiv =========================================================================== */ SEXP getLagDeriv(SEXP T, SEXP nr) { SEXP value; int i, ilen, interval; double t; ilen = LENGTH(nr); if (initialisehist == 0) error("pastgradient can only be called from 'func' or 'res' when triggered by appropriate integrator."); if (!isNumeric(T)) error("'t' should be numeric"); t = *NUMERIC_POINTER(T); interval = findHistInt (t); if ((ilen ==1) && (INTEGER(nr)[0] == 0)) { PROTECT(value=NEW_NUMERIC(n_eq)); for(i=0; i<n_eq; i++) { NUMERIC_POINTER(value)[i] = past(i, interval, t, 2); } } else { PROTECT(value=NEW_NUMERIC(ilen)); for(i=0; i<ilen; i++) { NUMERIC_POINTER(value)[i] = past(INTEGER(nr)[i]-1, interval, t, 2); } } UNPROTECT(1); return(value); }
STGM::CBoolSphereSystem * InitSphereSystem(SEXP R_param, SEXP R_cond) { SEXP R_box; PROTECT( R_box = getListElement( R_cond, "box")); double *boxX = NUMERIC_POINTER( getListElement( R_box, "xrange")); double *boxY = NUMERIC_POINTER( getListElement( R_box, "yrange")); double *boxZ = NUMERIC_POINTER( getListElement( R_box, "zrange")); double lam = asReal(AS_NUMERIC( getListElement( R_param, "lam"))); /* print level */ PL = asInteger(getListElement( R_cond,"pl")); /* simulation box */ STGM::CBox3 box(boxX,boxY,boxZ); /* set up sphere system */ STGM::CBoolSphereSystem *sp = (STGM::CBoolSphereSystem*)Calloc(1,STGM::CBoolSphereSystem); try { new(sp)STGM::CBoolSphereSystem(box,lam); } catch(...) { error(_("InitSpheroidSystem(): Memory allocation error for sphere system.")); } UNPROTECT(1); return sp; }
////////////////////////////////////////////////// // addXAxis - add X axis information unsigned int addXAxis(SEXP data, SEXP dataNames, unsigned int j, TH1* hist) { int n = hist->GetNbinsX(); TAxis* axis = hist->GetXaxis(); // Determine breaks-- // Add to list SEXP breaks = addNumericVector(data, dataNames, j++, n+1, "breaks"); // Get information for ( unsigned int i=0; i<n; ++i ) { NUMERIC_POINTER(breaks)[i] = axis->GetBinLowEdge(i+1); } // Add the high edge NUMERIC_POINTER(breaks)[n] = axis->GetBinUpEdge(n); // Determine mids-- SEXP mids = addNumericVector(data, dataNames, j++, n, "mids"); // Get information for ( unsigned int i=0; i<n; ++i ) { NUMERIC_POINTER(mids)[i] = axis->GetBinCenter(i+1); } // Get name of axis SEXP xname = addCharVector(data, dataNames, j++, 1, "xname"); SET_STRING_ELT( xname, 0, mkChar( axis->GetTitle() ) ); // Done return j; }
SEXP R_RngStreams_GetData (SEXP R_stream) /*----------------------------------------------------------------------*/ /* Get data structure of Stream object. */ /* (For the name of the Stream object use R_RngStreams_GetName() ). */ /* */ /* parameters: */ /* R_stream ... (pointer) ... pointer the Stream object */ /* */ /* return: */ /* data (double[20]) */ /*----------------------------------------------------------------------*/ { RngStream stream; SEXP R_stream_data; /* check pointer */ CHECK_STREAM_PTR(R_stream); /* Extract pointer to generator */ stream = R_ExternalPtrAddr(R_stream); CHECK_NULL(stream); PROTECT(R_stream_data = NEW_NUMERIC(20)); memcpy(NUMERIC_POINTER(R_stream_data) , stream->Cg, 6*sizeof(double)); memcpy(NUMERIC_POINTER(R_stream_data)+ 6, stream->Bg, 6*sizeof(double)); memcpy(NUMERIC_POINTER(R_stream_data)+12, stream->Ig, 6*sizeof(double)); NUMERIC_POINTER(R_stream_data)[18] = (double) stream->Anti; NUMERIC_POINTER(R_stream_data)[19] = (double) stream->IncPrec; UNPROTECT(1); /* return data to R */ return R_stream_data; } /* end of R_RngStreams_GetData() */
void hess_lag_set(SEXP env) { HESS_LAG_SSE *pt; SEXP y, x, wy; int i, n, p, np; n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0]; p = INTEGER_POINTER(findVarInFrame(env, install("m")))[0]; np = n*p; pt = (HESS_LAG_SSE *) R_ExternalPtrAddr(findVarInFrame(env, install("ptr"))); if (pt->set) error("hess_lag_set: function called out of order"); y = findVarInFrame(env, install("y")); x = findVarInFrame(env, install("x")); wy = findVarInFrame(env, install("wy")); pt->y = Calloc(n, double); pt->x = Calloc(np, double); pt->yl = Calloc(n, double); pt->wy1 = Calloc(n, double); pt->beta1 = Calloc(p, double); pt->xb = Calloc(n, double); for (i=0; i<n; i++) { pt->y[i] = NUMERIC_POINTER(y)[i]; pt->wy1[i] = NUMERIC_POINTER(wy)[i]; } for (i=0; i<np; i++) pt->x[i] = NUMERIC_POINTER(x)[i]; pt->set = TRUE; return; }
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 seqlib_tm_santa_lucia(SEXP sequences,SEXP ct) { int vlen,i,wg=0; sequence_tp*ms; double Ct; SEXP res; if(!isString(sequences)) error("sequence must have character type"); if (!isReal(ct) || length(ct) != 1) error("ct value must be single real"); vlen = length(sequences); Ct = REAL(ct)[0]; PROTECT(res = NEW_NUMERIC(vlen)); for (i=0; i< vlen; i++) { ms = sequence_from_string(CHAR(STRING_ELT(sequences,i))); if (sequence_conv_to_acgt_only(ms)) NUMERIC_POINTER(res)[i] = sequence_melt_nn_SantaLucia(ms,Ct); else { NUMERIC_POINTER(res)[i] = NA_REAL; if (!wg) { warning("Non-determined nucleotides in sequences"); wg = 1; } } free(ms); } UNPROTECT(1); return res; }
// version for .Call, faster because nothing is duplicated SEXP jarowinklerCALL(SEXP str1EXP, SEXP str2EXP, SEXP W_1EXP, SEXP W_2EXP, SEXP W_tEXP, SEXP rEXP) { const char *str_1, *str_2; double *W_1, *W_2, *W_t, *r, *ans; int length_1, length_2, maxlen; SEXP ret; W_1 = NUMERIC_POINTER(W_1EXP); W_2 = NUMERIC_POINTER(W_2EXP); W_t = NUMERIC_POINTER(W_tEXP); r = NUMERIC_POINTER(rEXP); length_1 = LENGTH(str1EXP); length_2 = LENGTH(str2EXP); maxlen = length_1 > length_2 ? length_1 : length_2; PROTECT(ret = NEW_NUMERIC(maxlen)); ans = NUMERIC_POINTER(ret); for (int str_ind=0; str_ind < maxlen; str_ind++) { str_1=CHAR(STRING_ELT(str1EXP, str_ind % length_1)); str_2=CHAR(STRING_ELT(str2EXP, str_ind % length_2)); ans[str_ind]=jarowinkler_core(str_1, str_2, *W_1, *W_2, *W_t, *r); } UNPROTECT(1); return(ret); }
// Return closest point to given distance within geometry. // 'spgeom' must be a LineString SEXP rgeos_interpolate(SEXP env, SEXP spgeom, SEXP d, SEXP normalized) { GEOSContextHandle_t GEOShandle = getContextHandle(env); GEOSGeom geom = rgeos_convert_R2geos(env, spgeom); GEOSGeom res_geos; double dist; int nlines = length(GET_SLOT(spgeom, install("lines"))); if (nlines < 1) { error("rgeos_project: invalid number of lines"); } int n = LENGTH(d); if (n < 1) { error("rgeos_interpolate: invalid number of requested points"); } int pc = 0; SEXP crd; PROTECT(crd = NEW_NUMERIC(n*2)); pc++; double x; double y; SEXP ans; // select interpolation function (normalized/unnormalized) GEOSGeometry GEOS_DLL *(*interp_fun)(GEOSContextHandle_t, const GEOSGeometry*, double); if (LOGICAL_POINTER(normalized)[0]) { interp_fun = &GEOSInterpolateNormalized_r; } else { interp_fun = &GEOSInterpolate_r; } // interpolate points and store result in coord matrix for (int i = 0; i < n; i++) { dist = NUMERIC_POINTER(d)[i]; res_geos = (*interp_fun)(GEOShandle, geom, dist); rgeos_Pt2xy(env, res_geos, &x, &y); NUMERIC_POINTER(crd)[i] = x; NUMERIC_POINTER(crd)[n+i] = y; } GEOSGeom_destroy_r(GEOShandle, geom); GEOSGeom_destroy_r(GEOShandle, res_geos); // return coordinates as matrix PROTECT(ans = rgeos_formatcrdMat(crd, n)); pc++; UNPROTECT(pc); return(ans); }
/** * Calculate the sum of squared errors term for spatial regression * using an environment to hold data * * @param env pointer to an SEXP environment * @param coef current value of coefficient being optimzed * * @return double, value of SSE for current coef * */ SEXP R_ml_sse_env(SEXP env, SEXP coef) { SEXP res; // SEXP y, x, wy, WX; int i, k, n, p, np; double tol=1e-7, cyl, cxlqyl, sse; char *trans = "T"; double one = 1.0, zero = 0.0; double m_lambda = - NUMERIC_POINTER(coef)[0]; int pc=0, first_time; OPT_ERROR_SSE *pt; first_time = LOGICAL_POINTER(findVarInFrame(env, install("first_time")))[0]; if (first_time) { opt_error_set(env); } n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0]; p = INTEGER_POINTER(findVarInFrame(env, install("p")))[0]; np = n*p; pt = (OPT_ERROR_SSE *) R_ExternalPtrAddr(findVarInFrame(env, install("ptr"))); for (i=0; i<n; i++) pt->yl[i] = pt->y[i]; for (i=0; i<np; i++) pt->xlq[i] = pt->x[i]; F77_CALL(daxpy)(&n, &m_lambda, pt->wy1, &c__1, pt->yl, &c__1); F77_CALL(daxpy)(&np, &m_lambda, pt->wx1, &c__1, pt->xlq, &c__1); F77_CALL(dqrdc2)(pt->xlq, &n, &n, &p, &tol, &k, pt->qraux, pt->jpvt, pt->work); if (p != k) warning("Q looses full rank"); /* k = 0; F77_CALL(dqrdc)(pt->xlq, &n, &n, &p, pt->qraux, pt->jpvt, pt->work, &k);*/ for (i=0; i<n*k; i++) pt->qy[i] = 0.0; for (i=0; i<k; i++) pt->qy[(i +(n*i))] = 1.0; F77_CALL(dqrqy)(pt->xlq, &n, &k, pt->qraux, pt->qy, &k, pt->qy); F77_CALL(dgemv)(trans, &n, &k, &one, pt->qy, &n, pt->yl, &c__1, &zero, pt->xlqyl, &c__1); cyl = F77_CALL(ddot)(&n, pt->yl, &c__1, pt->yl, &c__1); cxlqyl = F77_CALL(ddot)(&k, pt->xlqyl, &c__1, pt->xlqyl, &c__1); sse = cyl - cxlqyl; PROTECT(res=NEW_NUMERIC(1)); pc++; NUMERIC_POINTER(res)[0] = sse; UNPROTECT(pc); return(res); }
/** * @brief Summarizes a list of vectors into a list of binned vectors of equal length. Each vector bin summarizes an approximately equal amount of values. * * @param method Charater array defining the method to be used for binning. Can be 'mean' 'median' or 'max' * @param score_list List with numeric vectors * @param window_size Window width of the vectors that will be returned * @return List with updated vectors * @details Walks through the vectors and calls shrink or expand to set vectors to equal widths * @note Nothing * @todo Nothing */ SEXP approx_window(SEXP window_count, SEXP score_list, SEXP method) { const char *methodn = STRING_VALUE(method); const int wsize=INTEGER_VALUE(window_count); SEXP lnames = getAttrib(score_list, R_NamesSymbol); SEXP ori_vec,new_vec,out_names,out_list; int elcount=0,elements=LENGTH(lnames),upc=0,olen; signal(SIGINT,SIG_DFL); PROTECT(lnames = AS_CHARACTER(lnames)); upc++; PROTECT(out_list = allocVector(VECSXP, elements)); upc++; PROTECT(out_names = allocVector(STRSXP,elements)); upc++; //Select proper call back double (*summarizep)(int *,int,double *); if(!strcmp(methodn,"mean")) { summarizep=mean_dble; } else if(!strcmp(methodn,"median")) { summarizep=median_dble; } else if(!strcmp(methodn,"max")) { summarizep=vect_max_dble; } else { error("%s not known",methodn); goto FINALIZE; } for(; elcount<elements; ++elcount) { PROTECT(ori_vec=AS_NUMERIC(VECTOR_ELT(score_list, elcount))); PROTECT(new_vec = NEW_NUMERIC(wsize)); olen=LENGTH(ori_vec); double *ori_vecp= NUMERIC_POINTER(ori_vec); double *new_vecp= NUMERIC_POINTER(new_vec); SET_STRING_ELT(out_names,elcount,mkChar(CHAR(STRING_ELT(lnames, elcount)))); if(olen>wsize) { shrink_dble(ori_vecp,new_vecp,olen,wsize,summarizep); SET_VECTOR_ELT(out_list, elcount, new_vec); } else if(olen<wsize) { expand_dble(ori_vecp,new_vecp,olen,wsize); SET_VECTOR_ELT(out_list, elcount, new_vec); } else { SET_VECTOR_ELT(out_list, elcount, ori_vec); } UNPROTECT(2); } setAttrib(out_list, R_NamesSymbol, out_names); FINALIZE: UNPROTECT(upc); return(out_list); }
SEXP fastcluster_correlation_distances(SEXP matrix_, SEXP const nrow_, SEXP const ncol_, SEXP const type_) { SEXP distance = NULL; // return value try{ PROTECT(type_); const int type = *INTEGER_POINTER(type_); UNPROTECT(1); // type_ PROTECT(nrow_); if (!IS_INTEGER(nrow_) || LENGTH(nrow_)!=1) Rf_error("'nrow' must be a single integer."); const int nrow = *INTEGER_POINTER(nrow_); UNPROTECT(1); // nrow_ if (nrow<2) Rf_error("nrow must be at least 2."); PROTECT(ncol_); if (!IS_INTEGER(ncol_) || LENGTH(ncol_)!=1) Rf_error("'ncol' must be a single integer."); const int ncol = *INTEGER_POINTER(ncol_); UNPROTECT(1); // ncol_ if (ncol<2) Rf_error("ncol must be at least 2."); const std::ptrdiff_t N = static_cast<std::ptrdiff_t>(nrow*ncol); PROTECT(matrix_ = AS_NUMERIC(matrix_)); if (LENGTH(matrix_)!=N) Rf_error("Improperly specified matrix dimensions."); const double * const matrix = NUMERIC_POINTER(matrix_); // R defaults to by-column comparisons const std::ptrdiff_t dsize = static_cast<std::ptrdiff_t>((ncol)*(ncol-1)/2); PROTECT(distance = NEW_NUMERIC(dsize)); double * const d = NUMERIC_POINTER(distance); if(type==2) pearson_distances_pairwise_complete_obs_variant(d, matrix, nrow, ncol); else if(type==3) spearman_distances_pairwise_complete_obs(d, matrix, nrow, ncol); else pearson_distances_pairwise_complete_obs(d, matrix, nrow, ncol); UNPROTECT(2); // matrix_ and distance } // try catch (const std::bad_alloc&) { Rf_error( "Memory overflow."); } catch(const std::exception& e){ Rf_error( e.what() ); } catch(const nan_error&){ Rf_error("NaN dissimilarity value."); } catch(...){ Rf_error( "C++ exception (unknown reason)." ); } return distance; }
SEXP MRF_Stat(SEXP _crf, SEXP _instances) { CRF crf(_crf); int nInstances = INTEGER_POINTER(GET_DIM(_instances))[0]; int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0]; PROTECT(_instances = AS_NUMERIC(_instances)); double *instances = NUMERIC_POINTER(_instances); SEXP _nodePar; PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par"))); int *nodePar = INTEGER_POINTER(_nodePar); SEXP _edgePar = GetVar(_crf, "edge.par"); int **edgePar = (int **) R_alloc(crf.nEdges, sizeof(int *)); SEXP _edgeParI, _temp; PROTECT(_edgeParI = NEW_LIST(crf.nEdges)); for (int i = 0; i < crf.nEdges; i++) { SET_VECTOR_ELT(_edgeParI, i, _temp = AS_INTEGER(GetListElement(_edgePar, i))); edgePar[i] = INTEGER_POINTER(_temp); } SEXP _stat; PROTECT(_stat = NEW_NUMERIC(nPar)); double *stat = NUMERIC_POINTER(_stat); SetValues(_stat, stat, 0.0); int *y = (int *) R_allocVector<int>(crf.nNodes); for (int n = 0; n < nInstances; n++) { for (int i = 0; i < crf.nNodes; i++) { y[i] = instances[n + nInstances * i] - 1; int p = nodePar[i + crf.nNodes * y[i]] - 1; if (p >= 0 && p < nPar) stat[p]++; } for (int i = 0; i < crf.nEdges; i++) { int p = edgePar[i][y[crf.EdgesBegin(i)] + crf.nStates[crf.EdgesBegin(i)] * y[crf.EdgesEnd(i)]] - 1; if (p >= 0 && p < nPar) stat[p]++; } } UNPROTECT(4); return(_stat); }
// Return distance of points 'spppoints' projected on 'spgeom' from origin // of 'spgeom'. Geometry 'spgeom' must be a lineal geometry SEXP rgeos_project(SEXP env, SEXP spgeom, SEXP sppoint, SEXP normalized) { GEOSContextHandle_t GEOShandle = getContextHandle(env); GEOSGeom geom = rgeos_convert_R2geos(env, spgeom); SEXP crds = GET_SLOT(sppoint, install("coords")); SEXP dim = getAttrib(crds, install("dim")); int nlines = length(GET_SLOT(spgeom, install("lines"))); if (nlines < 1) { error("rgeos_project: invalid number of lines"); } int n = INTEGER_POINTER(dim)[0]; if (n < 1) { error("rgeos_project: invalid number of points"); } int pc = 0; SEXP ans; PROTECT(ans = NEW_NUMERIC(n)); pc++; GEOSGeom p; // select projection function (normalized/unnormalized) double GEOS_DLL (*proj_fun)(GEOSContextHandle_t, const GEOSGeometry*, const GEOSGeometry*); if (LOGICAL_POINTER(normalized)[0]) { proj_fun = &GEOSProjectNormalized_r; } else { proj_fun = &GEOSProject_r; } // project points to line geometry for (int i = 0; i < n; i++) { p = rgeos_xy2Pt(env, NUMERIC_POINTER(crds)[i], NUMERIC_POINTER(crds)[i+n]); NUMERIC_POINTER(ans)[i] = (*proj_fun)(GEOShandle, geom, p); } GEOSGeom_destroy_r(GEOShandle, geom); GEOSGeom_destroy_r(GEOShandle, p); UNPROTECT(pc); return(ans); }
SEXP lmin22(SEXP nb, SEXP y, SEXP cy, SEXP card, SEXP beta) { int i, j, k, nswitch=0, n=length(card), pc=0; SEXP ans; double t1, t2, ytemp, yhat; double *Y, *CY, *B; Y = (double *) R_alloc((size_t) n, sizeof(double)); CY = (double *) R_alloc((size_t) n, sizeof(double)); B = (double *) R_alloc((size_t) length(beta), sizeof(double)); for (i=0; i<n; i++) { Y[i] = NUMERIC_POINTER(y)[i]; CY[i] = NUMERIC_POINTER(cy)[i]; } for (i=0; i<length(beta); i++) { B[i] = NUMERIC_POINTER(beta)[i]; } PROTECT(ans = NEW_LIST(2)); pc++; SET_VECTOR_ELT(ans, 0, NEW_NUMERIC(n)); SET_VECTOR_ELT(ans, 1, NEW_INTEGER(1)); for (i=0; i<n; i++) { if (INTEGER_POINTER(card)[i] > 0) { t1 = fabs(Y[i] - CY[i]); yhat = B[0] + B[1]*CY[i]; t2 = fabs(yhat - CY[i]); for (j=0; j<INTEGER_POINTER(card)[i]; j++) { k = INTEGER_POINTER(VECTOR_ELT(nb, i))[j]-ROFFSET; t1 = t1 + fabs(Y[k] - CY[k]); t2 = t2 + fabs(Y[k] - (CY[k] - Y[i] + B[0] + B[1]*CY[i])); } if (t1 <= t2) { nswitch++; ytemp = Y[i]; Y[i] = yhat; for (j=0; j<INTEGER_POINTER(card)[i]; j++) { k = INTEGER_POINTER(VECTOR_ELT(nb, i))[j]-ROFFSET; CY[k] = CY[k] - ytemp + Y[i]; } } } } for (i=0; i<n; i++) { NUMERIC_POINTER(VECTOR_ELT(ans, 0))[i] = Y[i]; } INTEGER_POINTER(VECTOR_ELT(ans, 1))[0] = nswitch; UNPROTECT(pc); /* ans */ return(ans); }
SEXP R_cv_svd_wold (SEXP xx, SEXP kk, SEXP maxrankmaxrank, SEXP toltol, SEXP maxitermaxiter, SEXP setssets) { bcv_error_t err = 0; bcv_index_t m, n, i, k, maxiter, maxrank; bcv_svd_wold_t *wold = NULL; double tol, *msep; SEXP msepmsep, dimdim; m = INTEGER (getAttrib (xx, R_DimSymbol))[0]; n = INTEGER (getAttrib (xx, R_DimSymbol))[1]; k = asInteger (kk); maxrank = asInteger (maxrankmaxrank); tol = asReal (toltol); maxiter = asInteger (maxitermaxiter); PROTECT (msepmsep = allocVector (REALSXP, (maxrank + 1) * k)); PROTECT (dimdim = allocVector (INTSXP, 2)); INTEGER (dimdim) [0] = maxrank + 1; INTEGER (dimdim) [1] = k; setAttrib (msepmsep, R_DimSymbol, dimdim); msep = NUMERIC_POINTER (msepmsep); bcv_matrix_t x = { m, n, NUMERIC_POINTER (xx), BCV_MAX (m,1) }; bcv_partition_t part = { m*n, k, INTEGER_POINTER (setssets) }; wold = bcv_svd_wold_alloc (m*n, m, n); if (!wold) error ("could not allocate enough memory for Wold " " cross-validation of a %d-by-%d matrix", m, n); bcv_svd_wold_init (wold, &x, &part); for (i = 0; i < k; i++) { R_CheckUserInterrupt (); err = bcv_svd_wold_get_msep (wold, i, tol, maxiter, msep, maxrank); if (err) error ("the SVD algorithm did not converge for the (%d)" " holdout", i); msep += maxrank + 1; } bcv_svd_wold_free (wold); UNPROTECT (2); return msepmsep; }
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); }
////////////////////////////////////////////////// // addXContents unsigned int addXContents(SEXP data, SEXP dataNames, unsigned int j, TH1* hist) { int n = hist->GetNbinsX(); // Determine counts and uncert-- // Add to list SEXP counts = addNumericVector(data, dataNames, j++, n, "counts"); SEXP uncert = addNumericVector(data, dataNames, j++, n, "uncert"); for ( unsigned int i=0; i<n; ++i ) { NUMERIC_POINTER(counts)[i] = hist->GetBinContent(i+1); NUMERIC_POINTER(uncert)[i] = hist->GetBinError(i+1); } // Set under and over flows SEXP uof = addNumericVector(data, dataNames, j++, 2, "underOverFlows"); NUMERIC_POINTER(uof)[0] = hist->GetBinContent(0); NUMERIC_POINTER(uof)[1] = hist->GetBinContent(n+1); // Get mean SEXP mean = addNumericVector(data, dataNames, j++, 2, "mean"); NUMERIC_POINTER(mean)[0] = hist->GetMean(1); NUMERIC_POINTER(mean)[1] = hist->GetMean(11); // Get rms SEXP rms = addNumericVector(data, dataNames, j++, 2, "rms"); NUMERIC_POINTER(rms)[0] = hist->GetRMS(1); NUMERIC_POINTER(rms)[1] = hist->GetRMS(11); return j; }
SEXP mom_calc_int2(SEXP is, SEXP m, SEXP nb, SEXP weights, SEXP card) { SEXP Omega; int hm = INTEGER_POINTER(m)[0]; int n = length(card); double *eta, *zeta, *omega, sum, res; int i, ii, j, k1, k2, k3; int iis = length(is); omega = (double *) R_alloc((size_t) hm, sizeof(double)); eta = (double *) R_alloc((size_t) n, sizeof(double)); zeta = (double *) R_alloc((size_t) n, sizeof(double)); for (j=0; j<hm; j++) omega[j] = 0.0; for (ii=0; ii<iis; ii++) { R_CheckUserInterrupt(); i = INTEGER_POINTER(is)[ii]-ROFFSET; for (j=0; j<n; j++) eta[j] = 0.0; eta[i] = 1.0; for (j=1; j<hm; j=j+2) { for (k1=0; k1<n; k1++) { k3 = INTEGER_POINTER(card)[k1]; if (k3 == 0) { zeta[k1] = 0.0; } else { sum = 0.0; for (k2=0; k2<k3; k2++) { sum += eta[INTEGER_POINTER(VECTOR_ELT(nb, k1))[k2] - ROFFSET] * NUMERIC_POINTER(VECTOR_ELT(weights, k1))[k2]; } zeta[k1] = sum; } } res = F77_CALL(ddot)(&n, zeta, &c__1, eta, &c__1); if (R_FINITE(res)) omega[(j-1)] += res; else error("non-finite dot product %d, %d", i, j); res = F77_CALL(ddot)(&n, zeta, &c__1, zeta, &c__1); if (R_FINITE(res)) omega[j] += res; else error("non-finite dot product %d, %d", i, j); for (k1=0; k1<n; k1++) eta[k1] = zeta[k1]; } } PROTECT(Omega = NEW_NUMERIC(hm)); for (j=0; j<hm; j++) NUMERIC_POINTER(Omega)[j] = omega[j]; UNPROTECT(1); return(Omega); }
SEXP R_RngStreams_Sample (SEXP R_stream, SEXP R_size) /*----------------------------------------------------------------------*/ /* Sample from Stream object. */ /* */ /* parameters: */ /* R_stream ... (pointer) ... pointer the Stream object */ /* R_size ... (int) ... sample size */ /* */ /* return: */ /* pointer to stream object */ /*----------------------------------------------------------------------*/ { RngStream stream; int n = INTEGER(R_size)[0]; int i; SEXP R_sample; /* check pointer */ CHECK_STREAM_PTR(R_stream); /* Extract pointer to generator */ stream = R_ExternalPtrAddr(R_stream); CHECK_NULL(stream); /* generate random sample of size n */ PROTECT(R_sample = NEW_NUMERIC(n)); for (i=0; i<n; i++) NUMERIC_POINTER(R_sample)[i] = RngStream_RandU01(stream); UNPROTECT(1); /* return sample to R */ return R_sample; } /* end of R_RngStreams_sample() */
SEXP match3bytes(SEXP buf, SEXP m1, SEXP m2, SEXP m3) { int i, j, n, n_match; double *resp; unsigned char *bufp, *m1p, *m2p, *m3p; SEXP res; PROTECT(buf = AS_RAW(buf)); PROTECT(m1 = AS_RAW(m1)); PROTECT(m2 = AS_RAW(m2)); PROTECT(m3 = AS_RAW(m3)); bufp = RAW_POINTER(buf); m1p = RAW_POINTER(m1); m2p = RAW_POINTER(m2); m3p = RAW_POINTER(m3); n = LENGTH(buf); n_match = 0; for (i = 0; i < n - 2; i++) { if (bufp[i] == *m1p && bufp[i + 1] == *m2p && bufp[i + 2] == *m3p) { n_match++; ++i; /* skip */ ++i; /* skip */ } } PROTECT(res = NEW_NUMERIC(n_match)); resp = NUMERIC_POINTER(res); j = 0; for (i = 0; i < n - 2; i++) { if (j <= n_match && bufp[i] == *m1p && bufp[i + 1] == *m2p && bufp[i + 2] == *m3p) { resp[j++] = i + 1; /* the 1 is to offset from C to R */ } } UNPROTECT(5); return(res); }
SEXP seqlib_dg_selfhyb(SEXP sequences,SEXP t,SEXP naC,SEXP mgC,SEXP acidtype) { int vlen,i,atype; double ct,nac,mgc,rv; sequence_tp *ms; SEXP res; if(!isString(sequences)) error("sequence must have character type"); vlen = length(sequences); PROTECT(res = NEW_NUMERIC(vlen)); if (!isReal(t) || length(t) != 1) error("t value must be single real"); ct = REAL(t)[0]; if (!isReal(naC) || length(naC) != 1) error("naC value must be single real"); nac = REAL(naC)[0]; if (!isReal(mgC) || length(mgC) != 1) error("mgC value must be single real"); mgc = REAL(mgC)[0]; if (!isInteger(acidtype) || length(acidtype) != 1) error("acidtype value must be single int"); atype = INTEGER(acidtype)[0]; for (i=0; i< vlen; i++) { ms = sequence_from_string(CHAR(STRING_ELT(sequences,i))); rv = sequence_hybrid_ss_min(ms,ct,nac,mgc,atype); NUMERIC_POINTER(res)[i] = rv; free(ms); } UNPROTECT(1); return res; }
SEXP short_to_SEXP(short val) { SEXP ret_val; PROTECT(ret_val=NEW_NUMERIC(1)); NUMERIC_POINTER(ret_val)[0]=val; UNPROTECT(1); return ret_val; }
//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; }
SEXP R_RngStreams_SetPackageSeed (SEXP R_seed) /*----------------------------------------------------------------------*/ /* Set global seed for RNGStreams package. */ /* */ /* parameters: */ /* R_seed ... (double [6]) ... seed */ /*----------------------------------------------------------------------*/ { int n_seed; unsigned long seed[6]; int i; /* get data */ PROTECT(R_seed = AS_NUMERIC(R_seed)); n_seed = LENGTH(R_seed); /* we need array of 6 unsigned long */ if (n_seed<6) { UNPROTECT(1); error("too few values for seed\n"); } for (i=0; i<6; i++) seed[i] = (unsigned long) NUMERIC_POINTER(R_seed)[i]; UNPROTECT(1); /* set seed */ if (RngStream_SetPackageSeed(seed)) error("invalid seed\n"); return R_NilValue; } /* end of R_RngStreams_SetPackageSeed() */
double perfunc(SEXP myldens, ENVELOPE *env, double x, SEXP rho) /* to evaluate log density and increment count of evaluations */ /* myldens : R function to evaluate log density */ /* *env : envelope attributes */ /* x : point at which to evaluate log density */ /* rho : R environment in which the logdensity is evaluated */ { double y; SEXP R_fcall, arg; /* evaluate logdensity function */ PROTECT(R_fcall = lang2(myldens, R_NilValue)); PROTECT(arg = NEW_NUMERIC(1)); NUMERIC_POINTER(arg)[0] = x; SETCADR(R_fcall, arg); y = REAL(eval(R_fcall, rho))[0]; UNPROTECT(2); /* increment count of function evaluations */ (*(env->neval))++; return y; }
void CRF::Init_LogZ() { PROTECT(_logZ = NEW_NUMERIC(1)); logZ = NUMERIC_POINTER(_logZ); *logZ = 0; numProtect++; }
SEXP rma_c_complete_copy(SEXP PMmat, SEXP ProbeNamesVec,SEXP N_probes, SEXP norm_flag, SEXP bg_flag, SEXP bg_type, SEXP verbose){ SEXP dim1,PMcopy,exprs; int rows,cols; double *PM; if (INTEGER(bg_flag)[0]){ if (INTEGER(verbose)[0]){ Rprintf("Background correcting\n"); } PROTECT(dim1 = getAttrib(PMmat,R_DimSymbol)); rows = INTEGER(dim1)[0]; cols = INTEGER(dim1)[1]; PROTECT(PMcopy = allocMatrix(REALSXP,rows,cols)); PM = NUMERIC_POINTER(PMcopy); copyMatrix(PMcopy,PMmat,0); rma_bg_correct(PM, rows, cols); exprs = rma_c_call(PMcopy, ProbeNamesVec, N_probes, norm_flag, verbose); UNPROTECT(2); return exprs; } else { PROTECT(dim1 = getAttrib(PMmat,R_DimSymbol)); rows = INTEGER(dim1)[0]; cols = INTEGER(dim1)[1]; PROTECT(PMcopy = allocMatrix(REALSXP,rows,cols)); copyMatrix(PMcopy,PMmat,0); exprs = rma_c_call(PMcopy, ProbeNamesVec, N_probes, norm_flag, verbose); UNPROTECT(2); return exprs; } }
SEXP rgeos_miscfunc(SEXP env, SEXP obj, SEXP byid, p_miscfunc miscfunc) { SEXP ans; GEOSContextHandle_t GEOShandle = getContextHandle(env); GEOSGeom geom = rgeos_convert_R2geos(env, obj); int type = GEOSGeomTypeId_r(GEOShandle, geom); int n = (LOGICAL_POINTER(byid)[0] && type == GEOS_GEOMETRYCOLLECTION) ? GEOSGetNumGeometries_r(GEOShandle, geom) : 1; int pc=0; PROTECT(ans = NEW_NUMERIC(n)); pc++; GEOSGeom curgeom = geom; for(int i=0; i<n; i++) { if ( n > 1) { curgeom = (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom, i); if (curgeom == NULL) error("rgeos_miscfunc: unable to get subgeometries"); } double val; if (!miscfunc(GEOShandle, curgeom, &val)) error("rgeos_miscfunc: unable to calculate"); NUMERIC_POINTER(ans)[i] = val; } GEOSGeom_destroy_r(GEOShandle, geom); UNPROTECT(pc); return(ans); }
SEXP lmin3(SEXP nb, SEXP ev1, SEXP ev1_lag, SEXP n_nei, SEXP beta, SEXP tol) { int i, j, k, nswitch=0, n=length(n_nei), pc=0; SEXP ans; double tmp, var, yhat, ntmp; double *Y, *CY, *B; Y = (double *) R_alloc((size_t) n, sizeof(double)); CY = (double *) R_alloc((size_t) n, sizeof(double)); B = (double *) R_alloc((size_t) length(beta), sizeof(double)); for (i=0; i<n; i++) { Y[i] = NUMERIC_POINTER(ev1)[i]; CY[i] = NUMERIC_POINTER(ev1_lag)[i]; } for (i=0; i<length(beta); i++) { B[i] = NUMERIC_POINTER(beta)[i]; } PROTECT(ans = NEW_LIST(2)); pc++; SET_VECTOR_ELT(ans, 0, NEW_NUMERIC(n)); SET_VECTOR_ELT(ans, 1, NEW_INTEGER(1)); for (i=0; i<n; i++) { if (INTEGER_POINTER(n_nei)[i] > 0) { yhat = B[0] + B[1]*CY[i]; var = fabs(Y[i] - yhat); if (var > NUMERIC_POINTER(tol)[0]) { nswitch++; tmp = Y[i]; Y[i] = yhat; for (j=0; j<INTEGER_POINTER(n_nei)[i]; j++) { k = INTEGER_POINTER(VECTOR_ELT(nb, i))[j]-ROFFSET; ntmp = sqrt(INTEGER_POINTER(n_nei)[i] * INTEGER_POINTER(n_nei)[k]); CY[k] = CY[k] - (tmp/ntmp) + (Y[i]/ntmp); } } } } for (i=0; i<n; i++) { NUMERIC_POINTER(VECTOR_ELT(ans, 0))[i] = Y[i]; } INTEGER_POINTER(VECTOR_ELT(ans, 1))[0] = nswitch; UNPROTECT(pc); /* ans */ return(ans); }