double rbeta(double alpha,double beta)
/*
* Generates from a beta (alpha,beta) distribution
*/
{
double tmp=1,random,temp;
temp=rgamma(alpha,tmp);
random=temp/(temp+rgamma(beta,tmp));
return(random);
}
double rnchisq(double df, double lambda)
{
if (!R_FINITE(df) || !R_FINITE(lambda) || df < 0. || lambda < 0.)
ML_ERR_return_NAN;
if(lambda == 0.) {
return (df == 0.) ? 0. : rgamma(df / 2., 2.);
}
else {
double r = rpois( lambda / 2.);
if (r > 0.) r = rchisq(2. * r);
if (df > 0.) r += rgamma(df / 2., 2.);
return r;
}
}
void predictExtrapUp(double *alpha, double *lambda, double *beta, double *predictPositions, int *NpredictPositions, double *currPositions1, double *theta1, int *maxExtrap, double *extractDate, double *predvals) {
// Runs the prediction code when we are extrapolating up beyond the first date
int bad=1,count=0,i;
double depthEvents[*maxExtrap],timeEvents[*maxExtrap];
depthEvents[0] = *currPositions1;
timeEvents[0] = *theta1;
while(bad==1) {
for(i=1;i<*maxExtrap;i++) {
depthEvents[i] = depthEvents[i-1]-rexp(1/(*lambda));
timeEvents[i] = timeEvents[i-1]-rgamma(*alpha,1/(*beta));
}
for(i=0;i<*NpredictPositions;i++) {
linInterp(maxExtrap,&predictPositions[i],depthEvents,timeEvents,&predvals[i]);
}
count+=1;
bad=0;
for(i=0;i<*NpredictPositions;i++) {
if(predvals[i]<*extractDate) bad=1;
}
if(count==50) {
for(i=0;i<*NpredictPositions;i++) {
if(predvals[i]<*extractDate) predvals[i] = *extractDate;
}
bad=0;
warning("Unable to find suitable chronologies for top of core - truncated to date of extraction");
}
}
}
void predictInterp(double *alpha, double *lambda, double *beta, double *predictPositions, int *NpredictPositions, double *diffPositionj, double *currPositionsj, double *currPositionsjp1, double *thetaj, double *thetajp1, double *predvals) {
// Runs the prediction code when we are interpolating between two positions
int Nd = rpois((*lambda)*(*diffPositionj));
int i;
double depthEvents[Nd];
for(i=0;i<Nd;i++) depthEvents[i] = runif(*currPositionsj,*currPositionsjp1);
R_rsort(depthEvents,Nd);
double timeEventsUnsc[Nd+1],timeEventsSum=0.0;
for(i=0;i<Nd+1;i++) timeEventsUnsc[i] = rgamma(*alpha,1/(*beta));
for(i=0;i<Nd+1;i++) timeEventsSum += timeEventsUnsc[i];
double timeEvents[Nd+1];
for(i=0;i<Nd+1;i++) timeEvents[i] = (*thetajp1-*thetaj)*timeEventsUnsc[i]/timeEventsSum;
double timeEventsCumsum[Nd+1],allTimeEvents[Nd+2];
timeEventsCumsum[0] = 0.0;
for(i=1;i<Nd+1;i++) timeEventsCumsum[i] = timeEventsCumsum[i-1] + timeEvents[i];
for(i=0;i<Nd+1;i++) allTimeEvents[i] = timeEventsCumsum[i]+*thetaj;
allTimeEvents[Nd+1] = *thetajp1;
double allDepthEvents[Nd+2];
allDepthEvents[0] = *currPositionsj;
for(i=1;i<Nd+1;i++) allDepthEvents[i] = depthEvents[i-1];
allDepthEvents[Nd+1] = *currPositionsjp1;
int Ndp2 = Nd+2;
for(i=0;i<*NpredictPositions;i++) {
linInterp(&Ndp2,&predictPositions[i],allDepthEvents,allTimeEvents,&predvals[i]);
}
}
double rgamma( double a) {
double d;
double c;
double x;
double v;
double u;
if( a < 0.0 )
p_internal_error( "rgamma: negative shape parameter" );
if( a < 1.0 )
return pow( UNI, 1.0 / a ) * rgamma( 1.0 + a );
d = a - 1.0/3.0;
c = 1.0 / sqrt( 9.0 * d );
while( TRUE ) {
do {
x = RNOR;
v= 1.0 + c * x;
} while( v <= 0.0 );
v = v * v * v;
u = UNI;
if( u < 1.0 - 0.0331 * (x * x) * (x * x) )
return( d * v );
if( log( u ) < 0.5* x * x + d * (1.0 - v + log( v ) ) )
return( d * v );
}
}
double rnbinom(double size, double prob)
{
if(!R_FINITE(size) || !R_FINITE(prob) || size <= 0 || prob <= 0 || prob > 1)
/* prob = 1 is ok, PR#1218 */
ML_ERR_return_NAN;
return (prob == 1) ? 0 : rpois(rgamma(size, (1 - prob) / prob));
}
/***** ***************************************************************************************** *****/
void
updateHyperVars_eps(double* gammaInv,
const double* sigma, const int* R,
const double* zeta, const double* g, const double* h)
{
static int s;
static double shape, scale;
static double *gammaInvP;
static const double *sigmaP, *zetaP, *gP, *hP;
gammaInvP = gammaInv;
sigmaP = sigma;
zetaP = zeta;
gP = g;
hP = h;
for (s = 0; s < *R; s++){
shape = *gP + 0.5 * *zetaP;
scale = 1 / (*hP + 0.5 * (1 / (*sigmaP * *sigmaP)));
*gammaInvP = rgamma(shape, scale);
gammaInvP++;
sigmaP++;
zetaP++;
gP++;
hP++;
}
return;
}
double rnbinom_mu(double size, double mu)
{
if(!R_FINITE(mu) || ISNAN(size) || size <= 0 || mu < 0)
ML_ERR_return_NAN;
if(!R_FINITE(size)) size = DBL_MAX / 2.;
return (mu == 0) ? 0 : rpois(rgamma(size, mu / size));
}
double rnbinom(double size, double prob)
{
if(!R_FINITE(prob) || ISNAN(size) || size <= 0 || prob <= 0 || prob > 1)
/* prob = 1 is ok, PR#1218 */
ML_ERR_return_NAN;
if(!R_FINITE(size)) size = DBL_MAX / 2.; // '/2' to prevent rgamma() returning Inf
return (prob == 1) ? 0 : rpois(rgamma(size, (1 - prob) / prob));
}
void SimOneNorm_IG(double *shape, double *rate, int *pd, int *pnreps,
int *pN, double *es, double *YY)
{
int i, j, l, d, N, nreps, mxnreps;
int *lbuff;
double sig, sigma2, sigma;
double *xbuff, *Y;
N = *pN;
d = *pd;
mxnreps=0;
for(l=0;l<N;l++) if(mxnreps < *(pnreps+l)) mxnreps = *(pnreps+l);
lbuff = (int *)S_alloc( 1, sizeof(int));
xbuff = (double *)S_alloc( d, sizeof(double));
Y = (double *)S_alloc(mxnreps*d, sizeof(double));
GetRNGstate();
/* NOTE: */
/* this block computes the average std dev over genes from the model */
/* it is used for the purposes of assigning mean value to Y's under the alternative */
/* */
sig = pow(*rate/(*shape-1.0), 0.5);
for(l=0;l<N;l++){
/* */
/* First, simulate sigma2 ~ InvGamma(shape, rate). This is done */
/* using the result: if sigma2^(-1) ~ Gamma(shape, rate) then */
/* sigma2 ~ InvGamma(shape, rate). */
sigma2 = 1.0/rgamma(*shape, 1.0/(*rate));
/* */
/* sigma2 ~ InvGamma(shape, rate) */
/* */
/* Next, use sigma2 to simulate Y ~ i.i.d. N(0_d, sigma2) */
nreps = *(pnreps+l);
*lbuff = nreps*d;
rnormn(lbuff, Y);
sigma = pow(sigma2, 0.5);
for(i=0;i<nreps;i++){
for(j=0;j<d;j++) *(Y + d*i + j) = *(Y + d*i + j)*(sigma) + *(es + l)*(sig);
}
for(i=0;i<(nreps*d);i++) *(YY + mxnreps*d*l + i) = *(Y+i);
}
PutRNGstate();
}
/*
Pass the arrays for each of the parameters. This routine will fill in these arrays.
return the acceptance rate */
double
mcmc(int numIterations, int n, double *theta, double *lambda,
int *k, double *b1, double *b2, double *Y)
{
int numAccepted;
int i;
double currTheta = theta[0], currLambda = lambda[0], curr_b1 = b1[0], curr_b2 = b2[0];
double currK = k[0]; // make this a double rather than an integer.
double proposedK, logMHratio;
for(i = 1; i < numIterations; i++) {
currTheta = rgamma( sumYs(Y, 0, currK) + .5, curr_b1/(currK * curr_b1 + 1.));
currLambda = rgamma( sumYs(Y, currK, n), curr_b2 / ( ((double) n - currK)*curr_b2 + 1) );
proposedK = riunif(2, n-1);
double a = sumYs(Y, 0, proposedK);
double b = sumYs(Y, proposedK, n);
logMHratio = a * log(currTheta) + b * log(currLambda) -
proposedK*currTheta - (n - proposedK) * currLambda -
(sumYs(Y, 0, currK) * log(currTheta) + sumYs(Y, currK, n)* log(currLambda) -
currK * currTheta - (n - currK) * currLambda);
double logAlpha = MIN(0, logMHratio);
double u = log(runif(0, 1));
if(u < logAlpha) {
numAccepted++;
currK = proposedK;
}
curr_b1 = 1/rgamma(.5, 1/(currTheta + 1.));
curr_b2 = 1/rgamma(.5, 1/(currLambda + 1.));
theta[i]= currTheta;
lambda[i]= currLambda;
k[i]= currK;
b1[i] = curr_b1;
b2[i] = curr_b2;
}
return( ((double)numAccepted)/ ((double) numIterations ));
}
void sampleSigPhi_kernel3(Chain *a){ /* kernel <<<1, 1>>> */
num_t rate = a->s1 / 2;
num_t shape = (a->G - 1) / 2;
num_t lb = 1/pow(a->sigPhi0, 2);
if(shape > 0 && rate > 0){
a->sigPhi = 1/sqrt(rgamma(shape, rate, lb));
} else {
a->sigPhi = a->sigPhi;
}
}
//' Samples from a Dirichlet distribution given a hyperparameter
//'
//' @param num_elements the dimention of the Dirichlet distribution
//' @param alpha the hyperparameter vector (a column vector)
//'
//' @return returns a Dirichlet sample (a column vector)
//'
//' @note
//' Author: Clint P. George
//'
//' Created on: 2014
//'
//' @family utils
//'
//' @export
// [[Rcpp::export]]
arma::vec sample_dirichlet(unsigned int num_elements, arma::vec alpha){
arma::vec dirichlet_sample = arma::zeros<arma::vec>(num_elements);
for ( register unsigned int i = 0; i < num_elements; i++ )
dirichlet_sample(i) = rgamma(1, alpha(i), 1.0)(0); // R::rgamma(1, alpha(i));
dirichlet_sample /= accu(dirichlet_sample);
return dirichlet_sample;
}
void predictExtrapDown(double *alpha, double *lambda, double *beta, double *predictPositions, int *NpredictPositions, double *currPositionsn, double *thetan, int *maxExtrap, double *predvals) {
// Runs the prediction code when we are extrapolating down below the bottom date
double depthEvents[*maxExtrap],timeEvents[*maxExtrap];
int i;
depthEvents[0] = *currPositionsn;
timeEvents[0] = *thetan;
for(i=1;i<*maxExtrap;i++) {
depthEvents[i] = depthEvents[i-1]+rexp(1/(*lambda));
timeEvents[i] = timeEvents[i-1]+rgamma(*alpha,1/(*beta));
}
for(i=0;i<*NpredictPositions;i++) {
linInterp(maxExtrap,&predictPositions[i],depthEvents,timeEvents,&predvals[i]);
}
}
void newChain_kernel2(Chain *a){ /* kernel <<<G, 1>>> */
int n, g, G = a->G;
num_t u;
for(g = 0; g < a->G; ++g){
a->tmp1[g] = 0;
a->tmp2[g] = 0;
a->dex[g] = 0;
a->hph[g] = 0;
a->lph[g] = 0;
a->mph[g] = 0;
a->phi[g] = rnormal(a->thePhi, a->sigPhi);
a->eta[g] = 1/sqrt(rgamma(a->d / 2,
a->d * a->tau * a->tau / 2, 0));
a->accPhi[g] = 0;
a->accAlp[g] = 0;
a->accDel[g] = 0;
a->tunePhi[g] = 1;
a->meanPhi[g] = 0;
a->meanAlp[g] = 0;
a->meanDel[g] = 0;
for(n = 0; n < a->N; ++n){
a->eps[iG(n, g)] = rnormal(0, a->eta[g]);
a->meanEps[iG(n, g)] = 0;
a->accEps[iG(n, g)] = 0;
a->tuneEps[iG(n, g)] = 1;
}
u = runiform(0, 1);
if(u < a->piAlp){
a->alp[g] = 0;
} else {
a->alp[g] = rnormal(a->theAlp, a->sigAlp);
}
u = runiform(0, 1);
if(u < a->piDel){
a->del[g] = 0;
} else {
a->del[g] = rnormal(a->theDel, a->sigDel);
}
}
}
int kleap (pomp_ssa_rate_fn *ratefun, double kappa, double *t, double *f,
double *y, const double *v, const double *d, const double *par,
int nvar, int nevent, int npar,
const int *istate, const int *ipar, int ncovar, const int *icovar,
int mcov, const double *cov) {
double prob[nevent];
int k[nevent];
double kk, tstep;
int change[nvar];
int i, j;
// Determine time interval and update time
double fsum = 0;
for (j = 0; j < nevent; j++) fsum += f[j];
if (fsum > 0.0) {
tstep = rgamma(kappa,1.0/fsum);
*t = *t+tstep;
} else {
*t = R_PosInf;
return 1;
}
// Determine frequency of events, update pops & events
for (j = 0; j < nevent; j++) prob[j] = f[j]/fsum;
rmultinom((int)kappa,prob,nevent,k);
// some matrix-vector multiplication but only where necessary
for (i = 0; i < nvar; i++) change[i] = 0;
for (j = 0; j < nevent; j++) {
if (k[j] != 0) {
kk = (double) k[j];
for (i = 0; i < nvar; i++) {
if (v[i+nvar*j] != 0) {
y[i] += kk*v[i+nvar*j];
change[i] = 1;
}
}
}
}
// only updating events & tree entries that have changed
for (j = 0; j < nevent; j++) {
for (i = 0; i < nvar; i++) {
if ((change[i] != 0) && (d[i+nvar*j] != 0)) {
f[j] = (*ratefun)(j+1,*t,y,par,istate,ipar,icovar,mcov,cov);
if (f[j] < 0.0)
errorcall(R_NilValue,"'rate.fun' returns a negative rate");
break;
}
}
}
return 0;
}
/* Dirichlet generator */
void rdirich(unsigned int n, double *epsilon)
{
unsigned int i;
double sum = 0;
// Rprintf("n = %d\n",n);
for (i=0; i<n; ++i){
// if(epsilon[i]==1)epsilon[i] +=0.5;
// Rprintf("epsilon[%d] = %1.7f\n",i,epsilon[i]);
epsilon[i] = rgamma(epsilon[i], 1.0);
sum += epsilon[i];
}
for (i=0; i<n; ++i)
epsilon[i] = epsilon[i]/sum;
}
void rdirich(double *alpha,int length,double **rand,double add)
/*
* Generates from a Dirichlet distribution,the generated random values are stored in "rand",add is psuedocount.
*/
{
double tmp,sum=0,beta=1.0;
int k;
for(k=0;k<length;k++)
{
tmp=rgamma(alpha[k]+add,beta);
(*rand)[k]=tmp;
sum+=tmp;
}
for(k=0;k<length;k++)
(*rand)[k]/=sum;
}
/* sample from truncated inverse chi squared truncated above at "max" */
double TruncInvChisq(int df, double scale, double max, int invcdf) {
double temp = 0, temp_pg, g_shape, g_scale;
double out;
int i;
g_shape = (double)df / 2;
g_scale = 2 / ((double)df * scale);
if (invcdf) {/* inverse cdf method */
temp = runif(0, 1);
temp_pg = pgamma(1 / max, g_shape, g_scale, 1, 0);
temp = (temp * ((double)1 - temp_pg)) + temp_pg;
out = qgamma(temp, g_shape, g_scale, 1, 0);
} else {/* rejection sampling method */
for (i = 0; i < 10000; i++) {
out = rgamma(g_shape, g_scale);
if (out > 1 / max ) break;
if (temp == 9999) {
/* error("Too many rejections. Try the inverse-CDF method"); */
/* If there are too many rejections, inverse-CDF method */
temp = runif(0, 1);
temp_pg = pgamma(1 / max, g_shape, g_scale, 1, 0);
temp = (temp * ((double)1 - temp_pg)) + temp_pg;
out = qgamma(temp, g_shape, g_scale, 1, 0);
}
}
}
return (1 / out);
}
/* inputs
d0 = d = dimension
cpar = parameter vector with correlations with latent and df for mvt
copcode = copula code (see the above #define)
output
zvec = random normal or t d-vector with 1-factor structure
*/
void sim1factmvt(int *d0, double *cpar, int *copcode, double *zvec)
{ int cop,j,d;
double df,w1,z,rho,rhe,denom;
double snorm(),rgamma(double,double); // in file rt.c
cop=*copcode; d=*d0; df=cpar[d];
//printf("copcode=%d\n", cop);
w1=snorm(); // latent variable
//printf("%f ", w1);
for(j=0;j<d;j++)
{ z=snorm();
//printf("%f ", z);
rho=cpar[j]; rhe=sqrt(1.-rho*rho);
zvec[j]=rho*w1+rhe*z;
}
//printf("\n");
if(cop==BVT && df<300. && df>0.) // bivariate t
{ denom=rgamma(df/2.,2.) / df; denom=sqrt(denom);
for(j=0;j<d;j++) zvec[j]/=denom;
}
}
///////////////////////////////////////////////////////////////////
// DEFINE THE PROCESS MODEL, THIS IS A STATISTICAL NON-MECHANISTIC MODEL
///////////////////////////////////////////////////////////////////
void null_chickenpox_proc_sim (double *x, const double *p,
const int *stateindex, const int *parindex, const int *covindex,
int covdim, const double *covar,
double t, double dt)
{
double beta_sd;
double epsilon;
double beta1;
double beta3;
double scale;
double omega;
// PUT PARS ON NATURAL SCALE
beta_sd = exp(LOGBETA_SD);
beta1 = exp(LOGBETA1);
beta3 = exp(LOGBETA3);
omega = exp(LOGOMEGA);
if (beta_sd > 0) {
scale = pow(beta_sd,2);
epsilon = rgamma(1/scale,scale);
} else {epsilon = 1;}
if(
isfinite(epsilon)== FALSE ||
isfinite(FOI)==FALSE ||
isfinite(I)==FALSE ||
isfinite(beta1)==FALSE
)
{
Rprintf("non finite value in chickenpox_proc_sim\n");
return;
}
FOI = (beta1*cos((2*M_PI/12)*(t+omega)) + beta3)*epsilon;
if(FOI < 0){FOI = 0;}
I = CHILDREN*FOI;
}
static void sim_Sigma(SEXP da){
SEXP V = GET_SLOT(da, install("Sigma")) ;
int *dm = DIMS_SLOT(da), *Gp = Gp_SLOT(da),
*nc = NCOL_SLOT(da), *nlev = NLEV_SLOT(da);
int nT = dm[nT_POS], mc = imax(nc, nT);
double *v, su, *u = U_SLOT(da),
*scl = Alloca(mc * mc, double);
R_CheckStack();
for (int i = 0; i < nT; i++){
v = REAL(VECTOR_ELT(V, i));
if (nc[i] == 1){ /* simulate from the inverse-Gamma */
su = sqr_length(u + Gp[i], nlev[i]);
v[0] = 1/rgamma(0.5 * nlev[i] + IG_SHAPE, 1.0/(su * 0.5 + IG_SCALE));
}
else { /* simulate from the inverse-Wishart */
mult_xtx(nlev[i], nc[i], u + Gp[i], scl); /* t(x) * (x) */
for (int j = 0; j < nc[i]; j++) scl[j * j] += 1.0; /* add prior (identity) scale matrix */
solve_po(nc[i], scl, v);
rwishart(nc[i], (double) (nlev[i] + nc[i]), v, scl);
solve_po(nc[i], scl, v);
}
}
}
void update_beta(double *response, double *preds, int *n, int *np, int *nj, double *betas, double *vari, double *psis, double *phis, double *var_beta)
{
/* Gibbs update for all parameters. Updates beta and then sigma2 */
int i, j, k, m;
double cov_sum, cov_sum2, cov_sum4;
double beta_mean;
double beta_sigma2;
double phi_new, psi_new;
int num_community = *n, num_bins = *nj, num_covariates = *np;
double psi = *psis, phi = *phis, sigma2_beta = *var_beta;
double sigma2;
double weight_hist[num_community][num_bins];
double covariates[num_community][num_covariates];
double beta[num_covariates][num_bins];
//Added this line - not sure if it will fix it or not - sigma2 not passing back to R.
//Consider changing the gamma function - this might fix it.
sigma2 = *vari;
for (i = 0; i < num_community; i++) {
for (j = 0; j < num_bins; j++) {
weight_hist[i][j] = response[i * num_bins + j];
}
for (k = 0; k < num_covariates; k++) {
covariates[i][k] = preds[i * num_covariates + k];
}
}
for (k = 0; k < num_covariates; k++) {
for (j = 0; j < num_bins; j++) {
beta[k][j] = betas[k * num_bins + j];
}
}
GetRNGstate();
//Update beta
// j = 0
for (k = 0; k < num_covariates ; k++) {
cov_sum = 0;
cov_sum2 = 0;
for (i = 0; i < num_community; i++) {
cov_sum4 = 0;
cov_sum2 += covariates[i][k] * covariates[i][k];
for (m = 0; m < num_covariates; m++) {
if (m != k) {
cov_sum4 += beta[m][0] * covariates[i][k] * covariates[i][m];
}
}
cov_sum += 2.0 * weight_hist[i][0] * covariates[i][k] - 2.0 * cov_sum4;
}
beta_mean = (sigma2 * (6.0 * beta[k][1] - 2.0 * beta[k][2])
+ sigma2_beta * cov_sum) / (6.0 * sigma2 + 2.0 * sigma2_beta * cov_sum2);
beta_sigma2 = (sigma2 * sigma2_beta) / (3.0 * sigma2 + sigma2_beta * cov_sum2);
//Sample new beta[k][0]
beta[k][0] = rnorm(beta_mean, sqrt(beta_sigma2));
}
// j = 1
for (k = 0; k < num_covariates ; k++) {
cov_sum = 0;
cov_sum2 = 0;
for (i = 0; i < num_community; i++) {
cov_sum4 = 0;
cov_sum2 += covariates[i][k] * covariates[i][k];
for (m = 0; m < num_covariates; m++) {
if (m != k) {
cov_sum4 += beta[m][1] * covariates[i][k] * covariates[i][m];
}
}
cov_sum += 2.0 * weight_hist[i][1] * covariates[i][k] - 2.0 * cov_sum4;
}
beta_mean = (sigma2 * (6.0 * beta[k][0] + 8.0 * beta[k][2] - 2.0 * beta[k][3])
+ sigma2_beta * cov_sum) / (12.0 * sigma2 + 2.0 * sigma2_beta * cov_sum2);
beta_sigma2 = (sigma2 * sigma2_beta) / (6.0 * sigma2 + sigma2_beta * cov_sum2);
//Sample new beta[k][1]
beta[k][1] = rnorm(beta_mean, sqrt(beta_sigma2));
}
// 1 < j < max(j) - 1
for (j = 2; j < (num_bins - 2); j++) {
for (k = 0; k < num_covariates ; k++) {
cov_sum = 0;
cov_sum2 = 0;
for (i = 0; i < num_community; i++) {
cov_sum4 = 0;
cov_sum2 += covariates[i][k] * covariates[i][k];
for (m = 0; m < num_covariates; m++) {
if (m != k) {
cov_sum4 += beta[m][j] * covariates[i][k] * covariates[i][m];
}
}
cov_sum += 2.0 * weight_hist[i][j] * covariates[i][k] - 2.0 * cov_sum4;
}
beta_mean = (sigma2 * (-2.0 * beta[k][j-2] + 8.0 * beta[k][j-1] + 8.0 * beta[k][j+1] - 2.0 * beta[k][j+2])
+ sigma2_beta * cov_sum) / (12.0 * sigma2 + 2.0 * sigma2_beta * cov_sum2);
beta_sigma2 = (sigma2 * sigma2_beta) / (6.0 * sigma2 + sigma2_beta * cov_sum2);
//Sample new beta[k][j]
beta[k][j] = rnorm(beta_mean, sqrt(beta_sigma2));
}
}
// j = max(j) - 1
for (k = 0; k < num_covariates ; k++) {
cov_sum = 0;
cov_sum2 = 0;
for (i = 0; i < num_community; i++) {
cov_sum4 = 0;
cov_sum2 += covariates[i][k] * covariates[i][k];
for (m = 0; m < num_covariates; m++) {
if (m != k) {
cov_sum4 += beta[m][num_bins - 2] * covariates[i][k] * covariates[i][m];
}
}
cov_sum += 2.0 * weight_hist[i][num_bins - 2] * covariates[i][k] - 2.0 * cov_sum4;
}
beta_mean = (sigma2 * (-2.0 * beta[k][num_bins - 4] + 8.0 * beta[k][num_bins - 3] + 4.0 * beta[k][num_bins - 1])
+ sigma2_beta * cov_sum) / (10.0 * sigma2 + 2.0 * sigma2_beta * cov_sum2);
beta_sigma2 = (sigma2 * sigma2_beta) / (5.0 * sigma2 + sigma2_beta * cov_sum2);
//Sample new beta[k][num_bins - 2]
beta[k][num_bins - 2] = rnorm(beta_mean, sqrt(beta_sigma2));
}
// j = max(j)
for (k = 0; k < num_covariates ; k++) {
cov_sum = 0;
cov_sum2 = 0;
for (i = 0; i < num_community; i++) {
cov_sum4 = 0;
cov_sum2 += covariates[i][k] * covariates[i][k];
for (m = 0; m < num_covariates; m++) {
if (m != k) {
cov_sum4 += beta[m][num_bins - 1] * covariates[i][k] * covariates[i][m];
}
}
cov_sum += 2.0 * weight_hist[i][num_bins - 1] * covariates[i][k] - 2.0 * cov_sum4;
}
beta_mean = (sigma2 * (-2.0 * beta[k][num_bins - 3] + 4.0 * beta[k][num_bins - 2])
+ sigma2_beta * cov_sum) / (2.0 * sigma2 + 2.0 * sigma2_beta * cov_sum2);
beta_sigma2 = (sigma2 * sigma2_beta) / (sigma2 + sigma2_beta * cov_sum2);
//Sample new beta[k][num_bins - 1]
beta[k][num_bins - 1] = rnorm(beta_mean, sqrt(beta_sigma2));
}
//Update sigma2
cov_sum = 0;
for (i = 0; i < num_community; i++) {
for (j = 0; j < num_bins; j++) {
cov_sum2 = 0;
for (k = 0; k < num_covariates; k++) {
cov_sum2 += beta[k][j] * covariates[i][k];
}
cov_sum += (weight_hist[i][j] - cov_sum2) * (weight_hist[i][j] - cov_sum2);
}
}
psi_new = psi + num_covariates * num_bins / 2.0;
phi_new = phi + (1.0 / 2.0) * cov_sum;
//Sample new sigma2
sigma2 = 1 / rgamma(psi_new, 1 / phi_new);
//Update and return values
for (i = 0; i < num_community; i++) {
for (j = 0; j < num_bins; j++) {
response[i * num_bins + j] = weight_hist[i][j];
}
for (k = 0; k < num_covariates; k++) {
preds[i * num_covariates + k] = covariates[i][k];
}
}
for (k = 0; k < num_covariates; k++) {
for (j = 0; j < num_bins; j++) {
betas[k * num_bins + j] = beta[k][j];
}
}
*vari = sigma2;
PutRNGstate();
}
double rchisq(double df)
{
if (!R_FINITE(df) || df < 0.0) ML_ERR_return_NAN;
return rgamma(df / 2.0, 2.0);
}
//extern "C"{
SEXP sampler(
/*prior params*/
double *a1, double *a2, /* prior for tau2*/
double *b1, double *b2, /* prior for sigma2 */
double *alphaW, double *betaW, /* prior for w */
double *v0, /* gamma */
double *varKsi, /*vector length qKsiUpdate!!*/
/*model dimensions*/
int *q, /*length of ksi*/
int *qKsiUpdate, /*length of updated ksi*/
int *p, /*length alpha*/
int *pPen, /*length penalized alpha/ tau2 / gamma*/
int *n, /* no. of obs.*/
int *d, /*vector (length p): group sizes*/
/*parameter vectors*/
double *beta,
double *alpha,
double *ksi,
double *tau2,
double *gamma,
double *sigma2,
double *w,
/* (precomputed) constants */
double *y,
double *X,
double *G,
double *scale,
double *offset,
/*info about updateBlocks*/
int *blocksAlpha,
int *indA1Alpha,
int *indA2Alpha,
int *blocksKsi,
int *indA1Ksi,
int *indA2Ksi,
/*MCMC parameters*/
int *pcts,
int *burnin,
int *thin,
int *totalLength,
int *verbose,
double *ksiDF,
int *scaleMode,
double *modeSwitching,
int *family,
double *acceptKsi,
double *acceptAlpha,
/*return matrices*/
double *betaMatR,
double *alphaMatR,
double *ksiMatR,
double *gammaMatR,
double *probV1MatR,
double *tau2MatR,
double *sigma2MatR,
double *wMatR,
double *likMatR,
double *logPostMatR
)
{
// ############################################### //
// ######## unwrap/initialize args ############### //
// ############################################### //
int pIncluded=0, i=0, j=0, startPen = *p-*pPen, qKsiNoUpdate = *q - *qKsiUpdate,
save = 0, keep = *burnin, nrv =1, info=0,
nSamp=(*totalLength-*burnin)/(*thin), oneInt = 1, zeroInt = 0;
double *p1 =Calloc(*pPen, double);
double infV = 100000, oneV = 1.0, zeroV = 0.0, minusOneV =-1.0;
double *one=&oneV, *zero=&zeroV, *minusOne=&minusOneV, *inf=&infV, acceptance=0;
double invSigma2 = 1 / *sigma2, sqrtInvSigma2 = R_pow(invSigma2, 0.5);
double *penAlphaSq, *alphaLong, *varAlpha, *priorMeanAlpha, *modeAlpha, *offsetAlpha;;
penAlphaSq = Calloc(*pPen, double);
for(int i=*p-*pPen; i<*p; i++) penAlphaSq[i- *p + *pPen] = R_pow(alpha[i], 2.0);
alphaLong = Calloc(*q, double);
F77_CALL(dgemm)("N","N", q, &oneInt, p, one, G, q, alpha, p, zero, alphaLong, q);
varAlpha = Calloc(*p, double);
for(int i=0; i<startPen; i++) varAlpha[i] = *inf; /*unpenalized*/
for(int i=startPen; i<*p; i++) varAlpha[i] = tau2[i-startPen]*gamma[i-startPen]; /*penalized*/
priorMeanAlpha = Calloc(*p, double);
setToZero(priorMeanAlpha, *p);
modeAlpha = Calloc(*p, double);
F77_CALL(dcopy)(p, alpha, &oneInt, modeAlpha, &oneInt);
offsetAlpha = Calloc(*n, double);
F77_CALL(dcopy)(n, offset, &oneInt, offsetAlpha, &oneInt);
double *ksiUpdate, *priorMeanKsi, *modeKsi, *offsetKsi;
int safeQKsiUpdate = imax2(1, *qKsiUpdate);
//ksiUpdate contains the last qKsiUpdate elements in ksi
ksiUpdate = Calloc(safeQKsiUpdate, double);
F77_CALL(dcopy)(&safeQKsiUpdate, &ksi[*q-safeQKsiUpdate], &oneInt, ksiUpdate, &oneInt);
priorMeanKsi = Calloc(safeQKsiUpdate, double);
setToZero(priorMeanKsi, safeQKsiUpdate);
for(int i=0; i<*qKsiUpdate; i++) priorMeanKsi[i] = 1.0;
modeKsi = Calloc(safeQKsiUpdate, double);
setToZero(modeKsi, safeQKsiUpdate);
for(int i=0; i<*qKsiUpdate; i++) modeKsi[i] = ksi[i+qKsiNoUpdate];
// offsetKsi = offset + X_d=1*alpha : use lin.predictor of grps with ksi==1 as offset
offsetKsi = Calloc(*n, double);
F77_CALL(dcopy)(n, offset, &oneInt, offsetKsi, &oneInt);
if(qKsiNoUpdate < *q){
if(qKsiNoUpdate > 0){
F77_CALL(dgemm)("N","N", n, &oneInt, &qKsiNoUpdate, one, X, n, alpha, &qKsiNoUpdate, one, offsetKsi, n);
}
}
double *eta, *resid, rss, *XAlpha, *XKsiUpdate, *etaOffset;
eta = Calloc(*n, double);
F77_CALL(dgemm)("N","N", n, &oneInt, q, one, X, n, beta, q, zero, eta, n);
resid = Calloc(*n, double);
rss = 0;
for(int i=0; i<*n; i++) {
resid[i] = y[i]-eta[i] - offset[i];
rss += R_pow(resid[i], 2.0);
}
XAlpha = Calloc(*p * (*n), double);
updateXAlpha(XAlpha, X, G, ksi, q, qKsiUpdate, p, n);
XKsiUpdate = Calloc( *n * safeQKsiUpdate, double);
setToZero(XKsiUpdate, *n * safeQKsiUpdate);
if(qKsiNoUpdate < *q){
updateXKsi(XKsiUpdate, X, alphaLong, q, &qKsiNoUpdate, n);
}
etaOffset = Calloc(*n, double);
for(int i=0; i<*n; i++) etaOffset[i] = eta[i]+offset[i];
// ############################################################ //
// ######## set up blocks for blockwise updates ############### //
// ############################################################ //
XBlockQR *AlphaBlocks = Calloc(*blocksAlpha, XBlockQR);
XBlockQR *KsiBlocks = Calloc(*blocksKsi, XBlockQR);
for(int i=0; i < *blocksAlpha; i++){
(AlphaBlocks[i]).indA1 = indA1Alpha[i];
(AlphaBlocks[i]).indA2 = indA2Alpha[i];
(AlphaBlocks[i]).qA = (AlphaBlocks[i]).indA2 - (AlphaBlocks[i]).indA1 + 1;
(AlphaBlocks[i]).qI = *p - (AlphaBlocks[i]).qA;
(AlphaBlocks[i]).qraux = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).qraux, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).work = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).work, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).pivots = Calloc((AlphaBlocks[i]).qA, int);
for(int j=0; j < (AlphaBlocks[i]).qA; j++) (AlphaBlocks[i]).pivots[j] = 0;
(AlphaBlocks[i]).coefI = Calloc((AlphaBlocks[i]).qI, double);
setToZero((AlphaBlocks[i]).coefI, (AlphaBlocks[i]).qI);
(AlphaBlocks[i]).Xa = Calloc(((AlphaBlocks[i]).qA + *n) * (AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).Xa, ((AlphaBlocks[i]).qA + *n) * (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).Xi = Calloc(*n * (AlphaBlocks[i]).qI, double);
setToZero((AlphaBlocks[i]).Xi, *n * (AlphaBlocks[i]).qI );
(AlphaBlocks[i]).ya = Calloc(((AlphaBlocks[i]).qA + *n), double);
F77_CALL(dcopy)(n, y, &nrv, (AlphaBlocks[i]).ya, &nrv);
setToZero((AlphaBlocks[i]).ya + *n, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).m = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).m, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).err = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).err, (AlphaBlocks[i]).qA);
}
initializeBlocksQR(AlphaBlocks, XAlpha, *n, *blocksAlpha, *p, varAlpha, scale);
if(*qKsiUpdate > 0){
for(int i=0; i < *blocksKsi; i++){
(KsiBlocks[i]).indA1 = indA1Ksi[i];
(KsiBlocks[i]).indA2 = indA2Ksi[i];
(KsiBlocks[i]).qA = (KsiBlocks[i]).indA2 - (KsiBlocks[i]).indA1 + 1;
(KsiBlocks[i]).qI = *qKsiUpdate - (KsiBlocks[i]).qA;
(KsiBlocks[i]).qraux = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).qraux, (KsiBlocks[i]).qA);
(KsiBlocks[i]).work = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).work, (KsiBlocks[i]).qA);
(KsiBlocks[i]).pivots = Calloc((KsiBlocks[i]).qA, int);
for(int j=0; j < (KsiBlocks[i]).qA; j++) (KsiBlocks[i]).pivots[j] = 0;
(KsiBlocks[i]).coefI = Calloc((KsiBlocks[i]).qI, double);
setToZero((KsiBlocks[i]).coefI, (KsiBlocks[i]).qI);
(KsiBlocks[i]).Xa = Calloc(((KsiBlocks[i]).qA + *n) * (KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).Xa, ((KsiBlocks[i]).qA + *n) * (KsiBlocks[i]).qA);
(KsiBlocks[i]).Xi = Calloc(*n * (KsiBlocks[i]).qI, double);
setToZero((KsiBlocks[i]).Xi, *n * (KsiBlocks[i]).qI );
(KsiBlocks[i]).ya = Calloc(((KsiBlocks[i]).qA + *n), double);
F77_CALL(dcopy)(n, y, &nrv, (KsiBlocks[i]).ya, &nrv);
setToZero((KsiBlocks[i]).ya + *n, (KsiBlocks[i]).qA);
(KsiBlocks[i]).m = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).m, (KsiBlocks[i]).qA);
(KsiBlocks[i]).err = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).err, (KsiBlocks[i]).qA);
}
initializeBlocksQR(KsiBlocks, XKsiUpdate, *n, *blocksKsi, *qKsiUpdate, varKsi, scale);
}
// ############################################### //
// ######## start sampling ############### //
// ############################################### //
#ifdef Win32
R_FlushConsole();
#endif
/* sampling */
GetRNGstate();
for(i = 0; i < *totalLength; i++)
{
debugMsg("\n###########################################\n\n");
//update alpha
{
//update varAlpha
for(j=startPen; j<*p; j++) varAlpha[j] = tau2[j-startPen] * gamma[j-startPen];
//update alpha
updateCoefQR(y, XAlpha, AlphaBlocks,
*blocksAlpha,
alpha,
varAlpha, *p,
scale,
*n, nrv, oneInt, info, *minusOne, *zero, *one, 1, priorMeanAlpha,
*family, modeAlpha, eta, acceptAlpha, offsetAlpha, *modeSwitching, zeroInt);
}
//update ksi
if(qKsiNoUpdate < *q){
//update alphaLong = G %*% alpha
F77_CALL(dgemm)("N","N", q, &oneInt, p, one, G, q, alpha, p, zero, alphaLong, q);
//update design for ksi
updateXKsi(XKsiUpdate, X, alphaLong, q, &qKsiNoUpdate, n);
//update offsetKsi
if(qKsiNoUpdate > 0){
F77_CALL(dcopy)(n, offset, &oneInt, offsetKsi, &oneInt);
F77_CALL(dgemm)("N","N", n, &oneInt, &qKsiNoUpdate, one, X, n, alpha, &qKsiNoUpdate, one, offsetKsi, n);
}
for(j = 0; j < *qKsiUpdate; j++){
priorMeanKsi[j] = sign( 1/(1 + exp(-2*ksiUpdate[j]/varKsi[j])) - runif(0,1) );
}
if(*ksiDF>0){
updateVarKsi(ksiUpdate, varKsi, ksiDF, priorMeanKsi, qKsiNoUpdate, *q);
}
updateCoefQR(y, XKsiUpdate, KsiBlocks,
*blocksKsi,
ksiUpdate, varKsi, *qKsiUpdate,
scale,
*n, nrv, oneInt, info, *minusOne, *zero, *one, 1, priorMeanKsi,
*family, modeKsi, eta, acceptKsi, offsetKsi, *modeSwitching, *scaleMode);
//write back to ksi
F77_CALL(dcopy)(qKsiUpdate, ksiUpdate, &oneInt, &ksi[*q-*qKsiUpdate], &oneInt);
//rescale ksi, alpha & put back in ksiUpdate
if(*scaleMode > 0){
rescaleKsiAlpha(ksi, alpha, varKsi, tau2, G, d, *p, *q, qKsiNoUpdate, *pPen, *scaleMode, modeAlpha, modeKsi, *family);
F77_CALL(dcopy)(qKsiUpdate, &ksi[*q-*qKsiUpdate], &oneInt, ksiUpdate, &oneInt);
}
//update XAlpha
updateXAlpha(XAlpha, X, G, ksi, q, qKsiUpdate, p, n);
//update alphaLong = G %*% alpha
F77_CALL(dgemm)("N","N", q, &oneInt, p, one, G, q, alpha, p, zero, alphaLong, q);
} else {
F77_CALL(dcopy)(q, alpha, &oneInt, alphaLong, &oneInt);
}
for(int i = *p-*pPen; i < *p; i++) penAlphaSq[i - *p + *pPen] = R_pow(alpha[i], 2.0);
updateTau(penAlphaSq, gamma, tau2, *a1, *a2, *pPen);
updateP1Gamma(penAlphaSq, tau2, p1, gamma, *v0, *w, *pPen);
pIncluded = 0;
for(j=0; j<*p - startPen; j++) pIncluded += (gamma[j] == 1.0);
*w = rbeta( *alphaW + pIncluded, *betaW + *p - pIncluded );
// update beta
for(j = 0; j < *q; j++){
beta[j] = alphaLong[j]*ksi[j];
}
//update eta, eta+offset
F77_CALL(dgemm)("N", "N", n, &oneInt, q, one, X, n, beta, q, zero, eta, n);
for(int i=0; i<*n; i++) etaOffset[i] = eta[i] + offset[i];
//update sigma_eps
if(*family == 0){
//resid = y - eta - offset
F77_CALL(dcopy)(n, y, &nrv, resid, &nrv); //resid <- y
F77_CALL(daxpy)(n, minusOne, etaOffset, &nrv, resid, &nrv); //resid <- resid - eta - offset
//rss = resid'resid
rss = F77_CALL(ddot)(n, resid, &oneInt, resid, &oneInt);
//update sigma2
invSigma2 = rgamma(*n/2 + *b1, 1/(rss/2 + *b2));
sqrtInvSigma2 = R_pow(invSigma2, 0.5);
scale[0] = sqrtInvSigma2;
*sigma2 = 1 / invSigma2;
}
if(i >= *burnin){
/* report progress */
if(*verbose){
for(j=0; j<9; j++){
if(i == pcts[j]){
Rprintf(".");
#ifdef Win32
R_FlushConsole();
#endif
break;
}
}
}
/* save samples*/
if(i == keep){
for(j = 0; j < *q; j++){
(betaMatR)[save + j*nSamp] = beta[j];
(ksiMatR)[save + j*nSamp] = ksi[j];
}
for(j=0; j < *p; j++){
(alphaMatR)[save + j*nSamp] = alpha[j];
}
for(j=0; j < *pPen; j++){
(tau2MatR)[save + j*nSamp] = tau2[j];
(gammaMatR)[save + j*nSamp] = gamma[j];
(probV1MatR)[save + j*nSamp] = p1[j];
}
(wMatR)[save] = *w;
(sigma2MatR)[save] = *sigma2;
likMatR[save] = logLik(y, etaOffset, *family, scale, *n);
(logPostMatR)[save] = updateLogPost(y, alpha, varAlpha,
ksi, varKsi, scale, *b1, *b2, gamma, *w, *alphaW, *betaW,
tau2, *a1, *a2, *n, *q, *p, *pPen, pIncluded, qKsiNoUpdate, priorMeanKsi, *family, likMatR[save]);
keep = keep + *thin;
save ++;
R_CheckUserInterrupt();
}
} else {
if(*verbose){
if(i == (*burnin-1)){
Rprintf("b");
#ifdef Win32
R_FlushConsole();
#endif
}
}
}
} /* end for i*/
PutRNGstate();
if(*verbose) Rprintf(".");
if(*family > 0) {
acceptance = 0.0;
for(j=0; j<*blocksAlpha; j++) acceptance += acceptAlpha[j];
acceptance = 0.0;
if(qKsiNoUpdate < *q){
for(j=0; j<*blocksKsi; j++) acceptance += acceptKsi[j];
}
}
Free(etaOffset); Free(XKsiUpdate); Free(XAlpha); Free(resid); Free(eta);
Free(offsetKsi); Free(modeKsi); Free(priorMeanKsi); Free(ksiUpdate);
Free(offsetAlpha);
Free(modeAlpha);
Free(priorMeanAlpha);
Free(varAlpha);
Free(alphaLong);
Free(penAlphaSq);
freeXBlockQR(AlphaBlocks, *blocksAlpha);
if(qKsiNoUpdate < *q) freeXBlockQR(KsiBlocks, *blocksKsi);
Free(p1);
return(R_NilValue);
}/* end sampler ()*/
void simStahl(int *n_sim, double *nu, double *p, double *L,
int *nxo, double *loc, int *max_nxo,
int *n_bins4start)
{
double **Loc, scale;
double curloc=0.0, u;
double *startprob, step;
int i, j, n_nixo;
/* re-organize loc as a doubly index array */
Loc = (double **)R_alloc(*n_sim, sizeof(double *));
Loc[0] = loc;
for(i=1; i < *n_sim; i++)
Loc[i] = Loc[i-1] + *max_nxo;
GetRNGstate();
if(fabs(*nu - 1.0) < 1e-8) { /* looks like a Poisson model */
for(i=0; i< *n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
nxo[i] = rpois(*L);
if(nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < nxo[i]; j++)
Loc[i][j] = runif(0.0, *L);
}
}
else {
scale = 1.0 / (2.0 * *nu * (1.0 - *p));
/* set up starting distribution */
startprob = (double *)R_alloc(*n_bins4start, sizeof(double));
step = *L/(double)*n_bins4start;
startprob[0] = 2.0*(1.0 - *p)*pgamma(0.5*step, *nu, scale, 0, 0)*step;
for(i=1; i< *n_bins4start; i++) {
R_CheckUserInterrupt(); /* check for ^C */
startprob[i] = startprob[i-1] +
2.0*(1.0 - *p)*pgamma(((double)i+0.5)*step, *nu, scale, 0, 0)*step;
}
for(i=0; i< *n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
nxo[i] = 0;
/* locations of chiasmata from the gamma model */
/* shape = nu, rate = 2*nu*(1-p) [scale = 1/{2*nu*(1-p)}] */
u = unif_rand();
if( u > startprob[*n_bins4start-1] )
curloc = *L+1;
else {
for(j=0; j< *n_bins4start; j++) {
if(u <= startprob[j]) {
curloc = ((double)j+0.5)*step;
if(unif_rand() < 0.5) {
nxo[i] = 1;
Loc[i][0] = curloc;
}
break;
}
}
}
if(curloc < *L) {
while(curloc < *L) {
curloc += rgamma(*nu, scale);
if(curloc < *L && unif_rand() < 0.5) {
if(nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
Loc[i][nxo[i]] = curloc;
(nxo[i])++;
}
}
}
/* locations of crossovers from the no interference mechanism */
if(*p > 0) {
n_nixo = rpois(*L * *p);
if(n_nixo + nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < n_nixo; j++)
Loc[i][nxo[i]+j] = runif(0.0, *L);
nxo[i] += n_nixo;
}
}
}
/* sort the results */
for(i=0; i< *n_sim; i++)
R_rsort(Loc[i], nxo[i]);
PutRNGstate();
}
void latentgev(int *n, double *data, int *nSite, int *nObs, int *covmod,
int *dim, double *distMat, double *dsgnMat, int *nBeta,
double *beta, double *sills, double *ranges, double *smooths,
double *gevParams, double *hyperSill, double *hyperRange,
double *hyperSmooth, double *hyperBetaMean,
double *hyperBetaIcov, double *propGev, double *propRanges,
double *propSmooths, double *mcLoc, double *mcScale,
double *mcShape, double *accRates, double *extRates, int *thin,
int *burnin){
int iter = 0, iterThin = 0, idxSite, idxSite2, idxMarge, idxBeta, info = 0,
oneInt = 1, nSite2 = *nSite * *nSite,
nPairs = *nSite * (*nSite + 1) / 2,
*cumBeta = (int *) R_alloc(4, sizeof(int)),
*cumBeta2 = (int *) R_alloc(3, sizeof(int)),
*nBeta2 = (int *) R_alloc(3, sizeof(int)),
lagLoc = nBeta[0] + 3 + *nSite, lagScale = nBeta[1] + 3 + *nSite,
lagShape = nBeta[2] + 3 + *nSite;
cumBeta[0] = 0;
cumBeta[1] = nBeta[0];
cumBeta[2] = nBeta[0] + nBeta[1];
cumBeta[3] = cumBeta[2] + nBeta[2];
cumBeta2[0] = 0;
cumBeta2[1] = nBeta[0] * nBeta[0];
cumBeta2[2] = nBeta[0] * nBeta[0] + nBeta[1] * nBeta[1];
nBeta2[0] = nBeta[0] * nBeta[0];
nBeta2[1] = nBeta[1] * nBeta[1];
nBeta2[2] = nBeta[2] * nBeta[2];
double one = 1.0, zero = 0.0, flag = 0.0, logDetProp,
*logDet = (double *) R_alloc(3, sizeof(double)),
*covMatChol = (double *) R_alloc(3 * nSite2, sizeof(double)),
*GPmean = (double *) R_alloc(3 * *nSite, sizeof(double)),
*resTop = (double *) R_alloc(*nSite, sizeof(double)),
*resBottom = (double *) R_alloc(*nSite, sizeof(double)),
*covariances = (double *) R_alloc(nPairs, sizeof(double)),
*proposalGEV = (double *) R_alloc(3, sizeof(double)),
*covMatPropChol = (double *) R_alloc(nSite2, sizeof(double));
for (int i=3;i--;)
logDet[i] = 0;
for (int i=(3 * nSite2);i--;)
covMatChol[i] = 0;
for (int i=(3 * *nSite);i--;)
GPmean[i] = 0;
for (int i=nSite2;i--;)
covMatPropChol[i] = 0;
/*----------------------------------------------------*/
/* */
/* Compute some initial objects */
/* */
/*----------------------------------------------------*/
// a. The inverse of the covariance matrices
for (idxMarge=0;idxMarge<3;idxMarge++){
switch(covmod[idxMarge]){
case 1:
flag = whittleMatern(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
case 2:
flag = cauchy(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
case 3:
flag = powerExp(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
case 4:
flag = bessel(distMat, nPairs, *dim, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
}
if (flag != 0)
error("The starting values (covariance parameter) are ill-defined. Please check\n");
/* We need to fill in the upper triangular part of covMatChol with
covariances */
{
int current=-1;
for (idxSite=0;idxSite<*nSite;idxSite++)
for (idxSite2=idxSite;idxSite2<*nSite;idxSite2++){
current++;
covMatChol[idxSite + idxSite2 * *nSite + idxMarge * nSite2] = covariances[current];
}
}
// Finally compute its Cholesky decomposition
F77_CALL(dpotrf)("U", nSite, covMatChol + idxMarge * nSite2, nSite, &info);
if (info != 0)
error("Impossible to get the Cholesky decomp. from the starting values\n");
/* Compute the log of the determinant of the proposal
cov. mat. using the sum of the square of the diagonal elements of
the Cholesky decomposition */
for (idxSite2=0;idxSite2<*nSite;idxSite2++)
logDet[idxMarge] += log(covMatChol[idxSite2 * (*nSite + 1) + idxMarge *
nSite2]);
logDet[idxMarge] *= 2;
}
// b. The mean of the Gaussian processes
for (idxMarge=0;idxMarge<3;idxMarge++)
for (idxSite=0;idxSite<*nSite;idxSite++)
for (idxBeta=0;idxBeta<nBeta[idxMarge];idxBeta++)
GPmean[idxSite + idxMarge * *nSite] +=
dsgnMat[idxBeta * *nSite + idxSite + cumBeta[idxMarge] * *nSite] *
beta[cumBeta[idxMarge] + idxBeta];
// c. Some constant related to the conjugate distributions
double *conjMeanCst = (double *)R_alloc(cumBeta[3], sizeof(double));
for(int i=cumBeta[3];i--;)
conjMeanCst[i]=0;
for (idxMarge=0;idxMarge<3;idxMarge++)
F77_CALL(dsymv)("U", nBeta + idxMarge, &one, hyperBetaIcov +
cumBeta2[idxMarge], nBeta + idxMarge, hyperBetaMean +
cumBeta[idxMarge], &oneInt, &zero, conjMeanCst + cumBeta[idxMarge],
&oneInt);
/*----------------------------------------------------*/
/* */
/* Starting the MCMC algo */
/* */
/*----------------------------------------------------*/
GetRNGstate();
while (iterThin<*n){
/*----------------------------------------------------*/
/* */
/* Updating the GEV parameters */
/* */
/*----------------------------------------------------*/
for (idxSite=0;idxSite<*nSite;idxSite++){
for (idxMarge=0;idxMarge<3;idxMarge++){
double logpropRatio = 0;
proposalGEV[0] = gevParams[idxSite];
proposalGEV[1] = gevParams[*nSite + idxSite];
proposalGEV[2] = gevParams[2 * *nSite + idxSite];
if (idxMarge==1){
proposalGEV[1] = rlnorm(log(gevParams[*nSite + idxSite]), propGev[1]);
logpropRatio = log(proposalGEV[1] / gevParams[*nSite + idxSite]);
}
else
proposalGEV[idxMarge] = rnorm(gevParams[idxMarge * *nSite + idxSite], propGev[idxMarge]);
double topGEV = 0, bottomGEV = 0;
gevlik(data + idxSite * *nObs, nObs, proposalGEV, proposalGEV + 1,
proposalGEV + 2, &topGEV);
if (topGEV == -1e6){
extRates[idxMarge]++;
continue;
}
gevlik(data + idxSite * *nObs, nObs, gevParams + idxSite, gevParams +
*nSite + idxSite, gevParams + 2 * *nSite + idxSite, &bottomGEV);
double topGP = 0, bottomGP = 0;
for (idxSite2=0;idxSite2<*nSite;idxSite2++)
resBottom[idxSite2] = gevParams[idxSite2 + idxMarge * *nSite] -
GPmean[idxSite2 + idxMarge * *nSite];
memcpy(resTop, resBottom, *nSite * sizeof(double));
resTop[idxSite] = proposalGEV[idxMarge] - GPmean[idxSite + idxMarge *
*nSite];
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatChol +
idxMarge * nSite2, nSite, resTop, nSite);
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatChol +
idxMarge * nSite2, nSite, resBottom, nSite);
for (idxSite2=0;idxSite2<*nSite;idxSite2++){
topGP += resTop[idxSite2] * resTop[idxSite2];
bottomGP += resBottom[idxSite2] * resBottom[idxSite2];
}
topGP *= -0.5;
bottomGP *= -0.5;
if (unif_rand() < exp(topGEV - bottomGEV + topGP - bottomGP +
logpropRatio)){
gevParams[idxSite + idxMarge * *nSite] = proposalGEV[idxMarge];
accRates[idxMarge]++;
}
}
}
/*----------------------------------------------------*/
/* */
/* Updating the regression parameters */
/* (conjugate prior) */
/* */
/*----------------------------------------------------*/
for (idxMarge=0;idxMarge<3;idxMarge++){
/* conjCovMat is the covariance matrix for the conjugate
distribution i.e. MVN
conjCovMatChol is its Cholesky decomposition */
double *dummy = malloc(*nSite * nBeta[idxMarge] * sizeof(double)),
*conjCovMat = malloc(nBeta2[idxMarge] * sizeof(double)),
*conjCovMatChol = malloc(nBeta2[idxMarge] * sizeof(double));
memcpy(conjCovMat, hyperBetaIcov + cumBeta2[idxMarge],
nBeta2[idxMarge] * sizeof(double));
memcpy(dummy, dsgnMat + *nSite * cumBeta[idxMarge],
*nSite * nBeta[idxMarge] * sizeof(double));
// Compute dummy = covMatChol^(-T) %*% dsgnMat
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, nBeta + idxMarge, &one,
covMatChol + idxMarge * nSite2, nSite, dummy, nSite);
/* Compute conjCovMat = dummy^T %*% dummy + conjCovMat
WARNING: Only the upper diagonal elements will be stored */
F77_CALL(dsyrk)("U", "T", nBeta + idxMarge, nSite, &one, dummy, nSite,
&one, conjCovMat, nBeta + idxMarge);
/* Rmk: The "real" conjugate cov. matrix is the inverse of
conjCovMat but it is not necessary to compute it */
//Compute its Cholesky decomposition
memcpy(conjCovMatChol, conjCovMat, nBeta2[idxMarge] * sizeof(double));
F77_CALL(dpotrf)("U", nBeta + idxMarge, conjCovMatChol, nBeta + idxMarge,
&info);
// Compute dummy2 = covMatChol^(-T) %*% (locs or scales or shapes)
double *dummy2 = malloc(*nSite * sizeof(double));
memcpy(dummy2, gevParams + idxMarge * *nSite, *nSite * sizeof(double));
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatChol +
idxMarge * nSite2, nSite, dummy2, nSite);
// conjMean is the mean for the conjugate distribution i.e. MVN
// Set conjMean = conjMeanCst := hyperBetaIcov %*% hyperBetaMean
double *conjMean = malloc(nBeta[idxMarge] * sizeof(double));
memcpy(conjMean, conjMeanCst + cumBeta[idxMarge],
nBeta[idxMarge] * sizeof(double));
// Compute conjMean = conjMean + dummy^T %*% dummy2 (dummy2 is a vector)
F77_CALL(dgemv)("T", nSite, nBeta + idxMarge, &one, dummy, nSite, dummy2,
&oneInt, &one, conjMean, &oneInt);
// Compute conjMean = conjCovMat^(-1) %*% conjMean
F77_CALL(dposv)("U", nBeta + idxMarge, &oneInt, conjCovMat, nBeta +
idxMarge, conjMean, nBeta + idxMarge, &info);
/* The new state is a realisation from the MVN(conjMean,
conjCovMat) so we simulate it from the Cholesky
decomposition */
double *stdNormal = malloc(nBeta[idxMarge] * sizeof(double));
for (idxBeta=0;idxBeta<nBeta[idxMarge];idxBeta++)
stdNormal[idxBeta] = norm_rand();
/* Rmk: Recall that conjCovMat is the precision matrix and *NOT*
the covariance matrix. Instead of using the Cholesky
decomposition of the conjugate covariance matrix (that we
still haven't computed), we use the inverse of the Cholesky
decomposition. This is different from the standard simulation
technique but completely equivalent since
iSigma = iSigma_*^T %*% iSigma_*
<==> Sigma := iSigma^(-1) = iSigma_*^(-1) %*% iSigma_*^(-T),
where iSigma_* is the Cholesky decomposition of iSigma.
Therefore we can use iSigma_*^(-1) for the simulation. */
F77_CALL(dtrsm)("L", "U", "N", "N", nBeta + idxMarge, &oneInt,
&one, conjCovMatChol, nBeta + idxMarge, stdNormal,
nBeta + idxMarge);
for (idxBeta=0;idxBeta<nBeta[idxMarge];idxBeta++)
beta[cumBeta[idxMarge] + idxBeta] = stdNormal[idxBeta] +
conjMean[idxBeta];
//The last step is to update the mean of the GP
for (idxSite=0;idxSite<*nSite;idxSite++){
GPmean[idxSite + idxMarge * *nSite] = 0;
for (idxBeta=0;idxBeta<nBeta[idxMarge];idxBeta++)
GPmean[idxSite + idxMarge * *nSite] += dsgnMat[idxBeta * *nSite + idxSite +
cumBeta[idxMarge] * *nSite] *
beta[cumBeta[idxMarge] + idxBeta];
}
free(dummy);
free(conjCovMat);
free(conjCovMatChol);
free(dummy2);
free(conjMean);
free(stdNormal);
}
/*----------------------------------------------------*/
/* */
/* Updating the sills (conjugate prior) */
/* */
/*----------------------------------------------------*/
for (idxMarge=0;idxMarge<3;idxMarge++){
for (idxSite=0;idxSite<*nSite;idxSite++)
resTop[idxSite] = gevParams[idxSite + idxMarge * *nSite] -
GPmean[idxSite + idxMarge * *nSite];
// Compute resTop = covMatChol^(-T) %*% resTop
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatChol +
idxMarge * nSite2, nSite, resTop, nSite);
double shape = 0.5 * *nSite + hyperSill[2 * idxMarge];
double scale = 0;
for (idxSite=0;idxSite<*nSite;idxSite++)
scale += resTop[idxSite] * resTop[idxSite];
scale = hyperSill[1 + 2 * idxMarge] + 0.5 * sills[idxMarge] * scale;
/* Rmk: If Y ~ Gamma(shape = shape, rate = 1 / scale) then X :=
1 / Y \sim IGamma(shape = shape, scale = scale) */
sills[idxMarge] = 1 / rgamma(shape, 1 / scale);
// Now we need to update the covariance matrix and its inverse
switch(covmod[idxMarge]){
case 1:
flag = whittleMatern(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
case 2:
flag = cauchy(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
case 3:
flag = powerExp(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
case 4:
flag = bessel(distMat, nPairs, *dim, zero, sills[idxMarge], ranges[idxMarge],
smooths[idxMarge], covariances);
break;
}
/* We need to fill in the upper triangular part of covMatChol with
covariances */
{
int current=-1;
for (idxSite=0;idxSite<*nSite;idxSite++)
for (idxSite2=idxSite;idxSite2<*nSite;idxSite2++){
current++;
covMatChol[idxSite + idxSite2 * *nSite + idxMarge * nSite2] = covariances[current];
}
}
// Cholesky decomposition of the covariance matrices
F77_CALL(dpotrf)("U", nSite, covMatChol + idxMarge * nSite2, nSite,
&info);
// Compute the log of the determinant of the proposal cov. mat.
logDet[idxMarge] = 0;
for (idxSite=0;idxSite<*nSite;idxSite++)
logDet[idxMarge] += log(covMatChol[idxSite * (1 + *nSite) + idxMarge *
nSite2]);
logDet[idxMarge] *= 2;
}
/*----------------------------------------------------*/
/* */
/* Updating the ranges (M.-H. step) */
/* */
/*----------------------------------------------------*/
for (idxMarge=0;idxMarge<3;idxMarge++){
if (propRanges[idxMarge] == 0)
continue;
double rangeProp = rlnorm(log(ranges[idxMarge]), propRanges[idxMarge]),
logpropRatio = log(rangeProp / ranges[idxMarge]);
switch(covmod[idxMarge]){
case 1:
flag = whittleMatern(distMat, nPairs, zero, sills[idxMarge], rangeProp,
smooths[idxMarge], covariances);
break;
case 2:
flag = cauchy(distMat, nPairs, zero, sills[idxMarge], rangeProp,
smooths[idxMarge], covariances);
break;
case 3:
flag = powerExp(distMat, nPairs, zero, sills[idxMarge], rangeProp,
smooths[idxMarge], covariances);
break;
case 4:
flag = bessel(distMat, nPairs, *dim, zero, sills[idxMarge], rangeProp,
smooths[idxMarge], covariances);
break;
}
if (flag != 0){
extRates[3 + idxMarge]++;
continue;
}
/* We need to fill in the upper triangular part of covMatPropChol
with covariances */
{
int current=-1;
for (idxSite=0;idxSite<*nSite;idxSite++)
for (idxSite2=idxSite;idxSite2<*nSite;idxSite2++){
current++;
covMatPropChol[idxSite + idxSite2 * *nSite] = covariances[current];
}
}
// Cholesky decomposition of the proposal cov. mat.
F77_CALL(dpotrf)("U", nSite, covMatPropChol, nSite, &info);
if (info != 0){
extRates[3 + idxMarge]++;
continue;
}
// Log of the determinant of the proposal cov. mat.
logDetProp = 0;
for (idxSite=0;idxSite<*nSite;idxSite++)
logDetProp += log(covMatPropChol[idxSite * (1 + *nSite)]);
logDetProp *= 2;
for (idxSite=0;idxSite<*nSite;idxSite++)
resBottom[idxSite] = gevParams[idxSite + idxMarge * *nSite] -
GPmean[idxSite + idxMarge * *nSite];
memcpy(resTop, resBottom, *nSite * sizeof(double));
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatChol +
idxMarge * nSite2, nSite, resBottom, nSite);
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatPropChol,
nSite, resTop, nSite);
double top = logDetProp, bottom = logDet[idxMarge],
logpriorRatio = (hyperRange[2 * idxMarge] - 1) *
log(rangeProp / ranges[idxMarge]) + (ranges[idxMarge] - rangeProp) /
hyperRange[2 * idxMarge + 1];
for (idxSite=0;idxSite<*nSite;idxSite++){
top += resTop[idxSite] * resTop[idxSite];
bottom += resBottom[idxSite] * resBottom[idxSite];
}
top *= -0.5;
bottom *= -0.5;
if (unif_rand() < exp(top - bottom + logpriorRatio + logpropRatio)){
ranges[idxMarge] = rangeProp;
logDet[idxMarge] = logDetProp;
memcpy(covMatChol + idxMarge * nSite2, covMatPropChol, nSite2 *
sizeof(double));
accRates[3 + idxMarge]++;
}
}
/*----------------------------------------------------*/
/* */
/* Updating the smooths (M.-H. step) */
/* */
/*----------------------------------------------------*/
for (idxMarge=0;idxMarge<3;idxMarge++){
if (propSmooths[idxMarge] == 0)
continue;
double smoothProp = rlnorm(log(smooths[idxMarge]), propSmooths[idxMarge]),
logpropRatio = log(smoothProp / smooths[idxMarge]);
switch(covmod[idxMarge]){
case 1:
flag = whittleMatern(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smoothProp, covariances);
break;
case 2:
flag = cauchy(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smoothProp, covariances);
break;
case 3:
flag = powerExp(distMat, nPairs, zero, sills[idxMarge], ranges[idxMarge],
smoothProp, covariances);
break;
case 4:
flag = bessel(distMat, nPairs, *dim, zero, sills[idxMarge], ranges[idxMarge],
smoothProp, covariances);
break;
}
if (flag != 0){
extRates[6 + idxMarge]++;
continue;
}
/* We need to fill in the upper triangular part of covMatPropChol
with covariances */
{
int current=-1;
for (idxSite=0;idxSite<*nSite;idxSite++)
for (idxSite2=idxSite;idxSite2<*nSite;idxSite2++){
current++;
covMatPropChol[idxSite + idxSite2 * *nSite] = covariances[current];
}
}
// Cholesky decomposition of the proposal cov. mat.
F77_CALL(dpotrf)("U", nSite, covMatPropChol, nSite, &info);
if (info != 0){
extRates[6 + idxMarge]++;
continue;
}
// Log of the determinant of the proposal cov. mat.
logDetProp = 0;
for (idxSite=0;idxSite<*nSite;idxSite++)
logDetProp += log(covMatPropChol[idxSite * (1 + *nSite)]);
logDetProp *= 2;
for (idxSite=0;idxSite<*nSite;idxSite++)
resBottom[idxSite] = gevParams[idxSite + idxMarge * *nSite] -
GPmean[idxSite + idxMarge * *nSite];
memcpy(resTop, resBottom, *nSite * sizeof(double));
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatPropChol,
nSite, resTop, nSite);
F77_CALL(dtrsm)("L", "U", "T", "N", nSite, &oneInt, &one, covMatChol +
idxMarge * nSite2, nSite, resBottom, nSite);
double top = logDetProp, bottom = logDet[idxMarge],
logpriorRatio = (hyperSmooth[2 * idxMarge] - 1) *
log(smoothProp / smooths[idxMarge]) + (smooths[idxMarge] - smoothProp) /
hyperSmooth[2 * idxMarge + 1];
for (idxSite=0;idxSite<*nSite;idxSite++){
top += resTop[idxSite] * resTop[idxSite];
bottom += resBottom[idxSite] * resBottom[idxSite];
}
top *= -0.5;
bottom *= -0.5;
if (unif_rand() < exp(top - bottom + logpriorRatio + logpropRatio)){
smooths[idxMarge] = smoothProp;
logDet[idxMarge] = logDetProp;
memcpy(covMatChol + idxMarge * nSite2, covMatPropChol, nSite2 *
sizeof(double));
accRates[6 + idxMarge]++;
}
}
iter++;
//Need to store the new state into the mc object.
if ((iter > *burnin) & ((iter % *thin) == 0)){
mcLoc[nBeta[0] + iterThin * lagLoc] = sills[0];
mcLoc[nBeta[0] + 1 + iterThin * lagLoc] = ranges[0];
mcLoc[nBeta[0] + 2 + iterThin * lagLoc] = smooths[0];
mcScale[nBeta[1] + iterThin * lagScale] = sills[1];
mcScale[nBeta[1] + 1 + iterThin * lagScale] = ranges[1];
mcScale[nBeta[1] + 2 + iterThin * lagScale] = smooths[1];
mcShape[nBeta[2] + iterThin * lagShape] = sills[2];
mcShape[nBeta[2] + 1 + iterThin * lagShape] = ranges[2];
mcShape[nBeta[2] + 2 + iterThin * lagShape] = smooths[2];
for (idxBeta=0;idxBeta<nBeta[0];idxBeta++)
mcLoc[idxBeta + iterThin * lagLoc] = beta[idxBeta];
for (idxBeta=0;idxBeta<nBeta[1];idxBeta++)
mcScale[idxBeta + iterThin * lagScale] = beta[cumBeta[1] + idxBeta];
for (idxBeta=0;idxBeta<nBeta[2];idxBeta++)
mcShape[idxBeta + iterThin * lagShape] = beta[cumBeta[2] + idxBeta];
for (idxSite=0;idxSite<*nSite;idxSite++){
mcLoc[nBeta[0] + 3 + idxSite + iterThin * lagLoc] = gevParams[idxSite];
mcScale[nBeta[1] + 3 + idxSite + iterThin * lagScale] = gevParams[*nSite + idxSite];
mcShape[nBeta[2] + 3 + idxSite + iterThin * lagShape] = gevParams[2 * *nSite + idxSite];
}
iterThin++;
}
}
GetRNGstate();
for (int i=0;i<9;i++){
accRates[i] /= (double) iter;
extRates[i] /= (double) iter;
}
return;
}
void newChain_kernel1(Chain *a){ /* kernel <<<1, 1>>> */
int n;
a->m = 1;
a->accD = 0;
a->tuneD = 400;
a->meanLogLik = 0;
a->logLikMean = 0;
a->dic = 0;
for(n = 0; n < a->N; ++n){
a->meanC[n] = 0;
a->c[n] = 0;
a->accC[n] = 0;
a->tuneC[n] = 1;
}
if(!a->constTau)
a->tau = sqrt(rgamma(a->aTau, a->bTau, 0));
if(!a->constPiAlp)
a->piAlp = rbeta(a->aAlp, a->bAlp);
if(!a->constPiDel)
a->piDel = rbeta(a->aDel, a->bDel);
if(!a->constD)
a->d = runiform(0, a->d0);
if(!a->constThePhi)
a->thePhi = rnormal(0, a->gamPhi);
if(!a->constTheAlp)
a->theAlp = rnormal(0, a->gamAlp);
if(!a->constTheDel)
a->theDel = rnormal(0, a->gamDel);
if(!a->constSigC)
a->sigC = runiform(0, a->sigC0);
if(!a->constSigPhi)
a->sigPhi = runiform(0, a->sigPhi0);
if(!a->constSigAlp)
a->sigAlp = runiform(0, a->sigAlp0);
if(!a->constSigDel)
a->sigDel = runiform(0, a->sigDel0);
a->s1 = 0;
a->s2 = 0;
for(n = 0; n < a->N; ++n){
a->Old[n] = 0;
a->New[n] = 0;
a->lOld[n] = 0;
a->lNew[n] = 0;
}
}
/*
Susceptible-Infectious-Removed MCMC analysis:
. Exponentially distributed infectiousness periods
*/
SEXP expMH_SIR(SEXP N, SEXP removalTimes, SEXP otherParameters, SEXP priorValues,
SEXP initialValues, SEXP bayesReps, SEXP bayesStart, SEXP bayesThin, SEXP bayesOut){
/* Declarations */
int ii, jj, kk, ll, nInfected, nRemoved, nProtected=0, initialInfected;
SEXP infRateSIR, remRateSIR, logLikelihood;/*, timeInfected, timeDim, initialInf ; */
SEXP parameters, infectionTimes, candidateTimes, infectedBeforeDay;
SEXP allTimes, indicator, SS, II;
double infRate, remRate, oldLkhood, newLkhood, minimumLikelyInfectionTime; /* starting values */
double infRatePrior[2], remRatePrior[2], thetaprior; /* priors values */
double sumSI, sumDurationInfectious, likelihood,logR;
int acceptRate=0, consistent=0, verbose, missingInfectionTimes;
SEXP retParameters, parNames, acceptanceRate;
SEXP infTimes;
/* Code */
GetRNGstate(); /* should be before a call to a random number generator */
initialInfected = INTEGER(getListElement(otherParameters, "initialInfected"))[0];
verbose = INTEGER(getListElement(otherParameters, "verbose"))[0];
missingInfectionTimes = INTEGER(getListElement(otherParameters, "missingInfectionTimes"))[0];
PROTECT(N = AS_INTEGER(N));
++nProtected;
PROTECT(removalTimes = AS_NUMERIC(removalTimes));
++nProtected;
/* priors and starting values */
PROTECT(priorValues = AS_LIST(priorValues));
++nProtected;
PROTECT(initialValues = AS_LIST(initialValues));
++nProtected;
nRemoved = LENGTH(removalTimes); /* number of individuals removed */
/* bayes replications, thin, etc */
PROTECT(bayesReps = AS_INTEGER(bayesReps));
++nProtected;
PROTECT(bayesStart = AS_INTEGER(bayesStart));
++nProtected;
PROTECT(bayesThin = AS_INTEGER(bayesThin));
++nProtected;
PROTECT(bayesOut = AS_INTEGER(bayesOut));
++nProtected;
PROTECT(infRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
PROTECT(remRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
PROTECT(logLikelihood = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
/*
PROTECT(timeInfected = allocVector(REALSXP, nRemoved * INTEGER(bayesOut)[0]));
++nProtected;
PROTECT(timeDim = allocVector(INTSXP, 2));
++nProtected;
INTEGER(timeDim)[0] = nRemoved;
INTEGER(timeDim)[1] = INTEGER(bayesOut)[0];
setAttrib(timeInfected, R_DimSymbol, timeDim);
PROTECT(initialInf = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
*/
PROTECT(parameters = allocVector(REALSXP,2));
++nProtected;
PROTECT(infectionTimes = allocVector(REALSXP,nRemoved));
++nProtected;
PROTECT(candidateTimes = allocVector(REALSXP,nRemoved));
++nProtected;
PROTECT(infectedBeforeDay = allocVector(REALSXP,nRemoved));
++nProtected;
PROTECT(infTimes = allocVector(REALSXP,nRemoved));
++nProtected;
for(jj = 0; jj < nRemoved; ++jj){
REAL(infectionTimes)[jj] = REAL(getListElement(initialValues, "infectionTimes"))[jj];
REAL(candidateTimes)[jj] = REAL(infectionTimes)[jj];
REAL(infectedBeforeDay)[jj] = REAL(getListElement(otherParameters, "infectedBeforeDay"))[jj];
REAL(infTimes)[jj] = 0;
}
nInfected = LENGTH(infectionTimes);
PROTECT(allTimes = allocVector(REALSXP,nRemoved+nInfected));
++nProtected;
PROTECT(indicator = allocVector(INTSXP,nRemoved+nInfected));
++nProtected;
PROTECT(SS = allocVector(INTSXP,nRemoved+nInfected+1));
++nProtected;
PROTECT(II = allocVector(INTSXP,nRemoved+nInfected+1));
++nProtected;
/* working variables */
infRate = REAL(getListElement(initialValues, "infectionRate"))[0];
remRate = REAL(getListElement(initialValues, "removalRate"))[0];
minimumLikelyInfectionTime = REAL(getListElement(otherParameters, "minimumLikelyInfectionTime"))[0];
for(ii = 0; ii < 2; ++ii){
infRatePrior[ii] = REAL(getListElement(priorValues, "infectionRate"))[ii];
remRatePrior[ii] = REAL(getListElement(priorValues, "removalRate"))[ii];
}
thetaprior = REAL(getListElement(priorValues, "theta"))[0];
REAL(parameters)[0] = infRate;
REAL(parameters)[1] = remRate;
expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
oldLkhood = likelihood;
for(ii = 1; ii <= INTEGER(bayesReps)[0]; ++ii){
infRate = rgamma(nInfected-1+infRatePrior[0],1/(sumSI+infRatePrior[1])); /* update infRate */
remRate = rgamma(nRemoved+remRatePrior[0],1/(sumDurationInfectious+remRatePrior[1]));/*remRate */
/*Rprintf("SI = %f : I = %f\n",sumSI,sumDurationInfectious);*/
REAL(parameters)[0] = infRate;
REAL(parameters)[1] = remRate;
if(missingInfectionTimes){
expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
oldLkhood = likelihood;
kk = ceil(unif_rand()*(nRemoved-1)); /* initial infection time excluded */
consistent=0;
if(kk == nRemoved-1){
REAL(candidateTimes)[kk] =
runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);}
else if((REAL(infectionTimes)[kk+1] > REAL(infectedBeforeDay)[kk])){
REAL(candidateTimes)[kk] =
runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);}
else{REAL(candidateTimes)[kk] =
runif(REAL(infectionTimes)[kk-1], REAL(infectionTimes)[kk+1]);}
expLikelihood_SIR(REAL(parameters),REAL(candidateTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
newLkhood = likelihood;
logR = (newLkhood-oldLkhood);
if(log(unif_rand()) <= logR){
REAL(infectionTimes)[kk] = REAL(candidateTimes)[kk];
++acceptRate;
}
REAL(candidateTimes)[kk] = REAL(infectionTimes)[kk];/* update candidate times */
REAL(infectionTimes)[0] = REAL(infectionTimes)[1]
-rexp(1/(infRate*INTEGER(N)[0]+remRate+thetaprior));
REAL(candidateTimes)[0] = REAL(infectionTimes)[0];
}
expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
oldLkhood = likelihood;
kk = ceil(INTEGER(bayesReps)[0]/100);
ll = ceil(INTEGER(bayesReps)[0]/ 10);
if(verbose == 1){
if((ii % kk) == 0){Rprintf(".");}
if((ii % ll) == 0){Rprintf(" %d\n",ii);}
}
if((ii >= (INTEGER(bayesStart)[0])) &&
((ii-INTEGER(bayesStart)[0]) % INTEGER(bayesThin)[0] == 0)){
ll = (ii - (INTEGER(bayesStart)[0]))/INTEGER(bayesThin)[0];
/* REAL(initialInf)[ll] = REAL(infectionTimes)[0]; */
REAL(logLikelihood)[ll] = likelihood;
REAL(infRateSIR)[ll] = infRate;
REAL(remRateSIR)[ll] = remRate;
for(jj = 0; jj < nRemoved; ++jj){
REAL(infTimes)[jj] += REAL(infectionTimes)[jj];
}
/*
for(jj = 0; jj < nRemoved; ++jj){
REAL(timeInfected)[(nRemoved*ll+jj)] = REAL(infectionTimes)[jj];
}
*/
}
}
PutRNGstate(); /* after using random number generators. */
/* Print infection times and removal times at last iteration */
for(jj = 0; jj < nRemoved; ++jj){
REAL(infTimes)[jj] = REAL(infTimes)[jj]/INTEGER(bayesOut)[0];
}
if(verbose){
for(jj = 0; jj < nRemoved; ++jj){
Rprintf("%2d %8.4f %2.0f\n",jj,
REAL(infTimes)[jj],REAL(removalTimes)[jj]);
}
}
PROTECT(retParameters = NEW_LIST(5));
++nProtected;
PROTECT(acceptanceRate = allocVector(INTSXP,1));
++nProtected;
INTEGER(acceptanceRate)[0] = acceptRate;
PROTECT(parNames = allocVector(STRSXP,5));
++nProtected;
SET_STRING_ELT(parNames, 0, mkChar("logLikelihood"));
SET_STRING_ELT(parNames, 1, mkChar("infRateSIR"));
SET_STRING_ELT(parNames, 2, mkChar("remRateSIR"));
SET_STRING_ELT(parNames, 3, mkChar("infectionTimes"));
SET_STRING_ELT(parNames, 4, mkChar("acceptanceRate"));
setAttrib(retParameters, R_NamesSymbol,parNames);
SET_ELEMENT(retParameters, 0, logLikelihood);
SET_ELEMENT(retParameters, 1, infRateSIR);
SET_ELEMENT(retParameters, 2, remRateSIR);
SET_ELEMENT(retParameters, 3, infTimes);
SET_ELEMENT(retParameters, 4, acceptanceRate);
/*
SET_ELEMENT(retParameters, 3, initialInf);
SET_ELEMENT(retParameters, 4, timeInfected);
*/
UNPROTECT(nProtected);
return(retParameters);
}
Vector MVT::sim(RNG &rng) const {
Vector ans = rmvn_L_mt(rng, mu().zero(), Sigma_chol());
double nu = this->nu();
double w = rgamma(nu / 2.0, nu / 2.0);
return mu() + ans / sqrt(w);
}
