这篇教程C++ LENGTH函数代码示例写得很实用,希望能帮到您。
本文整理汇总了C++中LENGTH函数的典型用法代码示例。如果您正苦于以下问题:C++ LENGTH函数的具体用法?C++ LENGTH怎么用?C++ LENGTH使用的例子?那么恭喜您, 这里精选的函数代码示例或许可以为您提供帮助。 在下文中一共展示了LENGTH函数的30个代码示例,这些例子默认根据受欢迎程度排序。您可以为喜欢或者感觉有用的代码点赞,您的评价将有助于我们的系统推荐出更棒的C++代码示例。 示例1: call_gambimSEXP call_gambim(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP rho, SEXP Tcrit, SEXP jacfunc, SEXP initfunc, SEXP verbose, SEXP LRW, SEXP rWork, SEXP iWork, SEXP jT, SEXP nOut, SEXP Nrmas, SEXP masfunc, SEXP ML, SEXP MU, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP flist, SEXP Type){/******************************************************************************//****** DECLARATION SECTION ******//******************************************************************************/ int j, nt, latol, lrtol, imas, mlmas, mumas, type; int isForcing, runOK; double *Atol, *Rtol, hini; int itol, ijac, ml, mu, iout, idid, liw, lrw, sum; /* pointers to functions passed to FORTRAN */ C_jac_func_type_gb *jac_func_gb = NULL; C_solout_type *solout = NULL; C_solout_type_bim *solout_bim = NULL; C_mas_type *mas_func = NULL;/******************************************************************************//****** STATEMENTS ******//******************************************************************************//* #### initialisation #### */ init_N_Protect(); type = INTEGER(Type)[0]; /* jacobian type */ ijac = INTEGER(jT)[0]; /* jacobian type */ n_eq = LENGTH(y); /* number of equations */ nt = LENGTH(times); /* number of output times */ maxt = nt; tt = (double *) R_alloc(nt, sizeof(double)); for (j = 0; j < nt; j++) tt[j] = REAL(times)[j];// mflag = INTEGER(verbose)[0]; /* is function a dll ?*/ isDll = inherits(derivfunc, "NativeSymbol"); /* initialise output ... */ initOutC(isDll, n_eq, nOut, Rpar, Ipar); /* copies of variables that will be changed in the FORTRAN subroutine */ xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; ytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) ytmp[j] = 0.; latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; /* tolerance specifications */ if (latol == 1 ) itol = 0; else itol = 1; /* mass matrix */ imas = INTEGER(Nrmas)[0]; mlmas = INTEGER(Nrmas)[1]; mumas = INTEGER(Nrmas)[2]; /* work vectors */ if (type == 1) { liw = 27; lrw = 21; } else { // if (type == 2) liw = n_eq + 40; lrw = INTEGER(LRW)[0]; } iwork = (int *) R_alloc(liw, sizeof(int)); for (j=0; j<LENGTH(iWork); j++) iwork[j] = INTEGER(iWork)[j]; for (j=LENGTH(iWork); j<liw; j++) iwork[j] = 0; rwork = (double *) R_alloc(lrw, sizeof(double)); for (j=0; j<length(rWork); j++) rwork[j] = REAL(rWork)[j]; for (j=length(rWork); j<lrw; j++) rwork[j] = 0.; ml = INTEGER(ML)[0]; mu = INTEGER(MU)[0]; hini = REAL(Hini)[0]; /* initialise global R-variables... */ initglobals (nt); /* Initialization of Parameters, Forcings (DLL) */ initParms(initfunc, parms); isForcing = initForcings(flist); if (nout > 0 ) { xdytmp= (double *) R_alloc(n_eq, sizeof(double));//.........这里部分代码省略.........
开发者ID:cran,项目名称:deTestSet,代码行数:101,
示例2: do_init_stateSEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi){ int nprotect = 0; SEXP Pnames, Snames; SEXP x = R_NilValue; int *dim; int npar, nrep, nvar, ns; int definit; int xdim[2]; const char *dimnms[2] = {"variable","rep"}; ns = *(INTEGER(AS_INTEGER(nsim))); PROTECT(params = as_matrix(params)); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; dim = INTEGER(GET_DIM(params)); npar = dim[0]; nrep = dim[1]; if (ns % nrep != 0) errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')"); definit = *(INTEGER(GET_SLOT(object,install("default.init")))); if (definit) { // default initializer SEXP fcall, pat, repl, val, ivpnames, statenames; int *pidx, j, k; double *xp, *pp; PROTECT(pat = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(pat,0,mkChar("//.0$")); PROTECT(repl = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(repl,0,mkChar("")); PROTECT(val = NEW_LOGICAL(1)); nprotect++; *(INTEGER(val)) = 1; // extract names of IVPs PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++; SET_TAG(fcall,install("value")); PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++; PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++; nvar = LENGTH(ivpnames); if (nvar < 1) { errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'."); } pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++; for (k = 0; k < nvar; k++) pidx[k]--; // construct names of state variables PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(repl,fcall)); nprotect++; SET_TAG(fcall,install("replacement")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++; PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++; xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,statenames,2); fixdimnames(x,dimnms,2); for (j = 0, xp = REAL(x); j < ns; j++) { pp = REAL(params) + npar*(j%nrep); for (k = 0; k < nvar; k++, xp++) *xp = pp[pidx[k]]; } } else { // user-supplied initializer SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue; pompfunmode mode = undef; double *cp = NULL; // extract the initializer function and its environment PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract covariates and interpolate PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++; if (LENGTH(tcovar) > 0) { // do table lookup PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++; PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++; cp = REAL(covars); } // extract userdata PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; switch (mode) { case Rfun: // use R function { SEXP par, rho, x1, x2; double *p, *pp, *xp, *xt;//.........这里部分代码省略.........
开发者ID:kingaa,项目名称:pomp,代码行数:101,
示例3: textRect/* Calculate the bounding rectangle for a string. * x and y assumed to be in INCHES. */void textRect(double x, double y, SEXP text, int i, const pGEcontext gc, double xadj, double yadj, double rot, pGEDevDesc dd, LRect *r){ /* NOTE that we must work in inches for the angles to be correct */ LLocation bl, br, tr, tl; LLocation tbl, tbr, ttr, ttl; LTransform thisLocation, thisRotation, thisJustification; LTransform tempTransform, transform; double w, h; if (isExpression(text)) { SEXP expr = VECTOR_ELT(text, i % LENGTH(text)); w = fromDeviceWidth(GEExpressionWidth(expr, gc, dd), GE_INCHES, dd); h = fromDeviceHeight(GEExpressionHeight(expr, gc, dd), GE_INCHES, dd); } else { const char* string = CHAR(STRING_ELT(text, i % LENGTH(text))); w = fromDeviceWidth(GEStrWidth(string, (gc->fontface == 5) ? CE_SYMBOL : getCharCE(STRING_ELT(text, i % LENGTH(text))), gc, dd), GE_INCHES, dd); h = fromDeviceHeight(GEStrHeight(string, (gc->fontface == 5) ? CE_SYMBOL : getCharCE(STRING_ELT(text, i % LENGTH(text))), gc, dd), GE_INCHES, dd); } location(0, 0, bl); location(w, 0, br); location(w, h, tr); location(0, h, tl); translation(-xadj*w, -yadj*h, thisJustification); translation(x, y, thisLocation); if (rot != 0) rotation(rot, thisRotation); else identity(thisRotation); /* Position relative to origin of rotation THEN rotate. */ multiply(thisJustification, thisRotation, tempTransform); /* Translate to (x, y) */ multiply(tempTransform, thisLocation, transform); trans(bl, transform, tbl); trans(br, transform, tbr); trans(tr, transform, ttr); trans(tl, transform, ttl); rect(locationX(tbl), locationX(tbr), locationX(ttr), locationX(ttl), locationY(tbl), locationY(tbr), locationY(ttr), locationY(ttl), r); /* For debugging, the following prints out an R statement to draw the * bounding box */ /* Rprintf("/ngrid.lines(c(%f, %f, %f, %f, %f), c(%f, %f, %f, %f, %f), default.units=/"inches/")/n", locationX(tbl), locationX(tbr), locationX(ttr), locationX(ttl), locationX(tbl), locationY(tbl), locationY(tbr), locationY(ttr), locationY(ttl), locationY(tbl) ); */}
开发者ID:janardhanv,项目名称:On-Demand-Analytics,代码行数:69,
示例4: FixDetectCSEXP FixDetectC(SEXP X, SEXP Y, SEXP R, SEXP Dispersion, SEXP MinDur, SEXP Debug){ //function input double *pDisp = REAL(Dispersion); double *pMinDur = REAL(MinDur); int fDebug; //function output double *res = NULL; SEXP Res,r_X,r_Y,r_D,r_dur,r_start,r_disp; SEXP list_names; //detection parameters ================================================= int MinDuration; //min dispersion duration (samples) float Threshold; //dispersion threshold float Xi,Yi; //X & Y coordinates int bGaze; //valid data flag //LC detector output ============================================================= float X_d,Y_d,FixX,FixY; float Deviation_d; int SaccadeDuration,FixDuration; int bGaze_d; int rc; //return code //================================= char *names[6] = {"X","Y","R","Dur","Start","Disp"}; int i,len,lmax,iend,istart; float Ri, dMean; //current and average pupil size int j, Dcnt; //after-detection pupil size and dispersion calculation int MaxNFix, NFix; struct _stFIXdata *pFIX_b, *pFIX; size_t FIXdata_sz; float fDx,fDy,dDrSq,fD,fDisp; fDebug = INTEGER_VALUE(Debug); //Flag - debug MinDuration = (int) *pMinDur; Threshold = (float) *pDisp; len=LENGTH(X); lmax=len - 1; i=0; MaxNFix = len / MinDuration; if (fDebug > 0) Rprintf("FixDetectC start: len =%d MaxNFix=%d /n",len,MaxNFix); FIXdata_sz = MaxNFix*sizeof(struct _stFIXdata); pFIX_b = (struct _stFIXdata *) malloc(FIXdata_sz); if (pFIX_b == NULL) { Rprintf("FixDetectC: memory allocation ERROR (fixations BLOCK allocation)/n"); PROTECT(Res = allocVector(REALSXP, 1)); res = REAL(Res); *res = 0; UNPROTECT(1); return Res; } pFIX = pFIX_b; NFix=0; if (fDebug > 0) Rprintf("FixDetectC: InitFication Call/n"); InitFixation(MinDuration); if (fDebug > 0) Rprintf("FixDetectC: main while(i < len) /n"); while (i < len) { Xi = (float) REAL(X)[i]; Yi = (float) REAL(Y)[i]; Ri = (float) REAL(R)[i]; if (Ri > 0) bGaze = 1; else bGaze = 0; rc=DetectFixation(bGaze,Xi,Yi,Threshold,MinDuration,&bGaze_d,&X_d,&Y_d,&Deviation_d,&FixX,&FixY,&SaccadeDuration,&FixDuration); if (fDebug > 1) Rprintf("FixDetectC DetectFixation %d,%d,%4.2f,%4.2f/n",i,rc,Xi,Yi); if ((rc == 2)||((rc == 1)&&(i == lmax)) ) { //--- Fixation finished ----- iend = i - MinDuration; istart = iend - FixDuration + 1; // Вычисляем средний диаметр зрачка j = 0; Dcnt=0; dMean=0; fD = 0; fDisp=0; for (j = istart; j < iend; j++) { Ri = (float) REAL(R)[j]; Xi = (float) REAL(X)[j]; Yi = (float) REAL(Y)[j]; if (Ri > 0) { Dcnt++; dMean += Ri; } fDx = FixX - Xi; fDy = FixY - Yi; dDrSq = fDx * fDx + fDy * fDy; fD = fD + dDrSq; } if (Dcnt >0) dMean = dMean / Dcnt; if (Dcnt > 1) fDisp = (float)sqrt(fD / (Dcnt - 1)); // Выводим информацию о фиксации if (fDebug > 0) Rprintf("FixDetectC fixation: %4.2f,%4.2f,%3.5f,%d,%d/n",FixX,FixY,dMean,istart,FixDuration); if (FixDuration >= MinDuration) { pFIX->fixx = FixX; pFIX->fixy = FixY; pFIX->D = dMean; pFIX->duration = FixDuration; pFIX->start = istart; pFIX->fixdisp = fDisp; if ( NFix < MaxNFix) {pFIX++; NFix++;} else { Rprintf("FixDetectC: ERROR NFix (%d) == MaxNFix (%d)",NFix,MaxNFix); break;//.........这里部分代码省略.........
开发者ID:deslion,项目名称:EyeTrackingProject,代码行数:101,
示例5: stri_escape_unicode/** * Escape Unicode code points * * @param str character vector * @return character vector * * @version 0.1-?? (Marek Gagolewski, 2013-08-17) * * @version 0.2-1 (Marek Gagolewski, 2014-04-01) * fail on incorrect utf8 byte seqs; * * @version 0.3-1 (Marek Gagolewski, 2014-11-04) * Issue #112: str_prepare_arg* retvals were not PROTECTed from gc*/SEXP stri_escape_unicode(SEXP str){ PROTECT(str = stri_prepare_arg_string(str, "str")); // prepare string argument STRI__ERROR_HANDLER_BEGIN(1) R_len_t str_length = LENGTH(str); StriContainerUTF8 str_cont(str, str_length); SEXP ret; STRI__PROTECT(ret = Rf_allocVector(STRSXP, str_length)); std::string out; // @TODO: estimate len a priori? for (R_len_t i = str_cont.vectorize_init(); i != str_cont.vectorize_end(); i = str_cont.vectorize_next(i)) { if (str_cont.isNA(i)) { SET_STRING_ELT(ret, i, NA_STRING); continue; } const char* str_cur_s = str_cont.get(i).c_str(); R_len_t str_cur_n = str_cont.get(i).length(); // estimate buf size R_len_t bufsize = 0; UChar32 c; R_len_t j = 0; while (j < str_cur_n) { U8_NEXT(str_cur_s, j, str_cur_n, c); if (c < 0) throw StriException(MSG__INVALID_UTF8); else if ((char)c >= 32 || (char)c <= 126) bufsize += 1; else if (c <= 0xff) bufsize += 6; // for /a, /n this will be overestimated else bufsize += 10; } out.clear(); if ((size_t)bufsize > (size_t)out.size()) out.reserve(bufsize); // do escape j = 0; char buf[11]; while (j < str_cur_n) { U8_NEXT(str_cur_s, j, str_cur_n, c); /* if (c < 0) throw StriException(MSG__INVALID_UTF8); // this has already been checked :) else */ if (c <= ASCII_MAXCHARCODE) { switch ((char)c) { case 0x07: out.append("//a"); break; case 0x08: out.append("//b"); break; case 0x09: out.append("//t"); break; case 0x0a: out.append("//n"); break; case 0x0b: out.append("//v"); break; case 0x0c: out.append("//f"); break; case 0x0d: out.append("//r"); break;// case 0x1b: out.append("//e"); break; // R doesn't know that case 0x22: out.append("///""); break; case 0x27: out.append("//'"); break; case 0x5c: out.append("////"); break; default: if ((char)c >= 32 || (char)c <= 126) // printable characters out.append(1, (char)c); else { sprintf(buf, "//u%4.4x", (uint16_t)c); out.append(buf, 6); } } } else if (c <= 0xffff) { sprintf(buf, "//u%4.4x", (uint16_t)c); out.append(buf, 6); } else { sprintf(buf, "//U%8.8x", (uint32_t)c); out.append(buf, 10); } } SET_STRING_ELT(ret, i, Rf_mkCharLenCE(out.c_str(), (int)out.size(), (cetype_t)CE_UTF8)//.........这里部分代码省略.........
开发者ID:balagopalraj,项目名称:clearlinux,代码行数:101,
示例6: port_ivsetSEXP port_ivset(SEXP kind, SEXP iv, SEXP v){ Rf_divset(asInteger(kind), INTEGER(iv), LENGTH(iv), LENGTH(v), REAL(v)); return R_NilValue;}
开发者ID:Bgods,项目名称:r-source,代码行数:5,
示例7: port_nlsbSEXP port_nlsb(SEXP m, SEXP d, SEXP gg, SEXP iv, SEXP v, SEXP lowerb, SEXP upperb){ int *dims = INTEGER(getAttrib(gg, R_DimSymbol)); int i, n = LENGTH(d), p = LENGTH(d), nd = dims[0]; SEXP getPars, setPars, resid, gradient, rr = PROTECT(allocVector(REALSXP, nd)), x = PROTECT(allocVector(REALSXP, n)); // This used to use Calloc, but that will leak if // there is a premature return (and did in package drfit) double *b = (double *) NULL, *rd = (double *)R_alloc(nd, sizeof(double)); if (!isReal(d) || n < 1) error(_("'d' must be a nonempty numeric vector")); if(!isNewList(m)) error(_("m must be a list")); /* Initialize parameter vector */ getPars = PROTECT(lang1(getFunc(m, "getPars", "m"))); eval_check_store(getPars, R_GlobalEnv, x); /* Create the setPars call */ setPars = PROTECT(lang2(getFunc(m, "setPars", "m"), x)); /* Evaluate residual and gradient */ resid = PROTECT(lang1(getFunc(m, "resid", "m"))); eval_check_store(resid, R_GlobalEnv, rr); gradient = PROTECT(lang1(getFunc(m, "gradient", "m"))); neggrad(gradient, R_GlobalEnv, gg); if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) { if (isReal(lowerb) && isReal(upperb)) { double *rl = REAL(lowerb), *ru = REAL(upperb); b = (double *)R_alloc(2*n, sizeof(double)); for (i = 0; i < n; i++) { b[2*i] = rl[i]; b[2*i + 1] = ru[i]; } } else error(_("'lowerb' and 'upperb' must be numeric vectors")); } do { nlsb_iterate(b, REAL(d), REAL(gg), INTEGER(iv), LENGTH(iv), LENGTH(v), n, nd, p, REAL(rr), rd, REAL(v), REAL(x)); switch(INTEGER(iv)[0]) { case -3: eval(setPars, R_GlobalEnv); eval_check_store(resid, R_GlobalEnv, rr); neggrad(gradient, R_GlobalEnv, gg); break; case -2: eval_check_store(resid, R_GlobalEnv, rr); neggrad(gradient, R_GlobalEnv, gg); break; case -1: eval(setPars, R_GlobalEnv); eval_check_store(resid, R_GlobalEnv, rr); neggrad(gradient, R_GlobalEnv, gg); break; case 0: Rprintf("nlsb_iterate returned %d", INTEGER(iv)[0]); break; case 1: eval(setPars, R_GlobalEnv); eval_check_store(resid, R_GlobalEnv, rr); break; case 2: eval(setPars, R_GlobalEnv); neggrad(gradient, R_GlobalEnv, gg); break; } } while(INTEGER(iv)[0] < 3); UNPROTECT(6); return R_NilValue;}
开发者ID:Bgods,项目名称:r-source,代码行数:74,
示例8: REG_SYSC char *name; bool active; int option; int maxcalls; int numcalls; char *s; // ... whatever else};#define REG_SYSC(x) [x] = {x, #x, false, 0, 0, 0, NULL}static struct one_call global_call_list[] = {#include "reg_sysc.c" {-1, NULL, false, 0, 0, 0, NULL}};static const int NUMCALLS = LENGTH(global_call_list);static char *call_name(int syscall){ int i = 0; struct one_call *c = global_call_list; while (i < NUMCALLS) { if (c[i].syscall == syscall) return c[i].name; i += 1; } return NULL;}/* * signal stuff
开发者ID:mnhrdt,项目名称:nurse,代码行数:31,
示例9: pollSocketSEXP pollSocket(SEXP sockets_, SEXP events_, SEXP timeout_) { SEXP result; if(TYPEOF(timeout_) != INTSXP) { error("poll timeout must be an integer."); } if(TYPEOF(sockets_) != VECSXP || LENGTH(sockets_) == 0) { error("A non-empy list of sockets is required as first argument."); } int nsock = LENGTH(sockets_); PROTECT(result = allocVector(VECSXP, nsock)); if (TYPEOF(events_) != VECSXP) { error("event list must be a list of strings or a list of vectors of strings."); } if(LENGTH(events_) != nsock) { error("event list must be the same length as socket list."); } zmq_pollitem_t *pitems = (zmq_pollitem_t*)R_alloc(nsock, sizeof(zmq_pollitem_t)); if (pitems == NULL) { error("failed to allocate memory for zmq_pollitem_t array."); } try { for (int i = 0; i < nsock; i++) { zmq::socket_t* socket = reinterpret_cast<zmq::socket_t*>(checkExternalPointer(VECTOR_ELT(sockets_, i), "zmq::socket_t*")); pitems[i].socket = (void*)*socket; pitems[i].events = rzmq_build_event_bitmask(VECTOR_ELT(events_, i)); } int rc = zmq::poll(pitems, nsock, *INTEGER(timeout_)); if(rc >= 0) { for (int i = 0; i < nsock; i++) { SEXP events, names; // Pre count number of polled events so we can // allocate appropriately sized lists. short eventcount = 0; if (pitems[i].events & ZMQ_POLLIN) eventcount++; if (pitems[i].events & ZMQ_POLLOUT) eventcount++; if (pitems[i].events & ZMQ_POLLERR) eventcount++; PROTECT(events = allocVector(VECSXP, eventcount)); PROTECT(names = allocVector(VECSXP, eventcount)); eventcount = 0; if (pitems[i].events & ZMQ_POLLIN) { SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLIN)); SET_VECTOR_ELT(names, eventcount, mkChar("read")); eventcount++; } if (pitems[i].events & ZMQ_POLLOUT) { SET_VECTOR_ELT(names, eventcount, mkChar("write")); SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLOUT)); eventcount++; } if (pitems[i].events & ZMQ_POLLERR) { SET_VECTOR_ELT(names, eventcount, mkChar("error")); SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLERR)); } setAttrib(events, R_NamesSymbol, names); SET_VECTOR_ELT(result, i, events); } } else { error("polling zmq sockets failed."); } } catch(std::exception& e) { error(e.what()); } // Release the result list (1), and per socket // events lists with associated names (2*nsock). UNPROTECT(1 + 2*nsock); return result;}
开发者ID:joemphilips,项目名称:rzmq,代码行数:81,
示例10: do_relop_dfltSEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y){ SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames; int nx, ny, xarray, yarray, xts, yts; Rboolean mismatch = FALSE, iS; PROTECT_INDEX xpi, ypi; PROTECT_WITH_INDEX(x, &xpi); PROTECT_WITH_INDEX(y, &ypi); nx = length(x); ny = length(y); /* pre-test to handle the most common case quickly. Used to skip warning too .... */ if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue && TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP && LENGTH(x) > 0 && LENGTH(y) > 0) { SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y); if (nx > 0 && ny > 0) mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0; if (mismatch) { PROTECT(ans); warningcall(call, _("longer object length is not a multiple of shorter object length")); UNPROTECT(1); } UNPROTECT(2); return ans; } /* That symbols and calls were allowed was undocumented prior to R 2.5.0. We deparse them as deparse() would, minus attributes */ if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) { SEXP tmp = allocVector(STRSXP, 1); PROTECT(tmp); SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) : STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0)); REPROTECT(x = tmp, xpi); UNPROTECT(1); } if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) { SEXP tmp = allocVector(STRSXP, 1); PROTECT(tmp); SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) : STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0)); REPROTECT(y = tmp, ypi); UNPROTECT(1); } if (!isVector(x) || !isVector(y)) { if (isNull(x) || isNull(y)) { UNPROTECT(2); return allocVector(LGLSXP,0); } errorcall(call, _("comparison (%d) is possible only for atomic and list types"), PRIMVAL(op)); } if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP) errorcall(call, _("comparison is not allowed for expressions")); /* ELSE : x and y are both atomic or list */ if (LENGTH(x) <= 0 || LENGTH(y) <= 0) { UNPROTECT(2); return allocVector(LGLSXP,0); } mismatch = FALSE; xarray = isArray(x); yarray = isArray(y); xts = isTs(x); yts = isTs(y); if (nx > 0 && ny > 0) mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0; if (xarray || yarray) { if (xarray && yarray) { if (!conformable(x, y)) errorcall(call, _("non-conformable arrays")); PROTECT(dims = getAttrib(x, R_DimSymbol)); } else if (xarray) { PROTECT(dims = getAttrib(x, R_DimSymbol)); } else /*(yarray)*/ { PROTECT(dims = getAttrib(y, R_DimSymbol)); } PROTECT(xnames = getAttrib(x, R_DimNamesSymbol)); PROTECT(ynames = getAttrib(y, R_DimNamesSymbol)); } else { PROTECT(dims = R_NilValue); PROTECT(xnames = getAttrib(x, R_NamesSymbol)); PROTECT(ynames = getAttrib(y, R_NamesSymbol)); } if (xts || yts) { if (xts && yts) { if (!tsConform(x, y))//.........这里部分代码省略.........
开发者ID:SensePlatform,项目名称:R,代码行数:101,
示例11: rthhistextern "C" SEXP rthhist(SEXP x, SEXP nbins_, SEXP nch_, SEXP nthreads){ const int n = LENGTH(x); const int nbins = INTEGER(nbins_)[0]; const int nch = INTEGER(nch_)[0]; floublevec dx(REAL(x), REAL(x)+n); SEXP bincounts, R_left, R_binwidth; PROTECT(bincounts = allocVector(INTSXP, nbins)); PROTECT(R_left = allocVector(REALSXP, 1)); PROTECT(R_binwidth = allocVector(REALSXP, 1)); SEXP ret, retnames; RTH_GEN_NTHREADS(nthreads); // determine binwidth etc. thrust::pair<floubleveciter, floubleveciter> mm = thrust::minmax_element(dx.begin(), dx.end()); flouble left = *(mm.first), right = *(mm.second); flouble binwidth = (right - left) / nbins; // form matrix of bin counts, one row per chunk intvec dbincounts(nch*nbins); // the heart of the computation, a for_each() loop, one iteration per // chunk thrust::counting_iterator<int> seqa(0); thrust::counting_iterator<int> seqb = seqa + nch; thrust::for_each(seqa,seqb, do1chunk(dx.begin(),dbincounts.begin( ), n, nbins, nch, left, binwidth)); // copy result to host and combine the subhistograms int hbincounts[nch*nbins]; thrust::copy(dbincounts.begin(), dbincounts.end(), hbincounts); int binnum,chunknum; for (binnum = 0; binnum < nbins; binnum++) { int sum = 0; for (chunknum = 0; chunknum < nch; chunknum++) sum += hbincounts[chunknum*nbins + binnum]; INTEGER(bincounts)[binnum] = sum; } REAL(R_left)[0] = (double) left; REAL(R_binwidth)[0] = (double) binwidth; PROTECT(retnames = allocVector(STRSXP, 3)); SET_STRING_ELT(retnames, 0, mkChar("counts")); SET_STRING_ELT(retnames, 1, mkChar("left")); SET_STRING_ELT(retnames, 2, mkChar("binwidth")); PROTECT(ret = allocVector(VECSXP, 3)); SET_VECTOR_ELT(ret, 0, bincounts); SET_VECTOR_ELT(ret, 1, R_left); SET_VECTOR_ELT(ret, 2, R_binwidth); setAttrib(ret, R_NamesSymbol, retnames); UNPROTECT(5); return ret;}
开发者ID:Rth-org,项目名称:Rth,代码行数:66,
示例12: setupvoid setup(void){ ewmh_init(); screen = xcb_setup_roots_iterator(xcb_get_setup(dpy)).data; if (!screen) err("error: cannot aquire screen/n"); screen_width = screen->width_in_pixels; screen_height = screen->height_in_pixels; root_depth = screen->root_depth; xcb_atom_t net_atoms[] = {ewmh->_NET_SUPPORTED, ewmh->_NET_DESKTOP_NAMES, ewmh->_NET_NUMBER_OF_DESKTOPS, ewmh->_NET_CURRENT_DESKTOP, ewmh->_NET_CLIENT_LIST, ewmh->_NET_ACTIVE_WINDOW, ewmh->_NET_WM_DESKTOP, ewmh->_NET_WM_STATE, ewmh->_NET_WM_STATE_FULLSCREEN, ewmh->_NET_WM_WINDOW_TYPE, ewmh->_NET_WM_WINDOW_TYPE_DOCK, ewmh->_NET_WM_WINDOW_TYPE_NOTIFICATION, ewmh->_NET_WM_WINDOW_TYPE_DIALOG, ewmh->_NET_WM_WINDOW_TYPE_UTILITY, ewmh->_NET_WM_WINDOW_TYPE_TOOLBAR}; xcb_ewmh_set_supported(ewmh, default_screen, LENGTH(net_atoms), net_atoms); monitor_uid = desktop_uid = client_uid = 0; mon = last_mon = mon_head = mon_tail = NULL; bool xinerama_is_active = false; if (xcb_get_extension_data(dpy, &xcb_xinerama_id)->present) { xcb_xinerama_is_active_reply_t *xia = xcb_xinerama_is_active_reply(dpy, xcb_xinerama_is_active(dpy), NULL); if (xia != NULL) { xinerama_is_active = xia->state; free(xia); } } if (xinerama_is_active) { xcb_xinerama_query_screens_reply_t *xsq = xcb_xinerama_query_screens_reply(dpy, xcb_xinerama_query_screens(dpy), NULL); xcb_xinerama_screen_info_t *xsi = xcb_xinerama_query_screens_screen_info(xsq); int n = xcb_xinerama_query_screens_screen_info_length(xsq); PRINTF("number of monitors: %d/n", n); for (int i = 0; i < n; i++) { xcb_xinerama_screen_info_t info = xsi[i]; xcb_rectangle_t rect = (xcb_rectangle_t) {info.x_org, info.y_org, info.width, info.height}; add_monitor(&rect); } free(xsq); } else { warn("Xinerama is inactive"); xcb_rectangle_t rect = (xcb_rectangle_t) {0, 0, screen_width, screen_height}; add_monitor(&rect); } for (monitor_t *m = mon_head; m != NULL; m = m->next) add_desktop(m, NULL); ewmh_update_number_of_desktops(); ewmh_update_desktop_names(); rule_head = make_rule(); frozen_pointer = make_pointer_state(); get_pointer_position(&pointer_position); split_mode = MODE_AUTOMATIC;}
开发者ID:sunaku,项目名称:bspwm,代码行数:69,
示例13: do_sprintf//.........这里部分代码省略......... if (starc) { /* handle * format if present */ nstar = -1; if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') { v = starc[1] - '0'; if(starc[2] == '$') { if(v > nargs) error(_("reference to non-existent argument %d"), v); nstar = v-1; memmove(starc+1, starc+3, strlen(starc)-2); } else if(starc[2] >= '0' && starc[2] <= '9' && starc[3] == '$') { v = 10*v + starc[2] - '0'; if(v > nargs) error(_("reference to non-existent argument %d"), v); nstar = v-1; memmove(starc+1, starc+4, strlen(starc)-3); } } if(nstar < 0) { if (cnt >= nargs) error(_("too few arguments")); nstar = cnt++; } if (Rf_strchr(starc+1, '*')) error(_("at most one asterisk '*' is supported in each conversion specification")); _this = a[nstar]; if(ns == 0 && TYPEOF(_this) == REALSXP) { _this = coerceVector(_this, INTSXP); PROTECT(a[nstar] = _this); nprotect++; } if(TYPEOF(_this) != INTSXP || LENGTH(_this)<1 || INTEGER(_this)[ns % LENGTH(_this)] == NA_INTEGER) error(_("argument for '*' conversion specification must be a number")); star_arg = INTEGER(_this)[ns % LENGTH(_this)]; has_star = TRUE; } else has_star = FALSE; if (fmt[strlen(fmt) - 1] == '%') { /* handle % with formatting options */ if (has_star) snprintf(bit, MAXLINE+1, fmt, star_arg); else strcpy(bit, fmt); /* was sprintf(..) for which some compiler warn */ } else { Rboolean did_this = FALSE; if(nthis < 0) { if (cnt >= nargs) error(_("too few arguments")); nthis = cnt++; } _this = a[nthis]; if (has_star) { size_t nf; char *p, *q = fmt2; for (p = fmt; *p; p++) if (*p == '*') q += sprintf(q, "%d", star_arg); else *q++ = *p; *q = '/0'; nf = strlen(fmt2); if (nf > MAXLINE) error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);
开发者ID:jeffreyhorner,项目名称:cxxr,代码行数:67,
示例14: map_check_polygonsSEXP map_check_polygons(SEXP x, SEXP y, SEXP z, SEXP xokspan, SEXP usr) // returns new x vector{ //int nrow = INTEGER(GET_DIM(z))[0]; //int ncol = INTEGER(GET_DIM(z))[1]; PROTECT(x = AS_NUMERIC(x)); PROTECT(y = AS_NUMERIC(y)); PROTECT(z = AS_NUMERIC(z)); PROTECT(xokspan = AS_NUMERIC(xokspan)); PROTECT(usr = AS_NUMERIC(usr)); int nusr = LENGTH(usr); if (nusr != 4) error("'usr' must hold 4 values"); double *usrp = REAL(usr); // left right bottom top double *xp = REAL(x); double *yp = REAL(y); //double *zp = REAL(z); double *xokspanp = REAL(xokspan); int nx = length(x); int ny = length(y); int nz = length(z); if (nx < 2) error("must have at least two x values"); if (ny < 2) error("must have at least two y values"); if (nz < 1) error("must have at least one z value"); int npoly = nx / 5; SEXP okPoint, okPolygon, clippedPoint, clippedPolygon; PROTECT(okPolygon = allocVector(LGLSXP, npoly)); PROTECT(okPoint = allocVector(LGLSXP, nx)); PROTECT(clippedPoint = allocVector(LGLSXP, nx)); PROTECT(clippedPolygon = allocVector(LGLSXP, npoly)); int *okPointp = INTEGER(okPoint); int *okPolygonp = INTEGER(okPolygon); int *clippedPointp = INTEGER(clippedPoint); int *clippedPolygonp = INTEGER(clippedPolygon); // Initialize (not be needed if below catches all cases) for (int ipoly = 0; ipoly < npoly; ipoly++) { okPolygonp[ipoly] = 1; clippedPolygonp[ipoly] = 0; } for (int ix = 0; ix < nx; ix++) { okPointp[ix] = 1; clippedPointp[ix] = 0; } // x1 x2 x3 x4 NA x1 x2 x3 x4 NA ... double dxPermitted = fabs(*xokspanp);#ifdef DEBUG int count = 0, ncount=100000;#endif for (int ipoly = 0; ipoly < npoly; ipoly++) { int start = 5 * ipoly; // Check for bad polygons, in three phases. // 1. Find polygons that have some NA values for vertices#ifdef DEBUG if (ipoly < 3) Rprintf("start: %d; okPointp= %d %d .../n", start, okPointp[start], okPointp[start+1]);#endif for (int j = 0; j < 4; j++) { // skip 5th point which is surely NA // Check for x or y being NA if (ISNA(xp[start + j]) || ISNA(yp[start + j])) {#ifdef DEBUG if (count++ < ncount) { // FIXME: remove when working Rprintf("(1.) x or y is NA -- ipoly: %d, j: %d, span: %f (limit to span: %f)/n", ipoly, j, fabs(xp[start+j]-xp[start+j-1]), dxPermitted); }#endif for (int k = 0; k < 5; k++) okPointp[start + k] = 0; okPolygonp[ipoly] = 0; break; } } // 2. Find polygons with all vertices outside the plot region double xmin = xp[start], xmax = xp[start], ymin = yp[start], ymax=yp[start]; for (int j = 1; j < 4; j++) { if (xp[start + j] < xmin) xmin = xp[start + j]; if (yp[start + j] < ymin) ymin = yp[start + j]; if (xp[start + j] > xmax) xmax = xp[start + j]; if (yp[start + j] > ymax) ymax = yp[start + j]; } if (xmax < usrp[0] || usrp[1] < xmin || ymax < usrp[2] || usrp[3] < ymin) {#ifdef DEBUG if (count < ncount) { count++; Rprintf("clipping points %d to %d/n", start, start+4); }#endif for (int k = 0; k < 5; k++) { clippedPointp[start + k] = 1; } clippedPolygonp[ipoly] = 1; } // 3. Find polygons with excessive x range (an error in projection) for (int j = 1; j < 4; j++) { // skip 5th point which is surely NA if (dxPermitted < fabs(xp[start + j] - xp[start + j - 1])) {#ifdef DEBUG if (count++ < ncount) { // FIXME: remove when working Rprintf("(3.) ipoly: %d, j: %d, span: %f (limit to span: %f)/n", ipoly, j, fabs(xp[start+j]-xp[start+j-1]), dxPermitted); }#endif//.........这里部分代码省略.........
开发者ID:AnneMTreasure,项目名称:oce,代码行数:101,
示例15: loc_get_targetunsigned int loc_get_target(void){ if (gTarget != (unsigned int)-1) return gTarget; static const char hw_platform[] = "/sys/devices/soc0/hw_platform"; static const char id[] = "/sys/devices/soc0/soc_id"; static const char hw_platform_dep[] = "/sys/devices/system/soc/soc0/hw_platform"; static const char id_dep[] = "/sys/devices/system/soc/soc0/id"; static const char mdm[] = "/dev/mdm"; // No such file or directory char rd_hw_platform[LINE_LEN]; char rd_id[LINE_LEN]; char rd_mdm[LINE_LEN]; char baseband[LINE_LEN]; if (is_qca1530()) { gTarget = TARGET_QCA1530; goto detected; } loc_get_target_baseband(baseband, sizeof(baseband)); if (!access(hw_platform, F_OK)) { read_a_line(hw_platform, rd_hw_platform, LINE_LEN); } else { read_a_line(hw_platform_dep, rd_hw_platform, LINE_LEN); } if (!access(id, F_OK)) { read_a_line(id, rd_id, LINE_LEN); } else { read_a_line(id_dep, rd_id, LINE_LEN); } if( !memcmp(baseband, STR_APQ, LENGTH(STR_APQ)) ){ if( !memcmp(rd_id, MPQ8064_ID_1, LENGTH(MPQ8064_ID_1)) && IS_STR_END(rd_id[LENGTH(MPQ8064_ID_1)]) ) gTarget = TARGET_MPQ; else gTarget = TARGET_APQ_SA; } else { if( (!memcmp(rd_hw_platform, STR_LIQUID, LENGTH(STR_LIQUID)) && IS_STR_END(rd_hw_platform[LENGTH(STR_LIQUID)])) || (!memcmp(rd_hw_platform, STR_SURF, LENGTH(STR_SURF)) && IS_STR_END(rd_hw_platform[LENGTH(STR_SURF)])) || (!memcmp(rd_hw_platform, STR_MTP, LENGTH(STR_MTP)) && IS_STR_END(rd_hw_platform[LENGTH(STR_MTP)]))) { if (!read_a_line( mdm, rd_mdm, LINE_LEN)) gTarget = TARGET_MDM; } else if( (!memcmp(rd_id, MSM8930_ID_1, LENGTH(MSM8930_ID_1)) && IS_STR_END(rd_id[LENGTH(MSM8930_ID_1)])) || (!memcmp(rd_id, MSM8930_ID_2, LENGTH(MSM8930_ID_2)) && IS_STR_END(rd_id[LENGTH(MSM8930_ID_2)])) ) gTarget = TARGET_MSM_NO_SSC; else gTarget = TARGET_UNKNOWN; }detected: LOC_LOGD("HAL: %s returned %d", __FUNCTION__, gTarget); return gTarget;}
开发者ID:F4k,项目名称:android_device_samsung_serrano-common,代码行数:66,
示例16: call_mebdfiSEXP call_mebdfi(SEXP y, SEXP yprime, SEXP times, SEXP resfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP itol, SEXP rho, SEXP Tcrit, SEXP Hini, SEXP Maxord, SEXP maxIt, SEXP nind, SEXP jacfunc, SEXP initfunc, SEXP verbose, SEXP Mf, SEXP Mbnd, SEXP Liw, SEXP Lrw, SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP flist, SEXP Funtype, SEXP Mass){/******************************************************************************//****** DECLARATION SECTION ******//******************************************************************************//* These R-structures will be allocated and returned to R*/ SEXP yout, yout2=NULL, dyout=NULL, ISTATE, RWORK; int i, j, k, nt, latol, lrtol, lrw, liw, isDll; int isForcing , Itol, *mbnd, mf, maxord, isOut; double *xytmp, *xdytmp, *rwork, tin, tout, *Atol, *Rtol, tcrit, hini; double *delta=NULL, cj; int idid, *iwork, ires, ierr, funtype; C_res_func_type *res_func = NULL; C_jac_func_type *jac_func = NULL;/******************************************************************************//****** STATEMENTS ******//******************************************************************************//* #### initialisation #### */ init_N_Protect(); n_eq = LENGTH(y); nt = LENGTH(times);// mflag = INTEGER(verbose)[0]; nout = INTEGER(nOut)[0]; funtype = INTEGER(Funtype)[0]; /* 1 = res, 2 = func */ ntot = n_eq; mf = INTEGER(Mf)[0]; maxord = INTEGER(Maxord)[0]; tcrit = REAL(Tcrit)[0]; hini = REAL(Hini)[0]; ierr = 0;/* function is a dll ?*/ if (inherits(resfunc, "NativeSymbol")) isDll = 1; else isDll = 0; isOut = 0; if (isDll == 0 && nout > 0) isOut =1; else if (isDll == 1 ) ntot = ntot+ nout;/* initialise output vectors ... */ if (isDll==1) { /* function is a dll */ lrpar = nout + LENGTH(Rpar); /* length of rpar */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ lipar = 1; lrpar = 1; } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); if (isDll ==1) { ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* first nout elements of rpar reserved for output variables other elements are set in R-function lsodx via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.; for (j = 0; j < LENGTH(Rpar);j++) out[nout+j] = REAL(Rpar)[j]; } else { for (j = 0; j < lrpar; j++) out[j] = 0.; for (j = 0; j < lipar; j++) ipar[j] = 0.; } /* copies of all variables that will be changed in the FORTRAN subroutine */ xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; xdytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xdytmp[j] = REAL(yprime)[j]; /* tolerance */ latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; Itol = INTEGER(itol)[0];//.........这里部分代码省略.........
开发者ID:cran,项目名称:deTestSet,代码行数:101,
示例17: shp_insideSEXP shp_inside(SEXP slist, SEXP pxv, SEXP pyv, SEXP clockw, SEXP sAll) { SEXP xv, yv, pv, res; double *x, *y, *px, *py; int *p, up = 0, *r, np, ns, mp = 0, i, expected = (asInteger(clockw) == TRUE) ? 1 : -1, all = (asInteger(sAll) == TRUE) ? 1 : 0; if (TYPEOF(slist) != VECSXP || !inherits(slist, "shp")) Rf_error("input must be a list of shapes (shp object)"); if (LENGTH(slist) == 0) return allocVector(INTSXP, 0); if (LENGTH(pxv) != LENGTH(pyv)) Rf_error("point coordinates must have the same length"); if (TYPEOF(pxv) != REALSXP) { pxv = PROTECT(coerceVector(pxv, REALSXP)); up++; } if (TYPEOF(pyv) != REALSXP) { pyv = PROTECT(coerceVector(pyv, REALSXP)); up++; } px = REAL(pxv); py = REAL(pyv); np = LENGTH(pxv); ns = LENGTH(slist); if (!all) { /* match-like behavior - find the first only */ res = allocVector(INTSXP, np); r = INTEGER(res); memset(r, 0, sizeof(*r) * np); for (i = 0; i < ns; i++) { int j; double *bb; SEXP shp = VECTOR_ELT(slist, i); bb = REAL(VECTOR_ELT(shp, 2)); pv = VECTOR_ELT(shp, 3); p = INTEGER(pv); xv = VECTOR_ELT(shp, 4); x = REAL(xv); yv = VECTOR_ELT(shp, 5); y = REAL(yv); for (j = 0; j < np; j++) { double X = px[j], Y = py[j]; /* is the point inside the bounding box? */ if (X >= bb[0] && X <= bb[2] && Y >= bb[1] && Y <= bb[3]) { if (inside_(X, Y, x, y, LENGTH(xv), expected) && !r[j]) { mp++; r[j] = i + 1; if (mp >= np) { /* if all points got matched, get out */ i = ns; break; } } } } } if (mp < np) /* replace 0 (no match) with NA */ for (i = 0; i < np; i++) if (r[i] == 0) r[i] = NA_INTEGER; } else { /* return a list of all matches - useful for heavily overlapping shapes */ SEXP tmp = PROTECT(allocVector(INTSXP, ns)); /* temporary vector to store per-point matches */ int *ti = INTEGER(tmp); memset(ti, 0, sizeof(ti[0]) * ns); res = PROTECT(allocVector(VECSXP, np)); /* result list */ up += 2; for (i = 0; i < np; i++) { double X = px[i], Y = py[i]; int j, k = 0; for (j = 0; j < ns; j++) { double *bb; SEXP shp = VECTOR_ELT(slist, j); bb = REAL(VECTOR_ELT(shp, 2)); if (X >= bb[0] && X <= bb[2] && Y >= bb[1] && Y <= bb[3]) { pv = VECTOR_ELT(shp, 3); p = INTEGER(pv); xv = VECTOR_ELT(shp, 4); x = REAL(xv); yv = VECTOR_ELT(shp, 5); y = REAL(yv); if (inside_(X, Y, x, y, LENGTH(xv), expected)) ti[k++] = j + 1; } } if (k) { memcpy(INTEGER(SET_VECTOR_ELT(res, i, allocVector(INTSXP, k))), ti, sizeof(ti[0]) * k); memset(ti, 0, sizeof(ti[0]) * k); } } } if (up) UNPROTECT(up); return res;}
开发者ID:StudyNAYO,项目名称:fastshp,代码行数:82,
示例18: make_dSEXP make_d(SEXP year, SEXP month, SEXP day) { if(!isInteger(year)) error("year must be integer"); if(!isInteger(month)) error("month must be integer"); if(!isInteger(day)) error("day must be integer"); R_len_t n = LENGTH(year); if(n != LENGTH(month)) error("length of 'month' vector is not the same as that of 'year'"); if(n != LENGTH(day)) error("length of 'day' vector is not the same as that of 'year'"); int* pyear = INTEGER(year); int* pmonth = INTEGER(month); int* pday = INTEGER(day); SEXP res = allocVector(REALSXP, n); double *data = REAL(res); for(int i = 0; i < n; i++) { // main accumulator double SECS = 0.0; int y = pyear[i]; int m = pmonth[i]; int d = pday[i]; if(y == NA_INTEGER || m == NA_INTEGER || d == NA_INTEGER) { data[i] = NA_REAL; } else { if ( 0 < m && m < 13 ) SECS += sm[m]; else { data[i] = NA_REAL; continue; } if ( 0 < d && d < 32 ) SECS += (d - 1) * 86400; else { data[i] = NA_REAL; continue; } int is_leap = IS_LEAP(y); if(check_ymd(y, m, d, is_leap)){ SECS += d30; y -= 2000; SECS += y * yearlen; SECS += adjust_leap_years(y, m, is_leap); data[i] = SECS; } else { data[i] = NA_REAL; } } } return res;}
开发者ID:hadley,项目名称:lubridate,代码行数:66,
示例19: port_nlminbSEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho, SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v){ int i, n = LENGTH(d); SEXP xpt; SEXP dot_par_symbol = install(".par"); double *b = (double *) NULL, *g = (double *) NULL, *h = (double *) NULL, fx = R_PosInf; if (isNull(rho)) { error(_("use of NULL environment is defunct")); rho = R_BaseEnv; } else if (!isEnvironment(rho)) error(_("'rho' must be an environment")); if (!isReal(d) || n < 1) error(_("'d' must be a nonempty numeric vector")); if (hs != R_NilValue && gr == R_NilValue) error(_("When Hessian defined must also have gradient defined")); if (R_NilValue == (xpt = findVarInFrame(rho, dot_par_symbol)) || !isReal(xpt) || LENGTH(xpt) != n) error(_("environment 'rho' must contain a numeric vector '.par' of length %d"), n); /* We are going to alter .par, so must duplicate it */ defineVar(dot_par_symbol, duplicate(xpt), rho); PROTECT(xpt = findVarInFrame(rho, dot_par_symbol)); if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) { if (isReal(lowerb) && isReal(upperb)) { double *rl=REAL(lowerb), *ru=REAL(upperb); b = (double *)R_alloc(2*n, sizeof(double)); for (i = 0; i < n; i++) { b[2*i] = rl[i]; b[2*i + 1] = ru[i]; } } else error(_("'lower' and 'upper' must be numeric vectors")); } if (gr != R_NilValue) { g = (double *)R_alloc(n, sizeof(double)); if (hs != R_NilValue) h = (double *)R_alloc((n * (n + 1))/2, sizeof(double)); } do { nlminb_iterate(b, REAL(d), fx, g, h, INTEGER(iv), LENGTH(iv), LENGTH(v), n, REAL(v), REAL(xpt)); if (INTEGER(iv)[0] == 2 && g) check_gv(gr, hs, rho, n, g, h); else { fx = asReal(eval(fn, rho)); if (ISNAN(fx)) { warning("NA/NaN function evaluation"); fx = R_PosInf; } } /* duplicate .par value again in case a callback has stored value (package varComp does this) */ defineVar(dot_par_symbol, duplicate(xpt), rho); xpt = findVarInFrame(rho, dot_par_symbol); UNPROTECT(1); PROTECT(xpt); } while(INTEGER(iv)[0] < 3); UNPROTECT(1); /* xpt */ return R_NilValue;}
开发者ID:Bgods,项目名称:r-source,代码行数:65,
示例20: trim_ts/*#define DEBUG*/SEXP trim_ts(SEXP x, SEXP xlim, SEXP extra){ PROTECT(x = AS_NUMERIC(x)); PROTECT(xlim = AS_NUMERIC(xlim)); PROTECT(extra = AS_NUMERIC(extra)); double *xp = REAL(x); double *xlimp = REAL(xlim); double *extrap = REAL(extra); int nx= LENGTH(x); int nxlim = LENGTH(xlim); if (nxlim != 2) error("In trim_ts(), length of xlim must be 2"); if (xlimp[1] < xlimp[0]) error("In trim_ts(), xlim must be ordered but it is (%g, %g)/n", xlimp[0], xlimp[1]); for (int i = 1; i < nx; i++) { if (xp[i] == xp[i-1]) { ; //error("In trim_ts(), x must be distinct but x[%d]=x[%d]=%.10g (sec after origin)/n", i-1, i, xp[i-1]); } else if (xp[i] < xp[i-1]) { error("In trim_ts(), x must be ordered but x[%d]=%.10g and x[%d]=%.10g (sec after origin)/n", i-1, xp[i-1], i, xp[i]); } } double epsilon = (xp[1] - xp[0]) / 1e9; SEXP from; SEXP to; PROTECT(from = NEW_NUMERIC(1)); PROTECT(to = NEW_NUMERIC(1)); double start = xlimp[0] - (*extrap)*(xlimp[1]-xlimp[0]) - epsilon; double end = xlimp[1] + (*extrap)*(xlimp[1]-xlimp[0]) + epsilon; double *fromp = REAL(from); double *top = REAL(to); for (int i = 0; i < nx; i++) { //Rprintf("examine x[%d]=%f/n", 1+i, xp[i]); if (xp[i] >= start) { *fromp = (double)i;//-1; break; } } for (int i = nx-1; i >= 0; i--) { //Rprintf("examine x[%d]=%f/n", 1+i, xp[i]); if (xp[i] < end) { *top = (double)i+2; break; } } if (*fromp < 1.0) *fromp = 1.0; if (*top > nx) *top = (double)nx; SEXP res, res_names; PROTECT(res = allocVector(VECSXP, 2)); PROTECT(res_names = allocVector(STRSXP, 2)); SET_VECTOR_ELT(res, 0, from); SET_STRING_ELT(res_names, 0, mkChar("from")); SET_VECTOR_ELT(res, 1, to); SET_STRING_ELT(res_names, 1, mkChar("to")); setAttrib(res, R_NamesSymbol, res_names); UNPROTECT(7); return(res);}
开发者ID:AnneMTreasure,项目名称:oce,代码行数:64,
示例21: call_rkAutoSEXP call_rkAuto(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Rtol, SEXP Atol, SEXP Tcrit, SEXP Verbose, SEXP Hmin, SEXP Hmax, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *FF, *rr; SEXP R_yout; double *y0, *y1, *y2, *dy1, *dy2, *out, *yout; double errold = 0.0, t, dt, tmax; SEXP R_FSAL, Alpha, Beta; int fsal = FALSE; /* assume no FSAL */ /* Use polynomial interpolation if not disabled by the method or when events come in to play (stop-and-go mode). Methods with dense output interpolate by default, all others do not. */ int interpolate = TRUE; int i = 0, j = 0, it = 0, it_tot = 0, it_ext = 0, nt = 0, neq = 0, it_rej = 0; int isForcing, isEvent; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ int lAtol = LENGTH(Atol); double *atol = (double*) R_alloc((int) lAtol, sizeof(double)); int lRtol = LENGTH(Rtol); double *rtol = (double*) R_alloc((int) lRtol, sizeof(double)); for (j = 0; j < lRtol; j++) rtol[j] = REAL(Rtol)[j]; for (j = 0; j < lAtol; j++) atol[j] = REAL(Atol)[j]; double tcrit = REAL(Tcrit)[0]; double hmin = REAL(Hmin)[0]; double hmax = REAL(Hmax)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs is func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_B2, R_C, R_D, R_densetype; double *A, *bb1, *bb2 = NULL, *cc = NULL, *dd = NULL; PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect(); A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect(); bb1 = REAL(R_B1); PROTECT(R_B2 = getListElement(Method, "b2")); incr_N_Protect(); if (length(R_B2)) bb2 = REAL(R_B2); PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect(); if (length(R_C)) cc = REAL(R_C); PROTECT(R_D = getListElement(Method, "d")); incr_N_Protect(); if (length(R_D)) dd = REAL(R_D); /* dense output Cash-Karp: densetype = 2 */ int densetype = 0; PROTECT(R_densetype = getListElement(Method, "densetype")); incr_N_Protect(); if (length(R_densetype)) densetype = INTEGER(R_densetype)[0]; double qerr = REAL(getListElement(Method, "Qerr"))[0]; double beta = 0; /* 0.4/qerr; */ PROTECT(Beta = getListElement(Method, "beta")); incr_N_Protect(); if (length(Beta)) beta = REAL(Beta)[0]; double alpha = 1/qerr - 0.75 * beta; PROTECT(Alpha = getListElement(Method, "alpha")); incr_N_Protect(); if (length(Alpha)) alpha = REAL(Alpha)[0]; PROTECT(R_FSAL = getListElement(Method, "FSAL")); incr_N_Protect(); if (length(R_FSAL)) fsal = INTEGER(R_FSAL)[0]; PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0;//.........这里部分代码省略.........
开发者ID:ReedWood,项目名称:desolve,代码行数:101,
示例22: bn_recovery/* check neighbourhood sets and markov blankets for consistency.. */SEXP bn_recovery(SEXP bn, SEXP strict, SEXP mb, SEXP debug, SEXP filter) {int i = 0, j = 0, k = 0, n = 0, counter = 0;short int *checklist = NULL, err = 0;int *debuglevel = NULL, *checkmb = NULL, *nbrfilter = NULL;SEXP temp, temp2, nodes, elnames = NULL, fixed; /* get the names of the nodes. */ nodes = getAttrib(bn, R_NamesSymbol); n = LENGTH(nodes); /* allocate and initialize the checklist. */ checklist = allocstatus(UPTRI_MATRIX(n)); /* dereference the debug, mb and filter parameters. */ debuglevel = LOGICAL(debug); checkmb = LOGICAL(mb); nbrfilter = INTEGER(filter); if (*debuglevel > 0) { Rprintf("----------------------------------------------------------------/n"); if (*checkmb) Rprintf("* checking consistency of markov blankets./n"); else Rprintf("* checking consistency of neighbourhood sets./n"); }/*THEN*/ /* scan the structure to determine the number of arcs. */ for (i = 0; i < n; i++) { if (*debuglevel > 0) Rprintf(" > checking node %s./n", NODE(i)); /* get the entry for the (neighbours|elements of the markov blanket) of the node.*/ temp = getListElement(bn, (char *)NODE(i)); if (!(*checkmb)) temp = getListElement(temp, "nbr"); /* check each element of the array and identify which variable it corresponds to. */ for (j = 0; j < LENGTH(temp); j++) { for (k = 0; k < n; k++) { /* increment the right element of checklist. */ if (!strcmp(NODE(k), (char *)CHAR(STRING_ELT(temp, j)))) checklist[UPTRI(i + 1, k + 1, n)]++; }/*FOR*/ }/*FOR*/ }/*FOR*/ /* if A is a neighbour of B, B is a neighbour of A; therefore each entry in * the checklist array must be equal to either zero (if the corresponding * nodes are not neighbours) or two (if the corresponding nodes are neighbours). * Any other value (typically one) is caused by an incorrect (i.e. asymmetric) * neighbourhood structure. The same logic holds for the markov blankets. */ for (i = 0; i < n; i++) for (j = i; j < n; j++) { if ((checklist[UPTRI(i + 1, j + 1, n)] != 0) && (checklist[UPTRI(i + 1, j + 1, n)] != 2)) { if (*debuglevel > 0) { if (*checkmb) Rprintf("@ asymmetry in the markov blankets for %s and %s./n", NODE(i), NODE(j)); else Rprintf("@ asymmetry in the neighbourhood sets for %s and %s./n", NODE(i), NODE(j)); }/*THEN*/ err = 1; }/*THEN*/ }/*FOR*/ /* no need to go on if the (neighbourhood sets|markov blankets) are symmetric; * otherwise throw either an error or a warning according to the value of the * strict parameter. */ if (!err) { return bn; }/*THEN*/ else if (isTRUE(strict)) { if (*checkmb) error("markov blankets are not symmetric./n"); else//.........这里部分代码省略.........
开发者ID:gasse,项目名称:bnlearn-clone-3.0,代码行数:101,
示例23: pointblankrange_calculateint pointblankrange_calculate(lpPointBlankRange pointblankrange){ Vector dr, r, tv, v, w; double mv, vm, elev, mh, vz, bw; double dt, eq, t, mach, drg; int i, itcnt, mhr;/* Set values that don't change for the pointblankrange... */ if (pointblankrange->alc) atmos_standardalt(pointblankrange->atmos); else atmos_atmos(pointblankrange->atmos); mach = pointblankrange->atmos->mach; eq = pointblankrange->atmos->density/ATMOS_DENSSTD; vz = INTOFT(pointblankrange->vital_zone); bw = pointblankrange->bullet_weight; itcnt = 0; pointblankrange->found = 0; elev = vz/(250.0*PBR_DX); while ((!pointblankrange->found) && (itcnt < PBR_MAXIMUM_ITCNT)) { vm = pointblankrange->muzzle_velocity; pointblankrange->muzzle_energy = PBR_ENERGY(bw, vm); t = 0.0; mh = INTOFT(-pointblankrange->sight_height); r = vector(0.0, mh, 0.0); dr = vector(0.0, 0.0, 0.0); v.x = vm*cos(elev); v.y = vm*sin(elev); v.z = 0.0; for (i = 0; (r.y > -vz); i++) { if (vm < PBR_ABSMINVX) break; vm = LENGTH(v); dt = 0.5*PBR_DX/v.x; drg = eq*vm*bc_getdrag(pointblankrange->bc, vm/mach); tv = SUBTRACT(v, MULTIPLY(dt, SUBTRACT(MULTIPLY(drg, v), PBR_GRAVITY))); vm = LENGTH(tv); dt = PBR_DX/tv.x; drg = eq*vm*bc_getdrag(pointblankrange->bc, vm/mach); v = SUBTRACT(v, MULTIPLY(dt, SUBTRACT(MULTIPLY(drg, tv), PBR_GRAVITY))); dr = vector(PBR_DX, v.y*dt, v.z*dt); r = ADD(r, dr); t = t + LENGTH(dr)/vm; vm = LENGTH(v); if (r.y > 0.0) pointblankrange->pbzero = i; pointblankrange->pbrange = i; if (r.y > mh) { mh = r.y; mhr = i; } } pointblankrange->found = (fabs(mh - vz) < PBR_MAXIMUM_ERROR); if (!pointblankrange->found) { elev = elev - (mh - vz)/(mhr*PBR_DX); } itcnt++; pointblankrange->terminal_energy = PBR_ENERGY(bw, vm); } return 0;}
开发者ID:jw3,项目名称:jbmcgi,代码行数:71,
示例24: runvoidrun(){ /* Using Xlib event handling to use the keyboard helpers */ XEvent event; fd_set fds; struct timeval timeout; struct timeval now; uint32_t usec_sleep = 1000000 / config.HZ; uint32_t usec_sleep_passive = 1000000 / config.HZ_passive; int Xfd = XConnectionNumber(X.dpy); /* If there is no user activity, we can spend more time between screen * updates without the user feeling less responsiveness. Passive mode * means that there are no X events to respond to, and we could slow down * rendering a bit, offering more throughput */ struct timeval last_event; last_event.tv_sec = 0; last_event.tv_usec = 0; bool passive = false; for (;;) { FD_ZERO(&fds); FD_SET(Xfd, &fds); FD_SET(shell_fd, &fds); timeout.tv_sec = 0; timeout.tv_usec = usec_sleep; /* TODO: set to blinking time? */ if (select(max(Xfd, shell_fd) + 1, &fds, NULL, NULL, &timeout) < 0) { if (errno == EINTR) continue; die("select failed"); } if (FD_ISSET(shell_fd, &fds)) { sh_read(term_write); /* short circuit shell output and term input */ } while (XPending(X.dpy)) { XNextEvent(X.dpy, &event); if (XFilterEvent(&event, X.window)) continue; passive = false; if (event.type < (int)LENGTH(x_handler) && x_handler[event.type]) (x_handler[event.type])(&event); } gettimeofday(&now, NULL); if (timediff_usec(now, X.last_draw) > (passive ? usec_sleep_passive : usec_sleep)) { x_draw(); } if (FD_ISSET(Xfd, &fds)) { gettimeofday(&last_event, NULL); passive = false; } else { passive = timediff_usec(now, last_event) > usec_sleep_passive; } if (!FD_ISSET(shell_fd, &fds) && passive) { term_gc(); /* Clean up term if we have time to spare */ } }}
开发者ID:halhen,项目名称:terma,代码行数:70,
示例25: baseCallbackstatic SEXP baseCallback(GEevent task, pGEDevDesc dd, SEXP data){ GESystemDesc *sd; baseSystemState *bss, *bss2; SEXP result = R_NilValue; switch (task) { case GE_FinaliseState: /* called from unregisterOne */ sd = dd->gesd[baseRegisterIndex]; free(sd->systemSpecific); sd->systemSpecific = NULL; break; case GE_InitState: { /* called from registerOne */ pDevDesc dev; GPar *ddp; sd = dd->gesd[baseRegisterIndex]; dev = dd->dev; bss = malloc(sizeof(baseSystemState)); sd->systemSpecific = bss; /* Bail out if necessary */ if (!bss) return result; /* Make sure initialized, or valgrind may complain. */ memset(bss, 0, sizeof(baseSystemState)); ddp = &(bss->dp); GInit(ddp); /* For some things, the device sets the starting value at least. */ ddp->ps = dev->startps; ddp->col = ddp->fg = dev->startcol; ddp->bg = dev->startfill; ddp->font = dev->startfont; ddp->lty = dev->startlty; ddp->gamma = dev->startgamma; /* Initialise the gp settings too: formerly in addDevice. */ copyGPar(ddp, &(bss->gp)); GReset(dd); /* * The device has not yet received any base output */ bss->baseDevice = FALSE; /* Indicate success */ result = R_BlankString; break; } case GE_CopyState: { /* called from GEcopyDisplayList */ pGEDevDesc curdd = GEcurrentDevice(); bss = dd->gesd[baseRegisterIndex]->systemSpecific; bss2 = curdd->gesd[baseRegisterIndex]->systemSpecific; copyGPar(&(bss->dpSaved), &(bss2->dpSaved)); restoredpSaved(curdd); copyGPar(&(bss2->dp), &(bss2->gp)); GReset(curdd); break; } case GE_SaveState: /* called from GEinitDisplayList */ bss = dd->gesd[baseRegisterIndex]->systemSpecific; copyGPar(&(bss->dp), &(bss->dpSaved)); break; case GE_RestoreState: /* called from GEplayDisplayList */ bss = dd->gesd[baseRegisterIndex]->systemSpecific; restoredpSaved(dd); copyGPar(&(bss->dp), &(bss->gp)); GReset(dd); break; case GE_SaveSnapshotState: /* called from GEcreateSnapshot */ { SEXP pkgName; bss = dd->gesd[baseRegisterIndex]->systemSpecific; /* Changed from INTSXP in 2.7.0: but saved graphics lists are protected by an R version number */ PROTECT(result = allocVector(RAWSXP, sizeof(GPar))); copyGPar(&(bss->dpSaved), (GPar*) RAW(result)); PROTECT(pkgName = mkString("graphics")); setAttrib(result, install("pkgName"), pkgName); UNPROTECT(2); } break; case GE_RestoreSnapshotState: /* called from GEplaySnapshot */ { int i, nState = LENGTH(data) - 1; SEXP graphicsState, snapshotEngineVersion; PROTECT(graphicsState = R_NilValue); /* Prior to engine version 11, "pkgName" was not stored. * (can tell because "engineVersion" was not stored either.) * Assume 'graphics' is first state in snapshot * (though this could be fatal). */ PROTECT(snapshotEngineVersion = getAttrib(data, install("engineVersion"))); if (isNull(snapshotEngineVersion)) { graphicsState = VECTOR_ELT(data, 1); } else {//.........这里部分代码省略.........
开发者ID:bedatadriven,项目名称:renjin,代码行数:101,
示例26: bmergeSEXP bmerge(SEXP iArg, SEXP xArg, SEXP icolsArg, SEXP xcolsArg, SEXP isorted, SEXP rollarg, SEXP rollendsArg, SEXP nomatch, SEXP retFirstArg, SEXP retLengthArg, SEXP allLen1Arg){ int xN, iN, protecti=0; roll = 0.0; nearest = FALSE; enc_warn = TRUE; if (isString(rollarg)) { if (strcmp(CHAR(STRING_ELT(rollarg,0)),"nearest") != 0) error("roll is character but not 'nearest'"); roll=1.0; nearest=TRUE; // the 1.0 here is just any non-0.0, so roll!=0.0 can be used later } else { if (!isReal(rollarg)) error("Internal error: roll is not character or double"); roll = REAL(rollarg)[0]; // more common case (rolling forwards or backwards) or no roll when 0.0 } rollabs = fabs(roll); i = iArg; x = xArg; // set globals so bmerge_r can see them. if (!isInteger(icolsArg)) error("Internal error: icols is not integer vector"); if (!isInteger(xcolsArg)) error("Internal error: xcols is not integer vector"); if (LENGTH(icolsArg) > LENGTH(xcolsArg)) error("Internal error: length(icols) [%d] > length(xcols) [%d]", LENGTH(icolsArg), LENGTH(xcolsArg)); icols = INTEGER(icolsArg); xcols = INTEGER(xcolsArg); xN = LENGTH(VECTOR_ELT(x,0)); iN = LENGTH(VECTOR_ELT(i,0)); ncol = LENGTH(icolsArg); // there may be more sorted columns in x than involved in the join for(int col=0; col<ncol; col++) { if (icols[col]==NA_INTEGER) error("Internal error. icols[%d] is NA", col); if (xcols[col]==NA_INTEGER) error("Internal error. xcols[%d] is NA", col); if (icols[col]>LENGTH(i) || icols[col]<1) error("icols[%d]=%d outside range [1,length(i)=%d]", col, icols[col], LENGTH(i)); if (xcols[col]>LENGTH(x) || xcols[col]<1) error("xcols[%d]=%d outside range [1,length(x)=%d]", col, xcols[col], LENGTH(x)); int it = TYPEOF(VECTOR_ELT(i, icols[col]-1)); int xt = TYPEOF(VECTOR_ELT(x, xcols[col]-1)); if (it != xt) error("typeof x.%s (%s) != typeof i.%s (%s)", CHAR(STRING_ELT(getAttrib(x,R_NamesSymbol),xcols[col]-1)), type2char(xt), CHAR(STRING_ELT(getAttrib(i,R_NamesSymbol),icols[col]-1)), type2char(it)); } if (!isInteger(retFirstArg) || LENGTH(retFirstArg)!=iN) error("retFirst must be integer vector the same length as nrow(i)"); retFirst = INTEGER(retFirstArg); if (!isInteger(retLengthArg) || LENGTH(retLengthArg)!=iN) error("retLength must be integer vector the same length as nrow(i)"); retLength = INTEGER(retLengthArg); if (!isLogical(allLen1Arg) || LENGTH(allLen1Arg) != 1) error("allLen1 must be a length 1 logical vector"); allLen1 = LOGICAL(allLen1Arg); if (!isLogical(rollendsArg) || LENGTH(rollendsArg) != 2) error("rollends must be a length 2 logical vector"); rollends = LOGICAL(rollendsArg); if (nearest && TYPEOF(VECTOR_ELT(i, icols[ncol-1]-1))==STRSXP) error("roll='nearest' can't be applied to a character column, yet."); for (int j=0; j<iN; j++) { // defaults need to populated here as bmerge_r may well not touch many locations, say if the last row of i is before the first row of x. retFirst[j] = INTEGER(nomatch)[0]; // default to no match for NA goto below // retLength[j] = 0; // TO DO: do this to save the branch below and later branches at R level to set .N to 0 retLength[j] = INTEGER(nomatch)[0]==0 ? 0 : 1; } allLen1[0] = TRUE; // All-0 and All-NA are considered all length 1 according to R code currently. Really, it means any(length>1). o = NULL; if (!LOGICAL(isorted)[0]) { SEXP order = PROTECT(vec_init(length(icolsArg), ScalarInteger(1))); // rep(1, length(icolsArg)) SEXP oSxp = PROTECT(forder(i, icolsArg, ScalarLogical(FALSE), ScalarLogical(TRUE), order, ScalarLogical(FALSE))); protecti += 2; if (!LENGTH(oSxp)) o = NULL; else o = INTEGER(oSxp); } if (iN) bmerge_r(-1,xN,-1,iN,0,1,1); UNPROTECT(protecti); return(R_NilValue);}
开发者ID:RanaivosonHerimanitra,项目名称:data.table,代码行数:68,
示例27: do_editSEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho){ int i, rc; ParseStatus status; SEXP x, fn, envir, ed, src, srcfile, Rfn; char *filename, *editcmd; const char *cmd; const void *vmaxsave; FILE *fp;#ifdef Win32 SEXP ti; char *title;#endif checkArity(op, args); vmaxsave = vmaxget(); x = CAR(args); args = CDR(args); if (TYPEOF(x) == CLOSXP) envir = CLOENV(x); else envir = R_NilValue; PROTECT(envir); fn = CAR(args); args = CDR(args); if (!isString(fn)) error(_("invalid argument to edit()")); if (LENGTH(STRING_ELT(fn, 0)) > 0) { const char *ss = translateChar(STRING_ELT(fn, 0)); filename = R_alloc(strlen(ss), sizeof(char)); strcpy(filename, ss); } else filename = DefaultFileName; if (x != R_NilValue) { if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL) errorcall(call, _("unable to open file")); if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++; src = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */ for (i = 0; i < LENGTH(src); i++) fprintf(fp, "%s/n", translateChar(STRING_ELT(src, i))); fclose(fp); }#ifdef Win32 ti = CAR(args);#endif args = CDR(args); ed = CAR(args); if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid")); cmd = translateChar(STRING_ELT(ed, 0)); if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set")); editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));#ifdef Win32 if (!strcmp(cmd,"internal")) { if (!isString(ti)) error(_("'title' must be a string")); if (LENGTH(STRING_ELT(ti, 0)) > 0) { title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char)); strcpy(title, CHAR(STRING_ELT(ti, 0))); } else { title = R_alloc(strlen(filename)+1, sizeof(char)); strcpy(title, filename); } Rgui_Edit(filename, CE_NATIVE, title, 1); } else { /* Quote path if necessary */ if(cmd[0] != '"' && Rf_strchr(cmd, ' ')) sprintf(editcmd, "/"%s/" /"%s/"", cmd, filename); else sprintf(editcmd, "%s /"%s/"", cmd, filename); rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL); if (rc == NOLAUNCH) errorcall(call, _("unable to run editor '%s'"), cmd); if (rc != 0) warningcall(call, _("editor ran but returned error status")); }#else if (ptr_R_EditFile) rc = ptr_R_EditFile(filename); else { sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces rc = R_system(editcmd); } if (rc != 0) errorcall(call, _("problem with running editor %s"), cmd);#endif if (asLogical(GetOption1(install("keep.source")))) { PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv)); PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename))))); PROTECT(src = eval(src, R_BaseEnv)); PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv)); PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src)); srcfile = eval(srcfile, R_BaseEnv); UNPROTECT(5); } else srcfile = R_NilValue; PROTECT(srcfile); //.........这里部分代码省略.........
开发者ID:Grade-Two,项目名称:r-source,代码行数:101,
示例28: compcases/* complete.cases(.) */SEXP compcases(SEXP args){ SEXP s, t, u, rval; int i, len; args = CDR(args); len = -1; for (s = args; s != R_NilValue; s = CDR(s)) { if (isList(CAR(s))) { for (t = CAR(s); t != R_NilValue; t = CDR(t)) if (isMatrix(CAR(t))) { u = getAttrib(CAR(t), R_DimSymbol); if (len < 0) len = INTEGER(u)[0]; else if (len != INTEGER(u)[0]) goto bad; } else if (isVector(CAR(t))) { if (len < 0) len = LENGTH(CAR(t)); else if (len != LENGTH(CAR(t))) goto bad; } else error(R_MSG_type, type2char(TYPEOF(CAR(t)))); } /* FIXME : Need to be careful with the use of isVector() */ /* since this includes lists and expressions. */ else if (isNewList(CAR(s))) { int it, nt; t = CAR(s); nt = length(t); /* 0-column data frames are a special case */ if(nt) { for (it = 0 ; it < nt ; it++) { if (isMatrix(VECTOR_ELT(t, it))) { u = getAttrib(VECTOR_ELT(t, it), R_DimSymbol); if (len < 0) len = INTEGER(u)[0]; else if (len != INTEGER(u)[0]) goto bad; } else if (isVector(VECTOR_ELT(t, it))) { if (len < 0) len = LENGTH(VECTOR_ELT(t, it)); else if (len != LENGTH(VECTOR_ELT(t, it))) goto bad; } else error(R_MSG_type, "unknown"); } } else { u = getAttrib(t, R_RowNamesSymbol); if (!isNull(u)) { if (len < 0) len = LENGTH(u); else if (len != INTEGER(u)[0]) goto bad; } } } else if (isMatrix(CAR(s))) { u = getAttrib(CAR(s), R_DimSymbol); if (len < 0) len = INTEGER(u)[0]; else if (len != INTEGER(u)[0]) goto bad; } else if (isVector(CAR(s))) { if (len < 0) len = LENGTH(CAR(s)); else if (len != LENGTH(CAR(s))) goto bad; } else error(R_MSG_type, type2char(TYPEOF(CAR(s)))); } if (len < 0) error(_("no input has determined the number of cases")); PROTECT(rval = allocVector(LGLSXP, len)); for (i = 0; i < len; i++) INTEGER(rval)[i] = 1; /* FIXME : there is a lot of shared code here for vectors. */ /* It should be abstracted out and optimized. */ for (s = args; s != R_NilValue; s = CDR(s)) { if (isList(CAR(s))) { /* Now we only need to worry about vectors */ /* since we use mod to handle arrays. */ /* FIXME : using mod like this causes */ /* a potential performance hit. */ for (t = CAR(s); t != R_NilValue; t = CDR(t)) { u = CAR(t); for (i = 0; i < LENGTH(u); i++) { switch (TYPEOF(u)) { case INTSXP: case LGLSXP: if (INTEGER(u)[i] == NA_INTEGER)//.........这里部分代码省略.........
开发者ID:KarolinaSkandy,项目名称:R-3-0-branch-alt,代码行数:101,
示例29: make_dtSEXP make_dt(SEXP year, SEXP month, SEXP day, SEXP hour, SEXP minute, SEXP second) { if(!isInteger(year)) error("year must be integer"); if(!isInteger(month)) error("month must be integer"); if(!isInteger(day)) error("day must be integer"); if(!isInteger(hour)) error("hour must be integer"); if(!isInteger(minute)) error("minute must be integer"); if(!isNumeric(second)) error("second must be numeric"); R_len_t n = LENGTH(year); if(n != LENGTH(month)) error("length of 'month' vector is not the same as that of 'year'"); if(n != LENGTH(day)) error("length of 'day' vector is not the same as that of 'year'"); if(n != LENGTH(hour)) error("length of 'hour' vector is not the same as that of 'year'"); if(n != LENGTH(minute)) error("length of 'minute' vector is not the same as that of 'year'"); if(n != LENGTH(second)) error("length of 'second' vector is not the same as that of 'year'"); int* pyear = INTEGER(year); int* pmonth = INTEGER(month); int* pday = INTEGER(day); int* phour = INTEGER(hour); int* pminute = INTEGER(minute); int int_second = TYPEOF(second) == INTSXP; SEXP res = allocVector(REALSXP, n); double *data = REAL(res); for(int i = 0; i < n; i++) { // main accumulator double SECS = 0.0; int y = pyear[i]; int m = pmonth[i]; int d = pday[i]; int H = phour[i]; int M = pminute[i]; int naS; double S; if(int_second){ S = (double) INTEGER(second)[i]; naS = INTEGER(second)[i] == NA_INTEGER; } else { S = REAL(second)[i]; naS = ISNA(S); } if(naS || y == NA_INTEGER || m == NA_INTEGER || d == NA_INTEGER || H == NA_INTEGER || M == NA_INTEGER) { data[i] = NA_REAL; } else { if ( 0 < m && m < 13 ) SECS += sm[m]; else { data[i] = NA_REAL; continue; } if ( 0 < d && d < 32 ) SECS += (d - 1) * 86400; else { data[i] = NA_REAL; continue; } if( H < 25 ) SECS += H * 3600; else { data[i] = NA_REAL; continue; } if ( M < 61 ) SECS += M * 60; else{ data[i] = NA_REAL; continue; } // allow leap seconds if ( S < 62 ) { SECS += S; } else { data[i] = NA_REAL; continue; } int is_leap = LEAP(y); if(check_ymd(y, m, d, is_leap)){ SECS += d30; y -= 2000; SECS += y * yearlen; SECS += adjust_leap_years(y, m, is_leap);//.........这里部分代码省略.........
开发者ID:McClellandLegge,项目名称:lubridate,代码行数:101,
示例30: siminf_run/** * Initiate and run the simulation * * @param model The siminf_model * @param threads Number of threads * @param seed Random number seed. * @param tr_fun Vector of function pointers to transition rate functions. * @param pts_fun Function pointer to callback after each time step * e.g. update infectious pressure. */SEXP siminf_run( SEXP model, SEXP threads, SEXP seed, TRFun *tr_fun, PTSFun pts_fun){ int err = 0, n_threads; SEXP trajectory, names, result = R_NilValue; SEXP ext_events, E, G, N, S, prS; int Nn, Nc, Nt, Nd, Nld, tlen; unsigned long int s; /* Create a list to hold the result of the simulated trajectory. */ PROTECT(trajectory = allocVector(VECSXP, 2)); setAttrib(trajectory, R_NamesSymbol, names = allocVector(STRSXP, 2)); SET_STRING_ELT(names, 0, mkChar("error")); SET_STRING_ELT(names, 1, mkChar("model")); if (siminf_arg_check_model(model)) { err = SIMINF_ERR_INVALID_MODEL; goto cleanup; } /* number of threads */ err = siminf_get_threads(&n_threads, threads); if (err) goto cleanup; /* seed */ err = siminf_get_seed(&s, seed); if (err) goto cleanup; /* Duplicate model and add it to the 'model' item in the * trajectory list. */ SET_VECTOR_ELT(trajectory, 1, result = duplicate(model)); /* SimInf model */ G = GET_SLOT(result, Rf_install("G")); S = GET_SLOT(result, Rf_install("S")); PROTECT(prS = coerceVector(GET_SLOT(S, Rf_install("x")), INTSXP)); /* Scheduled events */ ext_events = GET_SLOT(result, Rf_install("events")); E = GET_SLOT(ext_events, Rf_install("E")); N = GET_SLOT(ext_events, Rf_install("N")); /* Constants */ Nn = INTEGER(GET_SLOT(GET_SLOT(result, Rf_install("u0")), R_DimSymbol))[1]; Nc = INTEGER(GET_SLOT(S, Rf_install("Dim")))[0]; Nt = INTEGER(GET_SLOT(S, Rf_install("Dim")))[1]; Nd = INTEGER(GET_SLOT(GET_SLOT(result, Rf_install("v0")), R_DimSymbol))[0]; Nld = INTEGER(GET_SLOT(GET_SLOT(result, Rf_install("ldata")), R_DimSymbol))[0]; tlen = LENGTH(GET_SLOT(result, Rf_install("tspan"))); /* Output array (to hold a single trajectory) */ SET_SLOT(result, Rf_install("U"), allocMatrix(INTSXP, Nn * Nc, tlen)); SET_SLOT(result, Rf_install("V"), allocMatrix(REALSXP, Nn * Nd, tlen)); /* Run simulation solver. */ err = siminf_run_solver( INTEGER(GET_SLOT(result, Rf_install("u0"))), REAL(GET_SLOT(result, Rf_install("v0"))), INTEGER(GET_SLOT(G, Rf_install("i"))), INTEGER(GET_SLOT(G, Rf_install("p"))), INTEGER(GET_SLOT(S, Rf_install("i"))), INTEGER(GET_SLOT(S, Rf_install("p"))), INTEGER(prS), REAL(GET_SLOT(result, Rf_install("tspan"))), tlen, INTEGER(GET_SLOT(result, Rf_install("U"))), REAL(GET_SLOT(result, Rf_install("V"))), REAL(GET_SLOT(result, Rf_install("ldata"))), REAL(GET_SLOT(result, Rf_install("gdata"))), INTEGER(GET_SLOT(result, Rf_install("sd"))), Nn, Nc, Nt, Nd, Nld, INTEGER(GET_SLOT(E, Rf_install("i"))), INTEGER(GET_SLOT(E, Rf_install("p"))), INTEGER(N), LENGTH(GET_SLOT(ext_events, Rf_install("event"))), INTEGER(GET_SLOT(ext_events, Rf_install("event"))), INTEGER(GET_SLOT(ext_events, Rf_install("time"))), INTEGER(GET_SLOT(ext_events, Rf_install("node"))), INTEGER(GET_SLOT(ext_events, Rf_install("dest"))), INTEGER(GET_SLOT(ext_events, Rf_install("n"))), REAL(GET_SLOT(ext_events, Rf_install("proportion"))), INTEGER(GET_SLOT(ext_events, Rf_install("select"))), INTEGER(GET_SLOT(ext_events, Rf_install("shift"))), n_threads, s, tr_fun, pts_fun);//.........这里部分代码省略.........
开发者ID:cran,项目名称:SimInf,代码行数:101,
注:本文中的LENGTH函数示例整理自Github/MSDocs等源码及文档管理平台,相关代码片段筛选自各路编程大神贡献的开源项目,源码版权归原作者所有,传播和使用请参考对应项目的License;未经允许,请勿转载。 C++ LENGTHOF函数代码示例 C++ LEN函数代码示例 |