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