int test_spd_orderings(taucs_ccs_matrix* A,
double* x, double* y, double* b, double* z)
{
int rc;
char* metis[] = {"taucs.factor.ordering=metis", NULL};
char* genmmd[] = {"taucs.factor.ordering=genmmd", NULL};
char* colamd[] = {"taucs.factor.ordering=colamd", NULL};
char* amd[] = {"taucs.factor.ordering=amd", NULL};
void* opt_arg[] = { NULL };
rc = taucs_factor_solve(A,NULL,1, y,b,metis,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
if (rnorm(A,x,y,z)) return TAUCS_ERROR;
rc = taucs_factor_solve(A,NULL,1, y,b,genmmd,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
if (rnorm(A,x,y,z)) return TAUCS_ERROR;
rc = taucs_factor_solve(A,NULL,1, y,b,amd,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
if (rnorm(A,x,y,z)) return TAUCS_ERROR;
/* colamd should fail on symmetric matrices */
rc = taucs_factor_solve(A,NULL,1, y,b,colamd,opt_arg);
if (rc == TAUCS_SUCCESS) return TAUCS_ERROR;
printf("TESING SYMMETRIC ORDERINGS SUCCEDDED\n");
return TAUCS_SUCCESS;
}
int test_spd_factorizations(taucs_ccs_matrix* A,
double* x, double* y, double* b, double* z)
{
int rc;
char* mf[] = {"taucs.factor.mf=true", NULL};
char* ll[] = {"taucs.factor.ll=true", NULL};
char* mfmd[] = {"taucs.factor.mf=true", "taucs.maxdepth=5", NULL};
char* llmd[] = {"taucs.factor.ll=true", "taucs.maxdepth=5", NULL};
char* ooc[] = {"taucs.ooc=true", "taucs.ooc.basename=/tmp/taucs-test", NULL};
void* opt_arg[] = { NULL };
rc = taucs_factor_solve(A,NULL,1, y,b,ooc,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
if (rnorm(A,x,y,z)) return TAUCS_ERROR;
rc = taucs_factor_solve(A,NULL,1, y,b,mf,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
if (rnorm(A,x,y,z)) return TAUCS_ERROR;
rc = taucs_factor_solve(A,NULL,1, y,b,ll,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
if (rnorm(A,x,y,z)) return TAUCS_ERROR;
/* low depth should fail */
rc = taucs_factor_solve(A,NULL,1, y,b,mfmd,opt_arg);
if (rc == TAUCS_SUCCESS) return TAUCS_ERROR;
rc = taucs_factor_solve(A,NULL,1, y,b,llmd,opt_arg);
if (rc == TAUCS_SUCCESS) return TAUCS_ERROR;
printf("TESING SPD FACTORIZATIONS SUCCEDDED\n");
return TAUCS_SUCCESS;
}
void factor_model_row(double *x, unsigned int row, unsigned int n,
unsigned int p, unsigned int n_factors, double sigma)
{
register unsigned int j, k, l;
double factor = 0.0;
l = row;
for (j = 0; j < p; j++) {
x[l] = 0.0;
l += n;
}
for (k = 0; k < n_factors; k++) {
factor = rnorm(0.0, sigma);
l = row;
for (j = 0; j < p; j++) {
x[l] += factor * rnorm(0.0, sigma);
l += n;
}
}
l = row;
for (j = 0; j < p; j++) {
x[l] += rnorm(0.0, sigma);
l += n;
}
}
// simple 2D Ornstein-Uhlenbeck process simulation
static void sim_ou2 (double *x1, double *x2,
double alpha1, double alpha2, double alpha3, double alpha4,
double sigma1, double sigma2, double sigma3)
{
double eps[2], xnew[2];
if (!(R_FINITE(*x1))) return;
if (!(R_FINITE(*x2))) return;
if (!(R_FINITE(alpha1))) return;
if (!(R_FINITE(alpha2))) return;
if (!(R_FINITE(alpha3))) return;
if (!(R_FINITE(alpha4))) return;
if (!(R_FINITE(sigma1))) return;
if (!(R_FINITE(sigma2))) return;
if (!(R_FINITE(sigma3))) return;
eps[0] = rnorm(0,1);
eps[1] = rnorm(0,1);
xnew[0] = alpha1*(*x1)+alpha3*(*x2)+sigma1*eps[0];
xnew[1] = alpha2*(*x1)+alpha4*(*x2)+sigma2*eps[0]+sigma3*eps[1];
*x1 = xnew[0];
*x2 = xnew[1];
}
// bivariate normal measurement error simulator
void ou2_rmeasure (double *y, double *x, double *p,
int *obsindex, int *stateindex, int *parindex, int *covindex,
int ncovar, double *covar,
double t)
{
double sd = fabs(TAU);
Y1 = rnorm(x[X1],sd);
Y2 = rnorm(x[X2],sd);
}
void LocalLinearTrendModule::SimulateData(int time_dimension) {
trend_.resize(time_dimension);
double level = initial_level_;
double slope = initial_slope_;
for (int i = 0; i < time_dimension; ++i) {
trend_[i] = level;
level += slope + rnorm(0, level_sd_);
slope += rnorm(0, slope_sd_);
}
}
// simple 2D Ornstein-Uhlenbeck process simulation
static void sim_ou2 (double *x1, double *x2,
double alpha1, double alpha2, double alpha3, double alpha4,
double sigma1, double sigma2, double sigma3)
{
double eps[2], xnew[2];
eps[0] = rnorm(0,1);
eps[1] = rnorm(0,1);
xnew[0] = alpha1*(*x1)+alpha3*(*x2)+sigma1*eps[0];
xnew[1] = alpha2*(*x1)+alpha4*(*x2)+sigma2*eps[0]+sigma3*eps[1];
*x1 = xnew[0];
*x2 = xnew[1];
}
void leftTruncNorm(double *mu, double *sigma2, double *x){
int check1, check2;
double alphaStar, u, muMinus, z;
muMinus = -*mu/sqrt(*sigma2);
if (muMinus <= 0.0){
check1 = FALSE;
while(check1 == FALSE){
GetRNGstate();
z = rnorm(0.0,1.0);
PutRNGstate();
check1 = (z > muMinus);
}
} else {
alphaStar = 0.5 * (muMinus + sqrt(muMinus * muMinus + 4.0));
check2 = FALSE;
while(check2 == FALSE){
GetRNGstate();
z = muMinus + rexp(1/alphaStar);
PutRNGstate();
GetRNGstate();
u = runif(0.0,1.0);
PutRNGstate();
check2 = (u <= exp(-0.5*(z-alphaStar) * (z-alphaStar)));
}
}
*x = *mu + z * sqrt(*sigma2);
}
Vec ArModel::simulate(int n, const Vec &y0) const {
if(y0.size() != number_of_lags()){
ostringstream err;
err << "Error in ArModel::simulate." << endl
<< "Initial state value y0 was size " << y0.size()
<< ", but the model has " << number_of_lags() << " lags."
<< endl;
report_error(err.str());
}
const Vec &phi(this->phi());
std::deque<double> lags(y0.rbegin(), y0.rend());
Vec ans;
ans.reserve(n);
for(int i = 0; i < n; ++i) {
double mu = 0;
for(int lag = 0; lag < number_of_lags(); ++lag) {
mu += phi[lag] * lags[lag];
}
double y = rnorm(mu, sigma());
lags.push_front(y);
lags.pop_back();
ans.push_back(y);
}
return ans;
}
static void xLz(float c,float x,float y,float d){
if(T==MT)
glTriangle(x,y,x+cos(d+M_PI/64)*c,y+sin(d+M_PI/64)*c,x+cos(d-M_PI/64)*c,y+sin(d-M_PI/64)*c);
c*=c;
for(int i=0;i<2;i++)
if(dst2(x,y,Px[i],Py[i])<c&&fabsf(rnorm(d-dir(x,y,Px[i],Py[i])))<M_PI/64)Ph[i]--;
}
SEXP mutate_constants_normal(SEXP sexp, double p, double mu, double sigma) {
SEXP c;
switch (TYPEOF(sexp)) { // switch for speed
case NILSXP:
return sexp; // do nothing with nils
case REALSXP:
if (unif_rand() < p) { // mutate constant with probability p
PROTECT(c = allocVector(REALSXP, 1));
REAL(c)[0] = REAL(sexp)[0] + rnorm(mu, sigma);
UNPROTECT(1);
return c;
} else {
return sexp;
}
case LANGSXP: {
int function_arity = 0;
SEXP tail_e, e;
PROTECT(tail_e = R_NilValue);
for (SEXP iterator = CDR(sexp); !isNull(iterator); iterator = CDR(iterator)) { // recurse on actual parameters
function_arity++; // determine arity on the fly
SEXP mutated_parameter;
PROTECT(mutated_parameter = mutate_constants_normal(CAR(iterator), p, mu, sigma));
PROTECT(tail_e = CONS(mutated_parameter, tail_e));
}
PROTECT(e = LCONS(CAR(sexp), tail_e));
UNPROTECT(2 * function_arity + 2);
return e;
}
case LISTSXP:
error("mutate_constants_normal: unexpected LISTSXP");
default: // base case
return sexp; // do nothing
}
}
int test_spd_factorsolve(taucs_ccs_matrix* A,
double* x, double* y, double* b, double* z)
{
int rc;
void* F = NULL;
char* factor[] = {"taucs.solve=false", NULL};
char* solve [] = {"taucs.factor=false", NULL};
void* opt_arg[] = { NULL };
/* solve without a factorization should fail */
rc = taucs_factor_solve(A,NULL,1, y,b,solve,opt_arg);
if (rc == TAUCS_SUCCESS) return TAUCS_ERROR;
/* solve without a factorization should fail */
rc = taucs_factor_solve(A,&F,1, y,b,solve,opt_arg);
if (rc == TAUCS_SUCCESS) return TAUCS_ERROR;
rc = taucs_factor_solve(A,&F,1, y,b,factor,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
rc = taucs_factor_solve(A,&F,1, y,b,solve,opt_arg);
if (rc != TAUCS_SUCCESS) return rc;
if (rnorm(A,x,y,z)) return TAUCS_ERROR;
printf("TESING SPD FACTORSOLVE SUCCEDDED\n");
return TAUCS_SUCCESS;
}
Vec MVTR::simulate_fake_x()const{
uint p = xdim();
Vec x(p);
x[0] = 1.0;
for(uint i=0; i<p; ++i) x[i] = rnorm();
return x;
}
/**
* Simulate beta using the naive Gibbs update
*
* @param da an SEXP struct
*
*/
static void sim_beta(SEXP da){
int *dm = DIMS_SLOT(da), *k = K_SLOT(da);
int nB = dm[nB_POS];
double *beta = FIXEF_SLOT(da), *mh_sd = MHSD_SLOT(da), *l = CLLIK_SLOT(da),
*pm = PBM_SLOT(da), *pv = PBV_SLOT(da), *acc = ACC_SLOT(da);
double xo, xn, l1, l2, A;
/* initialize llik_mu*/
*l = llik_mu(da);
for (int j = 0; j < nB; j++){
*k = j;
xo = beta[j];
xn = rnorm(xo, mh_sd[j]);
l1 = *l;
l2 = post_betak(xn, da);
A = exp(l2 - l1 + 0.5 * (xo - pm[j]) * (xo - pm[j]) / pv[j]);
/* determine whether to accept the sample */
if (A < 1 && runif(0, 1) >= A){ /* not accepted */
*l = l1; /* revert the likelihood (this is updated in post_betak) */
}
else {
beta[j] = xn;
acc[j]++;
}
} /* update the mean using the new beta */
if (dm[nU_POS]) cpglmm_fitted(beta, 1, da);
else cpglm_fitted(beta, da);
}
double CGaussianMDP::sample_phi0
(
int n,
double *ysamp,
double *sigmasamp,
double s2,
double m
)
{
int i;
double s=0.0;
double ys=0.0;
double var;
double mn;
for(i=0; i<n; i++)
{
s += 1.0/sigmasamp[i];
ys += ysamp[i]/sigmasamp[i];
}
var = 1.0/(1.0/s2 + s);
mn = (m/s2 + ys)*var;
return rnorm(mn,sqrt(var));
}
static void sim_u(SEXP da){
int *dm = DIMS_SLOT(da), *k = K_SLOT(da);
int nB = dm[nB_POS], nU = dm[nU_POS];
double *u = U_SLOT(da), *l = CLLIK_SLOT(da),
*mh_sd = MHSD_SLOT(da) + nB + 2, /* shift the proposal variance pointer */
*acc = ACC_SLOT(da) + nB + 2; /* shift the acc pointer */
double xo, xn, l1, l2, A;
/* initialize llik_mu*/
*l = llik_mu(da);
for (int j = 0; j < nU; j++){
*k = j ;
xo = u[j];
xn = rnorm(xo, mh_sd[j]);
l1 = *l;
l2 = post_uk(xn, da);
A = exp(l2 - (l1 + prior_uk(xo, da)));
/* determine whether to accept the sample */
if (A < 1 && runif(0, 1) >= A){
*l = l1; /* revert llik_mu (this is updated in post_uk) */
}
else{
u[j] = xn;
acc[j]++;
}
}
cpglmm_fitted(u, 0, da) ; /* update the mean using the new u */
}
//Erzeugt Normalverteilten Zufallsvektor der Laenge noa
void gausssample(double* temp, int* noa) {
int i;
for (i=0; i < *noa; i++) {
temp[i] = rnorm(0.0, 1.0);
}
return;
}
double rlnorm(double meanlog, double sdlog)
{
if(ISNAN(meanlog) || !R_FINITE(sdlog) || sdlog < 0.)
ML_ERR_return_NAN;
return exp(rnorm(meanlog, sdlog));
}
Vector IndependentMvnModel::sim()const{
Vector ans(mu());
for(int i = 0; i < ans.size(); ++i){
ans += rnorm(0, sigma(i));
}
return ans;
}
void gplot3d_layout_kamadakawai_R(double *pn, int *pniter, double *elen, double *pinitemp, double *pcoolexp, double *pkkconst, double *psigma, double *x, double *y, double *z)
{
double initemp,coolexp,sigma,temp,cx,cy,cz;
double dpot,odis,ndis,osqd,nsqd,kkconst;
int niter;
long int n,i,j,k;
/*Define various things*/
n=(long int)*pn;
niter=*pniter;
initemp=*pinitemp;
coolexp=*pcoolexp;
kkconst=*pkkconst;
sigma=*psigma;
GetRNGstate(); /*Get the RNG state*/
/*Perform the annealing loop*/
temp=initemp;
for(i=0;i<niter;i++){
/*Update each vertex*/
for(j=0;j<n;j++){
/*Draw the candidate via a gaussian perturbation*/
cx=rnorm(x[j],sigma*temp/initemp);
cy=rnorm(y[j],sigma*temp/initemp);
cz=rnorm(z[j],sigma*temp/initemp);
/*Calculate the potential difference for the new position*/
dpot=0.0;
for(k=0;k<n;k++) /*Potential differences for pairwise effects*/
if(j!=k){
odis=sqrt((x[j]-x[k])*(x[j]-x[k])+(y[j]-y[k])*(y[j]-y[k]) +(z[j]-z[k])*(z[j]-z[k]));
ndis=sqrt((cx-x[k])*(cx-x[k])+(cy-y[k])*(cy-y[k]) +(cz-z[k])*(cz-z[k]));
osqd=(odis-elen[j+k*n])*(odis-elen[j+k*n]);
nsqd=(ndis-elen[j+k*n])*(ndis-elen[j+k*n]);
dpot+=kkconst*(osqd-nsqd)/(elen[j+k*n]*elen[j+k*n]);
}
/*Make a keep/reject decision*/
if(log(runif(0.0,1.0))<dpot/temp){
x[j]=cx;
y[j]=cy;
z[j]=cz;
}
}
/*Cool the system*/
temp*=coolexp;
}
PutRNGstate(); /*Update the RNG*/
}
Eigen::Quaterniond RodriguesToQuat(const cv::Mat& rvec) {
Eigen::Vector3d r(rvec.at<double>(0), rvec.at<double>(1), rvec.at<double>(2));
// Copied from kr_math pose
const double rn = r.norm();
Eigen::Vector3d rnorm(0.0, 0.0, 0.0);
if (rn > std::numeric_limits<double>::epsilon() * 10) rnorm = r / rn;
return Eigen::Quaterniond(Eigen::AngleAxis<double>(rn, rnorm));
}
/* Normal rejection sampling (a,inf) */
static R_INLINE double nrs_a_inf(double a) {
SAMPLER_DEBUG("nrs_a_inf", a, R_PosInf);
double x = -DBL_MAX;
while (x < a) {
x = rnorm(0, 1);
}
return x;
}
/* Normal rejection sampling (a,b) */
static R_INLINE double nrs_a_b(double a, double b) {
SAMPLER_DEBUG("nrs_a_b", a, b);
double x = -DBL_MAX;
while (x < a || x > b) {
x = rnorm(0, 1);
}
return x;
}
float rnorm() {
float u = ((float)rand() / (RAND_MAX)) * 2 - 1;
float v = ((float)rand() / (RAND_MAX)) * 2 - 1;
float r = u * u + v * v;
if (r == 0 || r > 1) return rnorm();
float c = sqrt(-2 * log(r) / r);
return u * c;
}
void BAFT_LNsurv_update_sigSq(gsl_vector *yL,
gsl_vector *yU,
gsl_vector *yU_posinf,
gsl_vector *c0,
gsl_vector *c0_neginf,
gsl_matrix *X,
gsl_vector *y,
gsl_vector *beta,
double beta0,
double *sigSq,
double a_sigSq,
double b_sigSq,
double sigSq_prop_var,
int *accept_sigSq)
{
int i, u;
double eta, loglh, loglh_prop, logR, gamma_prop, sigSq_prop;
double logprior, logprior_prop;
int n = X -> size1;
gsl_vector *xbeta = gsl_vector_calloc(n);
loglh = 0;
loglh_prop = 0;
gamma_prop = rnorm(log(*sigSq), sqrt(sigSq_prop_var));
sigSq_prop = exp(gamma_prop);
gsl_blas_dgemv(CblasNoTrans, 1, X, beta, 0, xbeta);
for(i=0;i<n;i++)
{
eta = beta0 + gsl_vector_get(xbeta, i);
if(gsl_vector_get(c0_neginf, i) == 0)
{
loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(*sigSq), 1) - pnorm(gsl_vector_get(c0, i), eta, sqrt(*sigSq), 0, 1);
loglh_prop += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq_prop), 1) - pnorm(gsl_vector_get(c0, i), eta, sqrt(sigSq_prop), 0, 1);
}else
{
loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(*sigSq), 1);
loglh_prop += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq_prop), 1);
}
}
logprior = (-a_sigSq-1)*log(*sigSq)-b_sigSq /(*sigSq);
logprior_prop = (-a_sigSq-1)*log(sigSq_prop)-b_sigSq/sigSq_prop;
logR = loglh_prop - loglh + logprior_prop - logprior + gamma_prop - log(*sigSq);
u = log(runif(0, 1)) < logR;
if(u == 1)
{
*sigSq = sigSq_prop;
*accept_sigSq += 1;
}
gsl_vector_free(xbeta);
return;
}
void rnb(double* mu, double* r, double* x, int* ny, double* y, double* ex, int* acceptr, double* rvar, double* a, double* b, double* r_r)
{
int i;
double u;
double rnew;
double temp;
double lr;
/*a,b: Parameter of Gamma(a,b)-Prior of r*/
GetRNGstate();
u=runif(0,1);
PutRNGstate();
/*Proposal forr r: truncated normal*/
rnew = rnorm(*r,*rvar);
while (rnew < 0){ /*| rnew > 100){*/
rnew = rnorm(*r,*rvar);
}
/*Calculation of acceptance probability*/
temp=0;
for (i=0; i < *ny; i++){
temp+=((lgammafn(y[i]+rnew)+lgammafn(*r))-(lgammafn(y[i]+ *r)+lgammafn(rnew))+rnew*log(rnew/(mu[i]+rnew))-(*r)*log(*r/(mu[i]+*r))+y[i]*log((mu[i]+*r)/(mu[i]+rnew)));
}
/*Prior for r*/
temp = temp + (*a-1)*log((rnew)/(*r)) - *b * ((rnew)-(*r));
/*Proposal Ratio for gamma proposal for r*/
/*temp=temp+((*r)-(rnew))/ *rvar*(log(*rvar)-1)+log(gammafn((*r)/ *rvar)/gammafn((rnew)/ *rvar))-((*r)/ *rvar-1)*log((rnew))+((rnew)/ *rvar-1)*log((*r));*/
lr = (temp<0)*temp;
if ((log(u) < lr) | (lr >= 0)){
*r = rnew;
*acceptr = *acceptr+1;
} else {
*r = *r;
}
r_r[0] = *r;
r_r[1] = *acceptr;
}
Vector MGXS::sim()const{
const Matrix & L(ivar_->var_chol());
uint p = dim();
Vector ans(p);
for(uint i=0; i<p; ++i) ans[i] = rnorm();
ans = L * ans;
ans += mu();
return ans;
}
/* Half-normal rejection sampling */
double hnrs_a_b(double a, double b) {
SAMPLER_DEBUG("hnrs_a_b", a, b);
double x = a - 1.0;
while (x < a || x > b) {
x = rnorm(0, 1);
x = fabs(x);
}
return x;
}
void RWHSM::simulate_state_error(VectorView eta, int t)const{
Date now = time_zero_ + t;
eta = 0;
if(holiday_->active(now)){
Date holiday_date(holiday_->nearest(now));
int position = now - holiday_->earliest_influence(holiday_date);
eta[position] = rnorm(0, sigma());
}
}
void VB5_stepfn (double *__x, const double *__p, const int *__stateindex, const int *__parindex, const int *__covindex, int __covdim, const double *__covars, double t, double dt)
{
double rate; //transition rates
double trans; // transition numbers
rate = r*(Linf-L);
trans = rnorm(rate*dt, G_sd*sqrt(dt));
L += trans;
}
