Exemple #1
0
/* 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;
}
Exemple #2
0
// 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
  }
}
Exemple #3
0
// 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
  }
}
Exemple #4
0
INLINE_FUN SEXP lang1(SEXP s)
{
    return LCONS(s, R_NilValue);
}
Exemple #5
0
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;
}
Exemple #6
0
/* 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;
}
Exemple #7
0
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;
}
Exemple #8
0
/* 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;
}
Exemple #9
0
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
    }
  }
}
Exemple #10
0
// (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;
}
Exemple #11
0
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;
}
Exemple #12
0
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;
  }
}
Exemple #13
0
static Rboolean latin1locale(void) {
    return  *LOGICAL(VECTOR_ELT(eval(LCONS(install("l10n_info"), R_NilValue),
		R_GlobalEnv), 2));
}
Exemple #14
0
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;
}
Exemple #15
0
// 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;
}
Exemple #16
0
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;
}
Exemple #17
0
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;
}
Exemple #18
0
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;
}
Exemple #19
0
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);
}
Exemple #20
0
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;
}