コード例 #1
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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;
}
コード例 #2
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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;
}
コード例 #3
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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;
}
コード例 #4
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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;
}
コード例 #5
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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);
}
コード例 #6
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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;
}
コード例 #7
0
ファイル: eval.c プロジェクト: dougvk/CS223
//------------------------------------------------ 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);
		}
	}
} 
コード例 #8
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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;
}
コード例 #9
0
ファイル: interface.cpp プロジェクト: johnlaing/rcppbugs
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;
}