Beispiel #1
0
/*
 * callable function from R
 */
SEXP gmrfLik(
		SEXP QR,
		SEXP obsCovR,
		SEXP xisqTausq,
		SEXP YrepAddR
		){

	int Drep, dooptim, DxisqAgain; // length(xisqTausq)
	double	oneD=1.0, zeroD=0.0;
	double optTol = pow(DBL_EPSILON, 0.25); // tolerence for fmin_brent
	double optMin  = log(0.01), optMax = log(100); // default interval for optimizer
	int NxisqMax = 100; // number of xisqTausq's to retain when optimizing
	double *YXVYX, *determinant, *determinantForReml;
	double *m2logL, *m2logReL, *varHatMl, *varHatReml, *resultXisqTausq;
	void *nothing;
	SEXP resultR;
	CHM_DN obsCov;

	Ltype=0; // set to 1 for reml

	Nrep =LENGTH(YrepAddR);
	YrepAdd = REAL(YrepAddR);

	Nobs = INTEGER(GET_DIM(obsCovR))[0];
	Nxy = INTEGER(GET_DIM(obsCovR))[1];
	Ncov = Nxy - Nrep;
	Nxysq = Nxy*Nxy;

	NxisqTausq = LENGTH(xisqTausq);
	// if length zero, do optimization
	dooptim=!NxisqTausq;

	if(dooptim){
		NxisqTausq = NxisqMax;
	}
//	Rprintf("d %d %d", dooptim, NxisqTausq);

	resultR = PROTECT(allocVector(REALSXP, Nxysq*NxisqTausq + 8*Nrep*NxisqTausq));

	YXVYX = REAL(resultR);
	determinant = &REAL(resultR)[Nxysq*NxisqTausq];
	determinantForReml = &REAL(resultR)[Nxysq*NxisqTausq + Nrep*NxisqTausq];
	m2logL = &REAL(resultR)[Nxysq*NxisqTausq + 2*Nrep*NxisqTausq];
	m2logReL = &REAL(resultR)[Nxysq*NxisqTausq + 3*Nrep*NxisqTausq];
	varHatMl = &REAL(resultR)[Nxysq*NxisqTausq + 4*Nrep*NxisqTausq];
	varHatReml = &REAL(resultR)[Nxysq*NxisqTausq + 5*Nrep*NxisqTausq];
	resultXisqTausq = &REAL(resultR)[Nxysq*NxisqTausq + 6*Nrep*NxisqTausq];

	YXYX = (double *) calloc(Nxysq,sizeof(double));
	copyLx = (double *) calloc(Nxy*Nrep,sizeof(double));

	Q = AS_CHM_SP(QR);
	obsCov = AS_CHM_DN(obsCovR);
	M_R_cholmod_start(&c);

	// get some stuff ready

	// allocate Lx
	Lx = M_cholmod_copy_dense(obsCov,&c);

	// likelihood without nugget

	// YX Vinv YX
	M_cholmod_sdmult(
			Q,
			0, &oneD, &zeroD, // transpose, scale, scale
			obsCov,Lx,// in, out
			&c);

	// put t(obscov) Q obscov in result
	F77_NAME(dgemm)(
			//	op(A), op(B),
			"T", "N",
			// nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB)
	  		&Nxy, &Nxy, &Nobs,
			// alpha
			&oneD,
			// A, nrow(A)
			obsCov->x, &Nobs,
			// B, nrow(B)
	  		Lx->x, &Nobs,
			// beta
	  		&zeroD,
			// C, nrow(c)
			YXVYX, &Nxy);


	// Q = P' L D L' P
	L = M_cholmod_analyze(Q, &c);
	M_cholmod_factorize(Q,L, &c);

	// determinant
	determinant[0] = M_chm_factor_ldetL2(L);
	resultXisqTausq[0]= R_PosInf;

	ssqFromXprod(
			YXVYX, // N by N
			determinantForReml,
			Nxy, Nrep,
			copyLx);

	for(Drep=0;Drep<Nrep;++Drep){
		determinant[Drep] = determinant[0];
		determinantForReml[Drep] = determinantForReml[0];

	m2logL[Drep] = Nobs*log(YXVYX[Drep*Nxy+Drep]) - Nobs*log(Nobs) -
			determinant[0] - YrepAdd[Drep];

	m2logReL[Drep] = (Nobs-Ncov)*log(YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov)) +
			determinantForReml[0] - determinant[0] - YrepAdd[Drep];

	varHatMl[Drep] = YXVYX[Drep*Nxy+Drep]/Nobs;
	varHatReml[Drep] = YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov);
	}
	// now with xisqTausq
	obsCovRot = M_cholmod_solve(CHOLMOD_P, L,obsCov,&c);

	// YXYX cross product of data
	F77_NAME(dgemm)(
			//	op(A), op(B),
			"T", "N",
			// nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB)
	  		&Nxy, &Nxy, &Nobs,
			// alpha
			&oneD,
			// A, nrow(A)
			obsCovRot->x, &Nobs,
			// B, nrow(B)
			obsCovRot->x, &Nobs,
			// beta
	  		&zeroD,
			// C, nrow(&c)
			YXYX, &Nxy);

	YXVYXglobal = YXVYX;


//	Rprintf("done zero ", dooptim);

	if(dooptim){

		// put NA's where DxisqTausq hasnt been used
		for(DxisqAgain=1;DxisqAgain < NxisqTausq; ++DxisqAgain){
				determinant[DxisqAgain*Nrep] = NA_REAL;
				determinantForReml[DxisqAgain*Nrep] = NA_REAL;
				m2logL[DxisqAgain*Nrep]  = NA_REAL;
				m2logReL[DxisqAgain*Nrep] = NA_REAL;
				varHatMl[DxisqAgain*Nrep] = NA_REAL;
				varHatReml[DxisqAgain*Nrep] = NA_REAL;
		}


		DxisqTausq=1;
// do optimizer
		Brent_fmin(
				optMin, optMax,
				logLoneLogNugget,
				nothing, optTol);
//		Rprintf("done opt ", dooptim);


		NxisqTausq = DxisqTausq;

	} else {

		for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){

			logLoneNugget(REAL(xisqTausq)[DxisqTausq], nothing);

		}
	}
	// assign global values into their correct spot

	for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){

		for(Drep=0;Drep<Nrep;++Drep){

			determinant[DxisqTausq*Nrep+Drep] =
					determinant[DxisqTausq*Nrep];

			determinantForReml[DxisqTausq*Nrep+Drep]=
					determinantForReml[DxisqTausq*Nrep];

			m2logL[DxisqTausq*Nrep+Drep]  -=
					determinant[0];

			m2logReL[DxisqTausq*Nrep+Drep] -=
					determinant[0];

			varHatMl[DxisqTausq*Nrep + Drep] =
					YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/Nobs;

			varHatReml[DxisqTausq*Nrep + Drep] =
					YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/(Nobs-Ncov);
			resultXisqTausq[DxisqTausq*Nrep + Drep] =
					resultXisqTausq[DxisqTausq*Nrep];
		}

	}

	M_cholmod_free_factor(&L, &c);
	M_cholmod_free_dense(&obsCovRot, &c);

	M_cholmod_free_dense(&Lx, &c);


// don't free Q because it's from an R object
//	M_cholmod_free_sparse(&Q, &c);

// don't free obsCov because it's from an R object
//	M_cholmod_free_dense(&obsCov, &c);

	free(copyLx);
	free(YXYX);
	M_cholmod_free_dense(&YwkL, &c);
	M_cholmod_free_dense(&YwkD, &c);
	M_cholmod_free_dense(&EwkL, &c);
	M_cholmod_free_dense(&EwkD, &c);

	M_cholmod_finish(&c);

	UNPROTECT(1);
	return resultR;
}
Beispiel #2
0
// compute pdf of a sequence of Euler steps
SEXP euler_model_density (SEXP func, 
			  SEXP x, SEXP times, SEXP params,
			  SEXP tcovar, SEXP covar, SEXP log, SEXP args, SEXP gnsi) 
{
  int nprotect = 0;
  pompfunmode mode = undef;
  int give_log;
  int nvars, npars, nreps, ntimes, ncovars, covlen;
  pomp_onestep_pdf *ff = NULL;
  SEXP cvec, pvec = R_NilValue;
  SEXP t1vec = R_NilValue, t2vec = R_NilValue;
  SEXP x1vec = R_NilValue, x2vec = R_NilValue;
  SEXP Snames, Pnames, Cnames;
  SEXP fn, rho = R_NilValue, fcall = R_NilValue;
  SEXP F;
  int *pidx = 0, *sidx = 0, *cidx = 0;

  {
    int *dim;
    dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nreps = dim[1];
    dim = INTEGER(GET_DIM(params)); npars = dim[0];
    dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
    ntimes = LENGTH(times);
  }

  PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
  PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
  PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;

  // set up the covariate table
  struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};

  // vector for interpolated covariates
  PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
  SET_NAMES(cvec,Cnames);

  PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;

  give_log = *(INTEGER(log));

  switch (mode) {

  case Rfun:			// R function

    PROTECT(t1vec = NEW_NUMERIC(1)); nprotect++;
    PROTECT(t2vec = NEW_NUMERIC(1)); nprotect++;
    PROTECT(x1vec = NEW_NUMERIC(nvars)); nprotect++;
    SET_NAMES(x1vec,Snames);
    PROTECT(x2vec = NEW_NUMERIC(nvars)); nprotect++;
    SET_NAMES(x2vec,Snames);
    PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
    SET_NAMES(pvec,Pnames);

    // set up the function call
    PROTECT(fcall = LCONS(cvec,args)); nprotect++;
    SET_TAG(fcall,install("covars"));
    PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
    SET_TAG(fcall,install("params"));
    PROTECT(fcall = LCONS(t2vec,fcall)); nprotect++;
    SET_TAG(fcall,install("t2"));
    PROTECT(fcall = LCONS(t1vec,fcall)); nprotect++;
    SET_TAG(fcall,install("t1"));
    PROTECT(fcall = LCONS(x2vec,fcall)); nprotect++;
    SET_TAG(fcall,install("x2"));
    PROTECT(fcall = LCONS(x1vec,fcall)); nprotect++;
    SET_TAG(fcall,install("x1"));
    PROTECT(fcall = LCONS(fn,fcall)); nprotect++;

    PROTECT(rho = (CLOENV(fn))); nprotect++;

    break;

  case native:			// native code

    // construct state, parameter, covariate indices
    sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
    pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
    cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;

    *((void **) (&ff)) = R_ExternalPtrAddr(fn);

    break;

  default:

    errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov

    break;

  }

  // create array to hold results
  {
    int dim[2] = {nreps, ntimes-1};
    PROTECT(F = makearray(2,dim)); nprotect++;
  }

  switch (mode) {

  case Rfun:			// R function

    {
      double *cp = REAL(cvec);
      double *t1p = REAL(t1vec);
      double *t2p = REAL(t2vec);
      double *x1p = REAL(x1vec);
      double *x2p = REAL(x2vec);
      double *pp = REAL(pvec);
      double *t1s = REAL(times);
      double *t2s = t1s+1;
      double *x1s = REAL(x);
      double *x2s = x1s + nvars*nreps;
      double *ps;
      double *fs = REAL(F);
      int j, k;

      for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times

	R_CheckUserInterrupt();

	*t1p = *t1s; *t2p = *t2s;

	// interpolate the covariates at time t1, store the results in cvec
	table_lookup(&covariate_table,*t1p,cp);
    
	for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates
      
	  memcpy(x1p,x1s,nvars*sizeof(double));
	  memcpy(x2p,x2s,nvars*sizeof(double));
	  memcpy(pp,ps,npars*sizeof(double));

	  *fs = *(REAL(AS_NUMERIC(eval(fcall,rho))));
      
	  if (!give_log) *fs = exp(*fs);
      
	}
      }
    }

    break;

  case native:			// native code

    set_pomp_userdata(args);

    {
      double *t1s = REAL(times);
      double *t2s = t1s+1;
      double *x1s = REAL(x);
      double *x2s = x1s + nvars*nreps;
      double *fs = REAL(F);
      double *cp = REAL(cvec);
      double *ps;
      int j, k;

      for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times

	R_CheckUserInterrupt();

	// interpolate the covariates at time t1, store the results in cvec
	table_lookup(&covariate_table,*t1s,cp);
    
	for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates
      
	  (*ff)(fs,x1s,x2s,*t1s,*t2s,ps,sidx,pidx,cidx,ncovars,cp);

	  if (!give_log) *fs = exp(*fs);
      
	}
      }
    }

    unset_pomp_userdata();

    break;

  default:

    errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov

    break;

  }

  UNPROTECT(nprotect);
  return F;
}
Beispiel #3
0
SEXP euler_model_simulator (SEXP func, 
                            SEXP xstart, SEXP times, SEXP params, 
                            SEXP deltat, SEXP method, SEXP zeronames,
                            SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi) 
{
  int nprotect = 0;
  pompfunmode mode = undef;
  int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen;
  int nstep = 0; 
  double dt, dtt;
  SEXP X;
  SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue;
  SEXP Snames, Pnames, Cnames;
  SEXP cvec, tvec = R_NilValue;
  SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue;
  int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0;
  pomp_onestep_sim *ff = NULL;
  int meth = INTEGER_VALUE(method);
  // meth: 0 = Euler, 1 = one-step, 2 = fixed step

  dtt = NUMERIC_VALUE(deltat);
  if (dtt <= 0) 
    errorcall(R_NilValue,"'delta.t' should be a positive number");

  {
    int *dim;
    dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1];
    dim = INTEGER(GET_DIM(params)); npars = dim[0];
    dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
    ntimes = LENGTH(times);
  }

  PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++;
  PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
  PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;

  // set up the covariate table
  struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};

  // vector for interpolated covariates
  PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
  SET_NAMES(cvec,Cnames);

  // indices of accumulator variables
  nzeros = LENGTH(zeronames);
  zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;

  // extract user function
  PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
  
  // set up
  switch (mode) {

  case Rfun:			// R function

    PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++;
    PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
    PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
    PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
    SET_NAMES(xvec,Snames);
    SET_NAMES(pvec,Pnames);

    // set up the function call
    PROTECT(fcall = LCONS(cvec,args)); nprotect++;
    SET_TAG(fcall,install("covars"));
    PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++;
    SET_TAG(fcall,install("delta.t"));
    PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
    SET_TAG(fcall,install("params"));
    PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
    SET_TAG(fcall,install("t"));
    PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
    SET_TAG(fcall,install("x"));
    PROTECT(fcall = LCONS(fn,fcall)); nprotect++;

    // get function's environment
    PROTECT(rho = (CLOENV(fn))); nprotect++;

    break;

  case native:			// native code

    // construct state, parameter, covariate indices
    sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
    pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
    cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;

    *((void **) (&ff)) = R_ExternalPtrAddr(fn);

    break;

  default:

    errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov

    break;

  }

  // create array to hold results
  {
    int dim[3] = {nvars, nreps, ntimes};
    PROTECT(X = makearray(3,dim)); nprotect++;
    setrownames(X,Snames,3);
  }

  // copy the start values into the result array
  memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double));

  if (mode==1) {
    set_pomp_userdata(args);
    GetRNGstate();
  }

  // now do computations
  {
    int first = 1;
    int use_names = 0;
    int *posn = 0;
    double *time = REAL(times);
    double *xs = REAL(X);
    double *xt = REAL(X)+nvars*nreps;
    double *cp = REAL(cvec);
    double *ps = REAL(params);
    double t = time[0];
    double *pm, *xm;
    int i, j, k, step;

    for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) {

      R_CheckUserInterrupt();
	
      if (t > time[step]) {
	errorcall(R_NilValue,"'times' is not an increasing sequence");
      }

      memcpy(xt,xs,nreps*nvars*sizeof(double));
	
      // set accumulator variables to zero 
      for (j = 0; j < nreps; j++)
	for (i = 0; i < nzeros; i++) 
	  xt[zidx[i]+nvars*j] = 0.0;

      switch (meth) {
      case 0:			// Euler method
	dt = dtt;
	nstep = num_euler_steps(t,time[step],&dt);
	break;
      case 1:			// one step 
	dt = time[step]-t;
	nstep = (dt > 0) ? 1 : 0;
	break;
      case 2:			// fixed step
	dt = dtt;
	nstep = num_map_steps(t,time[step],dt);
	break;
      default:
	errorcall(R_NilValue,"unrecognized 'method'"); // # nocov
	break;
      }

      for (k = 0; k < nstep; k++) { // loop over Euler steps

	// interpolate the covar functions for the covariates
	table_lookup(&covariate_table,t,cp);

	for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates
	  
	  switch (mode) {

	  case Rfun: 		// R function

	    {
	      double *xp = REAL(xvec);
	      double *pp = REAL(pvec);
	      double *tp = REAL(tvec);
	      double *dtp = REAL(dtvec);
	      double *ap;
	      
	      *tp = t;
	      *dtp = dt;
	      memcpy(xp,xm,nvars*sizeof(double));
	      memcpy(pp,pm,npars*sizeof(double));
	      
	      if (first) {

	      	PROTECT(ans = eval(fcall,rho));	nprotect++; // evaluate the call
	      	if (LENGTH(ans) != nvars) {
	      	  errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?",
	      		LENGTH(ans),nvars);
	      	}
		
	      	PROTECT(nm = GET_NAMES(ans)); nprotect++;
	      	use_names = !isNull(nm);
	      	if (use_names) {
	      	  posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
	      	}

	      	ap = REAL(AS_NUMERIC(ans));
		
	      	first = 0;

	      } else {
	      
		ap = REAL(AS_NUMERIC(eval(fcall,rho)));

	      }
	      
	      if (use_names) {
	      	for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i];
	      } else {
	      	for (i = 0; i < nvars; i++) xm[i] = ap[i];
	      }

	    }

	    break;
	      
	  case native: 		// native code

	    (*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt);

	    break;

	  default:

	    errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov

	    break;

	  }

	}

	t += dt;
	
	if ((meth == 0) && (k == nstep-2)) { // penultimate step
	  dt = time[step]-t;
	  t = time[step]-dt;
	}
      }
    }
  }

  if (mode==1) {
    PutRNGstate();
    unset_pomp_userdata();
  }
  
  UNPROTECT(nprotect);
  return X;
}
Beispiel #4
0
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);
}
Beispiel #5
0
/********************************************************************
 * nlopt main function
 * *****************************************************************/
SEXP TKF92LikelihoodFunction3DMain_nlopt(SEXP seq1IntR, SEXP seq2IntR,
    SEXP expectedLength, SEXP probMatR, SEXP eqFrequenciesR,
    SEXP method){
  int ncol, nrow;
  ncol = INTEGER(GET_DIM(probMatR))[1];
  nrow = INTEGER(GET_DIM(probMatR))[0];
  int i, j;

  // probMat
  gsl_matrix *probMat = gsl_matrix_alloc(nrow, ncol);
  for(i = 0; i < nrow; i++)
    for(j = 0; j < ncol; j++)
      gsl_matrix_set(probMat, i, j, REAL(probMatR)[i+j*ncol]);

  // eqFrequenciesR
  gsl_vector *eqFrequencies = gsl_vector_alloc(GET_LENGTH(eqFrequenciesR));
  for(i = 0; i < GET_LENGTH(eqFrequenciesR); i++){
    gsl_vector_set(eqFrequencies, i, REAL(eqFrequenciesR)[i]);
  }

  // seqInt preparation
  int *seq1Int, *seq2Int;
  seq1Int = (int *) R_alloc(GET_LENGTH(seq1IntR), sizeof(int));
  seq2Int = (int *) R_alloc(GET_LENGTH(seq2IntR), sizeof(int));
  for(i = 0; i < GET_LENGTH(seq1IntR); i++){
    seq1Int[i] = INTEGER(seq1IntR)[i];
  }
  for(i = 0; i < GET_LENGTH(seq2IntR); i++){
    seq2Int[i] = INTEGER(seq2IntR)[i];
  }
  
  // construct params
  struct TKF92LikelihoodFunction3D_params params;
  params.len = REAL(expectedLength)[0];
  params.substModel = probMat;
  params.eqFrequencies = eqFrequencies;
  params.seq1Int = seq1Int;
  params.seq2Int = seq2Int;
  params.SA = GET_LENGTH(seq1IntR);
  params.SB = GET_LENGTH(seq2IntR);

  // nlopt main procedure
  double lb[3] = {0.0494497, 1e-20, 1e-20}; // lower bounds
  double ub[3] = {2000, 0.1, 1-1e-20};  // upper bounds
  //double dx[3] = {20, 0.01, 0.1}; // The initial step size

  nlopt_opt opt;
  if(strcmp(CHAR(STRING_ELT(method, 0)), "NM") == 0){
    opt = nlopt_create(NLOPT_LN_NELDERMEAD, 3); /* algorithm and dimensionality */
  }else if(strcmp(CHAR(STRING_ELT(method, 0)), "Sbplx") == 0){
    opt = nlopt_create(NLOPT_LN_SBPLX, 3);
  }else if(strcmp(CHAR(STRING_ELT(method, 0)), "COBYLA") == 0){
    opt = nlopt_create(NLOPT_LN_COBYLA, 3);
  }else if(strcmp(CHAR(STRING_ELT(method, 0)), "BOBYQA") == 0){
    opt = nlopt_create(NLOPT_LN_BOBYQA, 3);
  }else if(strcmp(CHAR(STRING_ELT(method, 0)), "PRAXIS") == 0){
    opt = nlopt_create(NLOPT_LN_PRAXIS, 3);
  }else{
    error("Wrong optimisation method!");
  }

  nlopt_set_lower_bounds(opt, lb);
  nlopt_set_upper_bounds(opt, ub);
  
  nlopt_set_min_objective(opt, TKF92LikelihoodFunction3D_nlopt, &params);
  nlopt_set_ftol_rel(opt, F_TOL); // stopping criteria
  //nlopt_set_initial_step(opt, dx); // initial step size
  nlopt_set_maxeval(opt, MAX_ITER);

  double x[3] = {100, exp(-3), 0.5};  /* some initial guess */
  double minf; /* the minimum objective value, upon return */
  if (nlopt_optimize(opt, x, &minf) < 0) {
    Rprintf("nlopt failed!\n");
  }else{
    Rprintf("found minimum at f(%g,%g,%g) = %0.10g using %s algorithm\n",
        x[0], x[1], x[2], minf, CHAR(STRING_ELT(method, 0)));
  }

  SEXP ans, ansNames;
  PROTECT(ans = NEW_NUMERIC(4)); // a vector of distance, mu, r and the negative log likelihood
  PROTECT(ansNames = NEW_CHARACTER(4));
  REAL(ans)[0] = x[0];
  REAL(ans)[1] = x[1];
  REAL(ans)[2] = x[2];
  REAL(ans)[3] = minf;
  SET_STRING_ELT(ansNames, 0, mkChar("PAM"));
  SET_STRING_ELT(ansNames, 1, mkChar("Mu"));
  SET_STRING_ELT(ansNames, 2, mkChar("r"));
  SET_STRING_ELT(ansNames, 3, mkChar("negLogLikelihood"));
  SET_NAMES(ans, ansNames);

  // free everything
  nlopt_destroy(opt);
  gsl_vector_free(eqFrequencies);
  gsl_matrix_free(probMat);

  UNPROTECT(2);
  return ans;
}
SEXP matrixApply(SEXP result, SEXP data, SEXP margin, SEXP function,
                 int worldRank, int worldSize) {

  SEXP ans, data_size;
  
  MPI_Datatype row_type, column_type;
  MPI_Status status;
  
  int my_start, my_end, N, function_nlines,
    nvectors, offset;
  int local_check = 0, global_check = 0;
  int dimensions[2];

  if (worldRank == MASTER_PROCESS) { 
    data_size = GET_DIM(data);
    
    dimensions[0] = INTEGER_POINTER(data_size)[0];
    dimensions[1] = INTEGER_POINTER(data_size)[1];

    /* function SEXP object is a vector of strings, each element contains
       a single line of the function definition */

    function_nlines = length(function);   
  }

  MPI_Bcast(dimensions, 2, MPI_INT, 0, MPI_COMM_WORLD);
  MPI_Bcast(&function_nlines, 1, MPI_INT, 0, MPI_COMM_WORLD);

  /* margin provides the subscripts which the function will be
     applied over.  "1" indicates rows, "2" indicates columns,
     c(1,2)" indicates rows and columns */

  if(worldRank != MASTER_PROCESS)
    PROTECT(margin = allocVector(INTSXP, 1));

  MPI_Bcast(INTEGER(margin), 1, MPI_INT, 0, MPI_COMM_WORLD);

  /* Matrix dimensions in R are interpreted differen than in C.
     We will refer to R rows and columns ordering, so rows are not alligned
     in memory */

  if (INTEGER(margin)[0] == 1) {
    N = dimensions[0];

    /* define vector type type to handle R rows exchange
       (count, blocklength, stride)*/
    MPI_Type_vector (dimensions[1], 1, dimensions[0], MPI_DOUBLE, &row_type);
    MPI_Type_commit (&row_type);

  } else if (INTEGER(margin)[0] == 2) {
    N = dimensions[1];

    /* define contiguous type to handle R columns exchange */
    MPI_Type_contiguous(dimensions[0], MPI_DOUBLE, &column_type);
    MPI_Type_commit(&column_type);
    
  } else if (INTEGER(margin)[0] == 3) {
    // TODO
    DEBUG("Margin number 3 not yet implemented\n");
    return R_NilValue;
  } else {
    DEBUG("Don't know how to deal with margin number %d\n",
          INTEGER(margin)[0]);
    return R_NilValue;
  }
  
  if(worldRank != MASTER_PROCESS) {
  
    /* Allocate memory for SEXP objects on worker nodes.
       alloc... functions do their own error-checking and
       return if the allocation process will fail. */
    loopDistribute(worldRank, worldSize, N, &my_start, &my_end);
    
    if (INTEGER(margin)[0] == 1)
      PROTECT(data = allocMatrix(REALSXP, my_end-my_start, dimensions[1]));
    if (INTEGER(margin)[0] == 2)
      PROTECT(data = allocMatrix(REALSXP, dimensions[0], my_end-my_start));
              
    PROTECT(function = allocVector(STRSXP, function_nlines));
  }

  if ( (data == NULL) ||  (function == NULL) ) {
      local_check = 1;
  } else {
      local_check = 0;
  }

  /* Check whether memory was successfully allocated on all worker nodes */
  MPI_Allreduce(&local_check, &global_check, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD);

  /*  No need to free memory if allocation fails on one of the workers
      R_alloc will release it after .Call returns to R */
  if ( global_check != 0 ) {
    /* Remove all references from the stack, I'm not sure if this is necessary */
    if(worldRank != MASTER_PROCESS)
      UNPROTECT(3);

    return ScalarInteger(-1);
  }

  /* Distribute data between processes */

  for (int worker_id=1; worker_id<worldSize; worker_id++) {

    if (worldRank == MASTER_PROCESS) {

      /* Calculate expected message length for each worker */
      loopDistribute(worker_id, worldSize, N, &my_start, &my_end);
      nvectors = my_end - my_start;

      /* If we applying over rows, as defined in R, we need to use the MPI vector type
         sending each row as a separate message */
      if (INTEGER(margin)[0] == 1) {
        for(int k=0; k<nvectors; k++) {
          offset = my_start+k;
          MPI_Send(&REAL(data)[offset], 1, row_type, worker_id, 0, MPI_COMM_WORLD);
        }
      }

      /* R defined columns are alligned in memory, single message of build from contiguous
         column_type elemensts is send */
      else if (INTEGER(margin)[0] == 2) {
        offset = my_start*dimensions[0];
        MPI_Send(&REAL(data)[offset], nvectors, column_type, worker_id, 0, MPI_COMM_WORLD);
      }
    }
    else if (worldRank == worker_id) {

      nvectors = my_end - my_start;

      if (INTEGER(margin)[0] == 1) {
        
        for(int k=0; k<nvectors; k++) {
          offset = k*dimensions[1];
          MPI_Recv(&REAL(data)[offset], dimensions[1], MPI_DOUBLE, MASTER_PROCESS, 0, MPI_COMM_WORLD, &status);
        }
      }
      else if (INTEGER(margin)[0] == 2) {
        MPI_Recv(REAL(data), nvectors, column_type, MASTER_PROCESS, 0, MPI_COMM_WORLD, &status);
      }
    }
  }

  /* Redo loop distribution for the Master process */
  if (worldRank == MASTER_PROCESS) {
      loopDistribute(worldRank, worldSize, N, &my_start, &my_end);
  }
    
  /* Bcast function name or definition, cover case when definition is split into
     several lines and stored as a SEXP string vector */
   bcastRFunction(function, function_nlines, worldRank);
  
  /* Response container, Vector of SEXPs, margin determines vector length */
  PROTECT(ans = allocVector(VECSXP, N));

  do_matrixApply(ans, data, margin, function, my_start, my_end, dimensions, worldRank);

  gatherData(result, ans, N, my_start, my_end, worldRank);
  
  if(worldRank != MASTER_PROCESS) {
    UNPROTECT(4);
  } else {
    UNPROTECT(1);
  }

  return result;

}
Beispiel #7
0
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);
}
void
_showInGtkWindow (SEXP xx, SEXP caption) {
    int nx, ny, nz, width, height;
    udata *dat;
    SEXP dim;
    GdkPixbuf * pxbuf;
    GtkWidget *evBox, *winWG, *vboxWG, *tbarWG, *scrollWG,
      *btnZoomInWG, *btnZoomOutWG, *btnZoomOneWG,
      *btnNextWG, *btnPrevWG;
    GtkObject *hAdjustment;
    GtkIconSize iSize;
    if ( !GTK_OK )
        error ( "failed to initialize GTK+, use 'read.image' instead" );

    dim = GET_DIM (xx);
    nx = INTEGER (dim)[0];
    ny = INTEGER (dim)[1];
    nz = getNumberOfFrames(xx,1);

    dat=g_new(udata,1);
    dat->nx=nx;
    dat->ny=ny;
    dat->nz=nz;
    dat->x=0;
    dat->y=0;
    dat->zoom=1.0;
    dat->index=0;
    dat->hSlider=NULL;
    dat->xx=xx;
   
    // xx is preserved from garbage collection til the windows is closed
    R_PreserveObject(xx);

    /* create pixbuf from image data */
    pxbuf=newPixbufFromSEXP(xx,0);

    if ( pxbuf == NULL )
        error ( "cannot copy image data to display window" );

    /* create imae display */
    dat->imgWG = gtk_image_new_from_pixbuf (pxbuf);
    g_object_unref (pxbuf);

    /* create main window */
    winWG =  gtk_window_new (GTK_WINDOW_TOPLEVEL);
    if ( caption != R_NilValue )
      gtk_window_set_title ( GTK_WINDOW(winWG), CHAR( asChar(caption) ) );
    else
      gtk_window_set_title ( GTK_WINDOW(winWG), "R image display" );
    /* set destroy event handler for the window */
    g_signal_connect ( G_OBJECT(winWG), "delete-event", G_CALLBACK(onWinDestroy), dat);

    /* create controls and set event handlers */
    /* create general horizontal lyout with a toolbar and add it to the window */
    vboxWG = gtk_vbox_new (FALSE, 0);
    gtk_container_add ( GTK_CONTAINER(winWG), vboxWG);

    /* create toolbar and push it to layout */
    tbarWG = gtk_toolbar_new ();
    gtk_box_pack_start ( GTK_BOX(vboxWG), tbarWG, FALSE, FALSE, 0);

    // add a horizontal slider
    if (nz>1) {
      hAdjustment=gtk_adjustment_new(1,1,nz,1,1,0);
      dat->hSlider=gtk_hscale_new(GTK_ADJUSTMENT(hAdjustment));
      gtk_scale_set_digits(GTK_SCALE(dat->hSlider),0);
      gtk_box_pack_start(GTK_BOX(vboxWG), dat->hSlider, FALSE,FALSE, 0);
      gtk_signal_connect(GTK_OBJECT(dat->hSlider),"value-changed", GTK_SIGNAL_FUNC(onSlide), dat);
    }

    /* create scrollbox that occupies and extends and push it to layout */
    scrollWG = gtk_scrolled_window_new (NULL, NULL);
    gtk_box_pack_start ( GTK_BOX(vboxWG), scrollWG, TRUE, TRUE, 5);
    gtk_scrolled_window_set_policy ( GTK_SCROLLED_WINDOW(scrollWG), GTK_POLICY_AUTOMATIC, GTK_POLICY_AUTOMATIC);
    /* add image to event box */
    evBox = gtk_event_box_new();
    gtk_container_add(GTK_CONTAINER(evBox), dat->imgWG);
    /* add image to scroll */
    gtk_scrolled_window_add_with_viewport ( GTK_SCROLLED_WINDOW(scrollWG), evBox);
    gtk_signal_connect(GTK_OBJECT(gtk_scrolled_window_get_hadjustment(GTK_SCROLLED_WINDOW(scrollWG))),"value-changed", GTK_SIGNAL_FUNC(onScroll), dat);
    gtk_signal_connect(GTK_OBJECT(gtk_scrolled_window_get_vadjustment(GTK_SCROLLED_WINDOW(scrollWG))),"value-changed", GTK_SIGNAL_FUNC(onScroll), dat);
    
    /* create status bar and push it to layout */
    dat->stbarWG = gtk_statusbar_new ();
    gtk_box_pack_start ( GTK_BOX(vboxWG), dat->stbarWG, FALSE, FALSE, 0);

    /* add zoom buttons */
    iSize = gtk_toolbar_get_icon_size ( GTK_TOOLBAR(tbarWG) );
    btnZoomInWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-zoom-in", iSize), "Zoom in" );
    gtk_container_add ( GTK_CONTAINER(tbarWG), btnZoomInWG);
    g_signal_connect ( G_OBJECT(btnZoomInWG), "clicked", G_CALLBACK(onZoomInPress), dat);
    btnZoomOutWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-zoom-out", iSize), "Zoom out" );
    gtk_container_add ( GTK_CONTAINER(tbarWG), btnZoomOutWG);
    g_signal_connect ( G_OBJECT(btnZoomOutWG), "clicked", G_CALLBACK(onZoomOutPress), dat);
    btnZoomOneWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-yes", iSize), "1:1");
    gtk_container_add ( GTK_CONTAINER(tbarWG), btnZoomOneWG);
    g_signal_connect ( G_OBJECT(btnZoomOneWG), "clicked", G_CALLBACK(onZoomOnePress), dat);

    /* add browsing buttons */
    if ( nz > 1 ) {
        btnPrevWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-go-back", iSize), "Previous" );
        gtk_container_add ( GTK_CONTAINER(tbarWG), btnPrevWG);
        g_signal_connect ( G_OBJECT(btnPrevWG), "clicked", G_CALLBACK(onPrevImPress), dat);
        btnNextWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-go-forward", iSize), "Next" );
        gtk_container_add ( GTK_CONTAINER(tbarWG), btnNextWG);
        g_signal_connect ( G_OBJECT(btnNextWG), "clicked", G_CALLBACK(onNextImPress), dat);
    }
    
    gtk_signal_connect( GTK_OBJECT(evBox), "motion-notify-event", GTK_SIGNAL_FUNC(onMouseMove), dat);
    gtk_widget_set_events(evBox, GDK_BUTTON_PRESS_MASK | GDK_POINTER_MOTION_MASK );
    
    /* resize to fit image */
    width = gdk_screen_get_width ( gdk_screen_get_default() );
    height = gdk_screen_get_height ( gdk_screen_get_default () );
    width = ( nx + 20 < width - 20 ) ? ( nx + 20 ) : ( width - 20 );
    height = ( ny + 80 < height - 20 ) ? ( ny + 80 ) : ( height - 20 );
    if ( width < 150 ) width = 150;
    if ( height < 100 ) height = 100;
    gtk_window_resize ( GTK_WINDOW(winWG), width, height);

    /* show window */
    gtk_widget_show_all (winWG);
    updateStatusBar(dat);
    gdk_flush();
}
Beispiel #9
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);
   }
Beispiel #10
0
SEXP map_assemble_polygons(SEXP lon, SEXP lat, SEXP z)
{
    PROTECT(lon = AS_NUMERIC(lon));
    double *lonp = REAL(lon);
    PROTECT(lat = AS_NUMERIC(lat));
    double *latp = REAL(lat);
    PROTECT(z = AS_NUMERIC(z));
    double *zp = REAL(z);
    int nlat = length(lat);
    int nlon = length(lon);
    if (nlon < 1) error("must have at least 2 longitudes");
    if (nlat < 1) error("must have at least 2 latitudes");

    // Note that first dimension of z is for y (here, lat) and second for x (here, lon)

    int nrow = INTEGER(GET_DIM(z))[0];
    int ncol = INTEGER(GET_DIM(z))[1];
    if (nlat != ncol) error("mismatch; length(lat)=%d must equal nrow(z)=%d", nlat, ncol);
    if (nlon != nrow) error("mismatch; length(lon)=%d must equal ncol(z)=%d", nlon, nrow);

    int n = nlon * nlat;
    SEXP polylon, polylat, polyz; 
    PROTECT(polylon = allocVector(REALSXP, 5*n));
    PROTECT(polylat = allocVector(REALSXP, 5*n));
    PROTECT(polyz = allocMatrix(REALSXP, nlon, nlat));
    double *polylonp = REAL(polylon), *polylatp = REAL(polylat), *polyzp = REAL(polyz);

    double latstep = 0.5 * fabs(latp[1] - latp[0]);
    double lonstep = 0.5 * fabs(lonp[1] - lonp[0]);
#ifdef DEBUG
    Rprintf("nlon: %d, nlat: %d, latstep: %f, lonstep: %f\n", nlon, nlat, latstep, lonstep);
#endif
    int k = 0, l=0; // indices for points and polygons
    for (int j = 0; j < ncol; j++) {
        for (int i = 0; i < nrow; i++) {
#ifdef DEBUG
            if (j == 0 && i < 3)
                Rprintf("i: %d, j: %d, lon: %.4f, lat:%.4f, k: %d\n", i, j, lonp[i], latp[j], k);
#endif
            // Lower left
            polylonp[k] = lonp[i] - lonstep;
            polylatp[k++] = latp[j] - latstep;
            // Upper left
            polylonp[k] = lonp[i] - lonstep;
            polylatp[k++] = latp[j] + latstep;
            // Upper right
            polylonp[k] = lonp[i] + lonstep;
            polylatp[k++] = latp[j] + latstep;
            // Lower right
            polylonp[k] = lonp[i] + lonstep;
            polylatp[k++] = latp[j] - latstep;
            // end
            polylonp[k] = NA_REAL;
            polylatp[k++] = NA_REAL;
            polyzp[l++] = zp[ij(i, j)];
#ifdef DEBUG
            if (j == 0 && i < 3)
                for (int kk=k-5; kk<k-1; kk++)
                    Rprintf("k: %d, lon: %.4f, lat:%.4f\n", kk, polylonp[kk], polylatp[kk]);
#endif
        }
        if (k > 5 * n)
            error("coding error (assigned insufficient memory); k: %d,  5*n: %d", k, 5*n);
    }
    if (k != 5 * n)
        error("coding error (assigned surplus memory); k: %d,  5*n: %d", k, 5*n);
    SEXP res;
    SEXP res_names;
    PROTECT(res = allocVector(VECSXP, 3));
    PROTECT(res_names = allocVector(STRSXP, 3));
    SET_VECTOR_ELT(res, 0, polylon);
    SET_STRING_ELT(res_names, 0, mkChar("longitude"));
    SET_VECTOR_ELT(res, 1, polylat);
    SET_STRING_ELT(res_names, 1, mkChar("latitude"));
    SET_VECTOR_ELT(res, 2, polyz);
    SET_STRING_ELT(res_names, 2, mkChar("z"));
    setAttrib(res, R_NamesSymbol, res_names);
    UNPROTECT(8);
    return(res);
}
Beispiel #11
0
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi)
{
  int nprotect = 0;
  pompfunmode mode = undef;
  int npars, nreps;
  SEXP Pnames, F, fn, fcall;
  SEXP pompfun;
  int *dim;

  PROTECT(params = as_matrix(params)); nprotect++;
  dim = INTEGER(GET_DIM(params));
  npars = dim[0]; nreps = dim[1]; 

  PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
    
  // extract the user-defined function
  PROTECT(pompfun = GET_SLOT(object,install("dprior"))); nprotect++;
  PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;

  // extract 'userdata' as pairlist
  PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;

  // to store results
  PROTECT(F = NEW_NUMERIC(nreps)); nprotect++;
      
  // first do setup
  switch (mode) {
  case Rfun:			// use R function

    {
      SEXP pvec, rho;
      double *pp, *ps, *pt;
      int j;

      // temporary storage
      PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
      SET_NAMES(pvec,Pnames);
      
      // set up the function call
      PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++;
      SET_TAG(fcall,install("log"));
      PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
      SET_TAG(fcall,install("params"));
      PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
      
      // get the function's environment
      PROTECT(rho = (CLOENV(fn))); nprotect++;
      
      pp = REAL(pvec);

      for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) {

	memcpy(pp,ps,npars*sizeof(double));

	*pt = *(REAL(AS_NUMERIC(eval(fcall,rho))));

      }
    }

    break;

  case native:			// use native routine

    {
      int give_log, *pidx = 0;
      pomp_dprior *ff = NULL;
      double *ps, *pt;
      int j;

      // construct state, parameter, covariate, observable indices
      pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames"))); nprotect++;
      
      // address of native routine
      ff = (pomp_dprior *) R_ExternalPtrAddr(fn);

      give_log = *(INTEGER(AS_INTEGER(log)));

      R_CheckUserInterrupt();	// check for user interrupt

      set_pomp_userdata(fcall);

      // loop over replicates
      for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++)
	(*ff)(pt,ps,give_log,pidx);

      unset_pomp_userdata();
    }
    
    break;

  default:

    error("unrecognized 'mode' slot in 'dprior'");
    break;

  }

  UNPROTECT(nprotect);
  return F;
}
Beispiel #12
0
static SEXP divergence_update_H ( T_Rnumeric* pV, SEXP w, SEXP h, int nbterms=0, int ncterms=0, int dup=1)
{
	SEXP res;
	int nprotect = 0;

	// retrieve dimensions from W and H
	int n = INTEGER(GET_DIM(w))[0];
	int r = INTEGER(GET_DIM(w))[1];
	int p = INTEGER(GET_DIM(h))[1];
	// get number of non-fixed terms
	int vr = r - ncterms;

	// duplicate H (keeping attributes) or modify in place
	PROTECT(res = (dup != 0 ? duplicate(h) : h) ); nprotect++;

	// define internal pointers
	double* pW = NUMERIC_POINTER(w);
	double* pH = NUMERIC_POINTER(h);
	double* p_res = NUMERIC_POINTER(res);

	// allocate internal memory
	double* sumW = (double*) R_alloc(r, sizeof(double)); // will store column sums of W
	double* pWH = (double*) R_alloc(n, sizeof(double)); // will store the currently used column of WH

	// Compute update of H column by column
	for(int jH=0; jH < p; ++jH){

		for (int iH=0; iH < vr; ++iH){ // compute value for H_ij (non-fixed terms only)

			// initialise values
			double tmp_res = 0.0;
			double &w_sum = sumW[iH];
			if( jH == 0 ) w_sum = 0.0;

			// compute cross-product w_.i by (v/wh)_.j
			for( int u=0; u<n; u++){

				// The jH-th column of WH is used to compute all elements of H_.j
				// => compute once and store the result for using for the next rows
				double wh_term = pWH[u];
				if( iH == 0 ){
					wh_term = 0.0;
					for (int k=0; k<r; k++){
						wh_term += pW[u + k*n] * pH[k + jH*r];
					}
					wh_term = pV[u + jH*n] / wh_term;
					pWH[u] = wh_term;
				}

				tmp_res +=  pW[u + iH*n] * wh_term;

				// compute sum of iH-th column of W (done only once)
				if( jH == 0 ) w_sum += pW[u + iH*n];
			}

			// multiplicative update
			p_res[iH + jH*r] = pH[iH + jH*r] * tmp_res / w_sum;
		}
	}

	// return result
	UNPROTECT(nprotect);
	return res;

}
Beispiel #13
0
static SEXP divergence_update_W ( T_Rnumeric* pV, SEXP w, SEXP h, int nbterms=0, int ncterms=0, int dup=1)
{

	SEXP res;
	int nprotect = 0;

	// retrieve dimensions
	int n = INTEGER(GET_DIM(w))[0];
	int r = INTEGER(GET_DIM(w))[1];
	int p = INTEGER(GET_DIM(h))[1];

	// duplicate W (keeping attributes)
	PROTECT(res = (dup != 0 ? duplicate(w) : w) ); nprotect++;

	// define internal pointers
	double* pW = NUMERIC_POINTER(w);
	double* pH = NUMERIC_POINTER(h);
	double* p_res = NUMERIC_POINTER(res);

	// allocate internal memory
	double* sumH = (double*) R_alloc(r, sizeof(double)); // will store the row sums of H
	double* pWH = (double*) R_alloc(p, sizeof(double)); // will store currently used row of WH

	// Compute update of W row by row
	for(int iW=0; iW < n; iW++){

		for (int jW=0; jW < r; jW++){ // compute value for W_ij

			// initialise values
			double tmp_res = 0.0;
			double &h_sum = sumH[jW];
			if( iW == 0 ) h_sum = 0.0;

			// compute cross-product (v/wh)_i. by h_j.
			for( int u=0; u<p; u++){

				// The iW-th row of WH is used to compute all elements of W_i.
				// => compute once and store the result for using for the next columns
				if( jW == 0 ){
					double wh_term = 0.0;
					for (int k=0; k<r; k++){
						wh_term += pW[iW + k*n] * pH[k + u*r];
					}
					wh_term = pV[iW + u*n] / wh_term;
					pWH[u] = wh_term;
				}

				tmp_res +=  pH[jW + u*r] * pWH[u];

				// compute sum of jW-th row of H (done only once)
				if( iW == 0 ) h_sum += pH[jW + u*r];
			}

			// multiplicative update
			p_res[iW + jW*n] = pW[iW + jW*n] * tmp_res / h_sum;
		}

	}

	// return result
	UNPROTECT(nprotect);
	return res;
}
Beispiel #14
0
SEXP lik4bin(SEXP data, SEXP star, SEXP sigma, SEXP thr, SEXP var, SEXP power, SEXP restringi, SEXP tsp)
{
  double *Pdata, *Psigma, *Pstar, Pres[22], *Rres, *wstar, *age1, *age2;
  double *Teff, *logg, *z, *M, *R, *Dni, *nimax, *logage, *pcage;
  double Vthr, maxL, maxL1, maxL2, lmult, EXP, rpcage;
  long nrow, ncol, count;

  double sq2pi, chi[NVAR], locsigma[NVAR], chi2, mult, L, mass, 
    radius, lt, ltnlog;;
  double sTeffP, sTeffM, time1, time2;
  SEXP res, dm, sel;
  long i, j, nres, nres1, nres2, DIM, start, n, startT, stopT, up, low;
  int ii, norun, nstar, *Psel, *Pvar, restr;
  DATA5 *d, *d1, *d2, *d3, *d4;
  long lb, ub;
  double t_spread; // max diff. in age

  // cast and pointers 
  PROTECT(data = AS_NUMERIC(data));
  PROTECT(star = AS_NUMERIC(star));
  PROTECT(sigma = AS_NUMERIC(sigma));
  PROTECT(thr = AS_NUMERIC(thr));
  PROTECT(var = AS_INTEGER(var));
  PROTECT(power = AS_NUMERIC(power));
  PROTECT(restringi = AS_INTEGER(restringi));
  PROTECT(tsp = AS_NUMERIC(tsp));

  Pdata = NUMERIC_POINTER(data);
  Pstar = NUMERIC_POINTER(star);
  Psigma = NUMERIC_POINTER(sigma);
  Vthr = NUMERIC_VALUE(thr);
  Pvar = INTEGER_POINTER(var);
  EXP = NUMERIC_VALUE(power);
  restr = NUMERIC_VALUE(restringi);
  t_spread = NUMERIC_VALUE(tsp);

  // sqrt ( 2 * pi )
  sq2pi = 2.506628274631000;

  // dataset dimensions
  nrow = INTEGER(GET_DIM(data))[0];
  ncol = INTEGER(GET_DIM(data))[1];

  // column pointers
  // data are column ordered!
  Teff = Pdata;
  logg = Pdata+nrow;
  z = Pdata+2*nrow;
  Dni = Pdata+3*nrow;
  nimax = Pdata+4*nrow;
  M = Pdata+5*nrow;
  R = Pdata+6*nrow;
  logage = Pdata+7*nrow;
  pcage = Pdata+8*nrow;

  // vector for likelihood computations
  // 1 = include; 0 = exclude
  Psel = (int*)malloc(nrow*sizeof(int));

  for(nstar=0;nstar<2;nstar++) 
    {
      for(j=0;j<nrow;j++)
	Psel[j] = 0;

      wstar = &Pstar[(nstar)*9];

      // sigma scaling for Dni,nimax,M,R (it is a % in input)
      for(n=0;n<NVAR;n++)
	locsigma[n] = Psigma[n+NVAR*nstar];
      for(n=3;n<7;n++)
	locsigma[n] *= wstar[n];
      
      mult = 1;
      for(n=0;n<NVAR;n++)
	if(Pvar[n] == 1)
	  mult *= 1.0/(sq2pi * locsigma[n]);
      lmult = log(mult);

      // allowed Teff interval
      sTeffP = wstar[0] + Vthr*locsigma[0];
      sTeffM = wstar[0] - Vthr*locsigma[0];

      // ricerca righe con Teff minima e massima
      findrange(Teff, nrow, sTeffM, sTeffP, &startT, &stopT);
      if(startT == -1 || stopT == -1)
	{
	  free(Psel);
	  UNPROTECT(8);
	  return(R_NilValue);
	}

      // sel computation
      nres = 0;
      for(j=startT;j<=stopT;j++)
	{
	  for(ii=0;ii<NVAR;ii++)
	    chi[ii] = 0;
	  
	  if(Pvar[0] == 1)
	    chi[0] = (Teff[j] - wstar[0])/locsigma[0];
	  if(Pvar[1] == 1)
	    chi[1] = (logg[j] - wstar[1])/locsigma[1];
	  if(Pvar[2] == 1)
	    chi[2] = (z[j] - wstar[2])/locsigma[2];
	  if(Pvar[3] == 1)
	    chi[3] = (Dni[j] - wstar[3])/locsigma[3];
	  if(Pvar[4] == 1)
	    chi[4] = (nimax[j] - wstar[4])/locsigma[4];
	  if(Pvar[5] == 1)
	    chi[5] = (M[j] - wstar[5])/locsigma[5];
	  if(Pvar[6] == 1)
	    chi[6] = (R[j] - wstar[6])/locsigma[6];

	  norun = 0;
	  for(ii=0;ii<NVAR;ii++)
	    {
	      if(fabs(chi[ii]) >= Vthr)
		{
		  norun = 1;
		  break;
		}
	    }
	  
	  if( norun == 0 ) 
	    {
	      chi2 = 0;
	      for(ii=0;ii<NVAR;ii++)
		chi2 += chi[ii]*chi[ii];
	      if( restr == 1 ) 
		{
		  if(sqrt(chi2) <= 3 )
		    {
		      nres++;
		      Psel[j] = 1;
		    }
		}
	      else 
		{
		  nres++;
		  Psel[j] = 1;
		}
	    }
	}
      
      // no data! return
      if(nres == 0) 
	{
	  free(Psel);
	  UNPROTECT(8);
	  return(R_NilValue);
	}
      // init output matrix
      DIM = nres;
      if(nstar == 0)
	{
	  d1 = (DATA5 *)calloc(DIM+1, sizeof(DATA5));
	  d = d1;
	}
      else
	{
	  d2 = (DATA5 *)calloc(DIM+1, sizeof(DATA5));
	  d = d2;
	}
      
      // compute lik only if sel = 1
      nres = 0;
      maxL = 0;
      for(j=startT;j<=stopT;j++)
	{
	  if( Psel[j] == 1 ) 
	    {
	      for(ii=0;ii<NVAR;ii++)
		chi[ii] = 0;
	      
	      if(Pvar[0] == 1)
		chi[0] = (Teff[j] - wstar[0])/locsigma[0];
	      if(Pvar[1] == 1)
		chi[1] = (logg[j] - wstar[1])/locsigma[1];
	      if(Pvar[2] == 1)
		chi[2] = (z[j] - wstar[2])/locsigma[2];
	      if(Pvar[3] == 1)
		chi[3] = (Dni[j] - wstar[3])/locsigma[3];
	      if(Pvar[4] == 1)
		chi[4] = (nimax[j] - wstar[4])/locsigma[4];
	      if(Pvar[5] == 1)
		chi[5] = (M[j] - wstar[5])/locsigma[5];
	      if(Pvar[6] == 1)
		chi[6] = (R[j] - wstar[6])/locsigma[6];
	      
	      chi2 = 0;
	      for(n=0;n<NVAR;n++)
		chi2 += chi[n]*chi[n];
	      
	      // likelihood
	      L = mult * exp(-0.5*chi2);
	      if(L > maxL)
		maxL = L;
	      d[nres].L = L;
	      d[nres].M = M[j];
	      d[nres].R = R[j];
	      d[nres].logage = logage[j];
	      d[nres].pcage = pcage[j];
	      nres++;
	    }
	}
      if(nstar==0) 
	{
	  nres1 = nres;
	  maxL1 = maxL;
	}
      else
	{
	  nres2 = nres;
	  maxL2 = maxL;
	}
    }
  
   // independent estimates
  for(nstar=0;nstar<2;nstar++)
    {
      mass = radius = lt = ltnlog = rpcage = 0;
      count = 0;
      if(nstar==0)
	{
	  nres = nres1;
	  maxL = maxL1;
	  d = d1;
	}
      else
	{
	  nres = nres2;
	  maxL = maxL2;
	  d = d2;
	}
      
      // select only points with L >= 0.95 maxL
      for(j=0;j<nres;j++)
	{
	  if(d[j].L >= 0.95*maxL) 
	    {
	      mass += d[j].M;
	      radius += d[j].R;
	      lt += d[j].logage;
	      rpcage += d[j].pcage;
	      ltnlog += 1e-9*pow(10, d[j].logage);
	      count++;
	    }
	}
      mass /= (double)(count);
      radius /= (double)(count);
      lt /= (double)(count);
      ltnlog /= (double)(count);
      rpcage /= (double)(count);
     
      Pres[0+6*nstar] = mass;
      Pres[1+6*nstar] = radius;
      Pres[2+6*nstar] = lt;
      Pres[3+6*nstar] = ltnlog;
      Pres[4+6*nstar] = maxL;
      Pres[5+6*nstar] = rpcage;
    }

  // joint estimates
  qsort(d2, nres2, sizeof(DATA5), orderage);
  age2 = (double*)malloc(nres2*sizeof(double));
  age1 = (double*)malloc(nres1*sizeof(double));

  for(i=0;i<nres1;i++)
    age1[i] = 1e-9*pow(10, d1[i].logage);

  for(i=0;i<nres2;i++)
    age2[i] = 1e-9*pow(10, d2[i].logage);

  maxL = 0;
  for(j=0;j<nres1;j++)
    {
      findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub);
      // the joint estimate is impossible
      if(lb == -1 || ub == -1) continue;
      if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue;
      for(i=lb;i<=ub;i++)
	{
	  count++;
	  L = d1[j].L * d2[i].L;
	  if(L > maxL)
	    maxL = L;
	}
    }

  for(j=12;j<22;j++)
    Pres[j] = 0;
  
  count = 0;
  for(j=0;j<nres1;j++)
    {
      findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub);
      if(lb == -1 || ub == -1) continue;
      if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue;
      for(i=lb;i<=ub;i++)
	{
	  L = d1[j].L * d2[i].L;
	  if(L > 0.95*maxL)
	    {
	      
	      Pres[12] += d1[j].M;
	      Pres[13] += d1[j].R;
	      Pres[14] += d1[j].logage;
	      Pres[15] += age1[j];
	      
	      Pres[16] += d2[i].M;
	      Pres[17] += d2[i].R;
	      Pres[18] += d2[i].logage;
	      Pres[19] += age2[i];

	      Pres[21] += d1[j].pcage;

	      count++;
	    }
	}
    }
  
  Pres[20] = (double)count;

  for(j=12;j<20;j++)
    Pres[j] /= (double)(count);
  Pres[21] /= (double)(count);

  PROTECT( res = NEW_NUMERIC(22) );
  Rres = NUMERIC_POINTER(res);
  for(j=0;j<22;j++)
    Rres[j] = Pres[j];

  free(d1);
  free(d2);
  free(Psel);
  free(age1);
  free(age2);
  
  // exit
  UNPROTECT(9);
  return(res);
}
Beispiel #15
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;
  }
}
Beispiel #16
0
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
{
  int nprotect = 0;
  SEXP Pnames, Snames;
  SEXP x = R_NilValue;
  int *dim;
  int npar, nrep, nvar, ns;
  int definit;
  int xdim[2];
  const char *dimnms[2] = {"variable","rep"};

  ns = *(INTEGER(AS_INTEGER(nsim)));
  PROTECT(params = as_matrix(params)); nprotect++;
  PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
  dim = INTEGER(GET_DIM(params));
  npar = dim[0]; nrep = dim[1]; 

  if (ns % nrep != 0) 
    errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')");

  definit = *(INTEGER(GET_SLOT(object,install("default.init"))));

  if (definit) {		// default initializer

    SEXP fcall, pat, repl, val, ivpnames, statenames;
    int *pidx, j, k;
    double *xp, *pp;
  
    PROTECT(pat = NEW_CHARACTER(1)); nprotect++;
    SET_STRING_ELT(pat,0,mkChar("\\.0$"));
    PROTECT(repl = NEW_CHARACTER(1)); nprotect++;
    SET_STRING_ELT(repl,0,mkChar(""));
    PROTECT(val = NEW_LOGICAL(1)); nprotect++;
    *(INTEGER(val)) = 1;
    
    // extract names of IVPs
    PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++;
    SET_TAG(fcall,install("value"));
    PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++;
    SET_TAG(fcall,install("x"));
    PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
    SET_TAG(fcall,install("pattern"));
    PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++;
    PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++;
    
    nvar = LENGTH(ivpnames);
    if (nvar < 1) {
      errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'.");
    }
    pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++;
    for (k = 0; k < nvar; k++) pidx[k]--;
    
    // construct names of state variables
    PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++;
    SET_TAG(fcall,install("x"));
    PROTECT(fcall = LCONS(repl,fcall)); nprotect++;
    SET_TAG(fcall,install("replacement"));
    PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
    SET_TAG(fcall,install("pattern"));
    PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++;
    PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++;

    xdim[0] = nvar; xdim[1] = ns;
    PROTECT(x = makearray(2,xdim)); nprotect++;
    setrownames(x,statenames,2);
    fixdimnames(x,dimnms,2);

    for (j = 0, xp = REAL(x); j < ns; j++) {
      pp = REAL(params) + npar*(j%nrep);
      for (k = 0; k < nvar; k++, xp++) 
	*xp = pp[pidx[k]];
    }

  } else {			// user-supplied initializer
    
    SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue;
    pompfunmode mode = undef;
    double *cp = NULL;

    // extract the initializer function and its environment
    PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++;
    PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
    
    // extract covariates and interpolate
    PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++;
    if (LENGTH(tcovar) > 0) {	// do table lookup
      PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++;
      PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++;
      cp = REAL(covars);
    }
	
    // extract userdata
    PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
	
    switch (mode) {
    case Rfun:			// use R function

      {
	SEXP par, rho, x1, x2;
	double *p, *pp, *xp, *xt;
	int j, *midx;

	// extract covariates and interpolate
	if (LENGTH(tcovar) > 0) { // add covars to call
	  PROTECT(fcall = LCONS(covars,fcall)); nprotect++;
	  SET_TAG(fcall,install("covars"));
	}
	
	// parameter vector
	PROTECT(par = NEW_NUMERIC(npar)); nprotect++;
	SET_NAMES(par,Pnames);
	pp = REAL(par); 
	
	// finish constructing the call
	PROTECT(fcall = LCONS(t0,fcall)); nprotect++;
	SET_TAG(fcall,install("t0"));
	PROTECT(fcall = LCONS(par,fcall)); nprotect++;
	SET_TAG(fcall,install("params"));
	PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
    
	// evaluation environment
	PROTECT(rho = (CLOENV(fn))); nprotect++;

	p = REAL(params);
	memcpy(pp,p,npar*sizeof(double));	   // copy the parameters
	PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call
	PROTECT(Snames = GET_NAMES(x1)); nprotect++;
	
	if (!IS_NUMERIC(x1) || isNull(Snames)) {
	  UNPROTECT(nprotect);
	  errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector");
	}
	
	nvar = LENGTH(x1);
	xp = REAL(x1);
	midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++;
	
	for (j = 0; j < nvar; j++) {
	  if (midx[j]!=0) {
	    UNPROTECT(nprotect);
	    errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j)));
	  }
	}
	
	xdim[0] = nvar; xdim[1] = ns;
	PROTECT(x = makearray(2,xdim)); nprotect++;
	setrownames(x,Snames,2);
	fixdimnames(x,dimnms,2);
	xt = REAL(x);
	
	memcpy(xt,xp,nvar*sizeof(double));
	
	for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
	  memcpy(pp,p+npar*(j%nrep),npar*sizeof(double));
	  PROTECT(x2 = eval(fcall,rho));
	  xp = REAL(x2);
	  if (LENGTH(x2)!=nvar)
	    errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length");
	  memcpy(xt,xp,nvar*sizeof(double));
	  UNPROTECT(1);
	} 
	
      }

      break;
      
    case native:		// use native routine
      
      {

	SEXP Cnames;
	int *sidx, *pidx, *cidx;
	double *xt, *ps, time;
	pomp_initializer *ff = NULL;
	int j;

	PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++;
	PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
	
	// construct state, parameter, covariate, observable indices
	sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
	pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
	cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
	
	// address of native routine
	*((void **) (&ff)) = R_ExternalPtrAddr(fn);
	
	nvar = LENGTH(Snames);
	xdim[0] = nvar; xdim[1] = ns;
	PROTECT(x = makearray(2,xdim)); nprotect++;
	setrownames(x,Snames,2);
	fixdimnames(x,dimnms,2);
	
	set_pomp_userdata(fcall);
	GetRNGstate();

	time = *(REAL(t0));

	// loop over replicates
	for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar)
	  (*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp);

	PutRNGstate();
	unset_pomp_userdata();
      
      }

      break;
      
    default:
      
      errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov

      break;

    }

  }

  UNPROTECT(nprotect);
  return x;
}
Beispiel #17
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;
}
SEXP
m_log_lambda(SEXP X1, SEXP X1_Columns, SEXP X1_Rows, 
             SEXP X2, SEXP X2_Columns,
             SEXP realS, SEXP OPTSimplicit_noisevar,
             SEXP hp_prior, SEXP hp_posterior) {
  long datalen;
  int  dim1, dim2, ncentroids;
  double *Mu_mu, *S2_mu, *Mu_bar, *Mu_tilde, 
    *Alpha_ksi, *Beta_ksi, *Ksi_alpha, *Ksi_beta, *U_p, *prior_alpha,
    *post_gamma, *log_lambda;
  double *data1;
  double *data2;
  SEXP olog_lambda, oU_hat;
  SEXP* U_hat;

  double *Ns;
  double implicit_noisevar;
  
  /******************** input variables ********************/
  
  
  /************ CONVERTED input variables ******************/
  /* data */
  PROTECT(X1 = AS_NUMERIC(X1));  
  data1   = NUMERIC_POINTER(X1);
  dim1    = INTEGER_VALUE(X1_Columns);
  datalen = INTEGER_VALUE(X1_Rows);

  PROTECT(X2 = AS_NUMERIC(X2));  
  data2   = NUMERIC_POINTER(X2);
  dim2    = INTEGER_VALUE(X2_Columns);

  Ns = NUMERIC_POINTER(realS);
  implicit_noisevar = NUMERIC_VALUE(OPTSimplicit_noisevar);
  

  /* Converted Initial Values of Model Parameters */

  if(dim1) {
    Mu_mu       = NUMERIC_POINTER(getListElement(hp_prior,"Mu_mu"));
    S2_mu       = NUMERIC_POINTER(getListElement(hp_prior,"S2_mu"));
    Alpha_ksi   = NUMERIC_POINTER(getListElement(hp_prior,"Alpha_ksi"));
    Beta_ksi    = NUMERIC_POINTER(getListElement(hp_prior,"Beta_ksi"));
    Mu_bar      = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_bar"));
    Mu_tilde    = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_tilde"));
    Ksi_alpha   = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_alpha"));
    Ksi_beta    = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_beta"));
  }
  if(dim2) {
    U_p         = NUMERIC_POINTER(getListElement(hp_prior,"U_p"));
    oU_hat      = getListElement(hp_posterior,"Uhat");
    U_hat      = &oU_hat;
  }
  

  prior_alpha = NUMERIC_POINTER(getListElement(hp_prior,"alpha"));
  post_gamma  = NUMERIC_POINTER(getListElement(hp_posterior,"gamma"));

  ncentroids = INTEGER_POINTER( GET_DIM(getListElement(hp_posterior,"Mu_bar")) )[0];

  /*printf("\nMu_mu ");  
  for(i=0; i< dim1;i++)
    printf("%f ", Mu_mu[i]);
  printf("\nS2_mu ");
  for(i=0; i< dim1;i++)
    printf("%f ", S2_mu[i]);
  printf("\nAlpha_ksi ");
  for(i=0; i< dim1;i++)
    printf("%f ", Alpha_ksi[i]);
  printf("\nBeta_ksi ");
  for(i=0; i< dim1;i++)
    printf("%f ", Beta_ksi[i]);
  
  printf("\nMu_bar ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Mu_bar[i]);
  printf("\nMu_tilde ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Mu_tilde[i]);
  printf("\nKsi_alpha ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Ksi_alpha[i]);
  printf("\nKsi_beta ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Ksi_beta[i]);
  printf("\nprior_alpha = %f", *prior_alpha);
  printf("\npost_gamma ");
  for(i=0;i<2*ncentroids;i++)
    printf("%f ", post_gamma[i]);
  printf("ncentroids = %d\n", ncentroids);
  printf("dim2 = %d\n",dim2);*/
  /******************** output variables ********************/
  PROTECT(olog_lambda     = NEW_NUMERIC(datalen*ncentroids));
  log_lambda = NUMERIC_POINTER(olog_lambda);


  vdp_mk_log_lambda(Mu_mu, S2_mu, Mu_bar, Mu_tilde, 
		    Alpha_ksi, Beta_ksi, Ksi_alpha, Ksi_beta, 
		    post_gamma, log_lambda, prior_alpha,
		    U_p, U_hat,
		    datalen, dim1, dim2, data1, data2, 
		    Ns, ncentroids, implicit_noisevar);

  UNPROTECT(3);

  return olog_lambda;
}