コード例 #1
0
ファイル: dmeasure.c プロジェクト: kingaa/pomp
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;
}
コード例 #2
0
ファイル: rmeasure.c プロジェクト: kingaa/pomp
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;
}
コード例 #3
0
ファイル: partrans.c プロジェクト: hoehleatsu/pomp
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;
}
コード例 #4
0
ファイル: euler.c プロジェクト: kingaa/pomp
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;
}
コード例 #5
0
ファイル: euler.c プロジェクト: kingaa/pomp
// 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;
}
コード例 #6
0
ファイル: initstate.c プロジェクト: kingaa/pomp
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;
}
コード例 #7
0
ファイル: dprior.c プロジェクト: hoehleatsu/pomp
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;
}