/* This is a special .Internal, so has unevaluated arguments. It is called from a closure wrapper, so X and FUN are promises. FUN must be unevaluated for use in e.g. bquote . */ SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho) { PROTECT_INDEX px; checkArity(op, args); SEXP X, XX, FUN; PROTECT_WITH_INDEX(X =CAR(args), &px); XX = PROTECT(eval(CAR(args), rho)); R_xlen_t n = xlength(XX); // a vector, so will be valid. FUN = CADR(args); Rboolean realIndx = n > INT_MAX; SEXP ans = PROTECT(allocVector(VECSXP, n)); SEXP names = getAttrib(XX, R_NamesSymbol); if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names); /* Build call: FUN(XX[[<ind>]], ...) */ SEXP ind = PROTECT(allocVector(realIndx ? REALSXP : INTSXP, 1)); SEXP isym = install("i"); defineVar(isym, ind, rho); SET_NAMED(ind, 1); /* Notice that it is OK to have one arg to LCONS do memory allocation and not PROTECT the result (LCONS does memory protection of its args internally), but not both of them, since the computation of one may destroy the other */ SEXP tmp = PROTECT(LCONS(R_Bracket2Symbol, LCONS(X, LCONS(isym, R_NilValue)))); SEXP R_fcall = PROTECT(LCONS(FUN, LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue)))); for(R_xlen_t i = 0; i < n; i++) { if (realIndx) REAL(ind)[0] = (double)(i + 1); else INTEGER(ind)[0] = (int)(i + 1); tmp = R_forceAndCall(R_fcall, 1, rho); if (MAYBE_REFERENCED(tmp)) tmp = lazy_duplicate(tmp); SET_VECTOR_ELT(ans, i, tmp); } UNPROTECT(6); return ans; }

// TODO static SEXP map_sexp_shortcut_depth_recursive(SEXP (*const f)(SEXP, int), SEXP sexp, const int current_depth) { switch (TYPEOF(sexp)) { // switch for speed case NILSXP: return sexp; // do nothing with nils case LANGSXP: { SEXP mapped_sexp = f(sexp, current_depth); if (sexp == mapped_sexp) // recurse iff the current sexp was not replaced return LCONS(map_sexp_shortcut_depth_recursive(f, CAR(sexp), current_depth + 1), map_sexp_shortcut_depth_recursive(f, CDR(sexp), current_depth + 1)); // recurse else return mapped_sexp; // shortcut } case LISTSXP: { // TODO this is buggy, as intermediates are not PROTECTED. use a for-loop instead SEXP mapped_sexp = f(sexp, current_depth); if (sexp == mapped_sexp) // recurse iff the current sexp was not replaced return CONS(map_sexp_shortcut_depth_recursive(f, CAR(sexp), current_depth + 1), map_sexp_shortcut_depth_recursive(f, CDR(sexp), current_depth + 1)); // recurse else return mapped_sexp; // shortcut } default: // base case return f(sexp, current_depth); // map leafs } }

// TODO SEXP map_sexp_shortcut(SEXP (*const f)(SEXP), SEXP sexp) { switch (TYPEOF(sexp)) { // switch for speed case NILSXP: return sexp; // do nothing with nils case LANGSXP: { SEXP mapped_sexp = f(sexp); if (sexp == mapped_sexp) return LCONS(map_sexp_shortcut(f, CAR(sexp)), map_sexp_shortcut(f, CDR(sexp))); // recurse else return mapped_sexp; // shortcut } case LISTSXP: { // TODO this is buggy, as intermediates are not PROTECTED. use a for-loop instead SEXP mapped_sexp = f(sexp); if (sexp == mapped_sexp) return CONS(map_sexp_shortcut(f, CAR(sexp)), map_sexp_shortcut(f, CDR(sexp))); // recurse else return mapped_sexp; // shortcut } default: // base case return f(sexp); // map leafs } }

INLINE_FUN SEXP lang1(SEXP s) { return LCONS(s, R_NilValue); }

SEXP deriv(SEXP args) { /* deriv(expr, namevec, function.arg, tag, hessian) */ SEXP ans, ans2, expr, funarg, names, s; int f_index, *d_index, *d2_index; int i, j, k, nexpr, nderiv=0, hessian; SEXP exprlist, tag; args = CDR(args); InitDerivSymbols(); PROTECT(exprlist = LCONS(R_BraceSymbol, R_NilValue)); /* expr: */ if (isExpression(CAR(args))) PROTECT(expr = VECTOR_ELT(CAR(args), 0)); else PROTECT(expr = CAR(args)); args = CDR(args); /* namevec: */ names = CAR(args); if (!isString(names) || (nderiv = length(names)) < 1) error(_("invalid variable names")); args = CDR(args); /* function.arg: */ funarg = CAR(args); args = CDR(args); /* tag: */ tag = CAR(args); if (!isString(tag) || length(tag) < 1 || length(STRING_ELT(tag, 0)) < 1 || length(STRING_ELT(tag, 0)) > 60) error(_("invalid tag")); args = CDR(args); /* hessian: */ hessian = asLogical(CAR(args)); /* NOTE: FindSubexprs is destructive, hence the duplication. It can allocate, so protect the duplicate. */ PROTECT(ans = duplicate(expr)); f_index = FindSubexprs(ans, exprlist, tag); d_index = (int*)R_alloc((size_t) nderiv, sizeof(int)); if (hessian) d2_index = (int*)R_alloc((size_t) ((nderiv * (1 + nderiv))/2), sizeof(int)); else d2_index = d_index;/*-Wall*/ UNPROTECT(1); for(i=0, k=0; i<nderiv ; i++) { PROTECT(ans = duplicate(expr)); PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i)))); PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */ d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */ PROTECT(ans = duplicate(ans2)); /* restore the copy */ if (hessian) { for(j = i; j < nderiv; j++) { PROTECT(ans2 = duplicate(ans)); /* install could allocate */ PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j)))); d2_index[k] = FindSubexprs(ans2, exprlist, tag); k++; UNPROTECT(2); } } UNPROTECT(4); } nexpr = length(exprlist) - 1; if (f_index) { Accumulate2(MakeVariable(f_index, tag), exprlist); } else { PROTECT(ans = duplicate(expr)); Accumulate2(expr, exprlist); UNPROTECT(1); } Accumulate2(R_NilValue, exprlist); if (hessian) { Accumulate2(R_NilValue, exprlist); } for (i = 0, k = 0; i < nderiv ; i++) { if (d_index[i]) { Accumulate2(MakeVariable(d_index[i], tag), exprlist); if (hessian) { PROTECT(ans = duplicate(expr)); PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i)))); for (j = i; j < nderiv; j++) { if (d2_index[k]) { Accumulate2(MakeVariable(d2_index[k], tag), exprlist); } else { PROTECT(ans2 = duplicate(ans)); PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j)))); Accumulate2(ans2, exprlist); UNPROTECT(2); } k++; } UNPROTECT(2); } } else { /* the first derivative is constant or simple variable */ PROTECT(ans = duplicate(expr)); PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i)))); Accumulate2(ans, exprlist); UNPROTECT(2); if (hessian) { for (j = i; j < nderiv; j++) { if (d2_index[k]) { Accumulate2(MakeVariable(d2_index[k], tag), exprlist); } else { PROTECT(ans2 = duplicate(ans)); PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j)))); if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist); else Accumulate2(ans2, exprlist); UNPROTECT(2); } k++; } } } } Accumulate2(R_NilValue, exprlist); Accumulate2(R_NilValue, exprlist); if (hessian) { Accumulate2(R_NilValue, exprlist); } i = 0; ans = CDR(exprlist); while (i < nexpr) { if (CountOccurrences(MakeVariable(i+1, tag), CDR(ans)) < 2) { SETCDR(ans, Replace(MakeVariable(i+1, tag), CAR(ans), CDR(ans))); SETCAR(ans, R_MissingArg); } else { SEXP var; PROTECT(var = MakeVariable(i+1, tag)); SETCAR(ans, lang3(install("<-"), var, AddParens(CAR(ans)))); UNPROTECT(1); } i = i + 1; ans = CDR(ans); } /* .value <- ... */ SETCAR(ans, lang3(install("<-"), install(".value"), AddParens(CAR(ans)))); ans = CDR(ans); /* .grad <- ... */ SETCAR(ans, CreateGrad(names)); ans = CDR(ans); /* .hessian <- ... */ if (hessian) { SETCAR(ans, CreateHess(names)); ans = CDR(ans); } /* .grad[, "..."] <- ... */ for (i = 0; i < nderiv ; i++) { SETCAR(ans, DerivAssign(STRING_ELT(names, i), AddParens(CAR(ans)))); ans = CDR(ans); if (hessian) { for (j = i; j < nderiv; j++) { if (CAR(ans) != R_MissingArg) { if (i == j) { SETCAR(ans, HessAssign1(STRING_ELT(names, i), AddParens(CAR(ans)))); } else { SETCAR(ans, HessAssign2(STRING_ELT(names, i), STRING_ELT(names, j), AddParens(CAR(ans)))); } } ans = CDR(ans); } } } /* attr(.value, "gradient") <- .grad */ SETCAR(ans, AddGrad()); ans = CDR(ans); if (hessian) { SETCAR(ans, AddHess()); ans = CDR(ans); } /* .value */ SETCAR(ans, install(".value")); /* Prune the expression list removing eliminated sub-expressions */ SETCDR(exprlist, Prune(CDR(exprlist))); if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */ funarg = names; } if (TYPEOF(funarg) == CLOSXP) { funarg = mkCLOSXP(FORMALS(funarg), exprlist, CLOENV(funarg)); } else if (isString(funarg)) { SEXP formals = allocList(length(funarg)); ans = formals; for(i = 0; i < length(funarg); i++) { SET_TAG(ans, installTrChar(STRING_ELT(funarg, i))); SETCAR(ans, R_MissingArg); ans = CDR(ans); } funarg = mkCLOSXP(formals, exprlist, R_GlobalEnv); } else { funarg = allocVector(EXPRSXP, 1); SET_VECTOR_ELT(funarg, 0, exprlist); /* funarg = lang2(install("expression"), exprlist); */ } UNPROTECT(2); return funarg; }

/* This is a special .Internal */ SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue, X, XX, FUN, value, dim_v; R_xlen_t i, n; int commonLen; int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value)) Rboolean array_value; SEXPTYPE commonType; PROTECT_INDEX index = 0; // -Wall checkArity(op, args); PROTECT(X = CAR(args)); PROTECT(XX = eval(CAR(args), rho)); FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */ PROTECT(value = eval(CADDR(args), rho)); if (!isVector(value)) error(_("'FUN.VALUE' must be a vector")); useNames = asLogical(eval(CADDDR(args), rho)); if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES"); n = xlength(XX); if (n == NA_INTEGER) error(_("invalid length")); Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX); commonLen = length(value); if (commonLen > 1 && n > INT_MAX) error(_("long vectors are not supported for matrix/array results")); commonType = TYPEOF(value); dim_v = getAttrib(value, R_DimSymbol); array_value = CXXRCONSTRUCT(Rboolean, (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1)); PROTECT(ans = allocVector(commonType, n*commonLen)); if (useNames) { PROTECT(names = getAttrib(XX, R_NamesSymbol)); if (isNull(names) && TYPEOF(XX) == STRSXP) { UNPROTECT(1); PROTECT(names = XX); } PROTECT_WITH_INDEX(rowNames = getAttrib(value, array_value ? R_DimNamesSymbol : R_NamesSymbol), &index); } /* The R level code has ensured that XX is a vector. If it is atomic we can speed things up slightly by using the evaluated version. */ { SEXP ind, tmp; /* Build call: FUN(XX[[<ind>]], ...) */ /* Notice that it is OK to have one arg to LCONS do memory allocation and not PROTECT the result (LCONS does memory protection of its args internally), but not both of them, since the computation of one may destroy the other */ PROTECT(ind = allocVector(INTSXP, 1)); if(isVectorAtomic(XX)) PROTECT(tmp = LCONS(R_Bracket2Symbol, CONS(XX, CONS(ind, R_NilValue)))); else PROTECT(tmp = LCONS(R_Bracket2Symbol, CONS(X, CONS(ind, R_NilValue)))); PROTECT(R_fcall = LCONS(FUN, CONS(tmp, CONS(R_DotsSymbol, R_NilValue)))); for(i = 0; i < n; i++) { SEXP val; SEXPTYPE valType; PROTECT_INDEX indx; if (realIndx) REAL(ind)[0] = double(i + 1); else INTEGER(ind)[0] = int(i + 1); val = eval(R_fcall, rho); if (NAMED(val)) val = duplicate(val); PROTECT_WITH_INDEX(val, &indx); if (length(val) != commonLen) error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"), commonLen, i+1, length(val)); valType = TYPEOF(val); if (valType != commonType) { bool okay = FALSE; switch (commonType) { case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP) || (valType == LGLSXP); break; case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break; case INTSXP: okay = (valType == LGLSXP); break; default: Rf_error(_("Internal error: unexpected SEXPTYPE")); } if (!okay) error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"), type2char(commonType), i+1, type2char(valType)); REPROTECT(val = coerceVector(val, commonType), indx); } /* Take row names from the first result only */ if (i == 0 && useNames && isNull(rowNames)) REPROTECT(rowNames = getAttrib(val, array_value ? R_DimNamesSymbol : R_NamesSymbol), index); for (int j = 0; j < commonLen; j++) { switch (commonType) { case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break; case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break; case INTSXP: INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break; case LGLSXP: LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break; case RAWSXP: RAW(ans)[i*commonLen + j] = RAW(val)[j]; break; case STRSXP: SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break; case VECSXP: SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break; default: error(_("type '%s' is not supported"), type2char(commonType)); } } UNPROTECT(1); } UNPROTECT(3); } if (commonLen != 1) { SEXP dim; rnk_v = array_value ? LENGTH(dim_v) : 1; PROTECT(dim = allocVector(INTSXP, rnk_v+1)); if(array_value) for(int j = 0; j < rnk_v; j++) INTEGER(dim)[j] = INTEGER(dim_v)[j]; else INTEGER(dim)[0] = commonLen; INTEGER(dim)[rnk_v] = int( n); // checked above setAttrib(ans, R_DimSymbol, dim); UNPROTECT(1); } if (useNames) { if (commonLen == 1) { if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names); } else { if (!isNull(names) || !isNull(rowNames)) { SEXP dimnames; PROTECT(dimnames = allocVector(VECSXP, rnk_v+1)); if(array_value && !isNull(rowNames)) { if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v) // should never happen .. error(_("dimnames(<value>) is neither NULL nor list of length %d"), rnk_v); for(int j = 0; j < rnk_v; j++) SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j)); } else SET_VECTOR_ELT(dimnames, 0, rowNames); SET_VECTOR_ELT(dimnames, rnk_v, names); setAttrib(ans, R_DimNamesSymbol, dimnames); UNPROTECT(1); } } } UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */ return ans; }

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; }

/* This is a special .Internal */ SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue, X, XX, FUN, value, dim_v; R_xlen_t i, n; int commonLen; int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value)) Rboolean array_value; SEXPTYPE commonType; PROTECT_INDEX index = 0; /* initialize to avoid a warning */ checkArity(op, args); PROTECT(X = CAR(args)); PROTECT(XX = eval(CAR(args), rho)); FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */ PROTECT(value = eval(CADDR(args), rho)); if (!isVector(value)) error(_("'FUN.VALUE' must be a vector")); useNames = asLogical(eval(CADDDR(args), rho)); if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES"); n = xlength(XX); if (n == NA_INTEGER) error(_("invalid length")); Rboolean realIndx = n > INT_MAX; commonLen = length(value); if (commonLen > 1 && n > INT_MAX) error(_("long vectors are not supported for matrix/array results")); commonType = TYPEOF(value); // check once here if (commonType != CPLXSXP && commonType != REALSXP && commonType != INTSXP && commonType != LGLSXP && commonType != RAWSXP && commonType != STRSXP && commonType != VECSXP) error(_("type '%s' is not supported"), type2char(commonType)); dim_v = getAttrib(value, R_DimSymbol); array_value = (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1); PROTECT(ans = allocVector(commonType, n*commonLen)); if (useNames) { PROTECT(names = getAttrib(XX, R_NamesSymbol)); if (isNull(names) && TYPEOF(XX) == STRSXP) { UNPROTECT(1); PROTECT(names = XX); } PROTECT_WITH_INDEX(rowNames = getAttrib(value, array_value ? R_DimNamesSymbol : R_NamesSymbol), &index); } /* The R level code has ensured that XX is a vector. If it is atomic we can speed things up slightly by using the evaluated version. */ { SEXP ind, tmp; /* Build call: FUN(XX[[<ind>]], ...) */ SEXP isym = install("i"); PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1)); defineVar(isym, ind, rho); SET_NAMED(ind, 1); /* Notice that it is OK to have one arg to LCONS do memory allocation and not PROTECT the result (LCONS does memory protection of its args internally), but not both of them, since the computation of one may destroy the other */ PROTECT(tmp = LCONS(R_Bracket2Symbol, LCONS(X, LCONS(isym, R_NilValue)))); PROTECT(R_fcall = LCONS(FUN, LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue)))); int common_len_offset = 0; for(i = 0; i < n; i++) { SEXP val; SEXPTYPE valType; PROTECT_INDEX indx; if (realIndx) REAL(ind)[0] = (double)(i + 1); else INTEGER(ind)[0] = (int)(i + 1); val = R_forceAndCall(R_fcall, 1, rho); if (MAYBE_REFERENCED(val)) val = lazy_duplicate(val); // Need to duplicate? Copying again anyway PROTECT_WITH_INDEX(val, &indx); if (length(val) != commonLen) error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"), commonLen, i+1, length(val)); valType = TYPEOF(val); if (valType != commonType) { Rboolean okay = FALSE; switch (commonType) { case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP) || (valType == LGLSXP); break; case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break; case INTSXP: okay = (valType == LGLSXP); break; } if (!okay) error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"), type2char(commonType), i+1, type2char(valType)); REPROTECT(val = coerceVector(val, commonType), indx); } /* Take row names from the first result only */ if (i == 0 && useNames && isNull(rowNames)) REPROTECT(rowNames = getAttrib(val, array_value ? R_DimNamesSymbol : R_NamesSymbol), index); // two cases - only for efficiency if(commonLen == 1) { // common case switch (commonType) { case CPLXSXP: COMPLEX(ans)[i] = COMPLEX(val)[0]; break; case REALSXP: REAL(ans) [i] = REAL (val)[0]; break; case INTSXP: INTEGER(ans)[i] = INTEGER(val)[0]; break; case LGLSXP: LOGICAL(ans)[i] = LOGICAL(val)[0]; break; case RAWSXP: RAW(ans) [i] = RAW (val)[0]; break; case STRSXP: SET_STRING_ELT(ans, i, STRING_ELT(val, 0)); break; case VECSXP: SET_VECTOR_ELT(ans, i, VECTOR_ELT(val, 0)); break; } } else { // commonLen > 1 (typically, or == 0) : switch (commonType) { case REALSXP: memcpy(REAL(ans) + common_len_offset, REAL(val), commonLen * sizeof(double)); break; case INTSXP: memcpy(INTEGER(ans) + common_len_offset, INTEGER(val), commonLen * sizeof(int)); break; case LGLSXP: memcpy(LOGICAL(ans) + common_len_offset, LOGICAL(val), commonLen * sizeof(int)); break; case RAWSXP: memcpy(RAW(ans) + common_len_offset, RAW(val), commonLen * sizeof(Rbyte)); break; case CPLXSXP: memcpy(COMPLEX(ans) + common_len_offset, COMPLEX(val), commonLen * sizeof(Rcomplex)); break; case STRSXP: for (int j = 0; j < commonLen; j++) SET_STRING_ELT(ans, common_len_offset + j, STRING_ELT(val, j)); break; case VECSXP: for (int j = 0; j < commonLen; j++) SET_VECTOR_ELT(ans, common_len_offset + j, VECTOR_ELT(val, j)); break; } common_len_offset += commonLen; } UNPROTECT(1); } UNPROTECT(3); } if (commonLen != 1) { SEXP dim; rnk_v = array_value ? LENGTH(dim_v) : 1; PROTECT(dim = allocVector(INTSXP, rnk_v+1)); if(array_value) for(int j = 0; j < rnk_v; j++) INTEGER(dim)[j] = INTEGER(dim_v)[j]; else INTEGER(dim)[0] = commonLen; INTEGER(dim)[rnk_v] = (int) n; // checked above setAttrib(ans, R_DimSymbol, dim); UNPROTECT(1); } if (useNames) { if (commonLen == 1) { if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names); } else { if (!isNull(names) || !isNull(rowNames)) { SEXP dimnames; PROTECT(dimnames = allocVector(VECSXP, rnk_v+1)); if(array_value && !isNull(rowNames)) { if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v) // should never happen .. error(_("dimnames(<value>) is neither NULL nor list of length %d"), rnk_v); for(int j = 0; j < rnk_v; j++) SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j)); } else SET_VECTOR_ELT(dimnames, 0, rowNames); SET_VECTOR_ELT(dimnames, rnk_v, names); setAttrib(ans, R_DimNamesSymbol, dimnames); UNPROTECT(1); } } } UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */ return ans; }

SEXP mutate_subtrees(SEXP sexp, double p, double p_insert_delete, SEXP function_symbol_list, SEXP function_arities, SEXP input_variable_list, double constant_min, double constant_max, double p_subtree, double p_constant, int depth_max) { // Rprintf("->\n"); // DEBUG switch (TYPEOF(sexp)) { // switch for speed case NILSXP: return sexp; // do nothing with nils case LANGSXP: if (unif_rand() < p) { // mutate inner node with probability p if (unif_rand() < p_insert_delete) { // replace with new subtree (insert) // Rprintf("insert\n"); // DEBUG SEXP new_subtree = PROTECT(initialize_expression_grow(function_symbol_list, function_arities, input_variable_list, constant_min, constant_max, p_subtree, p_constant, depth_max)); UNPROTECT(1); return new_subtree; } else { // replace with new leaf (delete) // Rprintf("delete\n"); // DEBUG SEXP new_leaf = PROTECT(initialize_expression_grow(function_symbol_list, function_arities, input_variable_list, constant_min, constant_max, p_subtree, p_constant, 0)); UNPROTECT(1); return new_leaf; } } else { // Rprintf("pass\n"); // DEBUG int function_arity = 0; SEXP e; PROTECT(e = R_NilValue); for (SEXP iterator = CDR(sexp); !isNull(iterator); iterator = CDR(iterator)) { // recurse on actual parameters function_arity++; // determine arity on the fly SEXP mutated_parameter; PROTECT(mutated_parameter = mutate_subtrees(CAR(iterator), p, p_insert_delete, function_symbol_list, function_arities, input_variable_list, constant_min, constant_max, p_subtree, p_constant, depth_max)); PROTECT(e = CONS(mutated_parameter, e)); } PROTECT(e = LCONS(CAR(sexp), e)); UNPROTECT(2 * function_arity + 2); return e; } case LISTSXP: error("mutate_subtrees: unexpected LISTSXP"); default: // base case // Rprintf("default type %d\n", TYPEOF(sexp)); // DEBUG // if (REALSXP == TYPEOF(sexp)) { // Rprintf("real %f\n", REAL(sexp)[0]); // DEBUG // } // if (SYMSXP == TYPEOF(sexp)) { // Rprintf("symbol %s\n", CHAR(PRINTNAME(sexp))); // DEBUG // } if (unif_rand() < p) { // mutate leaf with probability p if (unif_rand() < p_insert_delete) { // replace with new subtree (insert) // Rprintf("insert at default\n"); // DEBUG SEXP new_subtree; new_subtree = PROTECT(initialize_expression_grow(function_symbol_list, function_arities, input_variable_list, constant_min, constant_max, p_subtree, p_constant, depth_max)); UNPROTECT(1); return new_subtree; } else { // replace with new leaf (delete) // Rprintf("delete at default\n"); // DEBUG SEXP new_leaf; new_leaf = PROTECT(initialize_expression_grow(function_symbol_list, function_arities, input_variable_list, constant_min, constant_max, p_subtree, p_constant, 0)); UNPROTECT(1); return new_leaf; } } else { // Rprintf("pass at default\n"); // DEBUG return sexp; // do nothing } } }

// (C) ceeboo 2013/12 // // Wrapper for simple triplet matrix which runs in constant // memory. SEXP _col_apply_stm(SEXP a) { a = CDR(a); if (length(a) < 2) error("invalid number of arguments"); SEXP x = CAR(a); if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x)) error("'x' not of class 'simple_triplet_matrix'"); if (!isFunction(CADR(a))) error("invalid function parameter"); int n, m, *_ix, *_jx, *_nx, *_px; SEXP vx, z, r; vx = VECTOR_ELT(x, 2); n = INTEGER(VECTOR_ELT(x, 3))[0]; m = INTEGER(VECTOR_ELT(x, 4))[0]; z = PROTECT(allocVector(TYPEOF(vx), n)); a = PROTECT(LCONS(CADR(a), LCONS(z, CDDR(a)))); switch(TYPEOF(vx)) { case LGLSXP: case INTSXP: memset(INTEGER(z), 0, sizeof(int) * n); break; case REALSXP: memset(REAL(z), 0, sizeof(double) * n); break; case RAWSXP: memset(RAW(z), 0, sizeof(char) * n); break; case CPLXSXP: memset(COMPLEX(z), 0, sizeof(Rcomplex) * n); break; case EXPRSXP: case VECSXP: for (int i = 0; i < n; i++) SET_VECTOR_ELT(z, i, R_NilValue); break; case STRSXP: for (int i = 0; i < n; i++) SET_STRING_ELT(z, i, R_BlankString); break; default: error("type of 'v' not supported"); } // Map blocks of equal column indexes _jx = INTEGER(VECTOR_ELT(x, 1)); // column indexes _nx = INTEGER(PROTECT(allocVector(INTSXP, m + 1))); memset(_nx, 0, sizeof(int) * (m + 1)); for (int k = 0; k < LENGTH(vx); k++) _nx[_jx[k]]++; for (int k = 1; k < m + 1; k++) _nx[k] += _nx[k-1]; _px = INTEGER(PROTECT(allocVector(INTSXP, LENGTH(vx)))); _nx -= 1; // one-based R indexing for (int k = 0; k < LENGTH(vx); k++) { _px[_nx[_jx[k]]] = k; _nx[_jx[k]]++; } // Reset _nx += 1; for (int k = m; k > 0; k--) _nx[k] = _nx[k-1]; _nx[0] = 0; _ix = INTEGER(VECTOR_ELT(x, 0)); // row indexes r = PROTECT(allocVector(VECSXP, m)); int f, fl; f = fl = _nx[0]; for (int i = 1; i < m + 1; i++) { int l = _nx[i]; // (Re)set values switch(TYPEOF(vx)) { case LGLSXP: case INTSXP: for (int k = fl; k < f; k++) INTEGER(z)[_px[k]] = 0; for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; INTEGER(z)[i] = INTEGER(vx)[p]; _px[k] = i; } break; case REALSXP: for (int k = fl; k < f; k++) REAL(z)[_px[k]] = 0.0; for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; REAL(z)[i] = REAL(vx)[p]; _px[k] = i; } break; case RAWSXP: for (int k = fl; k < f; k++) RAW(z)[_px[k]] = (char) 0; for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; RAW(z)[i] = RAW(vx)[p]; _px[k] = i; } break; case CPLXSXP: for (int k = fl; k < f; k++) { static Rcomplex c; COMPLEX(z)[_px[k]] = c; } for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; COMPLEX(z)[i] = COMPLEX(vx)[p]; _px[k] = i; } break; case EXPRSXP: case VECSXP: for (int k = fl; k < f; k++) SET_VECTOR_ELT(z, _px[k], R_NilValue); for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; SET_VECTOR_ELT(z, i, VECTOR_ELT(vx, p)); _px[k] = i; } break; case STRSXP: for (int k = fl; k < f; k++) SET_STRING_ELT(z, _px[k], R_BlankString); for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; SET_STRING_ELT(z, i, STRING_ELT(vx, p)); _px[k] = i; } break; default: error("type of 'v' not supported"); } SEXP s = eval(a, R_GlobalEnv); if (s == z) // identity, print, ... SET_VECTOR_ELT(r, i - 1, duplicate(s)); else SET_VECTOR_ELT(r, i - 1, s); fl = f; f = l; } UNPROTECT(5); return r; }

SEXP do_partrans (SEXP object, SEXP params, SEXP dir, SEXP gnsi) { int nprotect = 0; SEXP fn, fcall, rho, ans, nm; SEXP pdim, pvec; SEXP pompfun; SEXP tparams = R_NilValue; pompfunmode mode = undef; char direc; int qmat; int ndim[2], *dim, *idx; double *pp, *ps, *pt, *pa; int npar1, npar2, nreps; pomp_transform_fn *ff = NULL; int k; direc = *(INTEGER(dir)); // extract the user-defined function switch (direc) { case 1: // forward transformation PROTECT(pompfun = GET_SLOT(object,install("from.trans"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; break; case -1: // inverse transformation PROTECT(pompfun = GET_SLOT(object,install("to.trans"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; break; default: error("impossible error"); break; } // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; PROTECT(pdim = GET_DIM(params)); nprotect++; if (isNull(pdim)) { // a single vector npar1 = LENGTH(params); nreps = 1; qmat = 0; } else { // a parameter matrix dim = INTEGER(pdim); npar1 = dim[0]; nreps = dim[1]; qmat = 1; } switch (mode) { case Rfun: // use user-supplied R function // set up the function call if (qmat) { // matrix case PROTECT(pvec = NEW_NUMERIC(npar1)); nprotect++; SET_NAMES(pvec,GET_ROWNAMES(GET_DIMNAMES(params))); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; } else { // vector case PROTECT(fcall = LCONS(params,fcall)); nprotect++; } SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; if (qmat) { // matrix case const char *dimnm[2] = {"variable","rep"}; ps = REAL(params); pp = REAL(pvec); memcpy(pp,ps,npar1*sizeof(double)); PROTECT(ans = eval(fcall,rho)); nprotect++; PROTECT(nm = GET_NAMES(ans)); nprotect++; if (isNull(nm)) error("user transformation functions must return a named numeric vector"); // set up matrix to hold the results npar2 = LENGTH(ans); ndim[0] = npar2; ndim[1] = nreps; PROTECT(tparams = makearray(2,ndim)); nprotect++; setrownames(tparams,nm,2); fixdimnames(tparams,dimnm,2); pt = REAL(tparams); pa = REAL(AS_NUMERIC(ans)); memcpy(pt,pa,npar2*sizeof(double)); ps += npar1; pt += npar2; for (k = 1; k < nreps; k++, ps += npar1, pt += npar2) { memcpy(pp,ps,npar1*sizeof(double)); pa = REAL(AS_NUMERIC(eval(fcall,rho))); memcpy(pt,pa,npar2*sizeof(double)); } } else { // vector case PROTECT(tparams = eval(fcall,rho)); nprotect++; if (isNull(GET_NAMES(tparams))) error("user transformation functions must return a named numeric vector"); } break; case native: // use native routine ff = (pomp_transform_fn *) R_ExternalPtrAddr(fn); if (qmat) { idx = INTEGER(PROTECT(name_index(GET_ROWNAMES(GET_DIMNAMES(params)),pompfun,"paramnames"))); nprotect++; } else { idx = INTEGER(PROTECT(name_index(GET_NAMES(params),pompfun,"paramnames"))); nprotect++; } set_pomp_userdata(fcall); PROTECT(tparams = duplicate(params)); nprotect++; for (k = 0, ps = REAL(params), pt = REAL(tparams); k < nreps; k++, ps += npar1, pt += npar1) { R_CheckUserInterrupt(); (*ff)(pt,ps,idx); } unset_pomp_userdata(); break; default: error("unrecognized 'mode' slot in 'partrans'"); } UNPROTECT(nprotect); return tparams; }

SEXP do_rprocess (SEXP object, SEXP xstart, SEXP times, SEXP params, SEXP offset, SEXP gnsi) { int nprotect = 0; int *xdim, nvars, npars, nreps, nrepsx, ntimes, off; SEXP X, Xoff, copy, fn, fcall, rho; SEXP dimXstart, dimP, dimX; PROTECT(gnsi = duplicate(gnsi)); nprotect++; ntimes = length(times); if (ntimes < 2) { error("rprocess error: length(times)==0: no transitions, no work to do"); } off = *(INTEGER(AS_INTEGER(offset))); if ((off < 0)||(off>=ntimes)) error("illegal 'offset' value %d",off); PROTECT(xstart = as_matrix(xstart)); nprotect++; PROTECT(dimXstart = GET_DIM(xstart)); nprotect++; xdim = INTEGER(dimXstart); nvars = xdim[0]; nrepsx = xdim[1]; PROTECT(params = as_matrix(params)); nprotect++; PROTECT(dimP = GET_DIM(params)); nprotect++; xdim = INTEGER(dimP); npars = xdim[0]; nreps = xdim[1]; if (nrepsx > nreps) { // more ICs than parameters if (nrepsx % nreps != 0) { error("rprocess error: larger number of replicates is not a multiple of smaller"); } else { double *src, *tgt; int dims[2]; int j, k; dims[0] = npars; dims[1] = nrepsx; PROTECT(copy = duplicate(params)); nprotect++; PROTECT(params = makearray(2,dims)); nprotect++; setrownames(params,GET_ROWNAMES(GET_DIMNAMES(copy)),2); src = REAL(copy); tgt = REAL(params); for (j = 0; j < nrepsx; j++) { for (k = 0; k < npars; k++, tgt++) { *tgt = src[k+npars*(j%nreps)]; } } } nreps = nrepsx; } else if (nrepsx < nreps) { // more parameters than ICs if (nreps % nrepsx != 0) { error("rprocess error: larger number of replicates is not a multiple of smaller"); } else { double *src, *tgt; int dims[2]; int j, k; dims[0] = nvars; dims[1] = nreps; PROTECT(copy = duplicate(xstart)); nprotect++; PROTECT(xstart = makearray(2,dims)); nprotect++; setrownames(xstart,GET_ROWNAMES(GET_DIMNAMES(copy)),2); src = REAL(copy); tgt = REAL(xstart); for (j = 0; j < nreps; j++) { for (k = 0; k < nvars; k++, tgt++) { *tgt = src[k+nvars*(j%nrepsx)]; } } } } // extract the process function PROTECT(fn = GET_SLOT(object,install("rprocess"))); nprotect++; // construct the call PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; PROTECT(fcall = LCONS(gnsi,fcall)); nprotect++; SET_TAG(fcall,install(".getnativesymbolinfo")); PROTECT(fcall = LCONS(GET_SLOT(object,install("zeronames")),fcall)); nprotect++; SET_TAG(fcall,install("zeronames")); PROTECT(fcall = LCONS(GET_SLOT(object,install("covar")),fcall)); nprotect++; SET_TAG(fcall,install("covar")); PROTECT(fcall = LCONS(GET_SLOT(object,install("tcovar")),fcall)); nprotect++; SET_TAG(fcall,install("tcovar")); PROTECT(fcall = LCONS(params,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(AS_NUMERIC(times),fcall)); nprotect++; SET_TAG(fcall,install("times")); PROTECT(fcall = LCONS(xstart,fcall)); nprotect++; SET_TAG(fcall,install("xstart")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; PROTECT(rho = (CLOENV(fn))); nprotect++; // environment of the function PROTECT(X = eval(fcall,rho)); nprotect++; // do the call PROTECT(dimX = GET_DIM(X)); nprotect++; if ((isNull(dimX)) || (length(dimX) != 3)) { error("rprocess error: user 'rprocess' must return a rank-3 array"); } xdim = INTEGER(dimX); if ((xdim[0] != nvars) || (xdim[1] != nreps) || (xdim[2] != ntimes)) { error("rprocess error: user 'rprocess' must return a %d x %d x %d array",nvars,nreps,ntimes); } if (isNull(GET_ROWNAMES(GET_DIMNAMES(X)))) { error("rprocess error: user 'rprocess' must return an array with rownames"); } if (off > 0) { xdim[2] -= off; PROTECT(Xoff = makearray(3,xdim)); nprotect++; setrownames(Xoff,GET_ROWNAMES(GET_DIMNAMES(X)),3); memcpy(REAL(Xoff),REAL(X)+off*nvars*nreps,(ntimes-off)*nvars*nreps*sizeof(double)); UNPROTECT(nprotect); return Xoff; } else { UNPROTECT(nprotect); return X; } }

static Rboolean latin1locale(void) { return *LOGICAL(VECTOR_ELT(eval(LCONS(install("l10n_info"), R_NilValue), R_GlobalEnv), 2)); }

SEXP euler_model_simulator (SEXP func, SEXP xstart, SEXP times, SEXP params, SEXP deltat, SEXP method, SEXP zeronames, SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen; int nstep = 0; double dt, dtt; SEXP X; SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue; SEXP Snames, Pnames, Cnames; SEXP cvec, tvec = R_NilValue; SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue; int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0; pomp_onestep_sim *ff = NULL; int meth = INTEGER_VALUE(method); // meth: 0 = Euler, 1 = one-step, 2 = fixed step dtt = NUMERIC_VALUE(deltat); if (dtt <= 0) errorcall(R_NilValue,"'delta.t' should be a positive number"); { int *dim; dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1]; dim = INTEGER(GET_DIM(params)); npars = dim[0]; dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1]; ntimes = LENGTH(times); } PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++; // set up the covariate table struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)}; // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); // indices of accumulator variables nzeros = LENGTH(zeronames); zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++; // extract user function PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++; // set up switch (mode) { case Rfun: // R function PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++; PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,args)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++; SET_TAG(fcall,install("delta.t")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate indices sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++; pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++; cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++; *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } // create array to hold results { int dim[3] = {nvars, nreps, ntimes}; PROTECT(X = makearray(3,dim)); nprotect++; setrownames(X,Snames,3); } // copy the start values into the result array memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double)); if (mode==1) { set_pomp_userdata(args); GetRNGstate(); } // now do computations { int first = 1; int use_names = 0; int *posn = 0; double *time = REAL(times); double *xs = REAL(X); double *xt = REAL(X)+nvars*nreps; double *cp = REAL(cvec); double *ps = REAL(params); double t = time[0]; double *pm, *xm; int i, j, k, step; for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) { R_CheckUserInterrupt(); if (t > time[step]) { errorcall(R_NilValue,"'times' is not an increasing sequence"); } memcpy(xt,xs,nreps*nvars*sizeof(double)); // set accumulator variables to zero for (j = 0; j < nreps; j++) for (i = 0; i < nzeros; i++) xt[zidx[i]+nvars*j] = 0.0; switch (meth) { case 0: // Euler method dt = dtt; nstep = num_euler_steps(t,time[step],&dt); break; case 1: // one step dt = time[step]-t; nstep = (dt > 0) ? 1 : 0; break; case 2: // fixed step dt = dtt; nstep = num_map_steps(t,time[step],dt); break; default: errorcall(R_NilValue,"unrecognized 'method'"); // # nocov break; } for (k = 0; k < nstep; k++) { // loop over Euler steps // interpolate the covar functions for the covariates table_lookup(&covariate_table,t,cp); for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates switch (mode) { case Rfun: // R function { double *xp = REAL(xvec); double *pp = REAL(pvec); double *tp = REAL(tvec); double *dtp = REAL(dtvec); double *ap; *tp = t; *dtp = dt; memcpy(xp,xm,nvars*sizeof(double)); memcpy(pp,pm,npars*sizeof(double)); if (first) { PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call if (LENGTH(ans) != nvars) { errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?", LENGTH(ans),nvars); } PROTECT(nm = GET_NAMES(ans)); nprotect++; use_names = !isNull(nm); if (use_names) { posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++; } ap = REAL(AS_NUMERIC(ans)); first = 0; } else { ap = REAL(AS_NUMERIC(eval(fcall,rho))); } if (use_names) { for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i]; } else { for (i = 0; i < nvars; i++) xm[i] = ap[i]; } } break; case native: // native code (*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } } t += dt; if ((meth == 0) && (k == nstep-2)) { // penultimate step dt = time[step]-t; t = time[step]-dt; } } } } if (mode==1) { PutRNGstate(); unset_pomp_userdata(); } UNPROTECT(nprotect); return X; }

// compute pdf of a sequence of Euler steps SEXP euler_model_density (SEXP func, SEXP x, SEXP times, SEXP params, SEXP tcovar, SEXP covar, SEXP log, SEXP args, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int give_log; int nvars, npars, nreps, ntimes, ncovars, covlen; pomp_onestep_pdf *ff = NULL; SEXP cvec, pvec = R_NilValue; SEXP t1vec = R_NilValue, t2vec = R_NilValue; SEXP x1vec = R_NilValue, x2vec = R_NilValue; SEXP Snames, Pnames, Cnames; SEXP fn, rho = R_NilValue, fcall = R_NilValue; SEXP F; int *pidx = 0, *sidx = 0, *cidx = 0; { int *dim; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nreps = dim[1]; dim = INTEGER(GET_DIM(params)); npars = dim[0]; dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1]; ntimes = LENGTH(times); } PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++; // set up the covariate table struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)}; // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++; give_log = *(INTEGER(log)); switch (mode) { case Rfun: // R function PROTECT(t1vec = NEW_NUMERIC(1)); nprotect++; PROTECT(t2vec = NEW_NUMERIC(1)); nprotect++; PROTECT(x1vec = NEW_NUMERIC(nvars)); nprotect++; SET_NAMES(x1vec,Snames); PROTECT(x2vec = NEW_NUMERIC(nvars)); nprotect++; SET_NAMES(x2vec,Snames); PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,args)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(t2vec,fcall)); nprotect++; SET_TAG(fcall,install("t2")); PROTECT(fcall = LCONS(t1vec,fcall)); nprotect++; SET_TAG(fcall,install("t1")); PROTECT(fcall = LCONS(x2vec,fcall)); nprotect++; SET_TAG(fcall,install("x2")); PROTECT(fcall = LCONS(x1vec,fcall)); nprotect++; SET_TAG(fcall,install("x1")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate indices sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++; pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++; cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++; *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } // create array to hold results { int dim[2] = {nreps, ntimes-1}; PROTECT(F = makearray(2,dim)); nprotect++; } switch (mode) { case Rfun: // R function { double *cp = REAL(cvec); double *t1p = REAL(t1vec); double *t2p = REAL(t2vec); double *x1p = REAL(x1vec); double *x2p = REAL(x2vec); double *pp = REAL(pvec); double *t1s = REAL(times); double *t2s = t1s+1; double *x1s = REAL(x); double *x2s = x1s + nvars*nreps; double *ps; double *fs = REAL(F); int j, k; for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times R_CheckUserInterrupt(); *t1p = *t1s; *t2p = *t2s; // interpolate the covariates at time t1, store the results in cvec table_lookup(&covariate_table,*t1p,cp); for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates memcpy(x1p,x1s,nvars*sizeof(double)); memcpy(x2p,x2s,nvars*sizeof(double)); memcpy(pp,ps,npars*sizeof(double)); *fs = *(REAL(AS_NUMERIC(eval(fcall,rho)))); if (!give_log) *fs = exp(*fs); } } } break; case native: // native code set_pomp_userdata(args); { double *t1s = REAL(times); double *t2s = t1s+1; double *x1s = REAL(x); double *x2s = x1s + nvars*nreps; double *fs = REAL(F); double *cp = REAL(cvec); double *ps; int j, k; for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times R_CheckUserInterrupt(); // interpolate the covariates at time t1, store the results in cvec table_lookup(&covariate_table,*t1s,cp); for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates (*ff)(fs,x1s,x2s,*t1s,*t2s,ps,sidx,pidx,cidx,ncovars,cp); if (!give_log) *fs = exp(*fs); } } } unset_pomp_userdata(); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } UNPROTECT(nprotect); return F; }

SEXP do_rmeasure (SEXP object, SEXP x, SEXP times, SEXP params, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs; SEXP Snames, Pnames, Cnames, Onames; SEXP cvec, tvec = R_NilValue, xvec = R_NilValue, pvec = R_NilValue; SEXP fn, fcall, rho = R_NilValue, ans, nm; SEXP pompfun; SEXP Y; int *dim; int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0; struct lookup_table covariate_table; pomp_measure_model_simulator *ff = NULL; PROTECT(times = AS_NUMERIC(times)); nprotect++; ntimes = length(times); if (ntimes < 1) errorcall(R_NilValue,"in 'rmeasure': length('times') = 0, no work to do"); PROTECT(x = as_state_array(x)); nprotect++; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nrepsx = dim[1]; if (ntimes != dim[2]) errorcall(R_NilValue,"in 'rmeasure': length of 'times' and 3rd dimension of 'x' do not agree"); PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nrepsp = dim[1]; nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx; if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0)) errorcall(R_NilValue,"in 'rmeasure': larger number of replicates is not a multiple of smaller"); dim = INTEGER(GET_DIM(GET_SLOT(object,install("data")))); nobs = dim[0]; PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(GET_SLOT(object,install("data"))))); nprotect++; // set up the covariate table covariate_table = make_covariate_table(object,&ncovars); // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); { int dim[3] = {nobs, nreps, ntimes}; const char *dimnm[3] = {"variable","rep","time"}; PROTECT(Y = makearray(3,dim)); nprotect++; setrownames(Y,Onames,3); fixdimnames(Y,dimnm,3); } // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("rmeasure"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // first do setup switch (mode) { case Rfun: // use R function PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,fcall)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // use native routine // construct state, parameter, covariate, observable indices oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++; 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); break; default: errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov break; } // now do computations switch (mode) { case Rfun: // R function { int first = 1; int use_names = 0; double *yt = REAL(Y); double *time = REAL(times); double *tp = REAL(tvec); double *cp = REAL(cvec); double *xp = REAL(xvec); double *pp = REAL(pvec); double *xs = REAL(x); double *ps = REAL(params); double *ys; int *posn; int i, j, k; for (k = 0; k < ntimes; k++, time++) { // loop over times R_CheckUserInterrupt(); // check for user interrupt *tp = *time; // copy the time table_lookup(&covariate_table,*tp,cp); // interpolate the covariates for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates // copy the states and parameters into place for (i = 0; i < nvars; i++) xp[i] = xs[i+nvars*((j%nrepsx)+nrepsx*k)]; for (i = 0; i < npars; i++) pp[i] = ps[i+npars*(j%nrepsp)]; if (first) { // evaluate the call PROTECT(ans = eval(fcall,rho)); nprotect++; if (LENGTH(ans) != nobs) { errorcall(R_NilValue,"in 'rmeasure': user 'rmeasure' returns a vector of %d observables but %d are expected: compare 'data' slot?", LENGTH(ans),nobs); } // get name information to fix potential alignment problems PROTECT(nm = GET_NAMES(ans)); nprotect++; use_names = !isNull(nm); if (use_names) { // match names against names from data slot posn = INTEGER(PROTECT(matchnames(Onames,nm,"observables"))); nprotect++; } else { posn = 0; } ys = REAL(AS_NUMERIC(ans)); first = 0; } else { ys = REAL(AS_NUMERIC(eval(fcall,rho))); } if (use_names) { for (i = 0; i < nobs; i++) yt[posn[i]] = ys[i]; } else { for (i = 0; i < nobs; i++) yt[i] = ys[i]; } } } } break; case native: // native routine { double *yt = REAL(Y); double *time = REAL(times); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *xp, *pp; int j, k; set_pomp_userdata(fcall); GetRNGstate(); for (k = 0; k < ntimes; k++, time++) { // loop over times R_CheckUserInterrupt(); // check for user interrupt // interpolate the covar functions for the covariates table_lookup(&covariate_table,*time,cp); for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates xp = &xs[nvars*((j%nrepsx)+nrepsx*k)]; pp = &ps[npars*(j%nrepsp)]; (*ff)(yt,xp,pp,oidx,sidx,pidx,cidx,ncovars,cp,*time); } } PutRNGstate(); unset_pomp_userdata(); } break; default: errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov break; } UNPROTECT(nprotect); return Y; }

SEXP do_dmeasure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP params, SEXP log, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int give_log; int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs; SEXP Snames, Pnames, Cnames, Onames; SEXP pompfun; SEXP cvec, tvec = R_NilValue; SEXP xvec = R_NilValue, yvec = R_NilValue, pvec = R_NilValue; SEXP fn, ans, fcall, rho = R_NilValue; SEXP F; int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0; int *dim; struct lookup_table covariate_table; pomp_measure_model_density *ff = NULL; PROTECT(times = AS_NUMERIC(times)); nprotect++; ntimes = length(times); if (ntimes < 1) errorcall(R_NilValue,"in 'dmeasure': length('times') = 0, no work to do"); PROTECT(y = as_matrix(y)); nprotect++; dim = INTEGER(GET_DIM(y)); nobs = dim[0]; if (ntimes != dim[1]) errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 2nd dimension of 'y' do not agree"); PROTECT(x = as_state_array(x)); nprotect++; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nrepsx = dim[1]; if (ntimes != dim[2]) errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 3rd dimension of 'x' do not agree"); PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nrepsp = dim[1]; nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx; if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0)) errorcall(R_NilValue,"in 'dmeasure': larger number of replicates is not a multiple of smaller"); PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(y))); nprotect++; PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; give_log = *(INTEGER(AS_INTEGER(log))); // set up the covariate table covariate_table = make_covariate_table(object,&ncovars); // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("dmeasure"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // first do setup switch (mode) { case Rfun: // R function PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(yvec = NEW_NUMERIC(nobs)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(yvec,Onames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,fcall)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++; SET_TAG(fcall,install("log")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(yvec,fcall)); nprotect++; SET_TAG(fcall,install("y")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate, observable indices oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++; 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); break; default: errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov break; } // create array to store results { int dim[2] = {nreps, ntimes}; const char *dimnm[2] = {"rep","time"}; PROTECT(F = makearray(2,dim)); nprotect++; fixdimnames(F,dimnm,2); } // now do computations switch (mode) { case Rfun: // R function { int first = 1; double *ys = REAL(y); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *tp = REAL(tvec); double *xp = REAL(xvec); double *yp = REAL(yvec); double *pp = REAL(pvec); double *ft = REAL(F); double *time = REAL(times); int j, k; for (k = 0; k < ntimes; k++, time++, ys += nobs) { // loop over times R_CheckUserInterrupt(); // check for user interrupt *tp = *time; // copy the time table_lookup(&covariate_table,*time,cp); // interpolate the covariates memcpy(yp,ys,nobs*sizeof(double)); for (j = 0; j < nreps; j++, ft++) { // loop over replicates // copy the states and parameters into place memcpy(xp,&xs[nvars*((j%nrepsx)+nrepsx*k)],nvars*sizeof(double)); memcpy(pp,&ps[npars*(j%nrepsp)],npars*sizeof(double)); if (first) { // evaluate the call PROTECT(ans = eval(fcall,rho)); nprotect++; if (LENGTH(ans) != 1) errorcall(R_NilValue,"in 'dmeasure': user 'dmeasure' returns a vector of length %d when it should return a scalar",LENGTH(ans)); *ft = *(REAL(AS_NUMERIC(ans))); first = 0; } else { *ft = *(REAL(AS_NUMERIC(eval(fcall,rho)))); } } } } break; case native: // native code set_pomp_userdata(fcall); { double *yp = REAL(y); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *ft = REAL(F); double *time = REAL(times); double *xp, *pp; int j, k; for (k = 0; k < ntimes; k++, time++, yp += nobs) { // loop over times R_CheckUserInterrupt(); // check for user interrupt // interpolate the covar functions for the covariates table_lookup(&covariate_table,*time,cp); for (j = 0; j < nreps; j++, ft++) { // loop over replicates xp = &xs[nvars*((j%nrepsx)+nrepsx*k)]; pp = &ps[npars*(j%nrepsp)]; (*ff)(ft,yp,xp,pp,give_log,oidx,sidx,pidx,cidx,ncovars,cp,*time); } } } unset_pomp_userdata(); break; default: errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov break; } UNPROTECT(nprotect); return F; }

SEXP attribute_hidden do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho) { checkArity(op, args); SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args); int m, zero = 0; R_xlen_t *lengths, *counters, longest = 0; m = length(varyingArgs); SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol)); Rboolean named = vnames != R_NilValue; lengths = (R_xlen_t *) R_alloc(m, sizeof(R_xlen_t)); for (int i = 0; i < m; i++) { SEXP tmp1 = VECTOR_ELT(varyingArgs, i); lengths[i] = xlength(tmp1); if (isObject(tmp1)) { // possibly dispatch on length() /* Cache the .Primitive: unclear caching is worthwhile. */ static SEXP length_op = NULL; if (length_op == NULL) length_op = R_Primitive("length"); // DispatchOrEval() needs 'args' to be a pairlist SEXP ans, tmp2 = PROTECT(list1(tmp1)); if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1)) lengths[i] = (R_xlen_t) (TYPEOF(ans) == REALSXP ? REAL(ans)[0] : asInteger(ans)); UNPROTECT(1); } if (lengths[i] == 0) zero++; if (lengths[i] > longest) longest = lengths[i]; } if (zero && longest) error(_("zero-length inputs cannot be mixed with those of non-zero length")); counters = (R_xlen_t *) R_alloc(m, sizeof(R_xlen_t)); memset(counters, 0, m * sizeof(R_xlen_t)); SEXP mindex = PROTECT(allocVector(VECSXP, m)); SEXP nindex = PROTECT(allocVector(VECSXP, m)); /* build a call like f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7) */ SEXP fcall = R_NilValue; // -Wall if (constantArgs == R_NilValue) ; else if (isVectorList(constantArgs)) fcall = VectorToPairList(constantArgs); else error(_("argument 'MoreArgs' of 'mapply' is not a list")); PROTECT_INDEX fi; PROTECT_WITH_INDEX(fcall, &fi); Rboolean realIndx = longest > INT_MAX; SEXP Dots = install("dots"); for (int j = m - 1; j >= 0; j--) { SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1)); SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1)); SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j))); SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j))); REPROTECT(fcall = LCONS(tmp2, fcall), fi); UNPROTECT(2); if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0') SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j))); } REPROTECT(fcall = LCONS(f, fcall), fi); SEXP ans = PROTECT(allocVector(VECSXP, longest)); for (int i = 0; i < longest; i++) { for (int j = 0; j < m; j++) { counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j]; if (realIndx) REAL(VECTOR_ELT(nindex, j))[0] = (double) counters[j]; else INTEGER(VECTOR_ELT(nindex, j))[0] = (int) counters[j]; } SEXP tmp = eval(fcall, rho); if (NAMED(tmp)) tmp = duplicate(tmp); SET_VECTOR_ELT(ans, i, tmp); } for (int j = 0; j < m; j++) if (counters[j] != lengths[j]) warning(_("longer argument not a multiple of length of shorter")); UNPROTECT(5); return ans; }

SEXP attribute_hidden do_mapply(SEXP f, SEXP varyingArgs, SEXP constantArgs, SEXP rho) { int i, j, m, *lengths, *counters, named, longest = 0, zero = 0; SEXP vnames, fcall = R_NilValue, mindex, nindex, tmp1, tmp2, ans; m = length(varyingArgs); vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol)); named = vnames != R_NilValue; lengths = (int *) R_alloc(m, sizeof(int)); for(i = 0; i < m; i++){ lengths[i] = length(VECTOR_ELT(varyingArgs, i)); if(lengths[i] == 0) zero++; if (lengths[i] > longest) longest = lengths[i]; } if (zero && longest) error(_("Zero-length inputs cannot be mixed with those of non-zero length")); counters = (int *) R_alloc(m, sizeof(int)); for(i = 0; i < m; counters[i++] = 0); mindex = PROTECT(allocVector(VECSXP, m)); nindex = PROTECT(allocVector(VECSXP, m)); /* build a call like f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7) */ if (constantArgs == R_NilValue) PROTECT(fcall = R_NilValue); else if(isVectorList(constantArgs)) PROTECT(fcall = VectorToPairList(constantArgs)); else error(_("argument 'MoreArgs' of 'mapply' is not a list")); for(j = m - 1; j >= 0; j--) { SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1)); SET_VECTOR_ELT(nindex, j, allocVector(INTSXP, 1)); PROTECT(tmp1 = lang3(R_Bracket2Symbol, install("dots"), VECTOR_ELT(mindex, j))); PROTECT(tmp2 = lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j))); UNPROTECT(3); PROTECT(fcall = LCONS(tmp2, fcall)); if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0') SET_TAG(fcall, install(translateChar(STRING_ELT(vnames, j)))); } UNPROTECT(1); PROTECT(fcall = LCONS(f, fcall)); PROTECT(ans = allocVector(VECSXP, longest)); for(i = 0; i < longest; i++) { for(j = 0; j < m; j++) { counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j]; INTEGER(VECTOR_ELT(nindex, j))[0] = counters[j]; } SET_VECTOR_ELT(ans, i, eval(fcall, rho)); } for(j = 0; j < m; j++) { if (counters[j] != lengths[j]) warning(_("longer argument not a multiple of length of shorter")); } UNPROTECT(5); return(ans); }

SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int npars, nreps; SEXP Pnames, F, fn, fcall; SEXP pompfun; int *dim; PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nreps = dim[1]; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("dprior"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // to store results PROTECT(F = NEW_NUMERIC(nreps)); nprotect++; // first do setup switch (mode) { case Rfun: // use R function { SEXP pvec, rho; double *pp, *ps, *pt; int j; // temporary storage PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++; SET_TAG(fcall,install("log")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; pp = REAL(pvec); for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) { memcpy(pp,ps,npars*sizeof(double)); *pt = *(REAL(AS_NUMERIC(eval(fcall,rho)))); } } break; case native: // use native routine { int give_log, *pidx = 0; pomp_dprior *ff = NULL; double *ps, *pt; int j; // construct state, parameter, covariate, observable indices pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames"))); nprotect++; // address of native routine ff = (pomp_dprior *) R_ExternalPtrAddr(fn); give_log = *(INTEGER(AS_INTEGER(log))); R_CheckUserInterrupt(); // check for user interrupt set_pomp_userdata(fcall); // loop over replicates for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++) (*ff)(pt,ps,give_log,pidx); unset_pomp_userdata(); } break; default: error("unrecognized 'mode' slot in 'dprior'"); break; } UNPROTECT(nprotect); return F; }