cppbugs::MCMCObject* createNormal(SEXP x_,vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP mu_ = Rf_getAttrib(x_,Rf_install("mu"));
SEXP tau_ = Rf_getAttrib(x_,Rf_install("tau"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
//Rprintf("typeof mu: %d\n",TYPEOF(mu_));
if(x_ == R_NilValue || env_ == R_NilValue || mu_ == R_NilValue || tau_ == R_NilValue || observed_ == R_NilValue) {
throw std::logic_error("ERROR: createNormal, missing or null argument.");
}
// force substitutions
mu_ = forceEval(mu_, env_, eval_limit);
tau_ = forceEval(tau_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* mu_arma = mapOrFetch(mu_, armaMap);
ArmaContext* tau_arma = mapOrFetch(tau_, armaMap);
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignNormalLogp<cppbugs::ObservedNormal>(x_arma->getDouble(),mu_arma,tau_arma);
} else {
p = assignNormalLogp<cppbugs::Normal>(x_arma->getDouble(),mu_arma,tau_arma);
}
break;
case vecT:
if(observed) {
p = assignNormalLogp<cppbugs::ObservedNormal>(x_arma->getVec(),mu_arma,tau_arma);
} else {
p = assignNormalLogp<cppbugs::Normal>(x_arma->getVec(),mu_arma,tau_arma);
}
break;
case matT:
if(observed) {
p = assignNormalLogp<cppbugs::ObservedNormal>(x_arma->getMat(),mu_arma,tau_arma);
} else {
p = assignNormalLogp<cppbugs::Normal>(x_arma->getMat(),mu_arma,tau_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: normal must be a continuous variable type (double, vec, or mat).");
}
return p;
}
cppbugs::MCMCObject* createLinearGroupedDeterministic(SEXP x_, vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP X_ = Rf_getAttrib(x_,Rf_install("X"));
SEXP b_ = Rf_getAttrib(x_,Rf_install("b"));
SEXP group_ = Rf_getAttrib(x_,Rf_install("group"));
if(x_ == R_NilValue || env_ == R_NilValue || X_ == R_NilValue || b_ == R_NilValue || group_ == R_NilValue) {
throw std::logic_error("ERROR: createLinearDeterministic, missing or null argument.");
}
// force substitutions
X_ = forceEval(X_, env_, eval_limit);
b_ = forceEval(b_, env_, eval_limit);
group_ = forceEval(group_, env_, eval_limit);
// map to arma types
ArmaContext* X_arma = mapOrFetch(X_, armaMap);
ArmaContext* b_arma = mapOrFetch(b_, armaMap);
ArmaContext* group_arma = mapOrFetch(group_, armaMap);
// little x
if(x_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, x must be a real valued matrix.");
}
// big X
if(X_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, X must be a matrix.");
}
// b -- coefs vector
if(b_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, b must be a real valued matrix.");
}
// group -- multilevel group
if(group_arma->getArmaType() != ivecT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, group must be an integer vector.");
}
switch(X_arma->getArmaType()) {
case matT:
p = new cppbugs::LinearGroupedDeterministic<arma::mat>(x_arma->getMat(),X_arma->getMat(),b_arma->getMat(),group_arma->getiVec());
break;
case imatT:
p = new cppbugs::LinearGroupedDeterministic<arma::imat>(x_arma->getMat(),X_arma->getiMat(),b_arma->getMat(),group_arma->getiVec());
break;
default:
throw std::logic_error("ERROR: createLinearGroupedDeterministic, combination of arguments not supported.");
}
return p;
}
cppbugs::MCMCObject* createGamma(SEXP x_, vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP alpha_ = Rf_getAttrib(x_,Rf_install("alpha"));
SEXP beta_ = Rf_getAttrib(x_,Rf_install("beta"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
if(x_ == R_NilValue || env_ == R_NilValue || alpha_ == R_NilValue || beta_ == R_NilValue || observed_ == R_NilValue) {
REprintf("ERROR: missing argument.");
return NULL;
}
// force substitutions
alpha_ = forceEval(alpha_, env_, eval_limit);
beta_ = forceEval(beta_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* alpha_arma = mapOrFetch(alpha_, armaMap);
ArmaContext* beta_arma = mapOrFetch(beta_, armaMap);
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignGammaLogp<cppbugs::ObservedGamma>(x_arma->getDouble(),alpha_arma,beta_arma);
} else {
p = assignGammaLogp<cppbugs::Gamma>(x_arma->getDouble(),alpha_arma,beta_arma);
}
break;
case vecT:
if(observed) {
p = assignGammaLogp<cppbugs::ObservedGamma>(x_arma->getVec(),alpha_arma,beta_arma);
} else {
p = assignGammaLogp<cppbugs::Gamma>(x_arma->getVec(),alpha_arma,beta_arma);
}
break;
case matT:
if(observed) {
p = assignGammaLogp<cppbugs::ObservedGamma>(x_arma->getMat(),alpha_arma,beta_arma);
} else {
p = assignGammaLogp<cppbugs::Gamma>(x_arma->getMat(),alpha_arma,beta_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: gamma must be a continuous variable type (double, vec, or mat).");
}
return p;
}
cppbugs::MCMCObject* createUniform(SEXP x_,vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP lower_ = Rf_getAttrib(x_,Rf_install("lower"));
SEXP upper_ = Rf_getAttrib(x_,Rf_install("upper"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
if(x_ == R_NilValue || env_ == R_NilValue || lower_ == R_NilValue || upper_ == R_NilValue || observed_ == R_NilValue) {
REprintf("ERROR: missing argument.");
return NULL;
}
// force substitutions
lower_ = forceEval(lower_, env_, eval_limit);
upper_ = forceEval(upper_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* lower_arma = mapOrFetch(lower_, armaMap);
ArmaContext* upper_arma = mapOrFetch(upper_, armaMap);
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignUniformLogp<cppbugs::ObservedUniform>(x_arma->getDouble(),lower_arma,upper_arma);
} else {
p = assignUniformLogp<cppbugs::Uniform>(x_arma->getDouble(),lower_arma,upper_arma);
}
break;
case vecT:
if(observed) {
p = assignUniformLogp<cppbugs::ObservedUniform>(x_arma->getVec(),lower_arma,upper_arma);
} else {
p = assignUniformLogp<cppbugs::Uniform>(x_arma->getVec(),lower_arma,upper_arma);
}
break;
case matT:
if(observed) {
p = assignUniformLogp<cppbugs::ObservedUniform>(x_arma->getMat(),lower_arma,upper_arma);
} else {
p = assignUniformLogp<cppbugs::Uniform>(x_arma->getMat(),lower_arma,upper_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: uniform must be a continuous variable type (double, vec, or mat).");
}
return p;
}
SEXP logp(SEXP x_, SEXP rho_) {
const int eval_limit = 10;
double ans = std::numeric_limits<double>::quiet_NaN();
cppbugs::MCMCObject* node(NULL);
vpArmaMapT armaMap;
if(rho_ == R_NilValue || TYPEOF(rho_) != ENVSXP) {
REprintf("ERROR: bad environment passed to logp (contact the package maintainer).");
}
try {
x_ = forceEval(x_, rho_, eval_limit);
ArmaContext* ap = mapOrFetch(x_, armaMap);
node = createMCMC(x_,armaMap);
} catch (std::logic_error &e) {
releaseMap(armaMap);
UNPROTECT(armaMap.size());
REprintf("%s\n",e.what());
return R_NilValue;
}
cppbugs::Stochastic* sp = dynamic_cast<cppbugs::Stochastic*>(node);
if(sp) {
ans = sp->loglik();
} else {
REprintf("ERROR: could not convert node to stochastic.\n");
}
releaseMap(armaMap);
UNPROTECT(armaMap.size());
return Rcpp::wrap(ans);
}
cppbugs::MCMCObject* createBernoulli(SEXP x_, vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP p_ = Rf_getAttrib(x_,Rf_install("p"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
if(x_ == R_NilValue || env_ == R_NilValue || p_ == R_NilValue || observed_ == R_NilValue) {
REprintf("ERROR: missing argument.");
return NULL;
}
// force substitutions
p_ = forceEval(p_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* p_arma = mapOrFetch(p_, armaMap);
if(p_arma->getArmaType() != doubleT && p_arma->getArmaType() != vecT && p_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createBernoulli, p must be a continuous variable.");
}
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignBernoulliLogp<cppbugs::ObservedBernoulli>(x_arma->getDouble(),p_arma);
} else {
p = assignBernoulliLogp<cppbugs::Bernoulli>(x_arma->getDouble(),p_arma);
}
break;
case vecT:
if(observed) {
p = assignBernoulliLogp<cppbugs::ObservedBernoulli>(x_arma->getVec(),p_arma);
} else {
p = assignBernoulliLogp<cppbugs::Bernoulli>(x_arma->getVec(),p_arma);
}
break;
case matT:
if(observed) {
p = assignBernoulliLogp<cppbugs::ObservedBernoulli>(x_arma->getMat(),p_arma);
} else {
p = assignBernoulliLogp<cppbugs::Bernoulli>(x_arma->getMat(),p_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: Bernoulli must be a discrete valued continuous variable type (double, vec, or mat). This is due to an issue in armadillo.");
}
return p;
}
//------------------------------------------------ Read input and evaluate expression.
double evaluateEval(Eval ev) {
Intype next; // Classification of next input character.
char inSymbol; // Read input operators into this.
Operator inOp; // Operator object constructed from inSymbol.
double inNumVal; // Read input operands into this.
Operand And; // Operand value
int numread;
int n;
for (;;) {
next = classifyEval(ev);
switch (next) {
case number:
n = sscanf(ev->instream, "%lg%n", &inNumVal, &numread);
ev->instream += numread;
if (n!=1 || sizeStack(ev->Ands) != ev->numbin)
return expErrorEval(ev);
And = newOperand(inNumVal);
pushStack(ev->Ands, And);
break;
case op:
if (sizeStack(ev->Ands) != ev->numbin+1)
return expErrorEval(ev);
inSymbol = *(ev->instream++);
inOp = newOperator(inSymbol);
forceEval(ev, precedenceOperator(inOp) );
pushStack(ev->Ators, inOp);
ev->numbin++;
break;
case lpar:
if (sizeStack(ev->Ands) != ev->numbin) return expErrorEval(ev);
inSymbol = *(ev->instream++);
inOp = newOperator(inSymbol); // put left paren on Ators stack
pushStack(ev->Ators, inOp);
break;
case rpar:
n = sscanf(ev->instream, " %c%n", &inSymbol, &numread);
ev->instream += numread;
if (sizeStack(ev->Ands) != ev->numbin+1)
return expErrorEval(ev);
forceEval(ev, 0);
if (isemptyStack(ev->Ators)) expErrorEval(ev); // too many right parens
Operator op = topStack(ev->Ators); // remove left paren operator from Ators stack
freeOperator(op);
popStack(ev->Ators);
break;
case end:
if (sizeStack(ev->Ands) != ev->numbin+1)
return expErrorEval(ev);
forceEval(ev, 0);
if (!isemptyStack(ev->Ators)) return expErrorEval(ev);
And = topStack(ev->Ands);
popStack(ev->Ands);
double retval = value(And);
freeOperand(And);
return retval;
break;
case bad:
default:
return expErrorEval(ev);
}
}
}
cppbugs::MCMCObject* createBinomial(SEXP x_, vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP n_ = Rf_getAttrib(x_,Rf_install("n"));
SEXP p_ = Rf_getAttrib(x_,Rf_install("p"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
if(x_ == R_NilValue || env_ == R_NilValue || n_ == R_NilValue || p_ == R_NilValue || observed_ == R_NilValue) {
REprintf("ERROR: missing argument.");
return NULL;
}
// force substitutions
n_ = forceEval(n_, env_, eval_limit);
p_ = forceEval(p_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* n_arma = mapOrFetch(n_, armaMap);
ArmaContext* p_arma = mapOrFetch(p_, armaMap);
armaT n_arma_type = n_arma->getArmaType();
if(n_arma_type == intT || n_arma_type == ivecT || n_arma_type == imatT) {
throw std::logic_error("ERROR: binomial hyperparameter n must be a continuous variable type (double, vec, or mat). This is due to an issue in armadillo.");
}
armaT p_arma_type = p_arma->getArmaType();
if(p_arma_type == intT || p_arma_type == ivecT || p_arma_type == imatT) {
throw std::logic_error("ERROR: binomial hyperparameter p must be a continuous variable type (double, vec, or mat).");
}
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignBinomialLogp<cppbugs::ObservedBinomial>(x_arma->getDouble(),n_arma,p_arma);
} else {
p = assignBinomialLogp<cppbugs::Binomial>(x_arma->getDouble(),n_arma,p_arma);
}
break;
case vecT:
if(observed) {
p = assignBinomialLogp<cppbugs::ObservedBinomial>(x_arma->getVec(),n_arma,p_arma);
} else {
p = assignBinomialLogp<cppbugs::Binomial>(x_arma->getVec(),n_arma,p_arma);
}
break;
case matT:
if(observed) {
p = assignBinomialLogp<cppbugs::ObservedBinomial>(x_arma->getMat(),n_arma,p_arma);
} else {
p = assignBinomialLogp<cppbugs::Binomial>(x_arma->getMat(),n_arma,p_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
//throw std::logic_error("ERROR: binomial must be an integer variable type.");
throw std::logic_error("ERROR: binomial must be an discrete valued continuous variable type. This is due to a small issue in armadillo. email me if you want a full explanation");
}
return p;
}
SEXP runModel(SEXP m_, SEXP iterations, SEXP burn_in, SEXP adapt, SEXP thin) {
const int eval_limit = 10;
SEXP env_ = Rf_getAttrib(m_,Rf_install("env"));
if(env_ == R_NilValue || TYPEOF(env_) != ENVSXP) {
throw std::logic_error("ERROR: bad environment passed to deterministic.");
}
vpArmaMapT armaMap;
vpMCMCMapT mcmcMap;
std::vector<cppbugs::MCMCObject*> mcmcObjects;
arglistT arglist;
std::vector<const char*> argnames;
initArgList(m_, arglist, 1);
for(size_t i = 0; i < arglist.size(); i++) {
// capture arg name
// FIXME: check class of args to make sure it's mcmc
if(TYPEOF(arglist[i])==SYMSXP) {
argnames.push_back(CHAR(PRINTNAME(arglist[i])));
}
// force eval of late bindings
arglist[i] = forceEval(arglist[i],env_,eval_limit);
try {
ArmaContext* ap = mapOrFetch(arglist[i], armaMap);
cppbugs::MCMCObject* node = createMCMC(arglist[i],armaMap);
mcmcMap[rawAddress(arglist[i])] = node;
mcmcObjects.push_back(node);
} catch (std::logic_error &e) {
releaseMap(armaMap);
releaseMap(mcmcMap);
UNPROTECT(armaMap.size());
REprintf("%s\n",e.what());
return R_NilValue;
}
}
int iterations_ = Rcpp::as<int>(iterations);
int burn_in_ = Rcpp::as<int>(burn_in);
int adapt_ = Rcpp::as<int>(adapt);
int thin_ = Rcpp::as<int>(thin);
SEXP ar;
PROTECT(ar = Rf_allocVector(REALSXP,1));
try {
cppbugs::RMCModel m(mcmcObjects);
m.sample(iterations_, burn_in_, adapt_, thin_);
//std::cout << "acceptance_ratio: " << m.acceptance_ratio() << std::endl;
REAL(ar)[0] = m.acceptance_ratio();
} catch (std::logic_error &e) {
releaseMap(armaMap);
releaseMap(mcmcMap);
UNPROTECT(armaMap.size());
UNPROTECT(1); // ar
REprintf("%s\n",e.what());
return R_NilValue;
}
SEXP ans;
PROTECT(ans = createTrace(arglist,armaMap,mcmcMap));
releaseMap(armaMap);
releaseMap(mcmcMap);
UNPROTECT(armaMap.size());
Rf_setAttrib(ans, R_NamesSymbol, makeNames(argnames));
Rf_setAttrib(ans, Rf_install("acceptance.ratio"), ar);
UNPROTECT(2); // ans + ar
return ans;
}
