SEXP 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));
for (j = 0; j < n_eq; j++) xdytmp[j] = 0.;
}
/* pointers to functions deriv_func, jac_func, jac_vec, root_func, passed to FORTRAN */
if (isDll) { /* DLL address passed to FORTRAN */
deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc);
/* overruling deriv_func if forcing */
if (isForcing) {
DLL_deriv_func = deriv_func;
deriv_func = (C_deriv_func_type *) C_deriv_func_forc_gb;
}
} else {
/* interface function between FORTRAN and C/R passed to FORTRAN */
deriv_func = (C_deriv_func_type *) C_deriv_func_gb;
/* needed to communicate with R */
R_deriv_func = derivfunc;
R_envir = rho;
}
if (!isNull(jacfunc)) {
if (isDll)
jac_func_gb = (C_jac_func_type_gb *) R_ExternalPtrAddrFn_(jacfunc);
else {
R_jac_func = jacfunc;
jac_func_gb= C_jac_func_gb;
}
}
if (!isNull(masfunc)) {
R_mas_func = masfunc;
mas_func= C_mas_func;
}
solout = C_solout_gam;
solout_bim = C_solout_bim;
iout = 1; /* solout used */
idid = 0;
/* #### integration #### */
it = 0;
tin = REAL(times)[0];
tout = REAL(times)[nt-1];
saveOut (tin, xytmp); /* save initial condition */
it = it +1;
if (type == 1)
F77_CALL(gamd) ( &n_eq, deriv_func, &tin, xytmp, &tout, &hini,
Rtol, Atol, &itol, jac_func_gb, &ijac, &ml, &mu,
mas_func, &imas, &mlmas, &mumas, solout, &iout,
rwork, &lrw, iwork, &liw, out, ipar, &idid);
else if (type == 2)
F77_CALL(bimd) ( &n_eq, deriv_func, &tin, &tout, xytmp, &hini,
Rtol, Atol, &itol, jac_func_gb, &ijac, &ml, &mu,
mas_func, &imas, &mlmas, &mumas, solout_bim, &iout,
rwork, &lrw, iwork, &liw, out, ipar, &idid);
if (idid == -1)
warning("input is not consistent");
else if (idid == -2)
warning("larger maxsteps needed");
else if (idid == -3)
warning("step size becomes too small");
else if (idid == -4)
warning("matrix is repeatedly singular");
/* #### an error occurred #### */
if(it <= nt-1) saveOut (tin, xytmp); /* save final condition */
if (idid < 0 ) {
it = it-1;
returnearly (1);
}
/* #### returning output #### */
/* feval */
PROTECT(RWORK = allocVector(REALSXP, 3)); incr_N_Protect();
REAL(RWORK)[0] = hini;
REAL(RWORK)[1] = hini;
REAL(RWORK)[2] = tin;
PROTECT(ISTATE = allocVector(INTSXP, 6)); incr_N_Protect();
INTEGER(ISTATE)[0] = idid;
/* nsteps */
sum = 0;
runOK = 0;
if (type == 1) {
for (j = 11; j < 23; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[1] = sum;
/* feval */
INTEGER(ISTATE)[2] = iwork[9];
/* jacobian eval */
INTEGER(ISTATE)[3] = iwork[10];
/* LU decomp */
INTEGER(ISTATE)[4] = iwork[23];
/* number rejected steps */
sum = 0;
for (j = 11; j < 15; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[5] = INTEGER(ISTATE)[1]- sum;
if(idid > 0) runOK = 1;
} else {
for (j = 20; j < 25; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[1] = sum;
/* feval */
INTEGER(ISTATE)[2] = iwork[11];
/* jacobian eval */
INTEGER(ISTATE)[3] = iwork[12];
/* LU decomp */
INTEGER(ISTATE)[4] = iwork[13];
/* number rejected steps */
sum = 0;
for (j = 25; j < 29; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[5] = INTEGER(ISTATE)[1]- sum;
if(idid >= 0) runOK = 1;
}
if (runOK) {
setAttrib(YOUT, install("istate"), ISTATE);
setAttrib(YOUT, install("rstate"), RWORK);
}
else {
setAttrib(YOUT2, install("istate"), ISTATE);
setAttrib(YOUT2, install("rstate"), RWORK);
}
/* #### termination #### */
unprotect_all();
if (runOK)
return(YOUT);
else
return(YOUT2);
}
SEXP 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;
int j, *midx;
// extract covariates and interpolate
if (LENGTH(tcovar) > 0) { // add covars to call
PROTECT(fcall = LCONS(covars,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
}
// parameter vector
PROTECT(par = NEW_NUMERIC(npar)); nprotect++;
SET_NAMES(par,Pnames);
pp = REAL(par);
// finish constructing the call
PROTECT(fcall = LCONS(t0,fcall)); nprotect++;
SET_TAG(fcall,install("t0"));
PROTECT(fcall = LCONS(par,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// evaluation environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
p = REAL(params);
memcpy(pp,p,npar*sizeof(double)); // copy the parameters
PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call
PROTECT(Snames = GET_NAMES(x1)); nprotect++;
if (!IS_NUMERIC(x1) || isNull(Snames)) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector");
}
nvar = LENGTH(x1);
xp = REAL(x1);
midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++;
for (j = 0; j < nvar; j++) {
if (midx[j]!=0) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j)));
}
}
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
xt = REAL(x);
memcpy(xt,xp,nvar*sizeof(double));
for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
memcpy(pp,p+npar*(j%nrep),npar*sizeof(double));
PROTECT(x2 = eval(fcall,rho));
xp = REAL(x2);
if (LENGTH(x2)!=nvar)
errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length");
memcpy(xt,xp,nvar*sizeof(double));
UNPROTECT(1);
}
}
break;
case native: // use native routine
{
SEXP Cnames;
int *sidx, *pidx, *cidx;
double *xt, *ps, time;
pomp_initializer *ff = NULL;
int j;
PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
// construct state, parameter, covariate, observable indices
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
nvar = LENGTH(Snames);
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
set_pomp_userdata(fcall);
GetRNGstate();
time = *(REAL(t0));
// loop over replicates
for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar)
(*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp);
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov
break;
}
}
UNPROTECT(nprotect);
return x;
}
/* 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)
);
*/
}
SEXP 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;
}
}
}
i++;
}
if (fDebug > 1) Rprintf("FixDetectC main loop finished\n");
PROTECT(Res = allocVector(VECSXP,6));
PROTECT(r_X = allocVector(REALSXP,NFix));
PROTECT(r_Y = allocVector(REALSXP,NFix));
PROTECT(r_D = allocVector(REALSXP,NFix));
PROTECT(r_dur = allocVector(INTSXP,NFix));
PROTECT(r_start = allocVector(INTSXP,NFix));
PROTECT(r_disp = allocVector(REALSXP,NFix));
PROTECT(list_names = allocVector(STRSXP,6));
//=======
pFIX = pFIX_b;
i=0;
while (i<NFix) {
REAL(r_X)[i] = pFIX->fixx;
REAL(r_Y)[i] = pFIX->fixy;
REAL(r_D)[i] = pFIX->D;
INTEGER(r_dur)[i] = pFIX->duration;
INTEGER(r_start)[i] = pFIX->start;
REAL(r_disp)[i] = pFIX->fixdisp;
pFIX++; i++;
}
SET_VECTOR_ELT(Res,0,r_X);
SET_VECTOR_ELT(Res,1,r_Y);
SET_VECTOR_ELT(Res,2,r_D);
SET_VECTOR_ELT(Res,3,r_dur);
SET_VECTOR_ELT(Res,4,r_start);
SET_VECTOR_ELT(Res,5,r_disp);
//== Set names for output LIST elements ===========================
for(i = 0; i < 6; i++) SET_STRING_ELT(list_names,i,mkChar(names[i]));
setAttrib(Res, R_NamesSymbol, list_names);
UNPROTECT(8);
free(pFIX_b);
return Res;
}
/**
* 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)
);
}
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}
SEXP port_ivset(SEXP kind, SEXP iv, SEXP v)
{
Rf_divset(asInteger(kind), INTEGER(iv), LENGTH(iv), LENGTH(v), REAL(v));
return R_NilValue;
}
SEXP 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;
}
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
SEXP 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;
}
SEXP 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))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (length(x) < length(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (length(y) < length(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (mismatch)
warningcall(call, _("longer object length is not a multiple of shorter object length"));
if (isString(x) || isString(y)) {
REPROTECT(x = coerceVector(x, STRSXP), xpi);
REPROTECT(y = coerceVector(y, STRSXP), ypi);
x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isComplex(x) || isComplex(y)) {
REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
}
else if (isReal(x) || isReal(y)) {
REPROTECT(x = coerceVector(x, REALSXP), xpi);
REPROTECT(y = coerceVector(y, REALSXP), ypi);
x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isInteger(x) || isInteger(y)) {
REPROTECT(x = coerceVector(x, INTSXP), xpi);
REPROTECT(y = coerceVector(y, INTSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isLogical(x) || isLogical(y)) {
REPROTECT(x = coerceVector(x, LGLSXP), xpi);
REPROTECT(y = coerceVector(y, LGLSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
REPROTECT(x = coerceVector(x, RAWSXP), xpi);
REPROTECT(y = coerceVector(y, RAWSXP), ypi);
x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
} else errorcall(call, _("comparison of these types is not implemented"));
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if (xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if (ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if (length(x) == length(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if (length(x) == length(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(6);
return x;
}
extern "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;
}
void 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;
}
SEXP attribute_hidden do_sprintf(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
int i, nargs, cnt, v, thislen, nfmt, nprotect = 0;
/* fmt2 is a copy of fmt with '*' expanded.
bit will hold numeric formats and %<w>s, so be quite small. */
char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
*outputString;
const char *formatString;
size_t n, cur, chunk;
SEXP format, _this, a[MAXNARGS], ans /* -Wall */ = R_NilValue;
int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;
static R_StringBuffer outbuff = {nullptr, 0, MAXELTSIZE};
Rboolean has_star, use_UTF8;
#define _my_sprintf(_X_) \
{ \
int nc = snprintf(bit, MAXLINE+1, fmtp, _X_); \
if (nc > MAXLINE) \
error(_("required resulting string length %d is greater than maximal %d"), \
nc, MAXLINE); \
}
nargs = num_args;
/* grab the format string */
format = num_args ? args[0] : nullptr;
if (!isString(format))
error(_("'fmt' is not a character vector"));
nfmt = length(format);
if (nfmt == 0) return allocVector(STRSXP, 0);
args = (args + 1); nargs--;
if(nargs >= MAXNARGS)
error(_("only %d arguments are allowed"), MAXNARGS);
/* record the args for possible coercion and later re-ordering */
for(i = 0; i < nargs; i++, args = (args + 1)) {
SEXPTYPE t_ai;
a[i] = args[0];
if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */
error(_("invalid type of argument[%d]: '%s'"),
i+1, CHAR(type2str(t_ai)));
lens[i] = length(a[i]);
if(lens[i] == 0) return allocVector(STRSXP, 0);
}
#define CHECK_maxlen \
maxlen = nfmt; \
for(i = 0; i < nargs; i++) \
if(maxlen < lens[i]) maxlen = lens[i]; \
if(maxlen % nfmt) \
error(_("arguments cannot be recycled to the same length")); \
for(i = 0; i < nargs; i++) \
if(maxlen % lens[i]) \
error(_("arguments cannot be recycled to the same length"))
CHECK_maxlen;
outputString = CXXRCONSTRUCT(static_cast<char*>, R_AllocStringBuffer(0, &outbuff));
/* We do the format analysis a row at a time */
for(ns = 0; ns < maxlen; ns++) {
outputString[0] = '\0';
use_UTF8 = CXXRCONSTRUCT(Rboolean, getCharCE(STRING_ELT(format, ns % nfmt)) == CE_UTF8);
if (!use_UTF8) {
for(i = 0; i < nargs; i++) {
if (!isString(a[i])) continue;
if (getCharCE(STRING_ELT(a[i], ns % lens[i])) == CE_UTF8) {
use_UTF8 = TRUE; break;
}
}
}
formatString = TRANSLATE_CHAR(format, ns % nfmt);
n = strlen(formatString);
if (n > MAXLINE)
error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);
/* process the format string */
for (cur = 0, cnt = 0; cur < n; cur += chunk) {
const char *curFormat = formatString + cur, *ss;
char *starc;
ss = nullptr;
if (formatString[cur] == '%') { /* handle special format command */
if (cur < n - 1 && formatString[cur + 1] == '%') {
/* take care of %% in the format */
chunk = 2;
strcpy(bit, "%");
}
else {
/* recognise selected types from Table B-1 of K&R */
/* NB: we deal with "%%" in branch above. */
/* This is MBCS-OK, as we are in a format spec */
chunk = strcspn(curFormat + 1, "diosfeEgGxXaA") + 2;
if (cur + chunk > n)
error(_("unrecognised format specification '%s'"), curFormat);
strncpy(fmt, curFormat, chunk);
fmt[chunk] = '\0';
nthis = -1;
/* now look for %n$ or %nn$ form */
if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') {
v = fmt[1] - '0';
if(fmt[2] == '$') {
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nthis = v-1;
memmove(fmt+1, fmt+3, strlen(fmt)-2);
} else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') {
v = 10*v + fmt[2] - '0';
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nthis = v-1;
memmove(fmt+1, fmt+4, strlen(fmt)-3);
}
}
starc = Rf_strchr(fmt, '*');
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);
fmtp = fmt2;
} else fmtp = fmt;
#define CHECK_this_length \
PROTECT(_this); \
thislen = length(_this); \
if(thislen == 0) \
error(_("coercion has changed vector length to 0"))
/* Now let us see if some minimal coercion
would be sensible, but only do so once, for ns = 0: */
if(ns == 0) {
SEXP tmp; Rboolean do_check;
switch(*findspec(fmtp)) {
case 'd':
case 'i':
case 'o':
case 'x':
case 'X':
if(TYPEOF(_this) == REALSXP) {
double r = REAL(_this)[0];
if(double(int( r)) == r)
_this = coerceVector(_this, INTSXP);
PROTECT(a[nthis] = _this);
nprotect++;
}
break;
case 'a':
case 'A':
case 'e':
case 'f':
case 'g':
case 'E':
case 'G':
if(TYPEOF(_this) != REALSXP &&
/* no automatic as.double(<string>) : */
TYPEOF(_this) != STRSXP) {
PROTECT(tmp = lang2(install("as.double"), _this));
#define COERCE_THIS_TO_A \
_this = eval(tmp, env); \
UNPROTECT(1); \
PROTECT(a[nthis] = _this); \
nprotect++; \
did_this = TRUE; \
CHECK_this_length; \
do_check = (CXXRCONSTRUCT(Rboolean, lens[nthis] == maxlen)); \
lens[nthis] = thislen; /* may have changed! */ \
if(do_check && thislen < maxlen) { \
CHECK_maxlen; \
}
COERCE_THIS_TO_A
}
break;
case 's':
if(TYPEOF(_this) != STRSXP) {
/* as.character method might call sprintf() */
size_t nc = strlen(outputString);
char *z = Calloc(nc+1, char);
strcpy(z, outputString);
PROTECT(tmp = lang2(install("as.character"), _this));
COERCE_THIS_TO_A
strcpy(outputString, z);
Free(z);
}
break;
default:
break;
}
} /* ns == 0 (first-time only) */
if(!did_this)
CHECK_this_length;
switch(TYPEOF(_this)) {
case LGLSXP:
{
int x = LOGICAL(_this)[ns % thislen];
if (checkfmt(fmtp, "di"))
error(_("invalid format '%s'; %s"), fmtp,
_("use format %d or %i for logical objects"));
if (x == NA_LOGICAL) {
fmtp[strlen(fmtp)-1] = 's';
_my_sprintf("NA")
} else {
_my_sprintf(x)
}
break;
}
case INTSXP:
{
int x = INTEGER(_this)[ns % thislen];
if (checkfmt(fmtp, "dioxX"))
error(_("invalid format '%s'; %s"), fmtp,
_("use format %d, %i, %o, %x or %X for integer objects"));
if (x == NA_INTEGER) {
fmtp[strlen(fmtp)-1] = 's';
_my_sprintf("NA")
} else {
_my_sprintf(x)
}
break;
}
SEXP 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
for (int k = 0; k < 5; k++) {
okPointp[start + k] = 0;
}
okPolygonp[ipoly] = 0;
break;
}
}
}
SEXP res;
SEXP res_names;
PROTECT(res = allocVector(VECSXP, 4));
PROTECT(res_names = allocVector(STRSXP, 4));
SET_VECTOR_ELT(res, 0, okPoint);
SET_STRING_ELT(res_names, 0, mkChar("okPoint"));
SET_VECTOR_ELT(res, 1, clippedPoint);
SET_STRING_ELT(res_names, 1, mkChar("clippedPoint"));
SET_VECTOR_ELT(res, 2, okPolygon);
SET_STRING_ELT(res_names, 2, mkChar("okPolygon"));
SET_VECTOR_ELT(res, 3, clippedPolygon);
SET_STRING_ELT(res_names, 3, mkChar("clippedPolygon"));
setAttrib(res, R_NamesSymbol, res_names);
UNPROTECT(11);
return(res);
#undef ij
}
unsigned 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;
}
SEXP 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];
/* work arrays */
liw = INTEGER(Liw)[0];
iwork = (int *) R_alloc(liw, sizeof(int));
for (j = 0; j<3; j++) iwork[j] = INTEGER(nind)[j];
for (j = 3; j<liw; j++) iwork[j] = 0;
iwork[13] = INTEGER(maxIt)[0];
lrw = INTEGER(Lrw)[0];
rwork = (double *) R_alloc(lrw, sizeof(double));
for (j = 0; j < lrw; j++) rwork[j] = 0.;
rwork[0] = DBL_EPSILON;
mbnd = (int *) R_alloc(4, sizeof(int));
for (j = 0; j<4; j++) mbnd[j] = INTEGER(Mbnd)[j];
nrowpd = mbnd[3];
/* initialise global variables... */
PROTECT(Rin = NEW_NUMERIC(2)); incr_N_Protect();
PROTECT(Y = allocVector(REALSXP,n_eq)); incr_N_Protect();
PROTECT(YPRIME = allocVector(REALSXP,n_eq)); incr_N_Protect();
PROTECT(yout = allocMatrix(REALSXP,ntot+1,nt)); incr_N_Protect();
if (isOut == 1) {
PROTECT(dyout = allocMatrix(REALSXP,n_eq+1,nt)); incr_N_Protect();
}
/**************************************************************************/
/****** Initialization of Parameters and Forcings (DLL functions) ******/
/**************************************************************************/
initParms(initfunc, parms);
// error("till here");
isForcing = initForcings(flist);
/* pointers to functions passed to the FORTRAN subroutine */
isMass = 0;
if (isDll == 1) { /* DLL address passed to fortran */
if (funtype == 1) {
res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc);
if(isForcing==1) {
DLL_res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc);
res_func = (C_res_func_type *) DLL_res_func_forc;
}
} else if (funtype <= 3) {
res_func = DLL_res_ode;
DLL_deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(resfunc);
if(isForcing==1)
res_func = (C_res_func_type *) DLL_res_func_forc2;
if (funtype == 3) { /* mass matrix */
isMass = 1;
mass = (double *)R_alloc(n_eq * n_eq, sizeof(double));
for (j = 0; j < n_eq * n_eq; j++) mass[j] = REAL(Mass)[j];
dytmp = (double *) R_alloc(n_eq, sizeof(double));
}
} else /* for MASS matrix .... */
error("DLL function type not yet implemented");
delta = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) delta[j] = 0.;
} else {
/* interface function between fortran and R passed to Fortran*/
res_func = (C_res_func_type *) C_res_func;
/* needed to communicate with R */
PROTECT(R_res_func = resfunc); incr_N_Protect();
PROTECT(R_envir = rho); incr_N_Protect();
}
if (!isNull(jacfunc))
{
if (inherits(jacfunc,"NativeSymbol"))
jac_func = (C_jac_func_type *) R_ExternalPtrAddrFn_(jacfunc);
else {
jac_func = (C_jac_func_type *) C_jac_func;
PROTECT(R_daejac_func = jacfunc); incr_N_Protect();
}
}
/* #### initial time step #### */
idid = 1;
REAL(yout)[0] = REAL(times)[0];
for (j = 0; j < n_eq; j++)
REAL(yout)[j+1] = REAL(y)[j];
if (nout>0) {
tin = REAL(times)[0];
if (isDll == 1) {
res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ;
// for (j = 0; j < nout; j++)
// REAL(yout)[n_eq + j + 1] = out[j];
}
else for (j = 0; j < n_eq; j++)
REAL(dyout)[j] = xdytmp[j];
}
/* #### main time loop #### */
for (i = 0; i < nt-1; i++)
{
//
tin = REAL(times)[i];
tout = REAL(times)[i+1];
// Rprintf("idid %i tin %g tout %g xdytmp %g \n", idid, tin, tout, xdytmp[0]);
F77_CALL(mebdfi)(&n_eq, &tin, &hini, xytmp, xdytmp, &tout, &tcrit,
&mf, &idid, &lrw, rwork, &liw, iwork, mbnd, &maxord,
&Itol, Rtol, Atol, out, ipar, jac_func, res_func, &ierr);
// Rprintf(" hini, xytmp %g %g %g %g %g %g\n", hini, xytmp[0], xytmp[1],xytmp[2] ,xytmp[3], xytmp[4] );
// error("here");
if (idid == 1) {
idid = 0;
F77_CALL(mebdfi)(&n_eq, &tin, &hini, xytmp, xdytmp, &tout, &tcrit,
&mf, &idid, &lrw, rwork, &liw, iwork, mbnd, &maxord,
&Itol, Rtol, Atol, out, ipar, jac_func, res_func, &ierr);
}
// Rprintf("idid %i tin %g tout %g tin-tout %g \n", idid, tin, tout, tin-tout);
if (idid == -1) {
warning("the integration failed to pass the error test, even after reducing h by factor 1e10");
} else if (idid == -2) {
warning("the integration failed by repeated error test failures or by a test on rtol/atol. too much accuracy requested");
} else if (idid == -3) {
warning("the integration failed to achieve corrector convergence, even after reducing h by factor 1e10");
} else if (idid == -4) {
warning("illegal values of input parameters - see printed message");
} else if (idid == -5) {
warning("idid was -1 on input, but tout was not beyond t");
} else if (idid == -6) {
warning("maximum number of integration steps exceeded");
} else if (idid == -7) {
warning("stepsize is too small, < sqrt(uround)/100");
} else if (idid == -11) {
warning("insufficient real workspace for the integration");
} else if (idid == -12) {
warning("insufficient integer workspace for the integration");
}
// Rprintf(" i, tin, tout, ntot %i, %g, %g, %i\n", i, tin, tout, ntot);
REAL(yout)[(i+1)*(ntot+1)] = tin;
for (j = 0; j < n_eq; j++)
REAL(yout)[(i+1)*(ntot + 1) + j + 1] = xytmp[j];
if (nout>0) {
if (isDll == 1) {
res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ;
for (j = 0; j < nout; j++)
REAL(yout)[(i+1)*(ntot + 1) + n_eq + j + 1] = out[j];
}
else for (j = 0; j < n_eq; j++)
REAL(dyout)[(i+1)*(n_eq) + j + 1] = xdytmp[j];
}
/**/
/* #### an error occurred #### */
if (tin < tout) {
if (idid >=0) idid = -10;
warning("Returning early from mebdfi Results are accurate, as far as they go\n");
/* redimension yout */
PROTECT(yout2 = allocMatrix(REALSXP,ntot+1,(i+2)));incr_N_Protect();
for (k = 0; k < i+2; k++)
for (j = 0; j < ntot+1; j++)
REAL(yout2)[k*(ntot+1) + j] = REAL(yout)[k*(ntot+1) + j];
break;
}
} /* end main time loop */
/* error("tillhere");
#### returning output #### */
PROTECT(ISTATE = allocVector(INTSXP, 15));incr_N_Protect();
for (k = 0;k<14;k++) INTEGER(ISTATE)[k+1] = iwork[k];
INTEGER(ISTATE)[0] = idid;
PROTECT(RWORK = allocVector(REALSXP, 1));incr_N_Protect();
REAL(RWORK)[0] = rwork[1];
if (idid >= 0)
{
setAttrib(yout, install("istate"), ISTATE);
setAttrib(yout, install("rstate"), RWORK);
if (isOut ==1) setAttrib(yout, install("dy"), dyout);
}
else
{
setAttrib(yout2, install("istate"), ISTATE);
setAttrib(yout2, install("rstate"), RWORK);
if (isOut ==1) setAttrib(yout2, install("dy"), dyout);
}
//
/* #### termination #### */
unprotect_all();
if (idid >= 0)
return(yout);
else
return(yout2);
}
SEXP 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;
}
SEXP 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;
}
SEXP 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;
}
/*#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);
}
SEXP 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;
/*------------------------------------------------------------------------*/
/* DLL, ipar, rpar (for compatibility with lsoda) */
/*------------------------------------------------------------------------*/
int isDll = FALSE;
int lrpar= 0, lipar = 0;
int *ipar = NULL;
/* code adapted from lsoda to improve compatibility */
if (inherits(Func, "NativeSymbol")) {
/* function is a dll */
isDll = TRUE;
if (nout > 0) isOut = TRUE;
//ntot = neq + nout; /* length of yout */
lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */
lipar = 3 + LENGTH(Ipar); /* length of ipar */
} else {
/* function is not a dll */
isDll = FALSE;
isOut = FALSE;
//ntot = neq;
lipar = 3; /* in lsoda = 1 */
lrpar = nout; /* in lsoda = 1 */
}
out = (double*) R_alloc(lrpar, sizeof(double));
ipar = (int *) R_alloc(lipar, sizeof(int));
/* first 3 elements of ipar are special */
ipar[0] = nout;
ipar[1] = lrpar;
ipar[2] = lipar;
if (isDll == 1) {
/* 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];
/* out: first nout elements of out are reserved for output variables
other elements are set via argument "rpar" */
for (j = 0; j < nout; j++) out[j] = 0.0;
for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j];
}
/*------------------------------------------------------------------------*/
/* Allocation of Workspace */
/*------------------------------------------------------------------------*/
y0 = (double*) R_alloc(neq, sizeof(double));
y1 = (double*) R_alloc(neq, sizeof(double));
y2 = (double*) R_alloc(neq, sizeof(double));
dy1 = (double*) R_alloc(neq, sizeof(double));
dy2 = (double*) R_alloc(neq, sizeof(double));
f = (double*) R_alloc(neq, sizeof(double));
y = (double*) R_alloc(neq, sizeof(double));
Fj = (double*) R_alloc(neq, sizeof(double));
tmp = (double*) R_alloc(neq, sizeof(double));
FF = (double*) R_alloc(neq * stage, sizeof(double));
rr = (double*) R_alloc(neq * 5, sizeof(double));
/* matrix for polynomial interpolation */
SEXP R_nknots;
int nknots = 6; /* 6 = 5th order polynomials by default*/
int iknots = 0; /* counter for knots buffer */
double *yknots;
PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect();
if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1;
if (nknots < 2) {nknots = 1; interpolate = FALSE;}
if (densetype > 0) interpolate = TRUE;
yknots = (double*) R_alloc((neq + 1) * (nknots + 1), sizeof(double));
/* matrix for holding states and global outputs */
PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect();
yout = REAL(R_yout);
/* initialize outputs with NA first */
for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL;
/* attribute that stores state information, similar to lsoda */
SEXP R_istate;
int *istate;
PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect();
istate = INTEGER(R_istate);
istate[0] = 0; /* assume succesful return */
for (i = 0; i < 22; i++) istate[i] = 0;
/*------------------------------------------------------------------------*/
/* Initialization of Parameters (for DLL functions) */
/*------------------------------------------------------------------------*/
PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect();
initParms(Initfunc, Parms);
isForcing = initForcings(Flist);
isEvent = initEvents(elist, eventfunc, 0);
if (isEvent) interpolate = FALSE;
/*------------------------------------------------------------------------*/
/* Initialization of Integration Loop */
/*------------------------------------------------------------------------*/
yout[0] = tt[0]; /* initial time */
yknots[0] = tt[0]; /* for polynomial interpolation */
for (i = 0; i < neq; i++) {
y0[i] = xs[i]; /* initial values */
yout[(i + 1) * nt] = y0[i]; /* output array */
yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */
}
iknots++;
t = tt[0];
tmax = fmax(tt[nt - 1], tcrit);
dt = fmin(hmax, hini);
hmax = fmin(hmax, tmax - t);
/* Initialize work arrays (to be on the safe side, remove this later) */
for (i = 0; i < neq; i++) {
y1[i] = 0;
y2[i] = 0;
Fj[i] = 0;
for (j= 0; j < stage; j++) {
FF[i + j * neq] = 0;
}
}
/*------------------------------------------------------------------------*/
/* Main Loop */
/*------------------------------------------------------------------------*/
it = 1; /* step counter; zero element is initial state */
it_ext = 0; /* counter for external time step (dense output) */
it_tot = 0; /* total number of time steps */
it_rej = 0;
if (interpolate) {
/* integrate over the whole time step and interpolate internally */
rk_auto(
fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate,
densetype, maxsteps, nt,
&iknots, &it, &it_ext, &it_tot, &it_rej,
istate, ipar,
t, tmax, hmin, hmax, alpha, beta,
&dt, &errold,
tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A,
out, bb1, bb2, cc, dd, atol, rtol, yknots, yout,
Func, Parms, Rho
);
} else {
/* integrate separately between external time steps; do not interpolate */
for (int j = 0; j < nt - 1; j++) {
t = tt[j];
tmax = fmin(tt[j + 1], tcrit);
dt = tmax - t;
if (isEvent) {
updateevent(&t, y0, istate);
}
if (verbose) Rprintf("\n %d th time interval = %g ... %g", j, t, tmax);
rk_auto(
fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate,
densetype, maxsteps, nt,
&iknots, &it, &it_ext, &it_tot, &it_rej,
istate, ipar,
t, tmax, hmin, hmax, alpha, beta,
&dt, &errold,
tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A,
out, bb1, bb2, cc, dd, atol, rtol, yknots, yout,
Func, Parms, Rho
);
/* in this mode, internal interpolation is skipped,
so we can simply store the results at the end of each call */
yout[j + 1] = tmax;
for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y2[i];
}
}
/*====================================================================*/
/* call derivs again to get global outputs */
/* j = -1 suppresses unnecessary internal copying */
/*====================================================================*/
if (nout > 0) {
for (int j = 0; j < nt; j++) {
t = yout[j];
for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)];
derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing);
for (i = 0; i < nout; i++) {
yout[j + nt * (1 + neq + i)] = out[i];
}
}
}
/* attach diagnostic information (codes are compatible to lsoda) */
setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, it_rej);
if (densetype == 2) istate[12] = it_tot * stage + 2; /* number of function evaluations */
/* verbose printing in debugging mode*/
if (verbose)
Rprintf("\nNumber of time steps it = %d, it_ext = %d, it_tot = %d it_rej %d\n",
it, it_ext, it_tot, it_rej);
/* release R resources */
timesteps[0] = 0;
timesteps[1] = 0;
restore_N_Protected(old_N_Protect);
return(R_yout);
}
/* 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
error("neighbourhood sets are not symmetric.\n");
}/*THEN*/
else {
if (*checkmb)
warning("markov blankets are not symmetric.\n");
else
warning("neighbourhood sets are not symmetric.\n");
}/*ELSE*/
/* build a correct structure to return. */
PROTECT(fixed = allocVector(VECSXP, n));
setAttrib(fixed, R_NamesSymbol, nodes);
if (!(*checkmb)) {
/* allocate colnames. */
PROTECT(elnames = allocVector(STRSXP, 2));
SET_STRING_ELT(elnames, 0, mkChar("mb"));
SET_STRING_ELT(elnames, 1, mkChar("nbr"));
}/*THEN*/
for (i = 0; i < n; i++) {
if (!(*checkmb)) {
/* allocate the "mb" and "nbr" elements of the node. */
PROTECT(temp = allocVector(VECSXP, 2));
SET_VECTOR_ELT(fixed, i, temp);
setAttrib(temp, R_NamesSymbol, elnames);
/* copy the "mb" part from the old structure. */
temp2 = getListElement(bn, (char *)NODE(i));
temp2 = getListElement(temp2, "mb");
SET_VECTOR_ELT(temp, 0, temp2);
}/*THEN*/
/* fix the neighbourhoods with an AND or an OR filter.
* AND means that both neighbours have to see each other
* to be neighbours, OR means that one neighbour at least
* as to see the other one for both to be neighbours. */
switch(*nbrfilter) {
case AND_FILTER:
/* rescan the checklist. */
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] == 2)
if (i != j)
counter++;
/* allocate and fill the "nbr" element. */
PROTECT(temp2 = allocVector(STRSXP, counter));
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] == 2)
if (i != j)
SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));
break;
case OR_FILTER:
/* rescan the checklist. */
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] >= 1)
if (i != j)
counter++;
/* allocate and fill the "nbr" element. */
PROTECT(temp2 = allocVector(STRSXP, counter));
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] >= 1)
if (i != j)
SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));
break;
}
if (*checkmb) {
SET_VECTOR_ELT(fixed, i, temp2);
UNPROTECT(1);
}/*THEN*/
else {
SET_VECTOR_ELT(temp, 1, temp2);
UNPROTECT(2);
}/*ELSE*/
}/*FOR*/
if (*checkmb)
UNPROTECT(1);
else
UNPROTECT(2);
return fixed;
}/*BN_RECOVERY*/
int 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;
}
void
run()
{
/* 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 */
}
}
}
static 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 {
for (i=0; i<nState; i++) {
SEXP state = VECTOR_ELT(data, i + 1);
if (!strcmp(CHAR(STRING_ELT(getAttrib(state,
install("pkgName")),
0)),
"graphics")) {
graphicsState = state;
}
}
}
if (!isNull(graphicsState)) {
/* Check that RAW blob being restored is same size
* as GPar struct in current R version.
* Any version difference will have been warned about,
* but a difference here means STOP.
*/
if (LENGTH(graphicsState) != sizeof(GPar)) {
error(_("Incompatible graphics state"));
}
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
copyGPar((GPar*) RAW(graphicsState), &(bss->dpSaved));
/* These are probably redundant because GE_RestoreState
* will follow from GEplayDisplayList(), but no harm
* is done
* AND there is at least one place that
* depends on this ('gridGraphics' package replays
* an empty DL to do restoredpSaved() on new page)
*/
restoredpSaved(dd);
copyGPar(&(bss->dp), &(bss->gp));
GReset(dd);
/* Make the device "clean" with respect to 'graphics'
* so that the display list replay starts from scratch
*/
bss->baseDevice = FALSE;
}
UNPROTECT(2);
}
break;
case GE_CheckPlot:
/* called from GEcheckState:
Check that the current plotting state is "valid"
*/
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
result = ScalarLogical(bss->baseDevice ?
(bss->gp.state == 1) && bss->gp.valid :
TRUE);
break;
case GE_ScalePS:
{
/* called from GEhandleEvent in devWindows.c */
GPar *ddp, *ddpSaved;
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
ddp = &(bss->dp);
ddpSaved = &(bss->dpSaved);
if (isReal(data) && LENGTH(data) == 1) {
double rf = REAL(data)[0];
ddp->scale *= rf;
/* Modify the saved settings so this effects display list too */
ddpSaved->scale *= rf;
} else
error("event 'GE_ScalePS' requires a single numeric value");
break;
}
}
return result;
}
SEXP 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);
}
SEXP 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);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
/* 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)
INTEGER(rval)[i % len] = 0;
break;
case REALSXP:
if (ISNAN(REAL(u)[i]))
INTEGER(rval)[i % len] = 0;
break;
case CPLXSXP:
if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
INTEGER(rval)[i % len] = 0;
break;
case STRSXP:
if (STRING_ELT(u, i) == NA_STRING)
INTEGER(rval)[i % len] = 0;
break;
default:
UNPROTECT(1);
error(R_MSG_type, type2char(TYPEOF(u)));
}
}
}
}
if (isNewList(CAR(s))) {
int it, nt;
t = CAR(s);
nt = length(t);
for (it = 0 ; it < nt ; it++) {
u = VECTOR_ELT(t, it);
for (i = 0; i < LENGTH(u); i++) {
switch (TYPEOF(u)) {
case INTSXP:
case LGLSXP:
if (INTEGER(u)[i] == NA_INTEGER)
INTEGER(rval)[i % len] = 0;
break;
case REALSXP:
if (ISNAN(REAL(u)[i]))
INTEGER(rval)[i % len] = 0;
break;
case CPLXSXP:
if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
INTEGER(rval)[i % len] = 0;
break;
case STRSXP:
if (STRING_ELT(u, i) == NA_STRING)
INTEGER(rval)[i % len] = 0;
break;
default:
UNPROTECT(1);
error(R_MSG_type, type2char(TYPEOF(u)));
}
}
}
}
else {
for (i = 0; i < LENGTH(CAR(s)); i++) {
u = CAR(s);
switch (TYPEOF(u)) {
case INTSXP:
case LGLSXP:
if (INTEGER(u)[i] == NA_INTEGER)
INTEGER(rval)[i % len] = 0;
break;
case REALSXP:
if (ISNAN(REAL(u)[i]))
INTEGER(rval)[i % len] = 0;
break;
case CPLXSXP:
if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
INTEGER(rval)[i % len] = 0;
break;
case STRSXP:
if (STRING_ELT(u, i) == NA_STRING)
INTEGER(rval)[i % len] = 0;
break;
default:
UNPROTECT(1);
error(R_MSG_type, type2char(TYPEOF(u)));
}
}
}
}
UNPROTECT(1);
return rval;
bad:
error(_("not all arguments have the same length"));
return R_NilValue; /* -Wall */
}
SEXP 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);
data[i] = SECS;
} else {
data[i] = NA_REAL;
}
}
}
return res;
}
/**
* 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);
cleanup:
if (err)
SET_VECTOR_ELT(trajectory, 0, ScalarInteger(err));
if (result == R_NilValue)
UNPROTECT(1);
else
UNPROTECT(2);
return trajectory;
}
