Example #1
0
SEXP call_rkAuto(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc,
  SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho,
  SEXP Rtol, SEXP Atol, SEXP Tcrit, SEXP Verbose,
  SEXP Hmin, SEXP Hmax, SEXP Hini, SEXP Rpar, SEXP Ipar,
  SEXP Method, SEXP Maxsteps, SEXP Flist) {

  /**  Initialization **/
  long int old_N_Protect = save_N_Protected();

  double *tt = NULL, *xs = NULL;

  double *y,  *f,  *Fj, *tmp, *FF, *rr;
  SEXP  R_yout;
  double *y0,  *y1,  *y2,  *dy1,  *dy2, *out, *yout;

  double errold = 0.0, t, dt, tmax;

  SEXP R_FSAL, Alpha, Beta;
  int fsal = FALSE;       /* assume no FSAL */
  
  /* Use polynomial interpolation if not disabled by the method
     or when events come in to play (stop-and-go mode).
     Methods with dense output interpolate by default,
     all others do not.
  */
  int interpolate = TRUE;

  int i = 0, j = 0, it = 0, it_tot = 0, it_ext = 0, nt = 0, neq = 0, it_rej = 0;
  int isForcing, isEvent;

  /*------------------------------------------------------------------------*/
  /* Processing of Arguments                                                */
  /*------------------------------------------------------------------------*/
  int lAtol = LENGTH(Atol);
  double *atol = (double*) R_alloc((int) lAtol, sizeof(double));

  int lRtol = LENGTH(Rtol);
  double *rtol = (double*) R_alloc((int) lRtol, sizeof(double));

  for (j = 0; j < lRtol; j++) rtol[j] = REAL(Rtol)[j];
  for (j = 0; j < lAtol; j++) atol[j] = REAL(Atol)[j];

  double  tcrit = REAL(Tcrit)[0];
  double  hmin  = REAL(Hmin)[0];
  double  hmax  = REAL(Hmax)[0];
  double  hini  = REAL(Hini)[0];
  int  maxsteps = INTEGER(Maxsteps)[0];
  int  nout     = INTEGER(Nout)[0]; /* number of global outputs is func is in a DLL */
  int  verbose  = INTEGER(Verbose)[0];

  int stage     = (int)REAL(getListElement(Method, "stage"))[0];

  SEXP R_A, R_B1, R_B2, R_C, R_D, R_densetype;
  double  *A, *bb1, *bb2 = NULL, *cc = NULL, *dd = NULL;

  PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect();
  A = REAL(R_A);

  PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect();
  bb1 = REAL(R_B1);

  PROTECT(R_B2 = getListElement(Method, "b2")); incr_N_Protect();
  if (length(R_B2)) bb2 = REAL(R_B2);

  PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect();
  if (length(R_C)) cc = REAL(R_C);

  PROTECT(R_D = getListElement(Method, "d")); incr_N_Protect();
  if (length(R_D)) dd = REAL(R_D);

  /* dense output Cash-Karp: densetype = 2 */
  int densetype = 0;
  PROTECT(R_densetype = getListElement(Method, "densetype")); incr_N_Protect();
  if (length(R_densetype)) densetype = INTEGER(R_densetype)[0];

  double  qerr = REAL(getListElement(Method, "Qerr"))[0];
  double  beta = 0;      /* 0.4/qerr; */

  PROTECT(Beta = getListElement(Method, "beta")); incr_N_Protect();
  if (length(Beta)) beta = REAL(Beta)[0];

  double  alpha = 1/qerr - 0.75 * beta;
  PROTECT(Alpha = getListElement(Method, "alpha")); incr_N_Protect();
  if (length(Alpha)) alpha = REAL(Alpha)[0];

  PROTECT(R_FSAL = getListElement(Method, "FSAL")); incr_N_Protect();
  if (length(R_FSAL)) fsal = INTEGER(R_FSAL)[0];

  PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect();
  tt = NUMERIC_POINTER(Times);
  nt = length(Times);

  PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect();
  xs  = NUMERIC_POINTER(Xstart);
  neq = length(Xstart);
  /*------------------------------------------------------------------------*/
  /* timesteps (for advection computation in ReacTran)                      */
  /*------------------------------------------------------------------------*/
  for (i = 0; i < 2; i++) timesteps[i] = 0;

  /*------------------------------------------------------------------------*/
  /* DLL, ipar, rpar (for compatibility with lsoda)                         */
  /*------------------------------------------------------------------------*/
  int isDll = FALSE;
  int lrpar= 0, lipar = 0;
  int *ipar = NULL;

  /* code adapted from lsoda to improve compatibility */
  if (inherits(Func, "NativeSymbol")) { 
    /* function is a dll */
    isDll = TRUE;
    if (nout > 0) isOut = TRUE;
    //ntot  = neq + nout;           /* length of yout */
    lrpar = nout + LENGTH(Rpar);  /* length of rpar; LENGTH(Rpar) is always >0 */
    lipar = 3    + LENGTH(Ipar);  /* length of ipar */

  } else {
    /* function is not a dll */
    isDll = FALSE;
    isOut = FALSE;
    //ntot = neq;
    lipar = 3;    /* in lsoda = 1 */
    lrpar = nout; /* in lsoda = 1 */
  }
  out   = (double*) R_alloc(lrpar, sizeof(double)); 
  ipar  = (int *) R_alloc(lipar, sizeof(int));

  /* first 3 elements of ipar are special */
  ipar[0] = nout;              
  ipar[1] = lrpar;
  ipar[2] = lipar;
  if (isDll == 1) {
    /* other elements of ipar are set in R-function lsodx via argument "ipar" */
    for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j];
 
    /* out: first nout elements of out are reserved for output variables
       other elements are set via argument "rpar" */
    for (j = 0; j < nout; j++)         out[j] = 0.0;                
    for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j];
  }

  /*------------------------------------------------------------------------*/
  /* Allocation of Workspace                                                */
  /*------------------------------------------------------------------------*/
  y0  =  (double*) R_alloc(neq, sizeof(double));
  y1  =  (double*) R_alloc(neq, sizeof(double));
  y2  =  (double*) R_alloc(neq, sizeof(double));
  dy1 =  (double*) R_alloc(neq, sizeof(double));
  dy2 =  (double*) R_alloc(neq, sizeof(double));
  f   =  (double*) R_alloc(neq, sizeof(double));
  y   =  (double*) R_alloc(neq, sizeof(double));
  Fj  =  (double*) R_alloc(neq, sizeof(double));
  tmp =  (double*) R_alloc(neq, sizeof(double));
  FF  =  (double*) R_alloc(neq * stage, sizeof(double));
  rr  =  (double*) R_alloc(neq * 5, sizeof(double));

  /* matrix for polynomial interpolation */
  SEXP R_nknots;
  int nknots = 6;  /* 6 = 5th order polynomials by default*/
  int iknots = 0;  /* counter for knots buffer */
  double *yknots;

  PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect();
  if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1;
  if (nknots < 2) {nknots = 1; interpolate = FALSE;}
  if (densetype > 0) interpolate = TRUE;
  yknots = (double*) R_alloc((neq + 1) * (nknots + 1), sizeof(double));

  /* matrix for holding states and global outputs */
  PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect();
  yout = REAL(R_yout);
  /* initialize outputs with NA first */
  for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL;

  /* attribute that stores state information, similar to lsoda */
  SEXP R_istate;
  int *istate;
  PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect();
  istate = INTEGER(R_istate);
  istate[0] = 0; /* assume succesful return */
  for (i = 0; i < 22; i++) istate[i] = 0;

  /*------------------------------------------------------------------------*/
  /* Initialization of Parameters (for DLL functions)                       */
  /*------------------------------------------------------------------------*/
  PROTECT(Y = allocVector(REALSXP,(neq)));        incr_N_Protect(); 
  
  initParms(Initfunc, Parms);
  isForcing = initForcings(Flist);
  isEvent = initEvents(elist, eventfunc, 0);
  if (isEvent) interpolate = FALSE;

  /*------------------------------------------------------------------------*/
  /* Initialization of Integration Loop                                     */
  /*------------------------------------------------------------------------*/
  yout[0]   = tt[0];              /* initial time                 */
  yknots[0] = tt[0];              /* for polynomial interpolation */
  for (i = 0; i < neq; i++) {
    y0[i]        = xs[i];         /* initial values               */
    yout[(i + 1) * nt] = y0[i];   /* output array                 */
    yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */
  }
  iknots++;

  t = tt[0];
  tmax = fmax(tt[nt - 1], tcrit);
  dt   = fmin(hmax, hini);
  hmax = fmin(hmax, tmax - t);

  /* Initialize work arrays (to be on the safe side, remove this later) */
  for (i = 0; i < neq; i++)  {
    y1[i] = 0;
    y2[i] = 0;
    Fj[i] = 0;
    for (j= 0; j < stage; j++)  {
      FF[i + j * neq] = 0;
    }
  }

  /*------------------------------------------------------------------------*/
  /* Main Loop                                                              */
  /*------------------------------------------------------------------------*/
  it     = 1; /* step counter; zero element is initial state   */
  it_ext = 0; /* counter for external time step (dense output) */
  it_tot = 0; /* total number of time steps                    */
  it_rej = 0;
  
  if (interpolate) {
  /* integrate over the whole time step and interpolate internally */
    rk_auto(
      fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, 
      densetype, maxsteps, nt,
      &iknots, &it, &it_ext, &it_tot, &it_rej,
      istate, ipar, 
      t, tmax, hmin, hmax, alpha, beta,
      &dt, &errold,
      tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A,
      out, bb1, bb2, cc, dd, atol, rtol, yknots, yout,
      Func, Parms, Rho
    );
  } else {  
     /* integrate separately between external time steps; do not interpolate */
     for (int j = 0; j < nt - 1; j++) {
       t = tt[j];
       tmax = fmin(tt[j + 1], tcrit);
       dt = tmax - t;
       if (isEvent) {
         updateevent(&t, y0, istate);
       }
       if (verbose) Rprintf("\n %d th time interval = %g ... %g", j, t, tmax);
       rk_auto(
          fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, 
          densetype, maxsteps, nt,
          &iknots, &it, &it_ext, &it_tot, &it_rej,
          istate, ipar,
          t,  tmax, hmin, hmax, alpha, beta,
          &dt, &errold,
          tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A,
          out, bb1, bb2, cc, dd, atol, rtol, yknots, yout,
          Func, Parms, Rho
      );
      /* in this mode, internal interpolation is skipped,
         so we can simply store the results at the end of each call */
      yout[j + 1] = tmax;
      for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y2[i];
    }
  }

  /*====================================================================*/
  /* call derivs again to get global outputs                            */
  /* j = -1 suppresses unnecessary internal copying                     */
  /*====================================================================*/
  if (nout > 0) {
    for (int j = 0; j < nt; j++) {
      t = yout[j];
      for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)];
      derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing);
      for (i = 0; i < nout; i++) {
        yout[j + nt * (1 + neq + i)] = out[i];
      }
    }
  }

  /* attach diagnostic information (codes are compatible to lsoda) */
  setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, it_rej);
  if (densetype == 2)   istate[12] = it_tot * stage + 2; /* number of function evaluations */

  /* verbose printing in debugging mode*/
  if (verbose) 
    Rprintf("\nNumber of time steps it = %d, it_ext = %d, it_tot = %d it_rej %d\n", 
      it, it_ext, it_tot, it_rej);

  /* release R resources */
  timesteps[0] = 0;
  timesteps[1] = 0;
  
  restore_N_Protected(old_N_Protect);
  return(R_yout);
}
Example #2
0
/*
Susceptible-Infectious-Removed MCMC analysis:
	. Exponentially distributed infectiousness periods
*/
SEXP expMH_SIR(SEXP N, SEXP removalTimes, SEXP otherParameters, SEXP priorValues,
	SEXP initialValues, SEXP bayesReps, SEXP bayesStart, SEXP bayesThin, SEXP bayesOut){
	/* Declarations  */
	int ii, jj, kk, ll, nInfected, nRemoved, nProtected=0, initialInfected;
	SEXP infRateSIR, remRateSIR, logLikelihood;/*, timeInfected, timeDim, initialInf ; */
	SEXP parameters, infectionTimes, candidateTimes, infectedBeforeDay;
	SEXP allTimes, indicator, SS, II;
	double infRate, remRate, oldLkhood, newLkhood, minimumLikelyInfectionTime;	 /* starting values */
	double infRatePrior[2], remRatePrior[2], thetaprior;	 /* priors values */
	double sumSI, sumDurationInfectious, likelihood,logR;
	int acceptRate=0, consistent=0, verbose, missingInfectionTimes;
	SEXP retParameters, parNames, acceptanceRate;
	SEXP infTimes;
	/*  Code   */
	GetRNGstate(); /* should be before a call to a random number generator */
	initialInfected = INTEGER(getListElement(otherParameters, "initialInfected"))[0];
	verbose = INTEGER(getListElement(otherParameters, "verbose"))[0];
	missingInfectionTimes = INTEGER(getListElement(otherParameters, "missingInfectionTimes"))[0];
	PROTECT(N = AS_INTEGER(N));
	++nProtected;
	PROTECT(removalTimes = AS_NUMERIC(removalTimes));
	++nProtected;
	/* priors and starting values */
	PROTECT(priorValues = AS_LIST(priorValues));
	++nProtected;
	PROTECT(initialValues = AS_LIST(initialValues));
	++nProtected;
	nRemoved = LENGTH(removalTimes); /* number of individuals removed */
	/* bayes replications, thin, etc */
	PROTECT(bayesReps = AS_INTEGER(bayesReps));
	++nProtected;
	PROTECT(bayesStart = AS_INTEGER(bayesStart));
	++nProtected;
	PROTECT(bayesThin = AS_INTEGER(bayesThin));
	++nProtected;
	PROTECT(bayesOut = AS_INTEGER(bayesOut));
	++nProtected;
	PROTECT(infRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0]));
	++nProtected;
	PROTECT(remRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0]));
	++nProtected;
	PROTECT(logLikelihood = allocVector(REALSXP, INTEGER(bayesOut)[0]));
	++nProtected;
	/*
	PROTECT(timeInfected = allocVector(REALSXP, nRemoved * INTEGER(bayesOut)[0]));
	++nProtected;
	PROTECT(timeDim = allocVector(INTSXP, 2));
	++nProtected;
	INTEGER(timeDim)[0] = nRemoved;
	INTEGER(timeDim)[1] = INTEGER(bayesOut)[0];
	setAttrib(timeInfected, R_DimSymbol, timeDim);
	PROTECT(initialInf = allocVector(REALSXP, INTEGER(bayesOut)[0]));
	++nProtected;
	*/ 
	PROTECT(parameters = allocVector(REALSXP,2));
	++nProtected;
	PROTECT(infectionTimes = allocVector(REALSXP,nRemoved));
	++nProtected;
	PROTECT(candidateTimes = allocVector(REALSXP,nRemoved));
	++nProtected;
	PROTECT(infectedBeforeDay = allocVector(REALSXP,nRemoved));
	++nProtected;
	PROTECT(infTimes = allocVector(REALSXP,nRemoved));
	++nProtected;
	for(jj = 0; jj < nRemoved; ++jj){
		REAL(infectionTimes)[jj] = REAL(getListElement(initialValues, "infectionTimes"))[jj];
		REAL(candidateTimes)[jj] = REAL(infectionTimes)[jj];
		REAL(infectedBeforeDay)[jj] = REAL(getListElement(otherParameters, "infectedBeforeDay"))[jj];
		REAL(infTimes)[jj] = 0;
	}
	nInfected = LENGTH(infectionTimes);
	PROTECT(allTimes = allocVector(REALSXP,nRemoved+nInfected));
	++nProtected;
	PROTECT(indicator = allocVector(INTSXP,nRemoved+nInfected));
	++nProtected;
	PROTECT(SS = allocVector(INTSXP,nRemoved+nInfected+1));
	++nProtected;
	PROTECT(II = allocVector(INTSXP,nRemoved+nInfected+1));
	++nProtected;
	/* working variables */
	infRate = REAL(getListElement(initialValues, "infectionRate"))[0];
	remRate = REAL(getListElement(initialValues, "removalRate"))[0];
	minimumLikelyInfectionTime = REAL(getListElement(otherParameters, "minimumLikelyInfectionTime"))[0];
	for(ii = 0; ii < 2; ++ii){
		infRatePrior[ii] = REAL(getListElement(priorValues, "infectionRate"))[ii];
		remRatePrior[ii] = REAL(getListElement(priorValues, "removalRate"))[ii];
	}
	thetaprior = REAL(getListElement(priorValues, "theta"))[0];
	REAL(parameters)[0] = infRate;
	REAL(parameters)[1] = remRate;
	expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
		REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
		&sumSI, &sumDurationInfectious, &likelihood,
		REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
	oldLkhood = likelihood;
	for(ii = 1; ii <= INTEGER(bayesReps)[0]; ++ii){
		infRate = rgamma(nInfected-1+infRatePrior[0],1/(sumSI+infRatePrior[1])); /* update infRate */
		remRate = rgamma(nRemoved+remRatePrior[0],1/(sumDurationInfectious+remRatePrior[1]));/*remRate */
		/*Rprintf("SI = %f    : I  = %f\n",sumSI,sumDurationInfectious);*/
		REAL(parameters)[0] = infRate;
		REAL(parameters)[1] = remRate;
		if(missingInfectionTimes){
			expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
				REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
				&sumSI, &sumDurationInfectious, &likelihood,
				REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
			oldLkhood = likelihood;
			kk = ceil(unif_rand()*(nRemoved-1)); /* initial infection time excluded */
			consistent=0;
			if(kk == nRemoved-1){
				REAL(candidateTimes)[kk] =
					runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);}
			else if((REAL(infectionTimes)[kk+1] > REAL(infectedBeforeDay)[kk])){
				REAL(candidateTimes)[kk] =
					runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);}
			else{REAL(candidateTimes)[kk] =
					runif(REAL(infectionTimes)[kk-1], REAL(infectionTimes)[kk+1]);}
			expLikelihood_SIR(REAL(parameters),REAL(candidateTimes),
				REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
				&sumSI, &sumDurationInfectious, &likelihood,
				REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
			newLkhood = likelihood;
			logR = (newLkhood-oldLkhood);
			if(log(unif_rand()) <= logR){
				REAL(infectionTimes)[kk] = REAL(candidateTimes)[kk];
				++acceptRate;
			}
			REAL(candidateTimes)[kk] = REAL(infectionTimes)[kk];/* update candidate times */
			REAL(infectionTimes)[0] = REAL(infectionTimes)[1]
				-rexp(1/(infRate*INTEGER(N)[0]+remRate+thetaprior));	
			REAL(candidateTimes)[0] = REAL(infectionTimes)[0];
		}
		expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
			REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
			&sumSI, &sumDurationInfectious, &likelihood,
			REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
		oldLkhood = likelihood;
		kk = ceil(INTEGER(bayesReps)[0]/100);
		ll = ceil(INTEGER(bayesReps)[0]/ 10);
		if(verbose == 1){
			if((ii % kk) == 0){Rprintf(".");}
			if((ii % ll) == 0){Rprintf("   %d\n",ii);}
		}
		if((ii >= (INTEGER(bayesStart)[0])) &&
			((ii-INTEGER(bayesStart)[0]) % INTEGER(bayesThin)[0] == 0)){
			ll = (ii - (INTEGER(bayesStart)[0]))/INTEGER(bayesThin)[0];
			/* REAL(initialInf)[ll] = REAL(infectionTimes)[0]; */
			REAL(logLikelihood)[ll] = likelihood;
			REAL(infRateSIR)[ll] = infRate;
			REAL(remRateSIR)[ll] = remRate;
			for(jj = 0; jj < nRemoved; ++jj){
				REAL(infTimes)[jj] += REAL(infectionTimes)[jj];
			}
			/*
			for(jj = 0; jj < nRemoved; ++jj){
				REAL(timeInfected)[(nRemoved*ll+jj)] = REAL(infectionTimes)[jj];
			}
			*/				
		}
	}
	PutRNGstate(); /* after using random number generators.	*/
	/* Print infection times and removal times at last iteration */
	for(jj = 0; jj < nRemoved; ++jj){
		REAL(infTimes)[jj] = REAL(infTimes)[jj]/INTEGER(bayesOut)[0];
	}
	if(verbose){
		for(jj = 0; jj < nRemoved; ++jj){
			Rprintf("%2d  %8.4f   %2.0f\n",jj,
				REAL(infTimes)[jj],REAL(removalTimes)[jj]);
		}
	}
	PROTECT(retParameters = NEW_LIST(5));
	++nProtected;
	PROTECT(acceptanceRate = allocVector(INTSXP,1));
	++nProtected;
	INTEGER(acceptanceRate)[0] = acceptRate;
	PROTECT(parNames = allocVector(STRSXP,5));
	++nProtected;
	SET_STRING_ELT(parNames, 0, mkChar("logLikelihood"));
	SET_STRING_ELT(parNames, 1, mkChar("infRateSIR"));
	SET_STRING_ELT(parNames, 2, mkChar("remRateSIR"));
	SET_STRING_ELT(parNames, 3, mkChar("infectionTimes"));
	SET_STRING_ELT(parNames, 4, mkChar("acceptanceRate"));
	setAttrib(retParameters, R_NamesSymbol,parNames);
	
	SET_ELEMENT(retParameters, 0, logLikelihood);
	SET_ELEMENT(retParameters, 1, infRateSIR);
	SET_ELEMENT(retParameters, 2, remRateSIR);
	SET_ELEMENT(retParameters, 3, infTimes);
	SET_ELEMENT(retParameters, 4, acceptanceRate);
	/*
	SET_ELEMENT(retParameters, 3, initialInf);
	SET_ELEMENT(retParameters, 4, timeInfected);
	*/
	UNPROTECT(nProtected);
	return(retParameters);
}
Example #3
0
SEXP trAWBWlist(SEXP Alist, SEXP W, SEXP Blist, SEXP mode)
{
  R_len_t nA = length(Alist), nB=length(Blist);
  SEXP ans;
  SEXP Aitem, Aidims, Bitem, Bidims, Wdims;
  int nrA, ncA, nrB, ncB, nrW, ncW, ii, jj;
  int Aii, Bjj, Astart, Aend, idx;
  double  *modep;

  double *rA, *rB, *rW, *ansp, rans;
  //if(!isNewList(Alist)) error("'list’ must be a list");

  Wdims = getAttrib(W, R_DimSymbol);
  nrW = INTEGER(Wdims)[0];  ncW = INTEGER(Wdims)[1];
  rW  = REAL(W);

  PROTECT(ans = allocVector(REALSXP,nA*nB));
  ansp = REAL(ans);

  PROTECT(mode = coerceVector(mode, REALSXP)) ;
  modep = REAL(mode);

  idx = 0;

  for (Bjj=0; Bjj<nB; Bjj++){
    PROTECT(Bitem  = AS_NUMERIC(VECTOR_ELT(Blist, Bjj)));
    PROTECT(Bidims = getAttrib(Bitem, R_DimSymbol));
    if (length(Bidims) < 2) error("Bad Bidims");
    
    nrB = INTEGER(Bidims)[0];  
    ncB = INTEGER(Bidims)[1];
    
    //Rprintf("B: %i %i %i\n", Bjj, nrB, ncB);  
    rB = REAL(Bitem);
    // printmatd(rB, &nrB, &ncB);

    if (*modep==0){
      Astart=0;      Aend  =nA;
    } else {
      Astart=Bjj;    Aend  =nA;
    }

    for (Aii=Astart; Aii<Aend; Aii++){
  
      PROTECT(Aitem  = AS_NUMERIC(VECTOR_ELT(Alist, Aii)));
      PROTECT(Aidims = getAttrib(Aitem, R_DimSymbol));
      
      nrA = INTEGER(Aidims)[0];  
      ncA = INTEGER(Aidims)[1];
      
      // Rprintf("A: %i %i %i\n", Aii, nrA, ncA);  
      rA = REAL(Aitem);
      
      trAWBWprim(rA, &nrA, &ncA,
		rW, &nrW, &ncW,
		rB, &nrB, &ncB, &rans);
      //Rprintf("%i %i %f\n", Aii, Bjj, rans);
      //ansp[Aii+nA*Bjj] = rans;
      //Rprintf("A: %i B: %i %f \n", Aii, Bjj, rans);
      ansp[idx++] = rans;
      UNPROTECT(2);
    }
    UNPROTECT(2);

  }
  
  //setAttrib(ans, R_NamesSymbol, getAttrib(Alist, R_NamesSymbol));
  UNPROTECT(2);
  return(ans);
}
Example #4
0
SEXP call_rkImplicit(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc,
  SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho,
  SEXP Tcrit, SEXP Verbose, SEXP Hini, SEXP Rpar, SEXP Ipar,
		  SEXP Method, SEXP Maxsteps, SEXP Flist) {

  /**  Initialization **/
  long int old_N_Protect = save_N_Protected();

  double *tt = NULL, *xs = NULL;

  double *y,  *f,  *Fj, *tmp, *tmp2, *tmp3, *FF, *rr;
  SEXP  R_yout;
  double *y0,  *y1, *dy1, *out, *yout;

  double t, dt, tmax;

  int fsal = FALSE;       /* fixed step methods have no FSAL */
  int interpolate = TRUE; /* polynomial interpolation is done by default */

  int i = 0, j=0, it=0, it_tot=0, it_ext=0, nt = 0, neq=0;
  int isForcing, isEvent;

  double *alpha;
  int *index;

  /**************************************************************************/
  /****** Processing of Arguments                                      ******/
  /**************************************************************************/
  double  tcrit = REAL(Tcrit)[0];
  double  hini  = REAL(Hini)[0];
  int  maxsteps = INTEGER(Maxsteps)[0];
  int  nout     = INTEGER(Nout)[0]; /* number of global outputs if func is in a DLL */
  int  verbose  = INTEGER(Verbose)[0];

  int stage     = (int)REAL(getListElement(Method, "stage"))[0];

  SEXP R_A, R_B1, R_C;
  double  *A, *bb1, *cc=NULL;

  PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect();
  A = REAL(R_A);

  PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect();
  bb1 = REAL(R_B1);

  PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect();
  if (length(R_C)) cc = REAL(R_C);
  
    double  qerr  = REAL(getListElement(Method, "Qerr"))[0];

  PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect();
  tt = NUMERIC_POINTER(Times);
  nt = length(Times);

  PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect();
  xs  = NUMERIC_POINTER(Xstart);
  neq = length(Xstart);

  /*------------------------------------------------------------------------*/
  /* timesteps (for advection computation in ReacTran)                      */
  /*------------------------------------------------------------------------*/
  for (i = 0; i < 2; i++) timesteps[i] = 0;
  
  /**************************************************************************/
  /****** DLL, ipar, rpar (to be compatible with lsoda)                ******/
  /**************************************************************************/
  int isDll = FALSE;
  //int ntot  = 0;
  int lrpar= 0, lipar = 0;
  int *ipar = NULL;

  if (inherits(Func, "NativeSymbol")) { /* function is a dll */
    isDll = TRUE;
    if (nout > 0) isOut = TRUE;
    //ntot  = neq + nout;           /* length of yout */
    lrpar = nout + LENGTH(Rpar);  /* length of rpar; LENGTH(Rpar) is always >0 */
    lipar = 3    + LENGTH(Ipar);  /* length of ipar */

  } else {                              /* function is not a dll */
    isDll = FALSE;
    isOut = FALSE;
    //ntot = neq;
    lipar = 3;    /* in lsoda = 1 */
    lrpar = nout; /* in lsoda = 1 */
  }
  out   = (double *) R_alloc(lrpar, sizeof(double)); 
  ipar  = (int *) R_alloc(lipar, sizeof(int));

  ipar[0] = nout;              /* first 3 elements of ipar are special */
  ipar[1] = lrpar;
  ipar[2] = lipar;
  if (isDll == 1) {
    /* other elements of ipar are set in R-function lsodx via argument *ipar* */
    for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j];
    /* out:  first nout elements of out are reserved for output variables
       other elements are set via argument *rpar*  */
    for (j = 0; j < nout; j++)         out[j] = 0.0;                
    for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j];
  }

  /*------------------------------------------------------------------------*/
  /* Allocation of Workspace                                                */
  /*------------------------------------------------------------------------*/
  y0  =  (double *) R_alloc(neq, sizeof(double));
  y1  =  (double *) R_alloc(neq, sizeof(double));
  dy1 =  (double *) R_alloc(neq, sizeof(double));
  f   =  (double *) R_alloc(neq, sizeof(double));
  y   =  (double *) R_alloc(neq, sizeof(double));
  Fj  =  (double *) R_alloc(neq, sizeof(double));
  FF  =  (double *) R_alloc(neq * stage, sizeof(double));
  rr  =  (double *) R_alloc(neq * 5, sizeof(double));

  /* ks */
  alpha =  (double *) R_alloc(neq * stage * neq * stage, sizeof(double));
  index =  (int *)    R_alloc(neq * stage, sizeof(int));
  tmp   =  (double *) R_alloc(neq * stage, sizeof(double));
  tmp2  =  (double *) R_alloc(neq * stage, sizeof(double));
  tmp3  =  (double *) R_alloc(neq * stage, sizeof(double));


  /* matrix for polynomial interpolation */
  SEXP R_nknots;
  int nknots = 6;  /* 6 = 5th order polynomials by default*/
  int iknots = 0;  /* counter for knots buffer */
  double *yknots;

  PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect();
  if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1;

  if (nknots < 2) {nknots=1; interpolate = FALSE;}
  
  yknots = (double *) R_alloc((neq + 1) * (nknots + 1), sizeof(double));


  /* matrix for holding states and global outputs */
  PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect();
  yout = REAL(R_yout);
  /* initialize outputs with NA first */
  for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL;

  /* attribute that stores state information, similar to lsoda */
  SEXP R_istate;
  int *istate;
  PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect();
  istate = INTEGER(R_istate);
  istate[0] = 0; /* assume succesful return */
  for (i = 0; i < 22; i++) istate[i] = 0;

  /*------------------------------------------------------------------------*/
  /* Initialization of Parameters (for DLL functions)                       */
  /*------------------------------------------------------------------------*/
  PROTECT(Y = allocVector(REALSXP,(neq)));        incr_N_Protect(); 
  
  initParms(Initfunc, Parms);
  isForcing = initForcings(Flist);
  isEvent = initEvents(elist, eventfunc,0);
  if (isEvent) interpolate = FALSE;
  
  /*------------------------------------------------------------------------*/
  /* Initialization of Integration Loop                                     */
  /*------------------------------------------------------------------------*/
  yout[0]   = tt[0];              /* initial time                 */
  yknots[0] = tt[0];              /* for polynomial interpolation */
  for (i = 0; i < neq; i++) {
    y0[i]        = xs[i];         /* initial values               */
    yout[(i + 1) * nt] = y0[i];   /* output array                 */
    yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */
  }
  iknots++;

  t = tt[0];                   
  tmax = fmax(tt[nt - 1], tcrit);

  /* Initialization of work arrays (to be on the safe side, remove this later) */
  for (i = 0; i < neq; i++)  {
    y1[i] = 0;
    Fj[i] = 0;
    for (j= 0; j < stage; j++)  {
      FF[i + j * neq] = 0;
    }
  }

  /*------------------------------------------------------------------------*/
  /* Main Loop                                                              */
  /*------------------------------------------------------------------------*/
  it     = 1; /* step counter; zero element is initial state   */
  it_ext = 0; /* counter for external time step (dense output) */
  it_tot = 0; /* total number of time steps                    */

  if (interpolate) {
  /* integrate over the whole time step and interpolate internally */
    rk_implicit( alpha, index, 
         fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, 
         maxsteps, nt,
  	     &iknots, &it, &it_ext, &it_tot,
         istate, ipar,
  	     t, tmax, hini,
  	     &dt,
  	     tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A,
  	     out, bb1, cc, yknots,  yout,
  	     Func, Parms, Rho
    );
  } else {
   for (int j = 0; j < nt - 1; j++) {
       t = tt[j];
       tmax = fmin(tt[j + 1], tcrit);
       dt = tmax - t;
       if (isEvent) {
         updateevent(&t, y0, istate);
       }
      rk_implicit(alpha, index, 
         fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, 
         maxsteps, nt,
  	     &iknots, &it, &it_ext, &it_tot,
         istate, ipar,
  	     t, tmax, hini,
  	     &dt,
  	     tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A,
  	     out, bb1, cc, yknots,  yout,
  	     Func, Parms, Rho
      );
      /* in this mode, internal interpolation is skipped,
         so we can simply store the results at the end of each call */
      yout[j + 1] = tmax;
      for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y1[i];
    }
  }
  
  /*====================================================================*/
  /* call derivs again to get global outputs                            */
  /* j = -1 suppresses unnecessary internal copying                     */
  /*====================================================================*/

  if(nout > 0) {
    for (int j = 0; j < nt; j++) {
      t = yout[j];
      for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)];
      derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing);
      for (i = 0; i < nout; i++) {
        yout[j + nt * (1 + neq + i)] = out[i];
      }
    }
  }

  /* attach diagnostic information (codes are compatible to lsoda) */
  setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, 0);

  /* release R resources */
  if (verbose) {
    Rprintf("Number of time steps it = %d, it_ext = %d, it_tot = %d\n", it, it_ext, it_tot);
    Rprintf("Maxsteps %d\n", maxsteps);
  }
  /* release R resources */
  timesteps[0] = 0;
  timesteps[1] = 0;
 
  restore_N_Protected(old_N_Protect);
  return(R_yout);
}
Example #5
0
File: do_mdwt.c Project: cran/rwt
/*
 * Public
 */
SEXP do_mdwt(SEXP vntX, SEXP vntH, SEXP vntL)
{
    SEXP vntOut;
    SEXP vntY;
    SEXP vntLr;
    double *x, *h, *y;
    int m, n, lh, L;

#ifdef DEBUG_RWT
    REprintf("In do_mdwt(x, h, L)...\n");
#endif

    /*
     * Handle first parameter (numeric matrix)
     */
#ifdef DEBUG_RWT
    REprintf("\tfirst param 'x'\n");
#endif
    if (GetMatrixDimen(vntX, &m, &n) != 2)
    {
        error("'x' is not a two dimensional matrix");
        /*NOTREACHED*/
    }

    PROTECT(vntX = AS_NUMERIC(vntX));
    x = NUMERIC_POINTER(vntX);
#ifdef DEBUG_RWT
    REprintf("x[%d][%d] = 0x%p\n", m, n, x);
#endif

    /*
     * Handle second parameter (numeric vector)
     */
#ifdef DEBUG_RWT
    REprintf("\tsecond param 'h'\n");
#endif
    PROTECT(vntH = AS_NUMERIC(vntH));
    h = NUMERIC_POINTER(vntH);
    lh = GET_LENGTH(vntH);
#ifdef DEBUG_RWT
    REprintf("h[%d] = 0x%p\n", GET_LENGTH(vntH), h);
#endif

    /*
     * Handle third parameter (integer scalar)
     */
#ifdef DEBUG_RWT
    REprintf("\tthird param 'L'\n");
#endif
    {
        PROTECT(vntL = AS_INTEGER(vntL));
        {
            int *piL = INTEGER_POINTER(vntL);
            L = piL[0];
        }
        UNPROTECT(1);
    }
#ifdef DEBUG_RWT
    REprintf("L = %d\n", L);
#endif

#ifdef DEBUG_RWT
    REprintf("\tcheck number of levels\n");
#endif
    if (L < 0)
    {
        error("The number of levels, L, must be a non-negative integer");
        /*NOTREACHED*/
    }

#ifdef DEBUG_RWT
    REprintf("\tcheck dimen prereqs\n");
#endif
    /* Check the ROW dimension of input */
    if (m > 1)
    {
        double mtest = (double) m / pow(2.0, (double) L);
        if (!isint(mtest))
        {
            error("The matrix row dimension must be of size m*2^(L)");
            /*NOTREACHED*/
        }
    }

    /* Check the COLUMN dimension of input */
    if (n > 1)
    {
        double ntest = (double) n / pow(2.0, (double) L);
        if (!isint(ntest))
        {
            error("The matrix column dimension must be of size n*2^(L)");
            /*NOTREACHED*/
        }
    }

#ifdef DEBUG_RWT
    REprintf("\tcreate value objects\n");
#endif

    /* Create y value object */
    {
#ifdef DEBUG_RWT
        REprintf("\tcreate 'y' value object\n");
#endif
        PROTECT(vntY = NEW_NUMERIC(n*m));
        y = NUMERIC_POINTER(vntY);

        /* Add dimension attribute to value object */
#ifdef DEBUG_RWT
        REprintf("\tconvert 'y' value object to matrix\n");
#endif
        {
            SEXP vntDim;

            PROTECT(vntDim = NEW_INTEGER(2));
            INTEGER(vntDim)[0] = m;
            INTEGER(vntDim)[1] = n;
            SET_DIM(vntY, vntDim);
            UNPROTECT(1);
        }
    }

    /* Create Lr value object */
    {
#ifdef DEBUG_RWT
        REprintf("\tcreating 'Lr' value object\n");
#endif
        PROTECT(vntLr = NEW_INTEGER(1));
        INTEGER_POINTER(vntLr)[0] = L;
    }

#ifdef DEBUG_RWT
    REprintf("\tcompute discrete wavelet transform\n");
#endif
    MDWT(x, m, n, h, lh, L, y);

    /* Unprotect params */
    UNPROTECT(2);

#ifdef DEBUG_RWT
    REprintf("\tcreate list output object\n");
#endif
    PROTECT(vntOut = NEW_LIST(2));

#ifdef DEBUG_RWT
    REprintf("\tassigning value objects to list\n");
#endif
    SET_VECTOR_ELT(vntOut, 0, vntY);
    SET_VECTOR_ELT(vntOut, 1, vntLr);

    /* Unprotect value objects */
    UNPROTECT(2);

    {
        SEXP vntNames;

#ifdef DEBUG_RWT
        REprintf("\tassigning names to value objects in list\n");
#endif
        PROTECT(vntNames = NEW_CHARACTER(2));
        SET_STRING_ELT(vntNames, 0, CREATE_STRING_VECTOR("y"));
        SET_STRING_ELT(vntNames, 1, CREATE_STRING_VECTOR("L"));
        SET_NAMES(vntOut, vntNames);
        UNPROTECT(1);
    }

    /* Unprotect output object */
    UNPROTECT(1);

#ifdef DEBUG_RWT
    REprintf("\treturning output...\n");
#endif

    return vntOut;
}
Example #6
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;
}
Example #7
0
SEXP xmethas(
	     SEXP ncif,
	     SEXP cifname,
	     SEXP beta,
	     SEXP ipar,
	     SEXP iparlen,
	     SEXP period,
	     SEXP xprop,
	     SEXP yprop,
	     SEXP mprop,
	     SEXP ntypes,
	     SEXP nrep,
	     SEXP p,
	     SEXP q,
	     SEXP nverb,
	     SEXP nrep0,
	     SEXP x,
	     SEXP y,
	     SEXP marks,
	     SEXP ncond,
	     SEXP fixall,
             SEXP track,
	     SEXP thin,
             SEXP snoopenv,
	     SEXP temper,
	     SEXP invertemp)
{
  char *cifstring;
  double cvd, cvn, qnodds, anumer, adenom, betavalue;
  double *iparvector;
  int verb, marked, tempered, mustupdate, itype;
  int nfree, nsuspect;
  int irep, ix, j, maxchunk, iverb;
  int Ncif; 
  int *plength;
  long Nmore;
  int permitted;
  double invtemp;
  double *xx, *yy, *xpropose, *ypropose;
  int    *mm,      *mpropose, *pp, *aa;
  SEXP out, xout, yout, mout, pout, aout;
  int tracking, thinstart;
#ifdef HISTORY_INCLUDES_RATIO
  SEXP numout, denout;
  double *nn, *dd;
#endif

  State state;
  Model model;
  Algor algo;
  Propo birthprop, deathprop, shiftprop;
  History history;
  Snoop snooper;

  /* The following variables are used only for a non-hybrid interaction */
  Cifns thecif;     /* cif structure */
  Cdata *thecdata;  /* pointer to initialised cif data block */

  /* The following variables are used only for a hybrid interaction */
  Cifns *cif;       /* vector of cif structures */
  Cdata **cdata;    /* vector of pointers to initialised cif data blocks */
  int *needupd;     /* vector of logical values */
  int   k;          /* loop index for cif's */

  /* =================== Protect R objects from garbage collector ======= */

  PROTECT(ncif      = AS_INTEGER(ncif)); 
  PROTECT(cifname   = AS_CHARACTER(cifname)); 
  PROTECT(beta      = AS_NUMERIC(beta)); 
  PROTECT(ipar      = AS_NUMERIC(ipar)); 
  PROTECT(iparlen   = AS_INTEGER(iparlen)); 
  PROTECT(period    = AS_NUMERIC(period)); 
  PROTECT(xprop     = AS_NUMERIC(xprop)); 
  PROTECT(yprop     = AS_NUMERIC(yprop)); 
  PROTECT(mprop     = AS_INTEGER(mprop)); 
  PROTECT(ntypes    = AS_INTEGER(ntypes)); 
  PROTECT(nrep      = AS_INTEGER(nrep)); 
  PROTECT(   p      = AS_NUMERIC(p)); 
  PROTECT(   q      = AS_NUMERIC(q)); 
  PROTECT(nverb     = AS_INTEGER(nverb)); 
  PROTECT(nrep0     = AS_INTEGER(nrep0)); 
  PROTECT(   x      = AS_NUMERIC(x)); 
  PROTECT(   y      = AS_NUMERIC(y)); 
  PROTECT( marks    = AS_INTEGER(marks)); 
  PROTECT(fixall    = AS_INTEGER(fixall)); 
  PROTECT(ncond     = AS_INTEGER(ncond)); 
  PROTECT(track     = AS_INTEGER(track)); 
  PROTECT(thin      = AS_INTEGER(thin)); 
  PROTECT(temper    = AS_INTEGER(temper)); 
  PROTECT(invertemp = AS_NUMERIC(invertemp)); 

                    /* that's 24 protected objects */

  /* =================== Translate arguments from R to C ================ */

  /* 
     Ncif is the number of cif's
     plength[i] is the number of interaction parameters in the i-th cif
  */
  Ncif = *(INTEGER_POINTER(ncif));
  plength = INTEGER_POINTER(iparlen);

  /* copy RMH algorithm parameters */
  algo.nrep   = *(INTEGER_POINTER(nrep));
  algo.nverb  = *(INTEGER_POINTER(nverb));
  algo.nrep0  = *(INTEGER_POINTER(nrep0));
  algo.p = *(NUMERIC_POINTER(p));
  algo.q = *(NUMERIC_POINTER(q));
  algo.fixall = ((*(INTEGER_POINTER(fixall))) == 1);
  algo.ncond =  *(INTEGER_POINTER(ncond));
  algo.tempered = tempered = (*(INTEGER_POINTER(temper)) != 0);
  algo.invtemp  = invtemp  = *(NUMERIC_POINTER(invertemp));

  /* copy model parameters without interpreting them */
  model.beta = NUMERIC_POINTER(beta);
  model.ipar = iparvector = NUMERIC_POINTER(ipar);
  model.period = NUMERIC_POINTER(period);
  model.ntypes = *(INTEGER_POINTER(ntypes));

  state.ismarked = marked = (model.ntypes > 1);
  
  /* copy initial state */
  state.npts   = LENGTH(x);
  state.npmax  = 4 * ((state.npts > 256) ? state.npts : 256);
  state.x = (double *) R_alloc(state.npmax, sizeof(double));
  state.y = (double *) R_alloc(state.npmax, sizeof(double));
  xx = NUMERIC_POINTER(x);
  yy = NUMERIC_POINTER(y);
  if(marked) {
    state.marks =(int *) R_alloc(state.npmax, sizeof(int));
    mm = INTEGER_POINTER(marks);
  }
  if(!marked) {
    for(j = 0; j < state.npts; j++) {
      state.x[j] = xx[j];
      state.y[j] = yy[j];
    }
  } else {
    for(j = 0; j < state.npts; j++) {
      state.x[j] = xx[j];
      state.y[j] = yy[j];
      state.marks[j] = mm[j];
    }
  }
#if MH_DEBUG
  Rprintf("\tnpts=%d\n", state.npts);
#endif

  /* access proposal data */
  xpropose = NUMERIC_POINTER(xprop);
  ypropose = NUMERIC_POINTER(yprop);
  mpropose = INTEGER_POINTER(mprop);
  /* we need to initialise 'mpropose' to keep compilers happy.
     mpropose is only used for marked patterns.
     Note 'mprop' is always a valid pointer */

  
  /* ================= Allocate space for cifs etc ========== */

  if(Ncif > 1) {
    cif = (Cifns *) R_alloc(Ncif, sizeof(Cifns));
    cdata = (Cdata **) R_alloc(Ncif, sizeof(Cdata *));
    needupd = (int *) R_alloc(Ncif, sizeof(int));
  } else {
    /* Keep the compiler happy */
    cif = (Cifns *) R_alloc(1, sizeof(Cifns));
    cdata = (Cdata **) R_alloc(1, sizeof(Cdata *));
    needupd = (int *) R_alloc(1, sizeof(int));
  }


  /* ================= Determine process to be simulated  ========== */
  
  /* Get the cif's */
  if(Ncif == 1) {
    cifstring = (char *) STRING_VALUE(cifname);
    thecif = getcif(cifstring);
    mustupdate = NEED_UPDATE(thecif);
    if(thecif.marked && !marked)
      fexitc("cif is for a marked point process, but proposal data are not marked points; bailing out.");
    /* Keep compiler happy*/
    cif[0] = thecif;
    needupd[0] = mustupdate;
  } else {
    mustupdate = NO;
    for(k = 0; k < Ncif; k++) {
      cifstring = (char *) CHAR(STRING_ELT(cifname, k));
      cif[k] = getcif(cifstring);
      needupd[k] = NEED_UPDATE(cif[k]);
      if(needupd[k])
	mustupdate = YES;
      if(cif[k].marked && !marked)
	fexitc("component cif is for a marked point process, but proposal data are not marked points; bailing out.");
    }
  }
  /* ============= Initialise transition history ========== */

  tracking = (*(INTEGER_POINTER(track)) != 0);
  /* Initialise even if not needed, to placate the compiler */
  if(tracking) { history.nmax = algo.nrep; } else { history.nmax = 1; }
  history.n = 0;
  history.proptype = (int *) R_alloc(history.nmax, sizeof(int));
  history.accepted = (int *) R_alloc(history.nmax, sizeof(int));
#ifdef HISTORY_INCLUDES_RATIO
  history.numerator   = (double *) R_alloc(history.nmax, sizeof(double));
  history.denominator = (double *) R_alloc(history.nmax, sizeof(double));
#endif

  /* ============= Visual debugging ========== */

  /* Active if 'snoopenv' is an environment */


#if MH_DEBUG
  Rprintf("Initialising mhsnoop\n");
#endif

  initmhsnoop(&snooper, snoopenv);

#if MH_DEBUG
  Rprintf("Initialised\n");
  if(snooper.active) Rprintf("Debugger is active.\n");
#endif

  /* ================= Thinning of initial state ==================== */

  thinstart = (*(INTEGER_POINTER(thin)) != 0);

  /* ================= Initialise algorithm ==================== */
 
  /* Interpret the model parameters and initialise auxiliary data */
  if(Ncif == 1) {
    thecdata = (*(thecif.init))(state, model, algo);
    /* keep compiler happy */
    cdata[0] = thecdata;
  } else {
    for(k = 0; k < Ncif; k++) {
      if(k > 0)
	model.ipar += plength[k-1];
      cdata[k] = (*(cif[k].init))(state, model, algo);
    }
    /* keep compiler happy */
    thecdata = cdata[0];
  }

  /* Set the fixed elements of the proposal objects */
  birthprop.itype = BIRTH;
  deathprop.itype = DEATH;
  shiftprop.itype = SHIFT;
  birthprop.ix = NONE;
  if(!marked) 
    birthprop.mrk = deathprop.mrk = shiftprop.mrk = NONE;

  /* Set up some constants */
  verb   = (algo.nverb !=0);
  qnodds = (1.0 - algo.q)/algo.q;


  /* Set value of beta for unmarked process */
  /* (Overwritten for marked process, but keeps compiler happy) */
  betavalue = model.beta[0];

  /* ============= Run Metropolis-Hastings  ================== */

  /* Initialise random number generator */
  GetRNGstate();

/*

  Here comes the code for the M-H loop.

  The basic code (in mhloop.h) is #included many times using different options

  The C preprocessor descends through a chain of files 
       mhv1.h, mhv2.h, ...
  to enumerate all possible combinations of flags.

*/

#include "mhv1.h"

  /* relinquish random number generator */
  PutRNGstate();

  /* ============= Done  ================== */

  /* Create space for output, and copy final state */
  /* Point coordinates */
  PROTECT(xout = NEW_NUMERIC(state.npts));
  PROTECT(yout = NEW_NUMERIC(state.npts));
  xx = NUMERIC_POINTER(xout);
  yy = NUMERIC_POINTER(yout);
  for(j = 0; j < state.npts; j++) {
    xx[j] = state.x[j];
    yy[j] = state.y[j];
  }
  /* Marks */
  if(marked) {
    PROTECT(mout = NEW_INTEGER(state.npts));
    mm = INTEGER_POINTER(mout);
    for(j = 0; j < state.npts; j++) 
      mm[j] = state.marks[j];
  } else {
    /* Keep the compiler happy */
    PROTECT(mout = NEW_INTEGER(1));
    mm = INTEGER_POINTER(mout);
    mm[0] = 0;
  }
  /* Transition history */
  if(tracking) {
    PROTECT(pout = NEW_INTEGER(algo.nrep));
    PROTECT(aout = NEW_INTEGER(algo.nrep));
    pp = INTEGER_POINTER(pout);
    aa = INTEGER_POINTER(aout);
    for(j = 0; j < algo.nrep; j++) {
      pp[j] = history.proptype[j];
      aa[j] = history.accepted[j];
    }
#ifdef HISTORY_INCLUDES_RATIO
    PROTECT(numout = NEW_NUMERIC(algo.nrep));
    PROTECT(denout = NEW_NUMERIC(algo.nrep));
    nn = NUMERIC_POINTER(numout);
    dd = NUMERIC_POINTER(denout);
    for(j = 0; j < algo.nrep; j++) {
      nn[j] = history.numerator[j];
      dd[j] = history.denominator[j];
    }
#endif
  } else {
    /* Keep the compiler happy */
    PROTECT(pout = NEW_INTEGER(1));
    PROTECT(aout = NEW_INTEGER(1));
    pp = INTEGER_POINTER(pout);
    aa = INTEGER_POINTER(aout);
    pp[0] = aa[0] = 0;
#ifdef HISTORY_INCLUDES_RATIO
    PROTECT(numout = NEW_NUMERIC(1));
    PROTECT(denout = NEW_NUMERIC(1));
    nn = NUMERIC_POINTER(numout);
    dd = NUMERIC_POINTER(denout);
    nn[0] = dd[0] = 0;
#endif
  }

  /* Pack up into list object for return */
  if(!tracking) {
    /* no transition history */
    if(!marked) {
      PROTECT(out = NEW_LIST(2));
      SET_VECTOR_ELT(out, 0, xout);
      SET_VECTOR_ELT(out, 1, yout);
    } else {
      PROTECT(out = NEW_LIST(3)); 
      SET_VECTOR_ELT(out, 0, xout);
      SET_VECTOR_ELT(out, 1, yout); 
      SET_VECTOR_ELT(out, 2, mout);
    }
  } else {
    /* transition history */
    if(!marked) {
#ifdef HISTORY_INCLUDES_RATIO
      PROTECT(out = NEW_LIST(6));
#else
      PROTECT(out = NEW_LIST(4));
#endif
      SET_VECTOR_ELT(out, 0, xout);
      SET_VECTOR_ELT(out, 1, yout);
      SET_VECTOR_ELT(out, 2, pout);
      SET_VECTOR_ELT(out, 3, aout);
#ifdef HISTORY_INCLUDES_RATIO
      SET_VECTOR_ELT(out, 4, numout);
      SET_VECTOR_ELT(out, 5, denout);
#endif
      } else {
#ifdef HISTORY_INCLUDES_RATIO
      PROTECT(out = NEW_LIST(7));
#else
      PROTECT(out = NEW_LIST(5)); 
#endif
      SET_VECTOR_ELT(out, 0, xout);
      SET_VECTOR_ELT(out, 1, yout); 
      SET_VECTOR_ELT(out, 2, mout);
      SET_VECTOR_ELT(out, 3, pout);
      SET_VECTOR_ELT(out, 4, aout);
#ifdef HISTORY_INCLUDES_RATIO
      SET_VECTOR_ELT(out, 5, numout);
      SET_VECTOR_ELT(out, 6, denout);
#endif
    }
  }
#ifdef HISTORY_INCLUDES_RATIO
  UNPROTECT(32);  /* 24 arguments plus xout, yout, mout, pout, aout, out,
                            numout, denout */
#else
  UNPROTECT(30);  /* 24 arguments plus xout, yout, mout, pout, aout, out */
#endif
  return(out);
}
Example #8
0
File: euler.c Project: 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;
}
Example #9
0
File: euler.c Project: 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;
}
Example #10
0
//take the elements of a GFF in R and make a GFF object in C; return pointer
//Assume length of vectors are all equal (except optional elements can be NULL)
SEXP rph_gff_new(SEXP seqnameP, SEXP srcP, SEXP featureP, SEXP startP, SEXP endP,
		 SEXP scoreP, SEXP strandP, SEXP frameP, SEXP attributeP) {
  GFF_Set *gff;
  GFF_Feature *feat;
  int gfflen, i;
  int haveScore=0, haveStrand=0, haveFrame=0, haveAttribute=0, numProtect=5;
  String *seqname, *source, *feature, *attribute;
  int *start, *end, frame=GFF_NULL_FRAME, *frameVec=NULL;
  double *scoreVec=NULL, score;
  char strand;

  PROTECT(seqnameP = AS_CHARACTER(seqnameP));
  PROTECT(srcP = AS_CHARACTER(srcP));
  PROTECT(featureP = AS_CHARACTER(featureP));
  PROTECT(startP = AS_INTEGER(startP));
  start = INTEGER_POINTER(startP);
  PROTECT(endP = AS_INTEGER(endP));
  end = INTEGER_POINTER(endP);
  if (scoreP != R_NilValue) {
    PROTECT(scoreP = AS_NUMERIC(scoreP));
    haveScore = 1;
    scoreVec = NUMERIC_POINTER(scoreP);
  } else score=0;
  if (strandP != R_NilValue) {
    PROTECT(strandP = AS_CHARACTER(strandP));
    haveStrand=1;
  } else strand='.';
  if (frameP != R_NilValue) {
    PROTECT(frameP = AS_INTEGER(frameP));
    haveFrame=1;
    frameVec = INTEGER_POINTER(frameP);
  }
  if (attributeP != R_NilValue) {
    PROTECT(attributeP = AS_CHARACTER(attributeP));
    haveAttribute=1;
  }

  numProtect += (haveScore + haveStrand + haveFrame + haveAttribute);

  gfflen = LENGTH(seqnameP);
  gff = gff_new_set_len(gfflen);

  for (i=0; i<gfflen; i++) {
    checkInterruptN(i, 1000);
    seqname = str_new_charstr(CHAR(STRING_ELT(seqnameP, i)));
    source = str_new_charstr(CHAR(STRING_ELT(srcP, i)));
    feature = str_new_charstr(CHAR(STRING_ELT(featureP, i)));
    if (haveScore) score = scoreVec[i];
    if (haveStrand) strand = (CHAR(STRING_ELT(strandP, i)))[0];
    if (haveFrame) {
      if (frameVec[i] == 0) frame = 0;
      else if (frameVec[i] == 1) frame = 2;
      else if (frameVec[i] == 2) frame = 1;
    }
    if (haveAttribute) attribute = str_new_charstr(CHAR(STRING_ELT(attributeP, i)));
    else attribute = str_new_charstr("");

    if (seqname == NULL) die("seqname is NULL\n");
    if (source == NULL) die ("source is NULL\n");
    if (feature ==  NULL) die("feature is NULL\n");
    if (attribute == NULL) die("attribute is NULL\n");
    if (strand != '+' && strand != '-' && strand!='.') die("strand is %c\n", strand);
    if (frame != GFF_NULL_FRAME && (frame<0 || frame>2)) die("frame is %i\n", frame);

    feat = gff_new_feature(seqname, source, feature, start[i], end[i], score, strand,
			   frame, attribute, haveScore==0);
    lst_push_ptr(gff->features, feat);
  }

  UNPROTECT(numProtect);
  return rph_gff_new_extptr(gff);
}
Example #11
0
SEXP objFun_optimalf ( SEXP f, SEXP lsp, SEXP margin, SEXP equity,
  SEXP constrFun, SEXP constrVal, SEXP env )
{
  int P=0;
  
  double *d_fval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
  double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;

  double *d_f       = REAL(PROTECT(AS_NUMERIC(f))); P++;
  double *d_margin, d_equity, maxU;  /* -Wall */

  int len = length(f);

  /* is changing 'lsp' stupid / dangerous? */
  for(int i=0; i < len; i++) {
    d_fval[i] = d_f[i];
  }

  SEXP s_ghpr, s_cval, fcall;
  /* Calculate GHPR */
  PROTECT(s_ghpr = ghpr(lsp)); P++;
  double d_ghpr = -asReal(s_ghpr);

  if(d_ghpr < -1) {
    /* Margin constraint */
    if( !isNull(margin) && !isNull(equity) ) {

      d_margin = REAL(PROTECT(AS_NUMERIC(margin))); P++;
      d_equity = asReal(equity);

      maxU = 0;
      for(int i=0; i < len; i++) {
        maxU += d_f[i] * d_margin[i] / -d_maxloss[i];
      }
      maxU *= d_equity;

      if(maxU > d_equity) {
        d_ghpr = R_PosInf;
      }
    } /* Margin constraint */

    /* Constraint function */
    if( !isNull(constrFun) ) {

      if( !isFunction(constrFun) )
        error("constrFun is not a function");

      PROTECT(fcall = lang3(constrFun, lsp, R_DotsSymbol)); P++;
      PROTECT(s_cval = eval(fcall, env)); P++;

      if( asReal(s_cval) >= asReal(constrVal) ) {
        d_ghpr = R_PosInf;
      }
    }
  } else {
    d_ghpr = R_PosInf;
  }

  UNPROTECT(P);
  return(ScalarReal(d_ghpr));
}
Example #12
0
File: Train.cpp Project: rforge/crf
SEXP CRF_NLL(SEXP _crf, SEXP _par, SEXP _instances, SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt, SEXP _infer, SEXP _env)
{
	CRF crf(_crf);

	int nInstances = INTEGER_POINTER(GET_DIM(_instances))[0];
	int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0];
	int nNodeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.nf")))[0];
	int nEdgeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.ef")))[0];

	PROTECT(_par = AS_NUMERIC(_par));
	double *par = NUMERIC_POINTER(_par);
	double *crfPar = NUMERIC_POINTER(GetVar(_crf, "par"));
	for (int i = 0; i < nPar; i++)
		crfPar[i] = par[i];

	PROTECT(_instances = AS_NUMERIC(_instances));
	double *instances = NUMERIC_POINTER(_instances);

	SEXP _nodePar;
	PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par")));
	int *nodePar = INTEGER_POINTER(_nodePar);

	SEXP _edgePar = GetVar(_crf, "edge.par");
	int **edgePar = (int **) R_alloc(crf.nEdges, sizeof(int *));
	SEXP _edgeParI, _temp;
	PROTECT(_edgeParI = NEW_LIST(crf.nEdges));
	for (int i = 0; i < crf.nEdges; i++)
	{
		SET_VECTOR_ELT(_edgeParI, i, _temp = AS_INTEGER(GetListElement(_edgePar, i)));
		edgePar[i] = INTEGER_POINTER(_temp);
	}

	SEXP _nll = GetVar(_crf, "nll");
	double *nll = NUMERIC_POINTER(_nll);
	*nll = 0.0;

	double *gradient = NUMERIC_POINTER(GetVar(_crf, "gradient"));
	for (int i = 0; i < nPar; i++)
		gradient[i] = 0.0;

	int *y = (int *) R_allocVector<int>(crf.nNodes);

	SEXP _nodeFeaN = _nodeFea;
	SEXP _edgeFeaN = _edgeFea;
	SEXP _nodeExtN = _nodeExt;
	SEXP _edgeExtN = _edgeExt;
	for (int n = 0; n < nInstances; n++)
	{
		if (!isNull(_nodeFea) && isNewList(_nodeFea)) _nodeFeaN = GetListElement(_nodeFea, n);
		if (!isNull(_edgeFea) && isNewList(_edgeFea)) _edgeFeaN = GetListElement(_edgeFea, n);
		if (!isNull(_nodeExt) && isNewList(_nodeExt)) _nodeExtN = GetListElement(_nodeExt, n);
		if (!isNull(_edgeExt) && isNewList(_edgeExt)) _edgeExtN = GetListElement(_edgeExt, n);

		crf.Update_Pot(_nodeFeaN, _edgeFeaN, _nodeExtN, _edgeExtN);

		for (int i = 0; i < crf.nNodes; i++)
			y[i] = instances[n + nInstances * i] - 1;

		SEXP _belief;
		PROTECT(_belief = eval(_infer, _env));

		SEXP _nodeBel;
		PROTECT(_nodeBel = AS_NUMERIC(GetListElement(_belief, "node.bel")));
		double *nodeBel = NUMERIC_POINTER(_nodeBel);

		SEXP _edgeBel = GetListElement(_belief, "edge.bel");
		double **edgeBel = (double **) R_alloc(crf.nEdges, sizeof(double *));
		SEXP _edgeBelI, _temp;
		PROTECT(_edgeBelI = NEW_LIST(crf.nEdges));
		for (int i = 0; i < crf.nEdges; i++)
		{
			SET_VECTOR_ELT(_edgeBelI, i, _temp = AS_NUMERIC(GetListElement(_edgeBel, i)));
			edgeBel[i] = NUMERIC_POINTER(_temp);
		}

		*nll += NUMERIC_POINTER(AS_NUMERIC(GetListElement(_belief, "logZ")))[0] - crf.Get_LogPotential(y);

    if (!isNull(_nodeFeaN))
    {
  		PROTECT(_nodeFeaN = AS_NUMERIC(_nodeFeaN));
  		double *nodeFea = NUMERIC_POINTER(_nodeFeaN);
  		if (!ISNAN(nodeFea[0]))
  		{
  			for (int i = 0; i < crf.nNodes; i++)
  			{
  				int s = y[i];
  				for (int j = 0; j < nNodeFea; j++)
  				{
  					double f = nodeFea[j + nNodeFea * i];
  					if (f != 0)
  					{
  						for (int k = 0; k < crf.nStates[i]; k++)
  						{
  							int p = nodePar[i + crf.nNodes * (k + crf.maxState * j)] - 1;
  							if (p >= 0 && p < nPar)
  							{
  								if (k == s)
  								{
  									gradient[p] -= f;
  								}
  								gradient[p] += f * nodeBel[i + crf.nNodes * k];
  							}
  						}
  					}
  				}
  			}
  		}
      UNPROTECT(1);
    }

    if (!isNull(_edgeFeaN))
    {
  		PROTECT(_edgeFeaN = AS_NUMERIC(_edgeFeaN));
  		double *edgeFea = NUMERIC_POINTER(_edgeFeaN);
  		if (!ISNAN(edgeFea[0]))
  		{
  			for (int i = 0; i < crf.nEdges; i++)
  			{
  				int s = y[crf.EdgesBegin(i)] + crf.nStates[crf.EdgesBegin(i)] * y[crf.EdgesEnd(i)];
  				for (int j = 0; j < nEdgeFea; j++)
  				{
  					double f = edgeFea[j + nEdgeFea * i];
  					if (f != 0)
  					{
  						for (int k = 0; k < crf.nEdgeStates[i]; k++)
  						{
  							int p = edgePar[i][k + crf.nEdgeStates[i] * j] - 1;
  							if (p >= 0 && p < nPar)
  							{
  								if (k == s)
  								{
  									gradient[p] -= f;
  								}
  								gradient[p] += f * edgeBel[i][k];
  							}
  						}
  					}
  				}
  			}
  		}
      UNPROTECT(1);
    }

		if (!isNull(_nodeExtN) && isNewList(_nodeExtN))
		{
			for (int i = 0; i < nPar; i++)
			{
				SEXP _nodeExtI = GetListElement(_nodeExtN, i);
        if (!isNull(_nodeExtI))
        {
  				PROTECT(_nodeExtI = AS_NUMERIC(_nodeExtI));
  				double *nodeExt = NUMERIC_POINTER(_nodeExtI);
  				if (!ISNAN(nodeExt[0]))
  				{
  					for (int j = 0; j < crf.nNodes; j++)
  					{
  						int s = y[j];
  						for (int k = 0; k < crf.nStates[j]; k++)
  						{
  							double f = nodeExt[j + crf.nNodes * k];
  							if (k == s)
  							{
  								gradient[i] -= f;
  							}
  							gradient[i] += f * nodeBel[j + crf.nNodes * k];
  						}
  					}
  				}
          UNPROTECT(1);
        }
			}
		}

		if (!isNull(_edgeExtN) && isNewList(_edgeExtN))
		{
			for (int i = 0; i < nPar; i++)
			{
				SEXP _edgeExtI = GetListElement(_edgeExtN, i);
				if (!isNull(_edgeExtI) && isNewList(_edgeExtI))
				{
					for (int j = 0; j < crf.nEdges; j++)
					{
						SEXP _edgeExtII = GetListElement(_edgeExtI, j);
            if (!isNull(_edgeExtII))
            {
  						PROTECT(_edgeExtII = AS_NUMERIC(_edgeExtII));
  						double *edgeExt = NUMERIC_POINTER(_edgeExtII);
  						if (!ISNAN(edgeExt[0]))
  						{
  							int s = y[crf.EdgesBegin(j)] + crf.nStates[crf.EdgesBegin(j)] * y[crf.EdgesEnd(j)];
  							for (int k = 0; k < crf.nEdgeStates[j]; k++)
  							{
  								double f = edgeExt[k];
  								if (k == s)
  								{
  									gradient[i] -= f;
  								}
  								gradient[i] += f * edgeBel[j][k];
  							}
  						}
              UNPROTECT(1);
            }
					}
				}
			}
		}

		UNPROTECT(3);
	}

	UNPROTECT(4);

	return(_nll);
}
Example #13
0
File: Train.cpp Project: rforge/crf
SEXP MRF_NLL(SEXP _crf, SEXP _par, SEXP _instances, SEXP _infer, SEXP _env)
{
	CRF crf(_crf);

	int nInstances = INTEGER_POINTER(GET_DIM(_instances))[0];
	int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0];

	PROTECT(_par = AS_NUMERIC(_par));
	double *par = NUMERIC_POINTER(_par);
	double *crfPar = NUMERIC_POINTER(GetVar(_crf, "par"));
	for (int i = 0; i < nPar; i++)
		crfPar[i] = par[i];

	SEXP _parStat;
	PROTECT(_parStat = AS_NUMERIC(GetVar(_crf, "par.stat")));
	double *parStat = NUMERIC_POINTER(_parStat);

	SEXP _nll = GetVar(_crf, "nll");
	double *nll = NUMERIC_POINTER(_nll);
	*nll = 0.0;

	double *gradient = NUMERIC_POINTER(GetVar(_crf, "gradient"));
	for (int i = 0; i < nPar; i++)
		gradient[i] = 0.0;

	crf.Update_Pot();

	SEXP _belief;
	PROTECT(_belief = eval(_infer, _env));

	*nll = NUMERIC_POINTER(AS_NUMERIC(GetListElement(_belief, "logZ")))[0] * nInstances;
	for (int i = 0; i < nPar; i++)
	{
		*nll -= par[i] * parStat[i];
		gradient[i] = -parStat[i];
	}

	SEXP _nodePar, _nodeBel;
	PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par")));
	PROTECT(_nodeBel = AS_NUMERIC(GetListElement(_belief, "node.bel")));
	int *nodePar = INTEGER_POINTER(_nodePar);
	double *nodeBel = NUMERIC_POINTER(_nodeBel);
	for (int i = 0; i < crf.nNodes; i++)
	{
		for (int k = 0; k < crf.nStates[i]; k++)
		{
			int p = nodePar[i + crf.nNodes * k] - 1;
			if (p >= 0 && p < nPar)
			{
				gradient[p] += nodeBel[i + crf.nNodes * k] * nInstances;
			}
		}
	}

	SEXP _edgePar = GetVar(_crf, "edge.par");
	SEXP _edgeBel = GetListElement(_belief, "edge.bel");
	SEXP _edgeParI, _edgeBelI, _temp;
	PROTECT(_edgeParI = NEW_LIST(crf.nEdges));
	PROTECT(_edgeBelI = NEW_LIST(crf.nEdges));
	for (int i = 0; i < crf.nEdges; i++)
	{
		SET_VECTOR_ELT(_edgeParI, i, _temp = AS_INTEGER(GetListElement(_edgePar, i)));
	  int *edgePar = INTEGER_POINTER(_temp);
	  SET_VECTOR_ELT(_edgeBelI, i, _temp = AS_NUMERIC(GetListElement(_edgeBel, i)));
		double *edgeBel = NUMERIC_POINTER(_temp);
		for (int k = 0; k < crf.nEdgeStates[i]; k++)
		{
			int p = edgePar[k] - 1;
			if (p >= 0 && p < nPar)
			{
				gradient[p] += edgeBel[k] * nInstances;
			}
		}
	}

	UNPROTECT(7);

	return(_nll);
}
Example #14
0
File: Train.cpp Project: rforge/crf
void CRF::Update_Pot(SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt)
{
	int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0];

	SEXP _par;
	PROTECT(_par = AS_NUMERIC(GetVar(_crf, "par")));
	double *par = NUMERIC_POINTER(_par);

	for (int i = 0; i < nNodes * maxState; i++)
		nodePot[i] = 0;
	for (int i = 0; i < nEdges; i++)
		for (int j = 0; j < nEdgeStates[i]; j++)
			edgePot[i][j] = 0;

  if (!isNull(_nodeFea))
  {
    PROTECT(_nodeFea = AS_NUMERIC(_nodeFea));
  	double *nodeFea = NUMERIC_POINTER(_nodeFea);
  	if (!ISNAN(nodeFea[0]))
  	{
  		int nNodeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.nf")))[0];
  		SEXP _nodePar;
  		PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par")));
  		int *nodePar = INTEGER_POINTER(_nodePar);
  		for (int i = 0; i < nNodes; i++)
  		{
  			for (int j = 0; j < nNodeFea; j++)
  			{
  				double f = nodeFea[j + nNodeFea * i];
  				if (f != 0)
  					for (int k = 0; k < nStates[i]; k++)
  					{
  						int p = nodePar[i + nNodes * (k + maxState * j)] - 1;
  						if (p >= 0 && p < nPar)
  							nodePot[i + nNodes * k] += f * par[p];
  					}
  			}
  		}
  		UNPROTECT(1);
  	}
    UNPROTECT(1);
  }

  if (!isNull(_edgeFea))
  {
  	PROTECT(_edgeFea = AS_NUMERIC(_edgeFea));
  	double *edgeFea = NUMERIC_POINTER(_edgeFea);
  	if (!ISNAN(edgeFea[0]))
  	{
  		int nEdgeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.ef")))[0];
  		SEXP _edgePar = GetVar(_crf, "edge.par");
  		for (int i = 0; i < nEdges; i++)
  		{
  			SEXP _edgeParI;
  			PROTECT(_edgeParI = AS_INTEGER(GetListElement(_edgePar, i)));
  			int *edgePar = INTEGER_POINTER(_edgeParI);
  			for (int j = 0; j < nEdgeFea; j++)
  			{
  				double f = edgeFea[j + nEdgeFea * i];
  				if (f != 0)
  					for (int k = 0; k < nEdgeStates[i]; k++)
  					{
  						int p = edgePar[k + nEdgeStates[i] * j] - 1;
  						if (p >= 0 && p < nPar)
  							edgePot[i][k] += f * par[p];
  					}
  			}
  			UNPROTECT(1);
  		}
  	}
    UNPROTECT(1);
  }

	if (!isNull(_nodeExt) && isNewList(_nodeExt))
	{
		for (int i = 0; i < nPar; i++)
		{
			SEXP _nodeExtI = GetListElement(_nodeExt, i);
      if (!isNull(_nodeExtI))
      {
  			PROTECT(_nodeExtI = AS_NUMERIC(_nodeExtI));
  			double *nodeExt = NUMERIC_POINTER(_nodeExtI);
  			if (!ISNAN(nodeExt[0]))
  			{
  				for (int j = 0; j < nNodes; j++)
  				{
  					for (int k = 0; k < nStates[j]; k++)
  					{
  						nodePot[j + nNodes * k] += nodeExt[j + nNodes * k] * par[i];
  					}
  				}
  			}
        UNPROTECT(1);
      }
		}
	}

	if (!isNull(_edgeExt) && isNewList(_edgeExt))
	{
		for (int i = 0; i < nPar; i++)
		{
			SEXP _edgeExtI = GetListElement(_edgeExt, i);
			if (!isNull(_edgeExtI) && isNewList(_edgeExtI))
			{
				for (int j = 0; j < nEdges; j++)
				{
					SEXP _edgeExtII = GetListElement(_edgeExtI, j);
          if (!isNull(_edgeExtII))
          {
  					PROTECT(_edgeExtII = AS_NUMERIC(_edgeExtII));
  					double *edgeExt = NUMERIC_POINTER(_edgeExtII);
  					if (!ISNAN(edgeExt[0]))
  					{
  						for (int k = 0; k < nEdgeStates[j]; k++)
  						{
  							edgePot[j][k] += edgeExt[k] * par[i];
  						}
  					}
            UNPROTECT(1);
          }
				}
			}
		}
	}

	for (int i = 0; i < nNodes * maxState; i++)
		nodePot[i] = exp(nodePot[i]);
	for (int i = 0; i < nEdges; i++)
		for (int j = 0; j < nEdgeStates[i]; j++)
			edgePot[i][j] = exp(edgePot[i][j]);

	UNPROTECT(1);
}
  SEXP fastcluster(SEXP const N_, SEXP const method_, SEXP D_, SEXP members_) {
    SEXP r = NULL; // return value

    try{
      /*
        Input checks
      */
      // Parameter N: number of data points
      PROTECT(N_);
      if (!IS_INTEGER(N_) || LENGTH(N_)!=1)
        Rf_error("'N' must be a single integer.");
      const int N = *INTEGER_POINTER(N_);
      if (N<2)
        Rf_error("N must be at least 2.");
      const std::ptrdiff_t NN = static_cast<std::ptrdiff_t>(N)*(N-1)/2;
      UNPROTECT(1); // N_

      // Parameter method: dissimilarity index update method
      PROTECT(method_);
      if (!IS_INTEGER(method_) || LENGTH(method_)!=1)
        Rf_error("'method' must be a single integer.");
      const int method = *INTEGER_POINTER(method_) - 1; // index-0 based;
      if (method<METHOD_METR_SINGLE || method>METHOD_METR_MEDIAN) {
        Rf_error("Invalid method index.");
      }
      UNPROTECT(1); // method_

      // Parameter members: number of members in each node
      auto_array_ptr<t_float> members;
      if (method==METHOD_METR_AVERAGE ||
          method==METHOD_METR_WARD ||
          method==METHOD_METR_CENTROID) {
        members.init(N);
        if (Rf_isNull(members_)) {
          for (t_index i=0; i<N; ++i) members[i] = 1;
        }
        else {
          PROTECT(members_ = AS_NUMERIC(members_));
          if (LENGTH(members_)!=N)
            Rf_error("'members' must have length N.");
          const t_float * const m = NUMERIC_POINTER(members_);
          for (t_index i=0; i<N; ++i) members[i] = m[i];
          UNPROTECT(1); // members
        }
      }

      // Parameter D_: dissimilarity matrix
      PROTECT(D_ = AS_NUMERIC(D_));
      if (LENGTH(D_)!=NN)
        Rf_error("'D' must have length (N \\choose 2).");
      const double * const D = NUMERIC_POINTER(D_);
      // Make a working copy of the dissimilarity array
      // for all methods except "single".
      auto_array_ptr<double> D__;
      if (method!=METHOD_METR_SINGLE) {
        D__.init(NN);
        for (std::ptrdiff_t i=0; i<NN; ++i)
          D__[i] = D[i];
      }
      UNPROTECT(1); // D_

      /*
        Clustering step
      */
      cluster_result Z2(N-1);
      switch (method) {
      case METHOD_METR_SINGLE:
        MST_linkage_core(N, D, Z2);
        break;
      case METHOD_METR_COMPLETE:
        NN_chain_core<METHOD_METR_COMPLETE, t_float>(N, D__, NULL, Z2);
        break;
      case METHOD_METR_AVERAGE:
        NN_chain_core<METHOD_METR_AVERAGE, t_float>(N, D__, members, Z2);
        break;
      case METHOD_METR_WEIGHTED:
        NN_chain_core<METHOD_METR_WEIGHTED, t_float>(N, D__, NULL, Z2);
        break;
      case METHOD_METR_WARD:
        NN_chain_core<METHOD_METR_WARD, t_float>(N, D__, members, Z2);
        break;
      case METHOD_METR_CENTROID:
        generic_linkage<METHOD_METR_CENTROID, t_float>(N, D__, members, Z2);
        break;
      case METHOD_METR_MEDIAN:
        generic_linkage<METHOD_METR_MEDIAN, t_float>(N, D__, NULL, Z2);
        break;
      default:
        throw std::runtime_error(std::string("Invalid method."));
      }

      D__.free();     // Free the memory now
      members.free(); // (not strictly necessary).

      SEXP m; // return field "merge"
      PROTECT(m = NEW_INTEGER(2*(N-1)));
      int * const merge = INTEGER_POINTER(m);

      SEXP dim_m; // Specify that m is an (N-1)×2 matrix
      PROTECT(dim_m = NEW_INTEGER(2));
      INTEGER(dim_m)[0] = N-1;
      INTEGER(dim_m)[1] = 2;
      SET_DIM(m, dim_m);

      SEXP h; // return field "height"
      PROTECT(h = NEW_NUMERIC(N-1));
      double * const height = NUMERIC_POINTER(h);

      SEXP o; // return fiels "order'
      PROTECT(o = NEW_INTEGER(N));
      int * const order = INTEGER_POINTER(o);

      if (method==METHOD_METR_CENTROID ||
          method==METHOD_METR_MEDIAN)
        generate_R_dendrogram<true>(merge, height, order, Z2, N);
      else
        generate_R_dendrogram<false>(merge, height, order, Z2, N);

      SEXP n; // names
      PROTECT(n = NEW_CHARACTER(3));
      SET_STRING_ELT(n, 0, COPY_TO_USER_STRING("merge"));
      SET_STRING_ELT(n, 1, COPY_TO_USER_STRING("height"));
      SET_STRING_ELT(n, 2, COPY_TO_USER_STRING("order"));

      PROTECT(r = NEW_LIST(3)); // field names in the output list
      SET_ELEMENT(r, 0, m);
      SET_ELEMENT(r, 1, h);
      SET_ELEMENT(r, 2, o);
      SET_NAMES(r, n);

      UNPROTECT(6); // m, dim_m, h, o, r, n
    } // try
    catch (const std::bad_alloc&) {
      Rf_error( "Memory overflow.");
    }
    catch(const std::exception& e){
      Rf_error( e.what() );
    }
    catch(const nan_error&){
      Rf_error("NaN dissimilarity value.");
    }
    #ifdef FE_INVALID
    catch(const fenv_error&){
      Rf_error( "NaN dissimilarity value in intermediate results.");
    }
    #endif
    catch(...){
      Rf_error( "C++ exception (unknown reason)." );
    }

    return r;
  }
Example #16
0
File: util_win.c Project: cran/brnn
//This function will calculate the Jocobian for the errors
SEXP jacobian_(SEXP X, SEXP n, SEXP p, SEXP theta, SEXP neurons,SEXP J, SEXP reqCores)
{
   int i,j,k;
   double z,dtansig;
   double *pX;
   double *ptheta;
   double *pJ;
   int rows, columns, nneurons;

   SEXP list;

   rows=INTEGER_VALUE(n);
   columns=INTEGER_VALUE(p);
   nneurons=INTEGER_VALUE(neurons);
  
   PROTECT(X=AS_NUMERIC(X));
   pX=NUMERIC_POINTER(X);
   
   PROTECT(theta=AS_NUMERIC(theta));
   ptheta=NUMERIC_POINTER(theta);
   
   PROTECT(J=AS_NUMERIC(J));
   pJ=NUMERIC_POINTER(J);
   
  for(i=0; i<rows; i++)
  {
                //Rprintf("i=%d\n",i);
     		for(k=0; k<nneurons; k++)
     		{
	  		z=0;
	  		for(j=0;j<columns;j++)
	  		{
	      			z+=pX[i+(j*rows)]*ptheta[(columns+2)*k+j+2]; 
	  		}
	  		z+=ptheta[(columns+2)*k+1];
	  		dtansig=pow(sech(z),2.0);
	  
	  		/*
	  		 Derivative with respect to the weight
	  		*/
	  		pJ[i+(((columns+2)*k)*rows)]=-tansig(z);
	 
	  		/*
	  		Derivative with respect to the bias
	 		*/
	 
	 		pJ[i+(((columns+2)*k+1)*rows)]=-ptheta[(columns+2)*k]*dtansig;

	 		/*
	  		 Derivate with respect to the betas
	  		*/
	 		for(j=0; j<columns;j++)
	 		{
	     			pJ[i+(((columns+2)*k+j+2)*rows)]=-ptheta[(columns+2)*k]*dtansig*pX[i+(j*rows)];
	 		}
     		}
  }
  
  PROTECT(list=allocVector(VECSXP,1));
  SET_VECTOR_ELT(list,0,J);
  
  UNPROTECT(4);
   
  return(list);
}
Example #17
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;
  }
}
Example #18
0
/**********************************************************************
 * C Code Documentation ************************************************
 **********************************************************************
   NAME time_time_add

   DESCRIPTION  Add or subtract two time or time span objects.
   To be called from R as 
   \\
   {\tt 
   .Call("time_time_add", time1, time2, add.sign, ret.class)
   }
   where TIMECLASS is replaced by the name of the time or time
   span classes passed in those arguments.

   ARGUMENTS
      IARG  time1     The first R time or time span vector object
      IARG  time2     The second R time or time span vector object
      IARG  sign      Either +1. or -1., to add or subtract the second
      IARG  ret_class Return class, as a character string.

   RETURN Returns a time or time span vector (depending on ret_class) 
   that is the sum or difference of the input time and time span vectors.

   ALGORITHM  Each element of the second object is added to or subtracted
   from the corresponding element of the first object, by combining their
   days and milliseconds and then carrying milliseconds over into days
   as necessary using the adjust_time or adjust_span functions.  
   No special time zones or formats are put on the returned object.
   If one of the two vectors has a length that is a multiple of the other,
   the shorter one is repeated.

   EXCEPTIONS 

   NOTE See also: time_num_op, time_rel_add

**********************************************************************/
SEXP time_time_add( SEXP time1, SEXP time2, 
		    SEXP sign, SEXP ret_class )
{

  SEXP ret;
  double *in_sign;
  Sint *in_days1, *in_ms1, *in_days2, *in_ms2, *out_days, *out_ms;
  Sint i, lng1, lng2, lng, ind1, ind2, sign_na, is_span, tmp;
  const char *in_class;

  /* get the desired parts of the time objects */

  if( !time_get_pieces( time1, NULL, &in_days1, &in_ms1, &lng1, NULL, 
			NULL, NULL ))
    error( "Invalid time1 argument in C function time_time_add" );
  if(  !time_get_pieces( time2, NULL, &in_days2, &in_ms2, &lng2, NULL, 
			 NULL, NULL ))
    error( "Invalid time2 argument in C function time_time_add" );

  if(lng1 && lng2 && ( lng1 % lng2 ) && ( lng2 % lng1 ))
    error( "Length of longer operand is not a multiple of length of shorter in C function time_time_add" );

  /* get the sign and class */
  PROTECT(sign = AS_NUMERIC(sign));
  in_sign = REAL(sign);
  if( length(sign) < 1L ){
    UNPROTECT(5);
    error( "Problem extracting sign argument in C function time_time_add" );    
  }

  sign_na = (Sint) ISNA( *in_sign );

  if( !isString(ret_class) || length(ret_class) < 1L){
    UNPROTECT(5);
    error( "Problem extracting class argument in C function time_time_add" );    
  }
  in_class = (char *) CHAR(STRING_ELT(ret_class, 0));

  /* create output time or time span object */
  if( !lng1 || !lng2 )
    lng = 0;
  else if( lng2 > lng1 )
    lng = lng2;
  else
    lng = lng1;
  
  is_span = 1;
  if( !strcmp( in_class, TIME_CLASS_NAME ))
  {
    is_span = 0;
    PROTECT(ret = time_create_new( lng, &out_days, &out_ms ));
  }
  else if( !strcmp( in_class, TSPAN_CLASS_NAME ))
    PROTECT(ret = tspan_create_new( lng, &out_days, &out_ms ));
  else{
    UNPROTECT(5);
    error( "Unknown class argument in C function time_time_add" );
  }

  if( !ret || !out_days || !out_ms )
    error( "Could not create return object in C function time_time_add" );

  /* go through input and add */
  for( i = 0; i < lng; i++ )
  {
    ind1 = i % lng1;
    ind2 = i % lng2;

    /* check for NA */
    if( sign_na ||
	 in_days1[ind1] ==NA_INTEGER || 
	 in_ms1[ind1] ==NA_INTEGER ||
	 in_days2[ind2] ==NA_INTEGER || 
	 in_ms2[ind2] ==NA_INTEGER)
    {
      out_days[i] = NA_INTEGER;
      out_ms[i] = NA_INTEGER;
      continue;
    }

    /* add and adjust output */
    out_days[i] = in_days1[ind1] + *in_sign * in_days2[ind2];
    out_ms[i] = in_ms1[ind1] + *in_sign * in_ms2[ind2];
    if( is_span )
      tmp = adjust_span( &(out_days[i]), &(out_ms[i] ));
    else
      tmp = adjust_time( &(out_days[i]), &(out_ms[i] ));

    if( !tmp )
    {
      out_days[i] = NA_INTEGER;
      out_ms[i] = NA_INTEGER;
      continue;
    }

  }

  UNPROTECT(6); //2+4 from time_get_pieces
  return ret;
}
Example #19
0
SEXP R_THD_write_dset(SEXP Sfname, SEXP Sdset, SEXP Opts)
{
   SEXP Rdset, brik, head, names, opt, node_list;
   int i=0, ip=0, sb, cnt=0, scale = 1, overwrite=0, addFDR=0, 
       kparts=2, *iv=NULL;
   char *fname = NULL, *head_str, *stmp=NULL, *hist=NULL;
   NI_group *ngr=NULL;
   NI_element *nel=NULL;
   char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose 
                                         for backward compatibility */
   double *dv=NULL;
   float *fv=NULL;
   THD_3dim_dataset *dset = NULL;
   int debug=0;
   
   if (!debug) debug = get_odebug();

   /* get the options list, maybe */
   PROTECT(Opts = AS_LIST(Opts));
   if ((opt = getListElement(Opts,"debug")) != R_NilValue) {
	   debug = (int)INTEGER_VALUE(opt);
      if (debug>2) set_odebug(debug);
	   if (debug > 1) INFO_message("Debug is %d\n", debug);
   }
   
   /* get the filename */
   PROTECT(Sfname = AS_CHARACTER(Sfname));
   fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char));
   strcpy(fname, CHAR(STRING_ELT(Sfname,0)));
   if (debug >1) INFO_message("Output filename %s\n"
                          , fname);
   
   /* get the dset structure elements */
   PROTECT(Rdset = AS_LIST(Sdset));
   if ((head = AS_CHARACTER(getListElement(Rdset,"head"))) == R_NilValue) {
      ERROR_message("No header found");
      UNPROTECT(3);
      return(R_NilValue);
   }
   if (debug > 1) INFO_message("First head element %s\n"
                          , CHAR(STRING_ELT(head,0)));
   if ((brik = AS_NUMERIC(getListElement(Rdset,"brk"))) == R_NilValue) {
      ERROR_message("No brick found");
      UNPROTECT(3);
      return(R_NilValue);
   }
   dv = NUMERIC_POINTER(brik);
   if (debug > 1) INFO_message("First brik value %f\n"
                          , dv[0]);
   
                          
   ngr = NI_new_group_element();
   NI_rename_group(ngr, "AFNI_dataset" );
   NI_set_attribute(ngr,"AFNI_prefix", fname);
   if ((opt = getListElement(Opts,"idcode")) != R_NilValue) {
   	opt = AS_CHARACTER(opt);
	   stmp = (char *)(CHAR(STRING_ELT(opt,0)));
      if (stmp && !strcmp(stmp,"SET_AT_WRITE_FILENAME")) {
         stmp = UNIQ_hashcode(fname);
         NI_set_attribute(ngr, "AFNI_idcode", stmp);
         free(stmp);
      } else if (stmp && !strcmp(stmp,"SET_AT_WRITE_RANDOM")) {
         stmp = UNIQ_idcode() ;
         NI_set_attribute(ngr, "AFNI_idcode", stmp);
         free(stmp);
      } else if (stmp) {
         NI_set_attribute(ngr, "AFNI_idcode",
			   (char *)(CHAR(STRING_ELT(opt,0)))); 	
      }
   }
   if ((opt = getListElement(Opts,"scale")) != R_NilValue) {
	   scale = (int)INTEGER_VALUE(opt);
	   if (debug > 1) INFO_message("Scale is %d\n", scale);
   }
   if ((opt = getListElement(Opts,"overwrite")) != R_NilValue) {
	   overwrite = (int)INTEGER_VALUE(opt);
      if (debug > 1) INFO_message("overwrite is %d\n", overwrite); 	
      THD_force_ok_overwrite(overwrite) ;
      if (overwrite) THD_set_quiet_overwrite(1);
   }	
   if ((opt = getListElement(Opts,"addFDR")) != R_NilValue) {
	   addFDR = (int)INTEGER_VALUE(opt);
      if (debug > 1) INFO_message("addFDR is %d\n", addFDR); 	
   }
   
   PROTECT(opt = getListElement(Opts,"hist"));
   if ( opt != R_NilValue) {
	   opt = AS_CHARACTER(opt);
      hist = R_alloc(strlen(CHAR(STRING_ELT(opt,0)))+1, sizeof(char));
      strcpy(hist, CHAR(STRING_ELT(opt,0))); 
      if (debug > 1) INFO_message("hist is %s\n", hist); 	
   }
   UNPROTECT(1);
   
   for (ip=0,i=0; i<length(head); ++i) {
      head_str = (char *)CHAR(STRING_ELT(head,i));
      if (debug > 1) {
         INFO_message("Adding %s\n", head_str);
      }
      nel = NI_read_element_fromstring(head_str);
      if (!nel->vec) {
         ERROR_message("Empty attribute vector for\n%s\n"
                       "This is not expected.\n",
                       head_str);
         UNPROTECT(3);
         return(R_NilValue);
      }
      NI_add_to_group(ngr,nel);
   }
   
   if (debug > 1) INFO_message("Creating dset header\n");
   if (!(dset = THD_niml_to_dataset(ngr, 1))) {
      ERROR_message("Failed to create header");
      UNPROTECT(3);
      return(R_NilValue);
   }
   if (debug > 2) {
         INFO_message("Have header of %d, %d, %d, %d, scale=%d\n", 
                       DSET_NX(dset), DSET_NY(dset), 
                       DSET_NZ(dset), DSET_NVALS(dset), scale);
   }
   
   for (i=0; i<DSET_NVALS(dset); ++i) {
      if (debug > 2) {
         INFO_message("Putting values in sub-brick %d, type %d\n", 
                       i, DSET_BRICK_TYPE(dset,i));
      }
                            
      if (  ( DSET_BRICK_TYPE(dset,i) == MRI_byte || 
      	     DSET_BRICK_TYPE(dset,i) == MRI_short ) ) {
         EDIT_substscale_brick(dset, i, 
                            MRI_double, dv+i*DSET_NVOX(dset),
                            DSET_BRICK_TYPE(dset,i), scale ? -1.0:1.0);
      } else if ( DSET_BRICK_TYPE(dset,i) == MRI_double ) {
        EDIT_substitute_brick(dset, i, 
                            MRI_double, dv+i*DSET_NVOX(dset));
      } else if ( DSET_BRICK_TYPE(dset,i) == MRI_float ) {
        float *ff=(float*)calloc(DSET_NVOX(dset), sizeof(float));
        double *dvi=dv+i*DSET_NVOX(dset);
        for (ip=0; ip<DSET_NVOX(dset); ++ip) {
         ff[ip] = dvi[ip];
        }
        EDIT_substitute_brick(dset, i, MRI_float, ff);
      }
   }
   
   /* THD_update_statistics( dset ) ; */
   
   if (addFDR) {
      DSET_BRICK_FDRCURVE_ALLKILL(dset) ;
      DSET_BRICK_MDFCURVE_ALLKILL(dset) ;  /* 22 Oct 2008 */
      if( addFDR > 0 ){
         int  nFDRmask=0;    /* in the future, perhaps allow for a mask */
         byte *FDRmask=NULL; /* to be sent in also, for now, mask is exact */
                             /* 0 voxels . */
         mri_fdr_setmask( (nFDRmask == DSET_NVOX(dset)) ? FDRmask : NULL ) ;
         ip = THD_create_all_fdrcurves(dset) ;
         if( ip > 0 ){
            if (debug) 
               ININFO_message("created %d FDR curve%s in dataset header",
                              ip,(ip==1)?"\0":"s") ;
         } else {
            if (debug) 
               ININFO_message("failed to create FDR curves in dataset header") ;
         }
      }
   }
   
   /* Do we have an index_list? */
   if ((node_list=AS_INTEGER(getListElement(Rdset,"index_list")))!=R_NilValue) {
      iv = INTEGER_POINTER(node_list);
      if (debug > 1) INFO_message("First node index value %d, total (%d)\n", 
                                  iv[0], length(node_list));
      dset->dblk->nnodes = length(node_list);
      dset->dblk->node_list = (int *)XtMalloc(dset->dblk->nnodes * sizeof(int));
      memcpy(dset->dblk->node_list, iv, dset->dblk->nnodes*sizeof(int));
   }
   
   if (hist) {
      tross_Append_History(dset, hist);
   }
   
   DSET_write(dset); 
  
   UNPROTECT(3);
   return(R_NilValue);  
}
Example #20
0
/**********************************************************************
 * C Code Documentation ************************************************
 **********************************************************************
   NAME time_num_op

   DESCRIPTION  Perform an arithmetic operation between a time or
   time span and a numeric.  Supported operations are "+", "-", 
   "*", and "/".    To be called from R as 
   \\
   {\tt 
   .Call("time_num_op", time_vec, num_vec, op)
   }
   where TIMECLASS is replaced by the name of the time or time
   span class.

   ARGUMENTS
      IARG  time_vec    The R time or time span vector object
      IARG  num_vec     The numeric vector object
      IARG  op          Character string giving the operation

   RETURN Returns a time or time span vector (same as passed in class)
   that is the result of time_vec op num_vec.

   ALGORITHM  Addition and subtraction are performed by combining the integer 
   part of the numeric with the julian days of the time and the fractional 
   part of the numeric (converted from fraction of a day to milliseconds)
   to the milliseconds of the time object.  Multiplication and division
   are performed by converting the time object to a numeric with its
   integer part the number of days and fractional part the fraction of
   the day (found by the ms_to_fraction function), multiplying or dividing, 
   and then converting back. 
   No special time zones or formats are put on the returned object.
   If one of the two vectors has a length that is a multiple of the other,
   the shorter one is repeated.

   EXCEPTIONS 

   NOTE See also: time_time_add, time_rel_add

**********************************************************************/
SEXP time_num_op( SEXP time_vec, SEXP num_vec, SEXP op )
{

  SEXP ret;
  double *in_nums, tmpdbl;
  Sint *in_days, *in_ms, *out_days, *out_ms, add_sign;
  Sint i, lng1, lng2, lng, ind1, ind2, is_span, is_ok, tmp;
  const char *in_op;

  /* get the desired parts of the time object */

  if( !time_get_pieces( time_vec, NULL, &in_days, &in_ms, &lng1, NULL, 
			NULL, NULL ))
    error( "Invalid time argument in C function time_num_op" );

  /* extract other input data */
  PROTECT( num_vec = (SEXP) AS_NUMERIC(num_vec) );
  if( (lng2 = length(num_vec)) < 1L){
    UNPROTECT(3);
    error( "Problem extracting numeric argument in C function time_num_op" );
  }
  in_nums = REAL(num_vec);

  if(lng1 && lng2 && ( lng1 % lng2 ) && ( lng2 % lng1 )){
    UNPROTECT(3);
    error( "Length of longer operand is not a multiple of length of shorter in C function time_num_op" );
  }

  if( !isString(op) || length(op) < 1L){
    UNPROTECT(3);
    error( "Problem extracting operation argument in C function time_num_op" ); 
  }
  if( length(op) > 1L )
    warning( "Using only the first string in operation argument in C function time_num_op" );
  in_op = CHAR(STRING_ELT(op, 0));

  if(( *in_op != '*' ) && ( *in_op != '+' ) && ( *in_op != '-' ) && 
     ( *in_op != '/' )){
    UNPROTECT(3);
    error( "Unknown operator in C function time_num_op" );    
  }

  /* create output time or time span object */
  if( !lng1 || !lng2 )
    lng = 0;
  else if( lng2 > lng1 )
    lng = lng2;
  else
    lng = lng1;
  
  is_span = 1;
  if( checkClass( time_vec, IS_TIME_CLASS, 1L ))
  {
    is_span = 0;
    PROTECT(ret = time_create_new( lng, &out_days, &out_ms ));
  }
  else if( checkClass( time_vec, IS_TSPAN_CLASS, 1L )){
    PROTECT(ret = tspan_create_new( lng, &out_days, &out_ms ));
  } else {
    UNPROTECT(3);
    error( "Unknown class on first argument in C function time_num_op" );
  }

  if( !out_days || !out_ms || !ret ){
    UNPROTECT(4);
    error( "Could not create return object in C function time_num_op" );
  }

  /* go through input and perform operation */
  for( i = 0; i < lng; i++ )
  {
    ind1 = i % lng1;
    ind2 = i % lng2;

    /* check for NA */
    if(	 in_days[ind1] == NA_INTEGER || 
	 in_ms[ind1] == NA_INTEGER ||
	ISNA( in_nums[ind2]))
    {
      out_days[i] = NA_INTEGER;
      out_ms[i] = NA_INTEGER;
      continue;
    }

    /* operate and adjust output */
    add_sign = 1;
    is_ok = 1;
    switch( *in_op )
    {
    case '-':
      add_sign = -1;
    /*LINTED: Meant to fall through here */
    case '+':
      /* add/subtract integer part to days and fractional part to ms */
      out_days[i] = in_days[ind1] + add_sign * (Sint) floor( in_nums[ind2] );
      is_ok = ms_from_fraction( in_nums[ ind2 ] - floor( in_nums[ind2] ), 
			&(out_ms[i]));
      out_ms[i] = in_ms[ind1] + add_sign * out_ms[i];
      break;

    case '*':
      /* convert time to numeric, multiply, convert back */
      if( in_ms[ind1] > 0 )
	is_ok = ms_to_fraction( in_ms[ind1], &tmpdbl );
      else
      {
	is_ok = ms_to_fraction( - in_ms[ind1], &tmpdbl );
	tmpdbl = -tmpdbl;
      }
      tmpdbl = ( tmpdbl + in_days[ind1] ) * in_nums[ind2];
      out_days[i] = (Sint) floor( tmpdbl );
      is_ok = is_ok && ms_from_fraction( tmpdbl - out_days[i], &out_ms[i] );
      break;

    case '/':
      /* convert time to numeric, divide, convert back */
      if( in_ms[ind1] > 0 )
	is_ok = ms_to_fraction( in_ms[ind1], &tmpdbl );
      else
      {
	is_ok = ms_to_fraction( - in_ms[ind1], &tmpdbl );
	tmpdbl = -tmpdbl;
      }
      if( in_nums[ind2] == 0 )
	is_ok = 0;
      else
	tmpdbl = ( tmpdbl + in_days[ind1] ) / in_nums[ind2];
      out_days[i] = (Sint) floor( tmpdbl );
      is_ok = is_ok && ms_from_fraction( tmpdbl - out_days[i], &out_ms[i] );
      break;

    default:
      is_ok = 0;
    }

    if( !is_ok )
    {
      out_days[i] = NA_INTEGER;
      out_ms[i] = NA_INTEGER;
      continue;
    }

    if( is_span )
      tmp = adjust_span( &(out_days[i]), &(out_ms[i] ));
    else
      tmp = adjust_time( &(out_days[i]), &(out_ms[i] ));

    if( !tmp )
    {
      out_days[i] = NA_INTEGER;
      out_ms[i] = NA_INTEGER;
      continue;
    }

  }

  UNPROTECT(4); //2+2 from time_get_pieces
  return ret;
}
Example #21
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;
}
Example #22
0
SEXP biosonics_ping(SEXP bytes, SEXP Rspp, SEXP Rns, SEXP Rtype)
{
  PROTECT(bytes = AS_RAW(bytes));
  PROTECT(Rspp = AS_NUMERIC(Rspp));
  int spp = (int)floor(0.5 + *REAL(Rspp));
  PROTECT(Rns = AS_NUMERIC(Rns));
  int ns = (int)floor(0.5 + *REAL(Rns));
  PROTECT(Rtype = AS_NUMERIC(Rtype));
  int type = (int)floor(0.5 + *REAL(Rtype));
  //double *typep = REAL(type);
  //int beam = (int)floor(0.5 + *typep);
#ifdef DEBUG
  Rprintf("biosonics_ping() decoded type:%d, spp:%d, ns:%d\n", type, spp, ns);
#endif
  int byte_per_sample = 2;
  if (type == 1 || type == 2) {
    byte_per_sample = 4;
  }
  unsigned int nbytes = LENGTH(bytes);
#ifdef DEBUG
  Rprintf("nbytes: %d (should be 2*ns for single-beam or 4*ns for split- and dual-beam)\n", nbytes);
#endif
  unsigned char *bytep = RAW(bytes);

  SEXP res;
  PROTECT(res = allocVector(VECSXP, 3));
  SEXP res_names;
  PROTECT(res_names = allocVector(STRSXP, 3));
  SEXP res_a;
  PROTECT(res_a = allocVector(REALSXP, spp));
  SEXP res_b;
  PROTECT(res_b = allocVector(REALSXP, spp));
  SEXP res_c;
  PROTECT(res_c = allocVector(REALSXP, spp));
  // Get static storage; FIXME: is this thread-safe?
  biosonics_allocate_storage(spp, byte_per_sample);
#ifdef DEBUG
  Rprintf("allocVector(REALSXP, %d)\n", spp);
#endif
  double *resap = REAL(res_a);
  double *resbp = REAL(res_b);
  double *rescp = REAL(res_c);
  if (type == 0) { // single-beam
    rle(bytep, ns, spp, 2);
    for (int k = 0; k < spp; k++) {
      resap[k] = biosonic_float(buffer[byte_per_sample * k], buffer[1 + byte_per_sample * k]);
      resbp[k] = 0.0;
      rescp[k] = 0.0;
    }
  } else if (type == 1) { // dual-beam
    rle(bytep, ns, spp, 4);
    for (int k = 0; k < spp; k++) {
      // Quote [1 p37 re dual-beam]: "For an RLE-expanded sample x, the low-order
      // word (ie, (USHORT)(x & 0x0000FFFF)) contains the narrow-beam data. The
      // high-order word (ie, (USHORT)((x & 0xFFFF0000) >> 16)) contains the
      // wide beam data."
      resap[k] = biosonic_float(buffer[    byte_per_sample * k], buffer[1 + byte_per_sample * k]);
      resbp[k] = biosonic_float(buffer[2 + byte_per_sample * k], buffer[3 + byte_per_sample * k]);
      resbp[k] = 0.0;
    }
  } else if (type == 2) { // split-beam
    rle(bytep, ns, spp, 4);
    for (int k = 0; k < spp; k++) {
      // Quote [1 p38 split-beam e.g. 01-Fish.dt4 example]: "the low-order word
      // (ie, (USHORT)(x & 0x0000FFFF)) contains the amplitude data. The
      // high-order byte (ie, (TINY)((x & 0xFF000000) >> 24)) contains the
      // raw X-axis angle data. The other byte
      // (ie, (TINY)((x & 0x00FF0000) >> 16)) contains the raw Y-axis angle data.
      resap[k] = biosonic_float(buffer[byte_per_sample * k], buffer[1 + byte_per_sample * k]);
      resbp[k] = (double)buffer[2 + byte_per_sample * k];
      rescp[k] = (double)buffer[3 + byte_per_sample * k];
    }
  } else {
    error("unknown type, %d", type);
  }
  SET_VECTOR_ELT(res, 0, res_a);
  SET_VECTOR_ELT(res, 1, res_b);
  SET_VECTOR_ELT(res, 2, res_c);
  SET_STRING_ELT(res_names, 0, mkChar("a"));
  SET_STRING_ELT(res_names, 1, mkChar("b"));
  SET_STRING_ELT(res_names, 2, mkChar("c"));
  setAttrib(res, R_NamesSymbol, res_names);
  UNPROTECT(9);
  return(res);
}
Example #23
0
/*!
  \author Hanne Rognebakke
  \brief Makes a struct of type containing 

  Makes a struct of type Data_orig (see caa.h for definition)

  Space allocated in this routine is reallocated in re_makedata_COST
*/
int makedata_COST(SEXP i_COSTList, Data_orig **o_D_orig, Data_COST **o_D_COST)
{
  Data_orig     *D_orig;
  Data_COST     *D_COST;
  Data_obs      *D_obs;
  Data_mland    *D_mland;
  int            i,f,h,n,s,t;
  int            l_int,n_trip,n_fish,N_int,nHaul,nSize;
  int            ind,ind_alk,ind_fish,ind_fish_l,ind_haul,ind_size,ind_orig,ind_t;
  long          *lengths;
  double         l;
  double        *P_l,*int_len;
  SEXP           elmt = R_NilValue;

  FILE          *caa_debug;
  #ifdef DEBUG_COST
  caa_debug = fopen("caa_debug_COST.txt","w");
  #endif

  /* Allocating space for COST object */
  D_COST = CALLOC(1,Data_COST);


  /* Observer data */
  D_obs = CALLOC(1,Data_obs);
  if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_trip_obs")))
    D_obs->n_trip = INTEGER_VALUE(elmt); // number of trips with observer data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_obs")))
    D_obs->num_trip = INTEGER_POINTER(AS_INTEGER(elmt)); // number of hauls pr trip 

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_haul_disc")))
    D_obs->num_haul_disc = INTEGER_POINTER(AS_INTEGER(elmt)); // number of length-measured discarded fish pr haul

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "season_obs")))
    D_obs->season = INTEGER_POINTER(AS_INTEGER(elmt)); // observed month

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_disc")))
    D_obs->l_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for discard samples

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_disc")))
    D_obs->lfreq_disc = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for discards

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "haulsize_disc")))
    D_obs->haulsize_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // number of discards in haul

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_disc")))
    D_obs->sampsize_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // number of discards sampled

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_alk_disc")))
    D_obs->num_alk = INTEGER_POINTER(AS_INTEGER(elmt)); // number of discard age-length data within trip

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_l_disc")))
    D_obs->alk_l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lengths for discard age-length data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_a_disc")))
    D_obs->alk_a = INTEGER_POINTER(AS_INTEGER(elmt)); // ages for discard age-length data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_lfreq_disc")))
    D_obs->alk_lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // numbers at length for discard age-length data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_land")))
    D_obs->num_trip_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number of size classes pr trip with landings

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_size_land")))
    D_obs->num_size_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number of measured landed fish pr size class

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_land")))
    D_obs->l_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for landing samples

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_land")))
    D_obs->lfreq_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for landings

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "totsize_land")))
    D_obs->totsize_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // total weight landed in size class

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_land")))
    D_obs->sampsize_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // weight of landings sampled for lengths in size class

  /* Market landing data */
  D_mland = CALLOC(1,Data_mland);
  if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_trip_mland")))
    D_mland->n_trip = INTEGER_VALUE(elmt); // number of trips with market landing data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_mland")))
    D_mland->num_trip = INTEGER_POINTER(AS_INTEGER(elmt)); // number of size classes pr trip with market landings

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "season_mland")))
    D_mland->season = INTEGER_POINTER(AS_INTEGER(elmt)); // observed month

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_alk_mland")))
    D_mland->num_alk = INTEGER_POINTER(AS_INTEGER(elmt)); // number of market landing age-length data within trip

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_l_mland")))
    D_mland->alk_l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lengths for market landing age-length data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_a_mland")))
    D_mland->alk_a = INTEGER_POINTER(AS_INTEGER(elmt)); // ages for market landing age-length data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_lfreq_mland")))
    D_mland->alk_lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // numbers at length for market landing age-length data

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_size_mland")))
    D_mland->num_size = INTEGER_POINTER(AS_INTEGER(elmt)); // number of measured market landing fish pr size class

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_mland")))
    D_mland->l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for market landing samples

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_mland")))
    D_mland->lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for market landings

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "totsize_mland")))
    D_mland->totsize = NUMERIC_POINTER(AS_NUMERIC(elmt)); // total weight for market landing in size class

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_mland")))
    D_mland->sampsize = NUMERIC_POINTER(AS_NUMERIC(elmt)); // weight of market landings sampled for lengths in size class

  /* Allocating space for censoring parameters */
  D_COST->cens = CALLOC(1,cens_struct);
  D_COST->cens->ncat = D_obs->n_trip+D_mland->n_trip;
  D_COST->cens->r = CALLOC(D_COST->cens->ncat,double);
  D_COST->cens->mu = CALLOC(3,double);
  D_COST->cens->tau = CALLOC(3,double);


  /* Allocating space for 'original' parameters */

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_fish")))
    n_fish = INTEGER_VALUE(elmt);

  n_trip = D_obs->n_trip+D_mland->n_trip;
  D_orig = CALLOC(1,Data_orig);
  D_orig->nFishBoat = CALLOC(n_trip,int); // Free ok
  D_orig->totage = CALLOC(n_fish,int);  // Free ok 
  D_orig->totlength = CALLOC(n_fish,double); // Free ok
  D_orig->replength = CALLOC(n_fish,int);  // Free ok
  D_orig->discard = CALLOC(n_fish,int);  // Free ok
  D_orig->landed = CALLOC(n_fish,int);  // Free ok
  D_orig->start_noAge = CALLOC(n_trip,int); // Free ok
  D_orig->start_Age = CALLOC(n_trip,int); // Free ok
  D_orig->num_noAge = CALLOC(n_trip,int);  // Free ok
  D_orig->haulweight = CALLOC(n_trip,double); // Free ok
  D_orig->season = CALLOC(n_trip,int);   // Free ok
  D_orig->n_discard = CALLOC(n_trip,int);   // Free ok
  D_orig->n_landed = CALLOC(n_trip,int);   // Free ok

  if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_int_len")))
    D_orig->n_int_len = INTEGER_VALUE(elmt); // number of intervals for length
  N_int = D_orig->n_int_len;
  if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_lim")))
    D_orig->int_len_lim = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lower limits of length-intervals
  if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_vec")))
    D_orig->int_len = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals


  lengths = CALLOC(N_int,long);      // Free ok
  P_l = CALLOC(N_int,double);      // Free ok


  //printf("\nStart simulate total lengths for observer data\n");

  /* Simulate total lengths for observer data */
  ind_fish = 0;
  ind_fish_l = 0;
  ind_haul = 0;
  ind_size = 0;
  ind_alk = 0;
  ind_orig = 0;
  ind = 0;
  for(t=0;t<D_obs->n_trip;t++)
    {
      /* Discard data */
      D_orig->start_noAge[t] = ind_orig + D_obs->num_alk[t];
      D_orig->start_Age[t] = ind_orig;
      D_orig->num_noAge[t] = N_int;
      D_orig->nFishBoat[t] = D_obs->num_alk[t]+N_int;
      D_orig->season[t] = D_obs->season[t];
      D_orig->n_discard[t] = 0;
      D_orig->n_landed[t] = 0;
      ind_orig = D_orig->start_noAge[t];
      for(f=0;f<N_int;f++)
	{
	  D_orig->totage[ind_orig] = -99999;
	  D_orig->totlength[ind_orig] = D_orig->int_len[f];
	  D_orig->replength[ind_orig] = 0;
	  D_orig->discard[ind_orig] = 0;
	  D_orig->landed[ind_orig] = 0;
	  ind_orig++;
	}
      ind_orig = D_orig->start_noAge[t];
      for(h=0;h<D_obs->num_trip[t];h++)
	{
	  if(D_obs->num_haul_disc[ind_haul]>0)
	    {
	      nHaul = 0;
	      for(i=0;i<N_int;i++)
		P_l[i] = 0.0;
	      for(f=0;f<D_obs->num_haul_disc[ind_haul];f++)
		{
		  l = D_obs->l_disc[ind_fish];
		  l_int = 0;
		  while(l > D_orig->int_len_lim[l_int])
		    l_int++;
		  P_l[l_int] += D_obs->lfreq_disc[ind_fish];
		  D_orig->replength[ind_orig+l_int] += D_obs->lfreq_disc[ind_fish];
		  D_orig->discard[ind_orig+l_int] += D_obs->lfreq_disc[ind_fish];
		  D_orig->n_discard[t] += D_obs->lfreq_disc[ind_fish];
		  nHaul += D_obs->lfreq_disc[ind_fish];
		  ind_fish++;
		}
	      // convert to probabilities
	      for(i=0;i<N_int;i++)
		P_l[i] /= nHaul;
	      // number of fish to be simulated
	      if(nHaul==0)
		n=0;
	      else
		n = (int) nHaul*(D_obs->haulsize_disc[ind_haul]/D_obs->sampsize_disc[ind_haul]-1);
	      my_genmul(n,P_l,N_int,lengths);
	      for(i=0;i<N_int;i++)
		{
		  D_orig->replength[ind_orig+i] += (int) lengths[i];
		  D_orig->discard[ind_orig+i] += (int) lengths[i];
		  D_orig->n_discard[t] += (int) lengths[i];
		}
	    }
	  ind_haul++;
	}
      // put the age-length data into D_orig object
      for(f=0;f<D_obs->num_alk[t];f++)
	{
	  D_orig->totage[ind] = D_obs->alk_a[ind_alk];
	  D_orig->totlength[ind] = D_obs->alk_l[ind_alk];
	  D_orig->replength[ind] = D_obs->alk_lfreq[ind_alk];
	  D_orig->discard[ind] = D_obs->alk_lfreq[ind_alk];
	  // remove length count for lengths with missing ages
	  l_int = 0;
	  while(D_obs->alk_l[ind_alk] > D_orig->int_len_lim[l_int])
	    l_int++;
	  D_orig->replength[ind_orig+l_int] -= D_obs->alk_lfreq[ind_alk];
	  D_orig->discard[ind_orig+l_int] -= D_obs->alk_lfreq[ind_alk];
	  if(D_orig->replength[ind_orig+l_int]<0)
	    {
	      printf("trip=%d,ind_alk=%d,ind_orig=%d,replength=%d\n",
		     t,ind_alk,ind_orig+l_int,D_orig->replength[ind_orig+l_int]);
	      write_warning("makedata_COST:Something is wrong\n");
	      write_warning("age-length data not in length-only data\n");
	      D_orig->replength[ind_orig+l_int] = 0;
	      D_orig->discard[ind_orig+l_int] = 0;
	      D_orig->n_discard[t] = 0;
	    }
	  ind_alk++;
	  ind++;
	}
      ind += N_int;

      /* Landing data */
      for(s=0;s<D_obs->num_trip_land[t];s++)
	{
	  //	  if(D_obs->num_size_land[ind_size]==0)
	  nSize = 0;
	  for(i=0;i<N_int;i++)
	    P_l[i] = 0.0;
	  for(f=0;f<D_obs->num_size_land[ind_size];f++)
	    {
	      l = D_obs->l_land[ind_fish_l];
	      l_int = 0;
	      while(l > D_orig->int_len_lim[l_int])
		l_int++;
	      P_l[l_int] += D_obs->lfreq_land[ind_fish_l];
	      D_orig->replength[ind_orig+l_int] += D_obs->lfreq_land[ind_fish_l];
	      D_orig->landed[ind_orig+l_int] += D_obs->lfreq_land[ind_fish_l];
	      D_orig->n_landed[t] += D_obs->lfreq_land[ind_fish_l];
	      nSize += D_obs->lfreq_land[ind_fish_l];
	      ind_fish_l++;
	    }
	  // convert to probabilities
	  for(i=0;i<N_int;i++)
	    P_l[i] /= nSize;
	  // number of fish to be simulated
	  n = nSize*(D_obs->totsize_land[ind_size]/D_obs->sampsize_land[ind_size]-1);
          my_genmul(n,P_l,N_int,lengths);
	  for(i=0;i<N_int;i++)
	    {
	      D_orig->replength[ind_orig+i] += (int) lengths[i];
	      D_orig->landed[ind_orig+i] += (int) lengths[i];
	      D_orig->n_landed[t] += (int) lengths[i];
	    }
	  ind_size++; 
	}
      ind_orig += N_int;
    }

  #ifdef DEBUG_COST
  n=0;
  for(t=0;t<D_obs->n_trip;t++)
    {
      fprintf(caa_debug,"t=%d,nFishBoat=%d,start_noAge=%d,num_noAge=%d\n",
	      t,D_orig->nFishBoat[t],D_orig->start_noAge[t],D_orig->num_noAge[t]);
      n += D_orig->nFishBoat[t];
    }
  fprintf(caa_debug,"n=%d,totage[i],totlength[i],replength[i]:\n",n);
  n=0;
  for(i=0;i<n_fish;i++)
    {
      fprintf(caa_debug,"i=%d,%d,%f,%d\n",i,D_orig->totage[i],
	      exp(D_orig->totlength[i]),D_orig->replength[i]);
      n += D_orig->replength[i];
    }
  fprintf(caa_debug,"n=%d\n",n);
  #endif

  //printf("\nStart simulate total lengths for market landing data\n");
  ind_fish = 0;
  ind_size = 0;
  ind_alk = 0;
  ind_t = D_obs->n_trip;
  for(t=0;t<D_mland->n_trip;t++)
    {
      D_orig->start_noAge[ind_t] = ind_orig + D_mland->num_alk[t];
      D_orig->start_Age[ind_t] = ind_orig;
      D_orig->num_noAge[ind_t] = N_int;
      D_orig->nFishBoat[ind_t] = D_mland->num_alk[t]+N_int;
      D_orig->season[ind_t] = D_mland->season[t];
      D_orig->n_discard[ind_t] = 0;
      D_orig->n_landed[ind_t] = 0;
      ind_orig = D_orig->start_noAge[ind_t];
      for(f=0;f<N_int;f++)
	{
	  D_orig->totage[ind_orig] = -99999;
	  D_orig->totlength[ind_orig] = D_orig->int_len[f];
	  D_orig->replength[ind_orig] = 0;
	  D_orig->discard[ind_orig] = 0;
	  D_orig->landed[ind_orig] = 0;
	  ind_orig++;
	}
      ind_orig = D_orig->start_noAge[ind_t];
      for(s=0;s<D_mland->num_trip[t];s++)
	{
	  nSize = 0;
	  for(i=0;i<N_int;i++)
	    P_l[i] = 0.0;
	  for(f=0;f<D_mland->num_size[ind_size];f++)
	    {
	      l = D_mland->l[ind_fish];
	      l_int = 0;
	      while(l > D_orig->int_len_lim[l_int])
	      	l_int++;
	      P_l[l_int] += D_mland->lfreq[ind_fish];
	      D_orig->replength[ind_orig+l_int] += D_mland->lfreq[ind_fish];
	      D_orig->landed[ind_orig+l_int] += D_mland->lfreq[ind_fish];
	      D_orig->n_landed[ind_t] += D_mland->lfreq[ind_fish];
	      nSize += D_mland->lfreq[ind_fish];
	      ind_fish++;
	    }
	  // convert to probabilities
	  for(i=0;i<N_int;i++)
	    P_l[i] /= nSize;
	  // number of fish to be simulated
	  n = nSize*(D_mland->totsize[ind_size]/D_mland->sampsize[ind_size]-1);
          my_genmul(n,P_l,N_int,lengths);
	  for(i=0;i<N_int;i++)
	    {
	      D_orig->replength[ind_orig+i] += (int) lengths[i];
	      D_orig->landed[ind_orig+i] += (int) lengths[i];
	      D_orig->n_landed[ind_t] += (int) lengths[i];
	    }
	  ind_size++; 
	}
      // put the age-length data into D_orig object
      for(f=0;f<D_mland->num_alk[t];f++)
	{
	  D_orig->totage[ind] = D_mland->alk_a[ind_alk];
	  D_orig->totlength[ind] = D_mland->alk_l[ind_alk];
	  D_orig->replength[ind] = D_mland->alk_lfreq[ind_alk];
	  D_orig->landed[ind] = D_mland->alk_lfreq[ind_alk];
	  // remove length count for lengths with missing ages
	  l_int = 0;
	  while(D_mland->alk_l[ind_alk] > D_orig->int_len_lim[l_int])
	    l_int++;
	  D_orig->replength[ind_orig+l_int] -= D_mland->alk_lfreq[ind_alk];
	  D_orig->landed[ind_orig+l_int] -= D_mland->alk_lfreq[ind_alk];
	  if(D_orig->replength[ind_orig+l_int]<0)
	    {
	      printf("trip=%d,ind_alk=%d,ind_orig=%d,replength=%d\n",
		     t,ind_alk,ind_orig+l_int,D_orig->replength[ind_orig+l_int]);
	      write_warning("makedata_COST:Something is wrong\n");
	      write_warning("age-length data not in length-only data\n");
	      D_orig->replength[ind_orig+l_int] = 0;
	      D_orig->landed[ind_orig+l_int] = 0;
	      D_orig->n_landed[ind_t] = 0;
	    }
	  ind_alk++;
	  ind++;
	}
      ind += N_int;
      ind_orig += N_int; 
      ind_t++;
    }
  printf("\n");

  /* Allocating space and initalize simulated discards for market landing data */
  if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_int_len_disc")))
    N_int = INTEGER_VALUE(elmt); // number of intervals for length
  if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_vec_disc")))
    int_len = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals
  if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_lim_disc")))
    D_mland->int_len_lim = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals
  n_fish = (N_int)*D_mland->n_trip;
  D_mland->N_int_disc = N_int;
  D_mland->l_disc = CALLOC(n_fish,double); //Free ok
  D_mland->lfreq_disc = CALLOC(n_fish,int); //Free ok
  ind = 0;
  for(t=0;t<D_mland->n_trip;t++)
    {
      for(f=0;f<N_int;f++)
	{
	  D_mland->l_disc[ind] = int_len[f];
	  D_mland->lfreq_disc[ind] = 0;
	  ind++;
	}
    }
  D_mland->lambda = CALLOC(D_mland->n_trip,double); //Free ok

  #ifdef DEBUG_COST
  fclose(caa_debug);
  #endif

  FREE(lengths);
  FREE(P_l);

  D_COST->obs = D_obs;
  D_COST->mland = D_mland;

  *o_D_orig = D_orig;
  *o_D_COST = D_COST;

  return(0);
}		/* end of makedata_COST */
  SEXP fastcluster_vector(SEXP const method_,
                          SEXP const metric_,
                          SEXP X_,
                          SEXP members_,
                          SEXP p_) {
    SEXP r = NULL; // return value
    try{

      /*
        Input checks
      */

      // Parameter method: dissimilarity index update method
      PROTECT(method_);
      if (!IS_INTEGER(method_) || LENGTH(method_)!=1)
        Rf_error("'method' must be a single integer.");
      int method = *INTEGER_POINTER(method_) - 1; // index-0 based;
      if (method<METHOD_VECTOR_SINGLE || method>METHOD_VECTOR_MEDIAN) {
        Rf_error("Invalid method index.");
      }
      UNPROTECT(1); // method_

      // Parameter metric
      PROTECT(metric_);
      if (!IS_INTEGER(metric_) || LENGTH(metric_)!=1)
        Rf_error("'metric' must be a single integer.");
      int metric = *INTEGER_POINTER(metric_) - 1; // index-0 based;
      if (metric<0 || metric>5 ||
          (method!=METHOD_VECTOR_SINGLE && metric!=0) ) {
        Rf_error("Invalid metric index.");
      }
      UNPROTECT(1); // metric_

      // data array
      PROTECT(X_ = AS_NUMERIC(X_));
      SEXP dims_ = PROTECT( Rf_getAttrib( X_, R_DimSymbol ) ) ;
      if( dims_ == R_NilValue || LENGTH(dims_) != 2 ) {
        Rf_error( "Argument is not a matrix.");
      }
      const int * const dims = INTEGER(dims_);
      const int N = dims[0];
      const int dim = dims[1];
      if (N<2)
        Rf_error("There must be at least two data points.");
      // Make a working copy of the dissimilarity array
      // for all methods except "single".
      double * X__ = NUMERIC_POINTER(X_);
      // Copy the input array and change it from Fortran-contiguous  style
      // to C-contiguous style
      // (Waste of memory for 'single'; the other methods need a copy
      auto_array_ptr<double> X(LENGTH(X_));
      for (std::ptrdiff_t i=0; i<N; ++i)
        for (std::ptrdiff_t j=0; j<dim; ++j)
          X[i*dim+j] = X__[i+j*N];

      UNPROTECT(2); // dims_, X_

      // Parameter members: number of members in each node
      auto_array_ptr<t_float> members;
      if (method==METHOD_VECTOR_WARD ||
          method==METHOD_VECTOR_CENTROID) {
        members.init(N);
        if (Rf_isNull(members_)) {
          for (t_index i=0; i<N; ++i) members[i] = 1;
        }
        else {
          PROTECT(members_ = AS_NUMERIC(members_));
          if (LENGTH(members_)!=N)
            Rf_error("The length of 'members' must be the same as the number of data points.");
          const t_float * const m = NUMERIC_POINTER(members_);
          for (t_index i=0; i<N; ++i) members[i] = m[i];
          UNPROTECT(1); // members
        }
      }

      // Parameter p
      PROTECT(p_);
      double p = 0;
      if (metric==METRIC_R_MINKOWSKI) {
        if (!IS_NUMERIC(p_) || LENGTH(p_)!=1)
          Rf_error("'p' must be a single floating point number.");
        p = *NUMERIC_POINTER(p_);
      }
      else {
        if (p_ != R_NilValue) {
          Rf_error("No metric except 'minkowski' allows a 'p' parameter.");
        }
      }
      UNPROTECT(1); // p_

      /* The generic_linkage_vector_alternative algorithm uses labels
         N,N+1,... for the new nodes, so we need a table which node is
         stored in which row.

         Instructions: Set this variable to true for all methods which
         use the generic_linkage_vector_alternative algorithm below.
      */
      bool make_row_repr =
        (method==METHOD_VECTOR_CENTROID || method==METHOD_VECTOR_MEDIAN);

      R_dissimilarity dist(X, N, dim, members,
                           static_cast<unsigned char>(method),
                           static_cast<unsigned char>(metric),
                           p,
                           make_row_repr);
      cluster_result Z2(N-1);

      /*
        Clustering step
      */
      switch (method) {
      case METHOD_VECTOR_SINGLE:
        MST_linkage_core_vector(N, dist, Z2);
        break;

      case METHOD_VECTOR_WARD:
        generic_linkage_vector<METHOD_METR_WARD>(N, dist, Z2);
        break;

      case METHOD_VECTOR_CENTROID:
        generic_linkage_vector_alternative<METHOD_METR_CENTROID>(N, dist, Z2);
        break;

      case METHOD_VECTOR_MEDIAN:
        generic_linkage_vector_alternative<METHOD_METR_MEDIAN>(N, dist, Z2);
        break;

      default:
        throw std::runtime_error(std::string("Invalid method."));
      }

      X.free();     // Free the memory now
      members.free(); // (not strictly necessary).

      dist.postprocess(Z2);

      SEXP m; // return field "merge"
      PROTECT(m = NEW_INTEGER(2*(N-1)));
      int * const merge = INTEGER_POINTER(m);

      SEXP dim_m; // Specify that m is an (N-1)×2 matrix
      PROTECT(dim_m = NEW_INTEGER(2));
      INTEGER(dim_m)[0] = N-1;
      INTEGER(dim_m)[1] = 2;
      SET_DIM(m, dim_m);

      SEXP h; // return field "height"
      PROTECT(h = NEW_NUMERIC(N-1));
      double * const height = NUMERIC_POINTER(h);

      SEXP o; // return fiels "order'
      PROTECT(o = NEW_INTEGER(N));
      int * const order = INTEGER_POINTER(o);

      if (method==METHOD_VECTOR_SINGLE)
        generate_R_dendrogram<false>(merge, height, order, Z2, N);
      else
        generate_R_dendrogram<true>(merge, height, order, Z2, N);

      SEXP n; // names
      PROTECT(n = NEW_CHARACTER(3));
      SET_STRING_ELT(n, 0, COPY_TO_USER_STRING("merge"));
      SET_STRING_ELT(n, 1, COPY_TO_USER_STRING("height"));
      SET_STRING_ELT(n, 2, COPY_TO_USER_STRING("order"));

      PROTECT(r = NEW_LIST(3)); // field names in the output list
      SET_ELEMENT(r, 0, m);
      SET_ELEMENT(r, 1, h);
      SET_ELEMENT(r, 2, o);
      SET_NAMES(r, n);

      UNPROTECT(6); // m, dim_m, h, o, r, n
    } // try
    catch (const std::bad_alloc&) {
      Rf_error( "Memory overflow.");
    }
    catch(const std::exception& e){
      Rf_error( e.what() );
    }
    catch(const nan_error&){
      Rf_error("NaN dissimilarity value.");
    }
    catch(...){
      Rf_error( "C++ exception (unknown reason)." );
    }

    return r;
  }
Example #25
0
SEXP prob_profit ( SEXP beg, SEXP end, SEXP lsp,
        SEXP horizon, SEXP sample )
{
  /* Arguments:
   *   beg      First permutation index value
   *   end      Last permutation index value
   *   val      Profit target (percent)
   *   horizon  Horizon over which to determine probability
   *   hpr      Holding period returns
   *   prob     Probability of each HPR
   *   sample   If sample=0, run all permutations
   *            else run 'end - beg' random permutations
   *   replace  boolean (not implemented, always replace)
   */

  int P=0;  /* PROTECT counter */
  int i, j;  /* loop counters */

  /* extract lsp components */
  //double *d_event   = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 0)))); P++;
  double *d_prob    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 1)))); P++;
  //double *d_fval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
  //double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;
  double *d_zval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 4)))); P++;

  /* Get values from pointers */
  double i_beg = asReal(beg)-1;  /* zero-based */
  double i_end = asReal(end)-1;  /* zero-based */
  double i_sample = asReal(sample);
  int i_horizon = asInteger(horizon);

  /* initialize result object and pointer */
  SEXP result;
  PROTECT(result = allocVector(REALSXP, 2)); P++;
  double *d_result = REAL(result);

  /* initialize portfolio HPR object */
  SEXP phpr;

  double I; int J;
  double nr = nrows(VECTOR_ELT(lsp, 1));
  double passProb = 0;
  double sumProb = 0;
  double *d_phpr = NULL;

  /* does the lsp object have non-zero z values? */
  int using_z = (d_zval[0]==0 && d_zval[1]==0) ? 0 : 1;

  /* initialize object to hold permutation locations */
  SEXP perm;
  PROTECT(perm = allocVector(INTSXP, i_horizon)); P++;
  int *i_perm = INTEGER(perm);

  /* if lsp object contains z-values of zero, calculate HPR before
   * running permutations */
  if( !using_z ) {
    PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), R_NilValue)); P++;
    d_phpr = REAL(phpr);
  }

  /* Initialize R's random number generator (read in .Random.seed) */
  if(i_sample > 0) GetRNGstate();

  double probPerm;  /* proability of this permutation */
  double t0hpr;     /* this period's (t = 0) HPR */
  double t1hpr;     /* last period's (t = 1) HPR */
  double target = 1+d_zval[2];
    
  /* Loop over each permutation index */
  for(i=i_beg; i<=i_end; i++) {

    /* check for user-requested interrupt */
    if( i % 10000 == 999 ) R_CheckUserInterrupt();

    probPerm = 1;  /* proability of this permutation */
    t0hpr = 1;     /* this period's (t = 0) HPR */
    t1hpr = 1;     /* last period's (t = 1) HPR */
    
    /* if sampling, get a random permutation between 0 and nPr-1,
     * else use the current index value. */
    I = (i_sample > 0) ? ( unif_rand() * (i_sample-1) ) : i;

    /* set the permutation locations for index 'I' */
    for(j=i_horizon; j--;) {
      i_perm[j] = (long)fmod(I/pow(nr,j),nr);
    }
    /* Keep track of this permutation's probability */
    for(j=i_horizon; j--;) {
      probPerm *= d_prob[i_perm[j]];
    }
    /* if lsp object contains non-zero z values, calculate HPR for
     * each permutation */
    if( using_z ) {
      /* call lspm::hpr and assign pointer */
      PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), perm));
      d_phpr = REAL(phpr);
    }

    /* loop over permutation locations */
    for(j=0; j<i_horizon; j++) {
      /* if using_z, phpr has 'i_horizon' elements, else it has
       * 'nr' elements */
      J = using_z ? j : i_perm[j];
      t1hpr *= d_phpr[J];  /* New portfolio balance */
    }
    if( using_z ) UNPROTECT(1);  /* UNPROTECT phpr */
    /* If this permutation hit its target return,
     * add its probability to the total. */
    if( t1hpr >= target ) {
      passProb += probPerm;
    }
    /* Total probability of all permutations */
    sumProb += probPerm;
  }
  if(i_sample > 0) PutRNGstate();  /* Write out .Random.seed */

  /* Store results */
  d_result[0] = passProb;
  d_result[1] = sumProb;

  UNPROTECT(P);
  return result;
}
	// for obtaining a fast empirical distribution of mean values for randomly sampled 'clusters'
	SEXP emp_means(SEXP matrix_, SEXP nrow_, SEXP const cols_, SEXP nsample_, SEXP niter_){
		SEXP means = NULL;
		try{
			srand(time(NULL));

			PROTECT(nrow_ = AS_INTEGER(nrow_));
			int const nrow = *INTEGER_POINTER(nrow_);
			UNPROTECT(1);

			PROTECT(cols_);
			int * const cols = INTEGER_POINTER(cols_);
			int const ncol = LENGTH(cols_);

			PROTECT(nsample_ = AS_INTEGER(nsample_));
			int const nsample = *INTEGER_POINTER(nsample_);
			UNPROTECT(1);

			PROTECT(niter_ = AS_INTEGER(niter_));
			int const niter = *INTEGER_POINTER(niter_);
			UNPROTECT(1);

      PROTECT(matrix_ = AS_NUMERIC(matrix_));
      const double * const matrix = NUMERIC_POINTER(matrix_);

      PROTECT(means = NEW_NUMERIC(niter));
      double * const meansp = NUMERIC_POINTER(means);
			t_float val(0), sum(0);
			int row(0), i(0), j(0);

			for(int iter(0); iter<niter; ++iter){
				// compute mean over nsample rows for column indices cols
				// R matrices are filled BY COLUMN
				sum=0;
				for(i=0; i<nsample; ++i){
					row = rand() % nrow;
					for(j=0; j<ncol; ++j){
						// R is 1-indexed
						val = matrix[row+nrow*(cols[j]-1)];
						if(ISNA(val)) continue;
						sum += val;
					}
				}
				meansp[iter] = sum/nsample/ncol;
			}
			UNPROTECT(1); // matrix_
			UNPROTECT(1); // cols_

			UNPROTECT(1); // means
		}
    catch (const std::bad_alloc&) {
      Rf_error( "Memory overflow.");
    }
    catch(const std::exception& e){
      Rf_error( e.what() );
    }
    catch(const nan_error&){
      Rf_error("NaN dissimilarity value.");
    }
    catch(...){
      Rf_error( "C++ exception (unknown reason)." );
    }

		return means;
	}
Example #27
0
SEXP thinjumpequal(SEXP n,
		   SEXP p,
		   SEXP guess) 
{
  int N;
  double P;

  int *w;  /* temporary storage for selected integers */
  int nw, nwmax;

  int i, j, k;
  double log1u, log1p;

  /* R object return value */
  SEXP Out;
  /* external storage pointer */
  int *OutP;

  /* protect R objects from garbage collector */
  PROTECT(p = AS_NUMERIC(p));
  PROTECT(n = AS_INTEGER(n));
  PROTECT(guess = AS_INTEGER(guess));

  /* Translate arguments from R to C */
  N = *(INTEGER_POINTER(n));
  P = *(NUMERIC_POINTER(p));
  nwmax = *(INTEGER_POINTER(guess));

  /* Allocate space for result */
  w = (int *) R_alloc(nwmax, sizeof(int));

  /* set up */
  GetRNGstate();
  log1p = -log(1.0 - P);
  
  /* main loop */
  i = 0;  /* last selected element of 1...N */
  nw = 0;  /* number of selected elements */
  while(i <= N) {
    log1u = exp_rand();  /* an exponential rv is equivalent to -log(1-U) */
    j = (int) ceil(log1u/log1p); /* j is geometric(p) */
    i += j;
    if(nw >= nwmax) {
      /* overflow; allocate more space */
      w  = (int *) S_realloc((char *) w,  2 * nwmax, nwmax, sizeof(int));
      nwmax    = 2 * nwmax;
    }
    /* add 'i' to output vector */
    w[nw] = i;
    ++nw;
  }
  /* The last saved 'i' could have exceeded 'N' */
  /* For efficiency we don't check this in the loop */
  if(nw > 0 && w[nw-1] > N) 
    --nw;

  PutRNGstate();

  /* create result vector */
  PROTECT(Out = NEW_INTEGER(nw));

  /* copy results into output */
  OutP  = INTEGER_POINTER(Out);
  for(k = 0; k < nw; k++)
    OutP[k] = w[k];

  UNPROTECT(4);
  return(Out);
}
	// for obtaining a fast empirical distribution of mean differences between two sets of columns for randomly sampled 'clusters'
	SEXP emp_diffs(SEXP matrix_, SEXP nrow_, SEXP const colsA_, SEXP const colsB_, SEXP nsample_, SEXP niter_){
		SEXP diffs = NULL;
		try{
			srand(time(NULL));

			PROTECT(nrow_ = AS_INTEGER(nrow_));
			int const nrow = *INTEGER_POINTER(nrow_);
			UNPROTECT(1);

			PROTECT(colsA_);
			int * const colsA = INTEGER_POINTER(colsA_);
			int const ncolA = LENGTH(colsA_);

			PROTECT(colsB_);
			int * const colsB = INTEGER_POINTER(colsB_);
			int const ncolB = LENGTH(colsB_);

			PROTECT(nsample_ = AS_INTEGER(nsample_));
			int const nsample = *INTEGER_POINTER(nsample_);
			UNPROTECT(1);

			PROTECT(niter_ = AS_INTEGER(niter_));
			int const niter = *INTEGER_POINTER(niter_);
			UNPROTECT(1);

      PROTECT(matrix_ = AS_NUMERIC(matrix_));
      const double * const matrix = NUMERIC_POINTER(matrix_);

      PROTECT(diffs = NEW_NUMERIC(niter));
      double * const diffsp = NUMERIC_POINTER(diffs);
			t_float val(0), diff(0), sumA(0), sumB(0);
			int row(0), i(0), j(0);

			for(int iter(0); iter<niter; ++iter){
				// compute mean over nsample rows for column indices colsA
				// R matrices are filled BY COLUMN
				diff=0;
				for(i=0; i<nsample; ++i){
					row = rand() % nrow;
					sumA=0; sumB=0;
					for(j=0; j<ncolA; ++j){
						// R is 1-indexed
						val = matrix[row+nrow*(colsA[j]-1)];
						if(ISNA(val)) continue;
						sumA += val;
					}
					for(j=0; j<ncolB; ++j){
						val = matrix[row+nrow*(colsB[j]-1)];
						if(ISNA(val)) continue;
						sumB += val;
					}
					diff += sumB/ncolB - sumA/ncolA;
				}
				diffsp[iter] = diff/nsample;
			}
			UNPROTECT(1); // matrix_
			UNPROTECT(1); // colsA_
			UNPROTECT(1); // colsB_

			UNPROTECT(1); // diffs
		}
    catch (const std::bad_alloc&) {
      Rf_error( "Memory overflow.");
    }
    catch(const std::exception& e){
      Rf_error( e.what() );
    }
    catch(const nan_error&){
      Rf_error("NaN dissimilarity value.");
    }
    catch(...){
      Rf_error( "C++ exception (unknown reason)." );
    }

		return diffs;
	}
SEXP rph_phyloFit(SEXP msaP, 
		  SEXP treeStrP, 
		  SEXP substModP,
		  SEXP scaleOnlyP,
		  SEXP scaleSubtreeP,
		  SEXP nratesP,
		  SEXP alphaP,
		  SEXP rateConstantsP,
		  SEXP initModP,
		  SEXP initBackgdFromDataP,
		  SEXP initRandomP,
		  SEXP initParsimonyP,
		  SEXP clockP,
		  SEXP emP,
		  SEXP maxEmItsP,
		  SEXP precisionP,
		  SEXP gffP,
		  SEXP ninfSitesP,
		  SEXP quietP,
		  SEXP noOptP,
		  SEXP boundP,
		  SEXP logFileP,
		  SEXP selectionP) {
  struct phyloFit_struct *pf;
  int numProtect=0, i;
  double *doubleP;
  char *die_message=NULL;
  SEXP rv=R_NilValue;
  List *new_rate_consts = NULL;
  List *new_rate_weights = NULL;

  GetRNGstate(); //seed R's random number generator
  pf = phyloFit_struct_new(1);  //sets appropriate defaults for RPHAST mode

  pf->msa = (MSA*)EXTPTR_PTR(msaP);

  if (treeStrP != R_NilValue) 
    pf->tree = rph_tree_new(treeStrP);

  pf->use_em = LOGICAL_VALUE(emP);

  if (rateConstantsP != R_NilValue) {
    PROTECT(rateConstantsP = AS_NUMERIC(rateConstantsP));
    numProtect++;
    doubleP = NUMERIC_POINTER(rateConstantsP);
    new_rate_consts = lst_new_dbl(LENGTH(rateConstantsP));
    for (i=0; i < LENGTH(rateConstantsP); i++)
      lst_push_dbl(new_rate_consts, doubleP[i]);
//    pf->use_em = 1;
  }

  if (initModP != R_NilValue) {
    pf->input_mod = (TreeModel*)EXTPTR_PTR(initModP);
    pf->subst_mod = pf->input_mod->subst_mod;
    tm_register_protect(pf->input_mod);
    
    if (new_rate_consts == NULL && pf->input_mod->rK != NULL && pf->input_mod->nratecats > 1) {
      new_rate_consts = lst_new_dbl(pf->input_mod->nratecats);
      for (i=0; i < pf->input_mod->nratecats; i++) 
	lst_push_dbl(new_rate_consts, pf->input_mod->rK[i]);
//      pf-> = 1;
    }

    if (pf->input_mod->empirical_rates && pf->input_mod->freqK != NULL && pf->input_mod->nratecats > 1) {
      new_rate_weights = lst_new_dbl(pf->input_mod->nratecats);
      for (i=0; i < pf->input_mod->nratecats; i++)
	lst_push_dbl(new_rate_weights, pf->input_mod->freqK[i]);
    }

    tm_reinit(pf->input_mod, 
	      rph_get_subst_mod(substModP),
	      nratesP == R_NilValue ? pf->input_mod->nratecats : INTEGER_VALUE(nratesP),
	      NUMERIC_VALUE(alphaP),
	      new_rate_consts,
	      new_rate_weights);
  } else {
    if (nratesP != R_NilValue)
      pf->nratecats = INTEGER_VALUE(nratesP);
    if (alphaP != R_NilValue)
      pf->alpha = NUMERIC_VALUE(alphaP);
    if (rateConstantsP != R_NilValue) {
      pf->rate_consts = new_rate_consts;
      if (nratesP == R_NilValue)
	pf->nratecats = lst_size(new_rate_consts);
      else if (lst_size(new_rate_consts) != pf->nratecats) 
	die("length of new_rate_consts does not match nratecats\n");
    }
  }
  pf->subst_mod = rph_get_subst_mod(substModP);
  
  pf->estimate_scale_only = LOGICAL_VALUE(scaleOnlyP);
  
  if (scaleSubtreeP != R_NilValue) {
    pf->subtree_name = smalloc((1+strlen(CHARACTER_VALUE(scaleSubtreeP)))*sizeof(char));
    strcpy(pf->subtree_name, CHARACTER_VALUE(scaleSubtreeP));
  }
  
  pf->random_init = LOGICAL_VALUE(initRandomP);

  pf->init_backgd_from_data = LOGICAL_VALUE(initBackgdFromDataP);
  
  pf->init_parsimony = LOGICAL_VALUE(initParsimonyP);
  
  pf->assume_clock = LOGICAL_VALUE(clockP);

  if (maxEmItsP != R_NilValue)
    pf->max_em_its = INTEGER_VALUE(maxEmItsP);

  pf->precision = get_precision(CHARACTER_VALUE(precisionP));
  if (pf->precision == OPT_UNKNOWN_PREC) {
    die_message = "invalid precision";
    goto rph_phyloFit_end;
  }

  if (gffP != R_NilValue) {
    pf->gff = (GFF_Set*)EXTPTR_PTR(gffP);
    gff_register_protect(pf->gff);
  }

  if (ninfSitesP != R_NilValue)
    pf->nsites_threshold = INTEGER_VALUE(ninfSitesP);
  
  pf->quiet = LOGICAL_VALUE(quietP);

  if (noOptP != R_NilValue) {
    int len=LENGTH(noOptP), pos=0;
    char *temp;
    for (i=0; i < LENGTH(noOptP); i++) 
      len += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i)));
    temp = smalloc(len*sizeof(char));
    for (i=0; i < LENGTH(noOptP); i++) {
      if (i != 0) temp[pos++] = ',';
      sprintf(&temp[pos], "%s", CHARACTER_VALUE(STRING_ELT(noOptP, i)));
      pos += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i)));
    }
    if (pos != len-1) die("ERROR parsing noOpt len=%i pos=%i\n", len, pos);
    temp[pos] = '\0';
    pf->nooptstr = str_new_charstr(temp);
  }

  if (boundP != R_NilValue) {
    pf->bound_arg = lst_new_ptr(LENGTH(boundP));
    for (i=0; i < LENGTH(boundP); i++) {
      String *temp = str_new_charstr(CHARACTER_VALUE(STRING_ELT(boundP, i)));
      lst_push_ptr(pf->bound_arg, temp);
    }
  }

  if (logFileP != R_NilValue) {
    if (IS_CHARACTER(logFileP)) 
      pf->logf = phast_fopen(CHARACTER_VALUE(logFileP), "w+");
    else if (IS_LOGICAL(logFileP) &&
	     LOGICAL_VALUE(logFileP)) {
      pf->logf = stdout;
    }
  }

  if (selectionP != R_NilValue) {
    pf->use_selection = TRUE;
    pf->selection = NUMERIC_VALUE(selectionP);
  }

  msa_register_protect(pf->msa);

  run_phyloFit(pf);
  rv = PROTECT(rph_listOfLists_to_SEXP(pf->results));
  numProtect++;

 rph_phyloFit_end:
  if (pf->logf != NULL && pf->logf != stdout && pf->logf != stderr)
    phast_fclose(pf->logf);
  PutRNGstate();
  if (die_message != NULL) die(die_message);
  if (numProtect > 0) 
    UNPROTECT(numProtect);
  return rv;
}
Example #30
0
void FLQuant_pointer::Init(SEXP x)      
    {
    SEXP Quant    = GET_SLOT(x, install(".Data")),
         dims     = GET_DIM(Quant),
         dimnames = GET_DIMNAMES(Quant);

    data          = NUMERIC_POINTER(AS_NUMERIC(Quant));

    int dim[6], n = length(dims);

    dim[0] = INTEGER(dims)[0];
    dim[1] = INTEGER(dims)[1];
    dim[2] = INTEGER(dims)[2];
    dim[3] = INTEGER(dims)[3];
    dim[4] = INTEGER(dims)[4];
    dim[5] = n>=6 ? INTEGER(dims)[5] : 1; 
      
    if (((int)dim[0]) <  1 || ((int)dim[1]) < 1 || 
        ((int)dim[2]) <  1 || ((int)dim[3]) < 1 || ((int)dim[4]) < 1 || ((int)dim[5]) < 1)
      {
      UNPROTECT(1);

      return;
      }

    minquant() = 0;
    minyr()    = 0;
    maxquant() = (int)dim[0] -1;
    maxyr()    = (int)dim[1] -1;
    nunits()   = (int)dim[2];
    nseasons() = (int)dim[3];
    nareas()   = (int)dim[4]; 
    niters()   = (int)dim[5];
	   
      
    if (dimnames != R_NilValue) 
      if (TYPEOF(dimnames) == VECSXP) 
         {
         int  t = 0;
         const char *c;
         
         if (n >= 1 && INTEGER(dims)[0] >= 1) 
            {
            c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 0), 0));

            //check that name is not a text string
            for (int i=0; i<=(signed)strlen(c); i++)
               if (isalpha(c[i])) t=1;

            if (t !=1)
	            t = atoi(c); 

            minquant() += t;
            maxquant() += t;
  	         }
		   
         if (n >= 2 && INTEGER(dims)[1] >= 1) 
            {
            t = 0;
            c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 1), 0));

            //check that name is not a text string
            for (int i=0; i<=(signed)strlen(c); i++)
               if (isalpha(c[i])) t=1;

            if (t !=1)
	            t = atoi(c); 
            
            minyr()   += t;
            maxyr()   += t;
 	      	}
		   }

   InitFlag() = true;

   UNPROTECT(1);
   }