double dtnorm_std(const double lower_bound)
{
double y;
if (lower_bound < 0.0)
{
do {
y = norm_rand();
} while (y <= lower_bound);
return y;
}
else if (lower_bound < 0.75)
{
do {
y = fabs(norm_rand());
} while (y <= lower_bound);
return y;
}
else
{
do {
y = exp_rand();
} while (exp_rand() * lower_bound * lower_bound <= 0.5 * y * y);
return y / lower_bound + lower_bound;
}
}
void Prekazitor::ostruvek() {
BLOK bloky[9] = {K[3], K[4], K[5], K[6], K[7], K[8], K[9], K[10], K[11]};
int x2 = *X + 1 + exp_rand(4,6);
int y2 = *Y + 1 + exp_rand(4,4);
s->intact2->ram_obdelnik(bloky, *X, x2, *Y, y2);
s->intact2->poloz_blok(K[0], *X, (*Y)-1);
s->intact2->obdelnik(K[1], (*X)+1, x2-1, (*Y)-1, (*Y)-1);
s->intact2->poloz_blok(K[2], x2, (*Y)-1);
//std::cout << "před:" << *X;
*X = x2;
//std::cout << " po:" << *X << std::endl;
}
double rexp_mt(ENG & eng, double scale)
{
if (!R_FINITE(scale) || scale <= 0.0)
ML_ERR_return_NAN;
return scale * exp_rand(eng);
}
task *newtask(void) {
task *tsk = (task *) malloc (sizeof(task));
tsk->nkern = unif_rand(kmax);
tsk->nmem = unif_rand(vmax);
tsk->comptime = exp_rand(D, mu);
return tsk;
}
bool Prekazitor::pneumatic() {
int rezerva1 = (*Y) - min_y;
int rezerva2 = s->intact2->vyska - (*Y) - 1;
int rezerva = std::min(rezerva1, rezerva2);
if (rezerva < 5) {
return false;
}
int max_d = std::min(rezerva, 12) - 5;
int dy = 5 + exp_rand(10, max_d);
int y_pn = *Y;
int nove_y = y_pn + dy;
Objekt *o = new Objekt("rock", (*X)*32, ((*Y)-1)*32);
s->objekty.push_back(o);
while (*Y < nove_y) {
dolovak( std::min(nove_y - (*Y), 4) );
}
o = new Objekt("pneumatic-platform", (*X)*32, y_pn*32);
o->blbosti = "(sprite \"images/objects/platforms/small.sprite\")";
s->objekty.push_back(o);
stredovak(4);
nahorovak(2*dy);
return true;
}
double rexp(double scale)
{
if (!R_FINITE(scale) || scale <= 0.0) {
if(scale == 0.) return 0.;
/* else */
ML_ERR_return_NAN;
}
return scale * exp_rand(); // --> in ./sexp.c
}
double rztgeom(double prob)
{
if (!R_FINITE(prob) || prob <= 0 || prob > 1) return R_NaN;
/* limiting case as p approaches one is point mass at one */
if (prob == 1) return 1.0;
return 1 + rpois(exp_rand() * ((1 - prob) / prob));
}
/*
* For arrival events, use exponential distribution.
* For departure events, function assumes <src,pkt> have sufficient deficits.
*/
void stateDRR::schedule_event(int type, int pkt, int src)
{
events *evt = new events(type, src, pkt, 0, 0);
switch(type) {
case PKT_ARRIVE:
switch(src) {
case TELNET1:
case TELNET2:
case TELNET3:
case TELNET4:
#ifdef DEBUG
cout<<"Arr "<<this->lastArrival[src]<<", "<<exp_rand(L_TELNET/r)<<endl;
#endif
evt->eventTime = this->lastArrival[src] + exp_rand(L_TELNET/r);
this->lastArrival[src] = evt->eventTime;
evt->packetSize = exp_rand(L_TELNET);
break;
case FTP1:
case FTP2:
case FTP3:
case FTP4:
case FTP5:
case FTP6:
evt->eventTime = this->lastArrival[src] + exp_rand(L_FTP/r);
this->lastArrival[src] = evt->eventTime;
evt->packetSize = exp_rand(L_FTP);
break;
case ROGUE:
evt->eventTime = this->lastArrival[src] + exp_rand(L_ROGUE*2/ROGUE_SRC);
this->lastArrival[src] = evt->eventTime;
evt->packetSize = exp_rand(L_ROGUE);
break;
}
evt->arrivalTime = evt->eventTime;
evt->departureTime = INVAL;
this->eventQueue.push(evt);
#ifdef DEBUG
cout<<"sched\t"<<evt->eventTime<<"\tA\tpkt "<<evt->packetId<<"\tsrc "<<evt->sourceId<<"\ttime "<<evt->eventTime;
cout<<"\tQsize "<<this->eventQueue.size()<<endl;
#endif
break;
case PKT_DEPART:
evt->eventTime = this->lastDeparture +
this->flows[src].front()->packetSize/R;
evt->packetSize = this->flows[src].front()->packetSize;
evt->sourceId = src;
evt->packetId = this->flows[src].front()->packetId;
evt->departureTime = evt->eventTime;
evt->arrivalTime = this->flows[src].front()->arrivalTime;
this->eventQueue.push(evt);
#ifdef DEBUG
cout<<"sched\t"<<evt->eventTime<<"\tD\tpkt "<<evt->packetId<<"\tsrc "<<evt->sourceId;
cout<<"\ttime "<<evt->eventTime<<"\tQsize "<<this->eventQueue.size()<<endl;
#endif
break;
}
}
bool Prekazitor::tajna_chodba() {
bool sm = !(nahodne(2));
if (!uprav_smer(sm, 4)) {
return false;
}
int delka = exp_rand(6, max_x-(*X)-4) + 3;
if (delka < 3) {
return false;
}
Tilemap* tm = new Tilemap(delka, 4, false);
tm->pojmenuj("secretTM",s->tajnych_chodeb);
tm->z_pos = 101 + s->tajnych_chodeb;
tm->cesta = new Cesta();
float x, y;
if (sm) {
dolovak(4);
stredovak(delka);
s->intact2->obdelnik(K[1] , (*X)-delka-1, (*X)-3, (*Y)-5, (*Y)-5);
s->intact2->obdelnik(K[4] , (*X)-delka-1, (*X)-3, (*Y)-4, (*Y)-4);
s->intact2->obdelnik(K[10], (*X)-delka-1, (*X)-3, (*Y)-3, (*Y)-3);
s->intact2->poloz_blok(K[2] , (*X)-2, (*Y)-5);
s->intact2->poloz_blok(K[5] , (*X)-2, (*Y)-4);
s->intact2->poloz_blok(K[11], (*X)-2, (*Y)-3);
s->intact2->poloz_blok(V[0], (*X)-delka-1, (*Y)-3);
tm->obdelnik(S, 0, tm->sirka-2, 0, tm->vyska-1);
tm->obdelnik(K[8], tm->sirka-1, tm->sirka-1, 0, tm->vyska-3);
tm->poloz_blok(V[2], tm->sirka-1, tm->vyska-2);
tm->poloz_blok(V[4], tm->sirka-1, tm->vyska-1);
x = (*X)-delka-1;
y = (*Y)-3;
} else {
stredovak(delka);
nahorovak(4);
s->intact2->poloz_blok(K[0], (*X)-delka, (*Y)-1);
s->intact2->poloz_blok(K[3], (*X)-delka, *Y);
s->intact2->poloz_blok(K[9], (*X)-delka, (*Y)+1);
s->intact2->obdelnik(K[1] , (*X)-delka+1, *X, (*Y)-1, (*Y)-1);
s->intact2->obdelnik(K[4] , (*X)-delka+1, *X, *Y, *Y);
s->intact2->obdelnik(K[10], (*X)-delka+1, *X, (*Y)+1, (*Y)+1);
s->intact2->poloz_blok(V[1], (*X)-1, (*Y)+1);
tm->obdelnik(S, 1, tm->sirka-1, 0, tm->vyska-1);
tm->obdelnik(K[6], 0, 0, 0, tm->vyska-3);
tm->poloz_blok(V[3], 0, tm->vyska-2);
tm->poloz_blok(V[5], 0, tm->vyska-1);
x = (*X)-delka;
y = (*Y)+1;
}
secretarea(x, y, tm);
stredovak(1);
s->tilemapy.push_back(tm);
s->tajnych_chodeb++;
return true;
}
static int geodev (double p)
/* Return geometric distributed random deviate with p(i) = p*(1-p)^i,
where 0<p<1 and i=0,1,..
See Fishman, G. S., 1996, Monte Carlo (Springer, NY, Berlin, Heidelberg), 221. */
{
double b, y, z;
b = (-1.0)/log(1.0-p);
y = exp_rand();
z = b*y;
return (int)z;
}
void rsmith2d(double *coord, double *center, double *edge, int *nObs,
int *nSites, int *grid, double *cov11, double *cov12,
double *cov22, double *ans){
/* This function generates random fields for the 2d smith model
coord: the coordinates of the locations
center: the center of the compact set - here I use a square
edge: the length of the edge of the square
nObs: the number of observations to be generated
grid: Does coord specifies a grid?
nSites: the number of locations
covXX: the parameters of the bivariate normal density
ans: the generated random field */
const double det = *cov11 * *cov22 - *cov12 * *cov12,
uBound = 1 / (M_2PI * sqrt(det)), itwiceDet = 1 / (2 * det);
if ((det <= 0) || (*cov11 <= 0))
error("The covariance matrix isn't semi-definite positive!\n");
/* We first center the coordinates to avoid repetition of
unnecessary operations in the while loop */
for (int i=0;i<*nSites;i++){
coord[i] -= center[0];
coord[*nSites + i] -= center[1];
}
/* Simulation according to the Schlather methodology. The compact
set need to be inflated first */
*edge += 6.92 * sqrt(fmax2(*cov11, *cov22));
double lebesgue = *edge * *edge;
GetRNGstate();
if (*grid){
//Simulation part if a grid is used
for (int i=0;i<*nObs;i++){
double poisson = 0;
int nKO = *nSites * *nSites;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
poisson += exp_rand();
double ipoisson = 1 / poisson, thresh = uBound * ipoisson;
//We simulate points uniformly in [-r/2, r/2]^2
double u1 = *edge * runif(-0.5, 0.5),
u2 = *edge * runif(-0.5, 0.5);
nKO = *nSites * *nSites;
for (int j=0;j<*nSites;j++){
for (int k=0;k<*nSites;k++){
/* This is the bivariate normal density with 0 mean and
cov. matrix [cov11, cov12; cov12, cov22] */
double y = exp((-*cov22 * (coord[j] - u1) * (coord[j] - u1) + 2 * *cov12 *
(coord[j] - u1) * (coord[*nSites + k] - u2) - *cov11 *
(coord[*nSites + k] - u2) * (coord[*nSites + k] - u2)) *
itwiceDet) * thresh;
ans[j + k * *nSites + i * *nSites * *nSites] =
fmax2(y, ans[j + k * *nSites + i * *nSites * *nSites]);
nKO -= (thresh <= ans[j + k * *nSites + i * *nSites * *nSites]);
}
}
}
}
}
else{
//Simulation part if a grid isn't used
for (int i=0;i<*nObs;i++){
double poisson = 0;
int nKO = *nSites;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
poisson += exp_rand();
double ipoisson = 1 / poisson, thresh = uBound * ipoisson;
//We simulate points uniformly in [-r/2, r/2]^2
double u1 = *edge * runif(-0.5, 0.5),
u2 = *edge * runif(-0.5, 0.5);
nKO = *nSites;
for (int j=0;j<*nSites;j++){
/* This is the bivariate normal density with 0 mean and
cov. matrix [cov11, cov12; cov12, cov22] */
double y = exp((-*cov22 * (coord[j] - u1) * (coord[j] - u1) + 2 * *cov12 *
(coord[j] - u1) * (coord[*nSites + j] - u2) - *cov11 *
(coord[*nSites + j] - u2) * (coord[*nSites + j] - u2)) *
itwiceDet) * thresh;
ans[i + j * *nObs] = fmax2(y, ans[i + j * *nObs]);
nKO -= (thresh <= ans[i + j * *nObs]);
}
}
}
}
PutRNGstate();
/* Lastly, we multiply by the Lebesgue measure of the dilated
compact set */
if (*grid){
for (int i=0;i<(*nSites * *nSites * *nObs);i++)
ans[i] *= lebesgue;
}
else{
for (int i=0;i<(*nSites * *nObs);i++)
ans[i] *= lebesgue;
}
return;
}
void rsmith1d(double *coord, double *center, double *edge, int *nObs,
int *nSites, double *var, double *ans){
/* This function generates random fields for the 1d smith model
coord: the coordinates of the locations
center: the center of the compact set - here I use an interval
edge: the length of the interval
nObs: the number of observations to be generated
nSites: the number of locations
var: the variance of the univariate normal density
ans: the generated random field */
const double uBound = M_1_SQRT_2PI / sqrt(*var);
if (*var <= 0)
error("The variance should be strictly positive!\n");
/* We first center the coordinates to avoid repetition of
unnecessary operations in the while loop */
for (int i=0;i<*nSites;i++)
coord[i] -= center[0];
/* Simulation according to the Schlather methodology. The compact
set need to be inflated first */
*edge += 6.92 * sqrt(*var);
const double lebesgue = *edge;
GetRNGstate();
for (int i=0;i<*nObs;i++){
double poisson = 0;
int nKO = *nSites;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
poisson += exp_rand();
double ipoisson = 1 / poisson, thresh = uBound * ipoisson;
//We simulate points uniformly in [-r/2, r/2]
double u = *edge * runif(-0.5, 0.5);
nKO = *nSites;
for (int j=0;j<*nSites;j++){
//This is the normal density with 0 mean and variance var
double y = exp(-(coord[j] - u) * (coord[j] - u) / (2 * *var)) * thresh;
ans[i + j * *nObs] = fmax2(y, ans[i + j * *nObs]);
nKO -= (thresh <= ans[i + j * *nObs]);
}
}
}
PutRNGstate();
/* Lastly, we multiply by the Lebesgue measure of the dilated
compact set */
for (int i=0;i<(*nSites * *nObs);i++)
ans[i] *= lebesgue;
return;
}
SEXP thinjumpequal(SEXP n,
SEXP p,
SEXP guess)
{
int N;
double P;
int *w; /* temporary storage for selected integers */
int nw, nwmax;
int i, j, k;
double log1u, log1p;
/* R object return value */
SEXP Out;
/* external storage pointer */
int *OutP;
/* protect R objects from garbage collector */
PROTECT(p = AS_NUMERIC(p));
PROTECT(n = AS_INTEGER(n));
PROTECT(guess = AS_INTEGER(guess));
/* Translate arguments from R to C */
N = *(INTEGER_POINTER(n));
P = *(NUMERIC_POINTER(p));
nwmax = *(INTEGER_POINTER(guess));
/* Allocate space for result */
w = (int *) R_alloc(nwmax, sizeof(int));
/* set up */
GetRNGstate();
log1p = -log(1.0 - P);
/* main loop */
i = 0; /* last selected element of 1...N */
nw = 0; /* number of selected elements */
while(i <= N) {
log1u = exp_rand(); /* an exponential rv is equivalent to -log(1-U) */
j = (int) ceil(log1u/log1p); /* j is geometric(p) */
i += j;
if(nw >= nwmax) {
/* overflow; allocate more space */
w = (int *) S_realloc((char *) w, 2 * nwmax, nwmax, sizeof(int));
nwmax = 2 * nwmax;
}
/* add 'i' to output vector */
w[nw] = i;
++nw;
}
/* The last saved 'i' could have exceeded 'N' */
/* For efficiency we don't check this in the loop */
if(nw > 0 && w[nw-1] > N)
--nw;
PutRNGstate();
/* create result vector */
PROTECT(Out = NEW_INTEGER(nw));
/* copy results into output */
OutP = INTEGER_POINTER(Out);
for(k = 0; k < nw; k++)
OutP[k] = w[k];
UNPROTECT(4);
return(Out);
}
void rgeomtbm(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *sigma2, double *nugget,
double *range, double *smooth, double *uBound,
int *nlines, double *ans){
/* This function generates random fields from the geometric model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
sigma2: the variance of the geometric gaussian process
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
uBound: the uniform upper bound for the stoch. proc.
nlines: the number of lines used in the TBM algo
ans: the generated random field */
int i, neffSite, lagi = 1, lagj = 1;
const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2;
double sigma = sqrt(*sigma2), sill = 1 - *nugget;
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *gp = malloc(neffSite * sizeof(double)),
*lines = malloc(3 * *nlines * sizeof(double));
//rescale the coordinates
for (i=(*nSite * *dim);i--;){
const double irange = 1 / *range;
coord[i] = coord[i] * irange;
}
if ((*covmod == 3) && (*smooth == 2))
//This is the gaussian case
*covmod = 5;
//Generate lines
vandercorput(nlines, lines);
GetRNGstate();
for (i=*nObs;i--;){
int nKO = neffSite;
double poisson = 0;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
int j;
/* ------- Random rotation of the lines ----------*/
double u = unif_rand() - 0.5,
v = unif_rand() - 0.5,
w = unif_rand() - 0.5,
angle = runif(0, M_2PI),
inorm = 1 / sqrt(u * u + v * v + w * w);
u *= inorm;
v *= inorm;
w *= inorm;
rotation(lines, nlines, &u, &v, &w, &angle);
/* -------------- end of rotation ---------------*/
poisson += exp_rand();
double ipoisson = -log(poisson),
thresh = loguBound + ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (j=neffSite;j--;)
gp[j] = 0;
tbmcore(nSite, &neffSite, dim, covmod, grid, coord, nugget,
&sill, range, smooth, nlines, lines, gp);
nKO = neffSite;
double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2;
for (j=neffSite;j--;){
ans[j * lagj + i * lagi] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2,
ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
/* So far we generate a max-stable process with standard Gumbel
margins. Switch to unit Frechet ones */
for (i=*nObs * neffSite;i--;)
ans[i] = exp(ans[i]);
free(lines); free(gp);
return;
}
void rextremaltdirect(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *nugget, double *range,
double *smooth, double *DoF, double *uBound, double *ans){
/* This function generates random fields for the Extremal-t model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
DoF: the degree of freedom
blockSize: see rextremalttbm.
ans: the generated random field */
int neffSite, lagi = 1, lagj = 1, oneInt = 1;
double sill = 1 - *nugget;
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *covmat = malloc(neffSite * neffSite * sizeof(double)),
*gp = malloc(neffSite * sizeof(double));
buildcovmat(nSite, grid, covmod, coord, dim, nugget, &sill, range,
smooth, covmat);
/* Compute the Cholesky decomposition of the covariance matrix */
int info = 0;
F77_CALL(dpotrf)("U", &neffSite, covmat, &neffSite, &info);
if (info != 0)
error("error code %d from Lapack routine '%s'", info, "dpotrf");
GetRNGstate();
for (int i=*nObs;i--;){
double poisson = 0;
int nKO = neffSite;
while (nKO){
poisson += exp_rand();
double ipoisson = 1 / poisson,
thresh = *uBound * ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (int j=neffSite;j--;)
gp[j] = norm_rand();
F77_CALL(dtrmv)("U", "T", "N", &neffSite, covmat, &neffSite, gp, &oneInt);
nKO = neffSite;
for (int j=neffSite;j--;){
double dummy = R_pow(fmax2(0, gp[j]), *DoF) * ipoisson;
ans[j * lagj + i * lagi] = fmax2(dummy, ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
//Lastly we multiply by the normalizing constant
const double imean = M_SQRT_PI * R_pow(2, -0.5 * (*DoF - 2)) /
gammafn(0.5 * (*DoF + 1));
for (int i=(neffSite * *nObs);i--;)
ans[i] *= imean;
free(covmat); free(gp);
return;
}
/***** ***************************************************************************************** *****/
void
RJMCMCcombine(int* accept, double* log_AR,
int* K, double* w, double* logw, double* mu,
double* Q, double* Li, double* Sigma, double* log_dets,
int* order, int* rank, int* r, int* mixN, int** rInv,
double* u, double* P, double* log_dens_u,
double* dwork, int* iwork, int* err,
const double* y, const int* p, const int* n,
const int* Kmax, const double* logK, const double* log_lambda, const int* priorK,
const double* logPsplit, const double* logPcombine, const double* delta,
const double* c, const double* log_c, const double* xi, const double* D_Li, const double* log_dets_D,
const double* zeta, const double* log_Wishart_const, const double* gammaInv, const double* log_sqrt_detXiInv,
const int* priormuQ, const double* pars_dens_u,
void (*ld_u)(double* log_dens_u, const double* u, const double* pars_dens_u, const int* p))
{
const char *fname = "NMix::RJMCMCcombine";
*err = 0;
*accept = 0;
*log_AR = R_NegInf;
/*** Array of two zeros to be passed to ldMVN as log_dets to compute only -1/2(x-mu)'Sigma^{-1}(x-mu) ***/
static const double ZERO_ZERO[2] = {0.0, 0.0};
/*** Some variables ***/
static int i0, i1, k, LTp, p_p, ldwork_logJacLambdaVSigma;
static int jstar, jremove, j1, j2;
static int rInvPrev;
static int rankstar;
static double sqrt_u1_ratio, one_u1, log_u1, log_one_u1, log_u1_one_minus_u1_min32, one_minus_u2sq, erand;
static double log_Jacob, log_Palloc, log_LikelihoodRatio, log_PriorRatio, log_ProposalRatio;
static double log_phi1, log_phi2, log_phistar, Prob_r1, Prob_r2, log_Prob_r1, log_Prob_r2, max_log_Prob_r12, sum_Prob_r12;
static double mu1_vstar, mu2_vstar, mustar_vstar;
/*** Some pointers ***/
static double *w1, *w2, *logw1, *logw2, *mu1, *mu2, *Sigma1, *Sigma2, *Li1, *Li2, *Q1, *Q2, *log_dets1, *log_dets2;
static int *mixN1, *mixN2, *rInv1, *rInv2;
static int **rrInv1, **rrInv2;
static double *wOldP, *logwOldP, *muOldP, *SigmaOldP, *LiOldP, *QOldP, *log_detsOldP;
static double *Listar;
static int *mixNOldP;
static int **rrInvOldP;
static const double *muNewP, *SigmaNewP, *QNewP;
static const double *mu1P, *mu2P;
static const double *yP;
static int *rInv1P, *rInv2P, *rInvP;
static int *rP;
/*** Declaration for dwork ***/
static double *mustar, *Sigmastar, *Lambdastar, *Vstar, *Lstar, *Qstar;
static double *SigmaTemp, *Lambda1, *Lambda2, *V1, *V2, *Lambda_dspev, *V_dspev, *dwork_misc;
static double *dlambdaV_dSigma, *P_im, *VPinv_re, *VPinv_im, *sqrt_Plambda_re, *sqrt_Plambda_im, *VP_re, *VP_im;
static double *mustarP, *LambdastarP, *LstarP, *Lambda1P, *Lambda2P, *VstarP, *VP_reP;
/*** Declaration for iwork ***/
static int *iwork_misc;
static int complexP[1];
/*** Declaration for auxiliary variables ***/
static double *u1, *u2, *u3;
static double *u2P, *u3P;
/*** Declaration for other mixture related variables ***/
static double wstar[1]; /** weight of the new combined component **/
static double logwstar[1]; /** log(weight) of the new combined component **/
static double log_detsstar[2]; /** Like log_dets, related to the new combined component **/
static double logJ_part3[1]; /** the third part of the log-Jacobian **/
//static double log_dlambdaV_dSigma[1]; /** logarithm of |d(Lambdastar,Vstar)/d(Sigmastar)| **/
static double logL12[2]; /** logL12[0] = sum_{i=0}^{mixN1} log(phi(y_i | mu_{r_i}, Sigma_{r_i})) + sum_{i=0}^{mixN2}... **/
/** logL12[1] = sum_{i=0}^{mixN1} log(P(r = r_i | w, K)) + sum_{i=0}^{mixN2} ... **/
/** for observations allocated to the combined components, state before reallocation **/
static double logLstar[2]; /** the same as above, state after reallocation **/
static double log_prior_mu1[1]; /** logarithm of the prior of mu1 (first splitted component) **/
static double log_prior_mu2[1]; /** logarithm of the prior of mu2 (second splitted component) **/
static double log_prior_mustar[1]; /** logarithm of the prior of mu(star) (splitted component) **/
static double log_prior_Q1[1]; /** logarithm of the prior of Q1 = Sigma1^{-1} (first splitted component) **/
static double log_prior_Q2[1]; /** logarithm of the prior of Q2 = Sigma2^{-1} (first splitted component) **/
static double log_prior_Qstar[1]; /** logarithm of the prior of Q(star) = Sigma(star)^{-1} (splitted component) **/
static int mixNstar[1]; /** numbers of allocated observations in the new combined component **/
if (*K == 1) return;
LTp = (*p * (*p + 1))/2;
p_p = *p * *p;
ldwork_logJacLambdaVSigma = *p * LTp + (4 + 2 * *p) * *p;
/*** Components of dwork ***/
mustar = dwork; /** mean vector of the new combined component **/
Sigmastar = mustar + *p; /** covariance matrix of the new combined component **/
Lambdastar = Sigmastar + LTp; /** eigenvalues of the new combined component **/
Vstar = Lambdastar + *p; /** eigenvectors of the new combined component **/
Lstar = Vstar + p_p; /** Cholesky decomposition of Sigmastar **/
Qstar = Lstar + LTp; /** inversion of Sigmastar **/
SigmaTemp = Qstar + LTp; /** Sigma1 and Sigma2 passed to dspev which overwrites it during the decomposition **/
Lambda1 = Sigmastar + LTp; /** eigenvalues of the first component to be combined **/
Lambda2 = Lambda1 + *p; /** eigenvalues of the second component to be combined **/
V1 = Lambda2 + *p; /** eigenvectors of the first component to be combined **/
V2 = V1 + p_p; /** eigenvectors of the second component to be combined **/
Lambda_dspev = V2 + p_p; /** space to store lambda's computed by dspev (in ascending order) **/
V_dspev = Lambda_dspev + *p; /** space to store V computed by dspev **/
dwork_misc = V_dspev + p_p; /** working array for LAPACK dspev (needs 3*p) **/
/** Dist::ldMVN1, Dist::ldMVN2 (needs p) **/
/** NMix::RJMCMC_logJacLambdaVSigma (needs: see above) **/
/** AK_LAPACK::sqrtGE (needs p*p) **/
/** AK_LAPACK::correctMatGE (needs p*p) **/
/** NMix::orderComp (needs at most Kmax) **/
dlambdaV_dSigma = dwork_misc + ldwork_logJacLambdaVSigma + *Kmax;
P_im = dlambdaV_dSigma + LTp * LTp; /** needed by AK_LAPACK::sqrt_GE **/
VPinv_re = P_im + p_p; /** needed by AK_LAPACK::sqrt_GE **/
VPinv_im = VPinv_re + p_p; /** needed by AK_LAPACK::sqrt_GE **/
sqrt_Plambda_re = VPinv_im + p_p; /** needed by AK_LAPACK::sqrt_GE **/
sqrt_Plambda_im = sqrt_Plambda_re + *p; /** needed by AK_LAPACK::sqrt_GE **/
VP_re = sqrt_Plambda_im + *p; /** needed by AK_LAPACK::sqrt_GE **/
VP_im = VP_re + p_p; /** needed by AK_LAPACK::sqrt_GE **/
// next = VP_im + p_p;
/*** Components of iwork ***/
iwork_misc = iwork; /** working array for NMix::RJMCMC_logJacLambdaVSigma (needs p) **/
/** Rand::RotationMatrix (needs p) **/
/** AK_LAPACK::sqrtGE (needs p) **/
/** AK_LAPACK::correctMatGE (needs p) **/
// next = iwork_misc + *p;
/***** Pointers for auxiliary vector u *****/
/***** =============================== *****/
u1 = u;
u2 = u1 + 1;
u3 = u2 + *p;
/***** Choose the components to be splitted *****/
/***** ==================================== *****/
// TEMPORAR? For p > 1, a pair is sampled from all pairs,
// for p = 1, a pair of "adjacent components" is sampled
if (*p > 1){
// ===== Code for the situation when a pair is sampled from all pairs ===== //
Rand::SamplePair(&j1, &j2, K); // generates a pair (j1, j2) where j1 < j2
}
else{
// ===== Code for the situation when j1 is sampled from K-1 components with the "smallest" mean ===== //
// ===== and j2 is the adjacent component with just a "higher" mean ===== //
// ===== For a definition of ordering see NMix::orderComp function ===== //
rankstar = (int)(floor(unif_rand() * (*K - 1)));
if (rankstar == *K - 1) jstar = *K - 2; // this row is needed with pobability 0 (unif_rand() would have to return 1)
j1 = order[rankstar];
j2 = order[rankstar + 1];
}
// ===== Code for the situation similar to the Matlab code of I. Papageorgiou ===== //
//j1 = (int)(floor(unif_rand() * (*K - 1))); // This way is used in the Matlab code of I. Papageorgiou,
//if (j1 == *K - 1) j1 = *K - 2; // i.e., j1 is sampled from Unif(0,...,K-2)
//j2 = *K - 1; // I have no idea why in this way...
/*** Pointers to chosen components ***/
w1 = w + j1;
w2 = w1 + (j2 - j1);
logw1 = logw + j1;
logw2 = logw1 + (j2 - j1);
mu1 = mu + j1 * *p;
mu2 = mu1 + (j2 - j1) * *p;
Sigma1 = Sigma + j1 * LTp;
Sigma2 = Sigma1 + (j2 - j1) * LTp;
Li1 = Li + j1 * LTp;
Li2 = Li1 + (j2 - j1) * LTp;
Q1 = Q + j1 * LTp;
Q2 = Q1 + (j2 - j1) * LTp;
log_dets1 = log_dets + j1 * 2;
log_dets2 = log_dets1 + (j2 - j1) * 2;
rrInv1 = rInv + j1;
rrInv2 = rrInv1 + (j2 - j1);
rInv1 = *rrInv1;
rInv2 = *rrInv2;
mixN1 = mixN + j1;
mixN2 = mixN1 + (j2 - j1);
/*** Pointers to the old places where a new component will be written (if accepted) ***/
/*** jstar = index of the place where a new component will be written on the place of one of old components (if accepted) ***/
/*** jremove = index of the place where an old component will be removed (and the rest will be shifted forward) ***/
/*** I will ensure jstar < jremove ***/
if (j1 < j2){
jstar = j1; // combined component will be placed on place with a lower index if combine move accepted
jremove = j2; // component with a higher index will be removed if combine move accepted
wOldP = w1; // places where a new component will be written
logwOldP = logw1;
muOldP = mu1;
SigmaOldP = Sigma1;
LiOldP = Li1;
QOldP = Q1;
log_detsOldP = log_dets1;
rrInvOldP = rrInv1;
mixNOldP = mixN1;
}
else{
jstar = j2;
jremove = j1;
wOldP = w2; // places where a new component will be written
logwOldP = logw2;
muOldP = mu2;
SigmaOldP = Sigma2;
LiOldP = Li2;
QOldP = Q2;
log_detsOldP = log_dets2;
rrInvOldP = rrInv2;
mixNOldP = mixN2;
}
/***** Compute proposed weight, mean, variance and log-Jacobian of the RJ (split) move *****/
/***** =============================================================================== *****/
/***** Proposed weight *****/
*wstar = *w1 + *w2;
*logwstar = AK_Basic::log_AK(wstar[0]);
*u1 = *w1 / *wstar;
one_u1 = 1 - *u1;
/***** Log-Jacobian, part 1 *****/
/***** Jacobian = dtheta/dtheta^*, that is corresponds to the reversal split move *****/
log_Jacob = *logwstar;
/***** Code for UNIVARIATE mixtures *****/
if (*p == 1){ /*** UNIVARIATE mixture ***/
/***** Check inequality condition which is satisfied by the reversal split move *****/
/***** This will ensure that u2 is positive *****/
// ===== The following code is needed only when (j1, j2) is sampled from a set of all pairs and hence there is no guarantee ===== //
// ===== that mu1 <= mu2 ===== //
//if (*mu1 > *mu2){ // switch labels j1, j2 such that mu1 < mu2 to get correctly u1, u2 and u3
// AK_Basic::switchValues(&j1, &j2);
// *u1 = one_u1;
// one_u1 = 1 - *u1;
// AK_Basic::switchPointers(&w1, &w2);
// AK_Basic::switchPointers(&logw1, &logw2);
// AK_Basic::switchPointers(&mu1, &mu2);
// AK_Basic::switchPointers(&Sigma1, &Sigma2);
// AK_Basic::switchPointers(&Li1, &Li2);
// AK_Basic::switchPointers(&Q1, &Q2);
// AK_Basic::switchPointers(&log_dets1, &log_dets2);
// AK_Basic::switchPointers(&rInv1, &rInv2);
// AK_Basic::switchPointers(&mixN1, &mixN2);
//}
/***** Values derived from the auxiliary number u1 corresponding to the reversal split move *****/
sqrt_u1_ratio = sqrt(*u1 / (1 - *u1));
log_u1 = AK_Basic::log_AK(*u1);
log_one_u1 = AK_Basic::log_AK(1 - *u1);
log_u1_one_minus_u1_min32 = -1.5 * (log_u1+ log_one_u1);
/***** Proposed mean: mustar = u1 * mu1 + (1 - u1) * mu2 *****/
*mustar = *u1 * *mu1 + one_u1 * *mu2;
/***** Proposed variance *****/
*Sigmastar = *u1 * (*mu1 * *mu1 + *Sigma1) + one_u1 * (*mu2 * *mu2 + *Sigma2) - *mustar * *mustar;
if (*Sigmastar <= 0) return;
/***** Cholesky decomposition of the proposed variance (standard deviation) *****/
*Lstar = sqrt(*Sigmastar);
/***** Inverted proposed variance *****/
*Qstar = 1 / *Sigmastar;
/***** Auxiliary numbers u2 and u3 correspoding to the reversal split move *****/
*u2 = ((*mustar - *mu1) / *Lstar) * sqrt_u1_ratio;
one_minus_u2sq = 1 - *u2 * *u2;
*u3 = (*u1 * *Sigma1) / (one_minus_u2sq * *Sigmastar);
/***** Log-Jacobian, part 2 *****/
log_Jacob += AK_Basic::log_AK(one_minus_u2sq * *Sigmastar * *Lstar) + log_u1_one_minus_u1_min32;
/***** log|d(Lambdastar,Vstar)/d(Sigmastar)|*****/ // NOT NEEDED AS IT IS ZERO, moreover, 25/01/2008: included in logJ_part3
//*log_dlambdaV_dSigma = 0.0;
/***** Log-Jacobian, part 3 *****/ // NOT NEEDED AS IT IS ZERO
//*logJ_part3 = 0.0;
//log_Jacob += *logJ_part3;
/***** log-dets for the proposed variance *****/
log_detsstar[0] = -AK_Basic::log_AK(*Lstar); /** log_detsstar[0] = -log(Lstar) = log|Sigmastar|^{-1/2} **/
log_detsstar[1] = log_dets1[1]; /** log_detsstar[1] = -p * log(sqrt(2*pi)) **/
}
else{ /*** MULTIVARIATE mixture ***/
/***** Values derived from the auxiliary number u1 corresponding to the reversal split move *****/
sqrt_u1_ratio = sqrt(*u1 / (1 - *u1));
log_u1 = AK_Basic::log_AK(*u1);
log_one_u1 = AK_Basic::log_AK(1 - *u1);
log_u1_one_minus_u1_min32 = -1.5 * (log_u1+ log_one_u1);
/***** Spectral decomposition of Sigma1 *****/
AK_Basic::copyArray(SigmaTemp, Sigma1, LTp);
F77_CALL(dspev)("V", "L", p, SigmaTemp, Lambda_dspev, V_dspev, p, dwork_misc, err); /** eigen values in ascending order **/
if (*err){
warning("%s: Spectral decomposition of Sigma[%d] failed.\n", fname, j1);
return;
}
//AK_LAPACK::spevAsc2spevDesc(Lambda1, V1, Lambda_dspev, V_dspev, p); /** eigen values in descending order **/
// 05/02/2008: CHANGE - eigenvalues are assumed to be in ASCENDING order
AK_LAPACK::correctMatGE(V1, dwork_misc, iwork_misc, err, p); /** be sure that det(V1) = 1 and not -1 **/
if (*err){
warning("%s: Correction of V[%d] failed.\n", fname, j1);
return;
}
/***** Spectral decomposition of Sigma2 *****/
AK_Basic::copyArray(SigmaTemp, Sigma2, LTp);
F77_CALL(dspev)("V", "L", p, SigmaTemp, Lambda_dspev, V_dspev, p, dwork_misc, err); /** eigen values in ascending order **/
if (*err){
warning("%s: Spectral decomposition of Sigma[%d] failed.\n", fname, j2);
return;
}
//AK_LAPACK::spevAsc2spevDesc(Lambda2, V2, Lambda_dspev, V_dspev, p); /** eigen values in descending order **/
// 05/02/2008: CHANGE - eigenvalues are assumed to be in ASCENDING order
AK_LAPACK::correctMatGE(V2, dwork_misc, iwork_misc, err, p); /** be sure that det(V2) = 1 and not -1 **/
if (*err){
warning("%s: Correction of V[%d] failed.\n", fname, j2);
return;
}
/***** Rotation matrix which corresponds to the reversible split move, P = (V1 %*% t(V2))^{1/2} *****/
F77_CALL(dgemm)("N", "T", p, p, p, &AK_Basic::_ONE_DOUBLE, V1, p, V2, p, &AK_Basic::_ZERO_DOUBLE, P, p); /*** P = V1 %*% t(V2) ***/
AK_LAPACK::sqrtGE(P, P_im, VPinv_re, VPinv_im, complexP, sqrt_Plambda_re, sqrt_Plambda_im, VP_re, VP_im, dwork_misc, iwork_misc, err, p);
if (*err){
warning("%s: Computation of the square root of the rotation matrix failed.\n", fname);
return;
}
/***** Proposed eigenvectors: Vstar = (1/2) * (t(P) %*% V1 + P %*% V2) *****/
F77_CALL(dgemm)("T", "N", p, p, p, &AK_Basic::_ONE_DOUBLE, P, p, V1, p, &AK_Basic::_ZERO_DOUBLE, VP_re, p); /*** VP_re = t(P) %*% V1 ***/
F77_CALL(dgemm)("N", "N", p, p, p, &AK_Basic::_ONE_DOUBLE, P, p, V2, p, &AK_Basic::_ZERO_DOUBLE, Vstar, p); /*** Vstar = P %*% V2 ***/
/***** Proposed mean: mustar = u1*mu1 + (1 - u1)*mu2 *****/
/***** Finalize computation of Vstar (sum t(P) %*% V1 and P %*% V2 and multiply it by 0.5) *****/
mu1P = mu1;
mu2P = mu2;
mustarP = mustar;
VstarP = Vstar;
VP_reP = VP_re;
for (i1 = 0; i1 < *p; i1++){
*mustarP = *u1 * *mu1P + one_u1 * *mu2P;
mu1P++;
mu2P++;
mustarP++;
for (i0 = 0; i0 < *p; i0++){
*VstarP += *VP_reP;
*VstarP *= 0.5;
VstarP++;
VP_reP++;
}
}
/***** Proposed eigenvalues *****/
/***** Auxiliary numbers u2 and u3 correspoding to the reversal split move *****/
/***** Log-Jacobian, part 2 *****/
/***** Check also the adjacency condition from the reversal split move -> u2[p-1] must be positive *****/
/****** -> if not satisfied, take abs(u2[p-1]) -> this should be equivalent to labelswitching which is then not necessary *****/
LambdastarP = Lambdastar;
u2P = u2;
u3P = u3;
Lambda1P = Lambda1;
Lambda2P = Lambda2;
VstarP = Vstar;
for (i1 = 0; i1 < *p; i1++){
mu1_vstar = 0.0;
mu2_vstar = 0.0;
mustar_vstar = 0.0;
mu1P = mu1;
mu2P = mu2;
mustarP = mustar;
for (i0 = 0; i0 < *p; i0++){
mu1_vstar += *mu1P * *VstarP;
mu2_vstar += *mu2P * *VstarP;
mustar_vstar += *mustarP * *VstarP;
mu1P++;
mu2P++;
mustarP++;
VstarP++;
}
*LambdastarP = *u1 * (mu1_vstar * mu1_vstar + *Lambda1P) + one_u1 * (mu2_vstar * mu2_vstar + *Lambda2P) - mustar_vstar * mustar_vstar;
if (*LambdastarP <= 0){
return;
}
*u2P = ((mustar_vstar - mu1_vstar) / sqrt(*LambdastarP)) * sqrt_u1_ratio;
if (i1 == *p - 1 && *u2P <= 0) *u2P *= (-1);
one_minus_u2sq = 1 - *u2P * *u2P;
*u3P = (*u1 * *Lambda1P) / (one_minus_u2sq * *LambdastarP);
log_Jacob += 1.5 * AK_Basic::log_AK(*LambdastarP) + AK_Basic::log_AK(one_minus_u2sq);
LambdastarP++;
Lambda1P++;
Lambda2P++;
u2P++;
u3P++;
}
log_Jacob += *p * log_u1_one_minus_u1_min32;
/***** Proposed variance *****/
AK_LAPACK::spevSY2SP(Sigmastar, Lambdastar, Vstar, p);
/***** Cholesky decomposition of the proposed variance *****/
AK_Basic::copyArray(Lstar, Sigmastar, LTp);
F77_CALL(dpptrf)("L", p, Lstar, err);
if (*err){
warning("%s: Cholesky decomposition of proposed Sigmastar failed.\n", fname);
return;
}
/***** Inverted proposed variance *****/
AK_Basic::copyArray(Qstar, Lstar, LTp);
F77_CALL(dpptri)("L", p, Qstar, err);
if (*err){
warning("%s: Inversion of proposed Sigmastar failed.\n", fname);
return;
}
/***** log-dets for the proposed variance *****/
log_detsstar[0] = 0.0;
LstarP = Lstar;
for (i0 = *p; i0 > 0; i0--){ /** log_detsstar[0] = -sum(log(Lstar[i,i])) **/
log_detsstar[0] -= AK_Basic::log_AK(*LstarP);
LstarP += i0;
}
log_detsstar[1] = log_dets1[1]; /** log_detsstar[1] = -p * log(sqrt(2*pi)) **/
/***** log|d(Lambdastar,Vstar)/d(Sigmastar)|*****/ // 25/01/2008: this part included in NMix::RJMCMC_logJac_part3
//NMix::RJMCMC_logJacLambdaVSigma(log_dlambdaV_dSigma, dlambdaV_dSigma, dwork_misc, iwork_misc, err,
// Lambdastar, Vstar, Sigmastar, p, &AK_Basic::_ZERO_INT);
//if (*err){
// warning("%s: RJMCMC_logJacLambdaVSigma failed.\n", fname);
// return;
//}
/***** Log-Jacobian, part 3 *****/
NMix::RJMCMC_logJac_part3(logJ_part3, Lambdastar, Vstar, P, p);
log_Jacob += *logJ_part3;
} /*** end of the code for a MULTIVARIATE mixture ***/
/***** Log-density of the auxiliary vector *****/
/***** =================================== *****/
ld_u(log_dens_u, u, pars_dens_u, p);
/***** Propose new allocations *****/
/***** Compute logarithm of reversal Palloc *****/
/***** ==================================== *****/
log_Palloc = 0.0; /** to compute sum[i: r[i]=j1] log P(r[i]=j1|...) + sum[i: r[i]=j2] log P(r[i]=j2|...) **/
logL12[0] = 0.0; /** to sum up log_phi for observations in the original two components **/
logLstar[0] = 0.0; /** to sum up log_phi for observations belonging to the new combined component **/
*mixNstar = *mixN1 + *mixN2;
/*** Loop for component j1 ***/
yP = y; /** all observations **/
rInv1P = rInv1;
rInvPrev = 0;
for (i0 = 0; i0 < *mixN1; i0++){
yP += (*rInv1P - rInvPrev) * *p;
/*** log(phi(y | mu1, Sigma1)), log(phi(y | mu2, Sigma2)), log(phi(y | mustar, Sigmastar)) ***/
Dist::ldMVN1(&log_phi1, dwork_misc, yP, mu1, Li1, log_dets1, p);
Dist::ldMVN1(&log_phi2, dwork_misc, yP, mu2, Li2, log_dets2, p);
Dist::ldMVN2(&log_phistar, dwork_misc, yP, mustar, Lstar, log_detsstar, p);
/*** Probabilities of the full conditional of r (to compute log_Palloc of the reversal split move) ***/
log_Prob_r1 = log_phi1 + *logw1;
log_Prob_r2 = log_phi2 + *logw2;
max_log_Prob_r12 = (log_Prob_r1 > log_Prob_r2 ? log_Prob_r1 : log_Prob_r2);
log_Prob_r1 -= max_log_Prob_r12;
log_Prob_r2 -= max_log_Prob_r12;
Prob_r1 = AK_Basic::exp_AK(log_Prob_r1);
Prob_r2 = AK_Basic::exp_AK(log_Prob_r2);
sum_Prob_r12 = Prob_r1 + Prob_r2;
log_Palloc += log_Prob_r1 - AK_Basic::log_AK(sum_Prob_r12);
logL12[0] += log_phi1;
logLstar[0] += log_phistar;
rInvPrev = *rInv1P;
rInv1P++;
}
/*** Loop for component j2 ***/
yP = y; /** all observations **/
rInv2P = rInv2;
rInvPrev = 0;
for (i0 = 0; i0 < *mixN2; i0++){
yP += (*rInv2P - rInvPrev) * *p;
/*** log(phi(y | mu1, Sigma1)), log(phi(y | mu2, Sigma2)), log(phi(y | mustar, Sigmastar)) ***/
Dist::ldMVN1(&log_phi1, dwork_misc, yP, mu1, Li1, log_dets1, p);
Dist::ldMVN1(&log_phi2, dwork_misc, yP, mu2, Li2, log_dets2, p);
Dist::ldMVN2(&log_phistar, dwork_misc, yP, mustar, Lstar, log_detsstar, p);
/*** Probabilities of the full conditional of r (to compute log_Palloc of the reversal split move) ***/
log_Prob_r1 = log_phi1 + *logw1;
log_Prob_r2 = log_phi2 + *logw2;
max_log_Prob_r12 = (log_Prob_r1 > log_Prob_r2 ? log_Prob_r1 : log_Prob_r2);
log_Prob_r1 -= max_log_Prob_r12;
log_Prob_r2 -= max_log_Prob_r12;
Prob_r1 = AK_Basic::exp_AK(log_Prob_r1);
Prob_r2 = AK_Basic::exp_AK(log_Prob_r2);
sum_Prob_r12 = Prob_r1 + Prob_r2;
log_Palloc += log_Prob_r2 - AK_Basic::log_AK(sum_Prob_r12);
logL12[0] += log_phi2;
logLstar[0] += log_phistar;
rInvPrev = *rInv2P;
rInv2P++;
}
logL12[1] = *mixN1 * *logw1 + *mixN2 * *logw2;
logLstar[1] = *mixNstar * *logwstar;
/***** Logarithm of the likelihood ratio (of the reversal split move) *****/
/***** ============================================================== *****/
log_LikelihoodRatio = logL12[0] + logL12[1] - logLstar[0] - logLstar[1];
/***** Logarithm of the prior ratio (of the reversal split move) *****/
/***** ========================================================= *****/
/***** log-ratio of priors on mixture weights *****/
log_PriorRatio = (*delta - 1) * (*logw1 + *logw2 - *logwstar) - lbeta(*delta, *K * *delta);
/***** log-ratio of priors on K (+ factor comming from the equivalent ways that the components can produce the same likelihood) *****/
switch (*priorK){
case NMix::K_FIXED:
case NMix::K_UNIF: /*** K * (p(K)/p(K-1)) = K ***/
log_PriorRatio += logK[*K - 1];
break;
case NMix::K_TPOISS: /*** K * (p(K)/p(K-1)) = K * (lambda/K) = lambda ***/
log_PriorRatio += *log_lambda;
break;
}
/***** log-ratio of priors on mixture means *****/
switch (*priormuQ){
case NMix::MUQ_NC:
Dist::ldMVN1(log_prior_mu1, dwork_misc, mu1, xi + j1 * *p, Li1, ZERO_ZERO, p);
*log_prior_mu1 *= c[j1];
*log_prior_mu1 += log_dets1[0] + log_dets1[1] + (*p * log_c[j1]) / 2;
Dist::ldMVN1(log_prior_mu2, dwork_misc, mu2, xi + j2 * *p, Li2, ZERO_ZERO, p);
*log_prior_mu2 *= c[j2];
*log_prior_mu2 += log_dets2[0] + log_dets2[1] + (*p * log_c[j2]) / 2;
Dist::ldMVN2(log_prior_mustar, dwork_misc, mustar, xi + jstar * *p, Lstar, ZERO_ZERO, p);
*log_prior_mustar *= c[jstar];
*log_prior_mustar += log_detsstar[0] + log_detsstar[1] + (*p * log_c[jstar]) / 2;
break;
case NMix::MUQ_IC:
Dist::ldMVN1(log_prior_mu1, dwork_misc, mu1, xi + j1 * *p, D_Li + j1 * LTp, log_dets_D + j1 * 2, p);
Dist::ldMVN1(log_prior_mu2, dwork_misc, mu2, xi + j2 * *p, D_Li + j2 * LTp, log_dets_D + j2 * 2, p);
Dist::ldMVN1(log_prior_mustar, dwork_misc, mustar, xi + jstar * *p, D_Li + jstar * LTp, log_dets_D + jstar * 2, p);
break;
}
log_PriorRatio += *log_prior_mu1 + *log_prior_mu2 - *log_prior_mustar;
/***** log-ratio of priors on mixture (inverse) variances *****/
Dist::ldWishart_diagS(log_prior_Q1, Q1, log_dets1, log_Wishart_const, zeta, gammaInv, log_sqrt_detXiInv, p);
Dist::ldWishart_diagS(log_prior_Q2, Q2, log_dets2, log_Wishart_const, zeta, gammaInv, log_sqrt_detXiInv, p);
Dist::ldWishart_diagS(log_prior_Qstar, Qstar, log_detsstar, log_Wishart_const, zeta, gammaInv, log_sqrt_detXiInv, p);
log_PriorRatio += *log_prior_Q1 + *log_prior_Q2 - *log_prior_Qstar;
/***** Logarithm of the proposal ratio (of the reversal split move) *****/
/***** ============================================================ *****/
log_ProposalRatio = logPcombine[*K - 1] - logPsplit[*K - 2] - log_Palloc - *log_dens_u;
/***** Accept/reject *****/
/***** ============= *****/
*log_AR = -(log_LikelihoodRatio + log_PriorRatio + log_ProposalRatio + log_Jacob);
if (*log_AR >= 0) *accept = 1;
else{ /** decide by sampling from the exponential distribution **/
erand = exp_rand();
*accept = (erand > -(*log_AR) ? 1 : 0);
}
/***** Update mixture values if proposal accepted *****/
/***** ========================================== *****/
// Remember that jstar < jremove (irrespective of values j1 and j2)
//
if (*accept){
/*** r: loop for component j1 ***/
rP = r; /** all observations **/
rInv1P = rInv1; /** observations from component j1 **/
rInvPrev = 0;
for (i0 = 0; i0 < *mixN1; i0++){
rP += (*rInv1P - rInvPrev);
*rP = jstar;
rInvPrev = *rInv1P;
rInv1P++;
}
/*** r: loop for component j2 ***/
rP = r; /** all observations **/
rInv2P = rInv2; /** observations from component j2 **/
rInvPrev = 0;
for (i0 = 0; i0 < *mixN2; i0++){
rP += (*rInv2P - rInvPrev);
*rP = jstar;
rInvPrev = *rInv2P;
rInv2P++;
}
/*** w: weights ***/
*wOldP = *wstar;
wOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** logw: log-weights ***/
*logwOldP = *logwstar;
logwOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** mu: means ***/
/*** Q: inverse variances ***/
/*** Sigma: variances ***/
/*** Li: Cholesky decomposition of inverse variances, must be computed ***/
muNewP = mustar;
QNewP = Qstar;
SigmaNewP = Sigmastar;
Listar = LiOldP;
for (i1 = 0; i1 < *p; i1++){
*muOldP = *muNewP;
muOldP++;
muNewP++;
for (i0 = i1; i0 < *p; i0++){
*QOldP = *QNewP;
*LiOldP = *QNewP; /* preparing to calculate Cholesky decomposition */
QOldP++;
LiOldP++;
QNewP++;
*SigmaOldP = *SigmaNewP;
SigmaOldP++;
SigmaNewP++;
}
}
F77_CALL(dpptrf)("L", p, Listar, err);
if (*err){
error("%s: Cholesky decomposition of proposed Q(star) failed.\n", fname); // this should never happen
}
muOldP += *p * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
QOldP += LTp * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
SigmaOldP += LTp * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
LiOldP += LTp * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
/*** log_dets ***/
log_detsOldP[0] = log_detsstar[0];
log_detsOldP++;
log_detsOldP += 2 * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
/*** mixN ***/
*mixNOldP = *mixNstar;
mixNOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** rInv ***/
rInvP = *rrInvOldP;
rP = r;
for (i0 = 0; i0 < *n; i0++){
if (*rP == jstar){
*rInvP = i0;
rInvP++;
}
rP++;
}
rrInvOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** Shift forward components after the removed one ***/
for (k = jremove; k < *K-1; k++){
*wOldP = *(wOldP + 1);
wOldP++;
*logwOldP = *(logwOldP + 1);
logwOldP++;
for (i1 = 0; i1 < *p; i1++){
*muOldP = *(muOldP + *p);
muOldP++;
for (i0 = i1; i0 < *p; i0++){
*QOldP = *(QOldP + LTp);
QOldP++;
*SigmaOldP = *(SigmaOldP + LTp);
SigmaOldP++;
*LiOldP = *(LiOldP + LTp);
LiOldP++;
}
}
log_detsOldP[0] = log_detsOldP[2];
log_detsOldP += 2;
*mixNOldP = *(mixNOldP + 1);
AK_Basic::copyArray(*rrInvOldP, *(rrInvOldP + 1), *mixNOldP);
mixNOldP++;
rrInvOldP++;
}
/*** K ***/
*K -= 1;
/*** order, rank ***/
NMix::orderComp(order, rank, dwork_misc, &AK_Basic::_ZERO_INT, K, mu, p);
} /*** end of if (*accept) ***/
return;
}
double rpois(double mu)
{
/* Factorial Table (0:9)! */
const double fact[10] =
{
1., 1., 2., 6., 24., 120., 720., 5040., 40320., 362880.
};
/* These are static --- persistent between calls for same mu : */
static int l, m;
static double b1, b2, c, c0, c1, c2, c3;
static double pp[36], p0, p, q, s, d, omega;
static double big_l;/* integer "w/o overflow" */
static double muprev = 0., muprev2 = 0.;/*, muold = 0.*/
/* Local Vars [initialize some for -Wall]: */
double del, difmuk= 0., E= 0., fk= 0., fx, fy, g, px, py, t, u= 0., v, x;
double pois = -1.;
int k, kflag, big_mu, new_big_mu = false;
if (!R_FINITE(mu))
ML_ERR_return_NAN;
if (mu <= 0.)
return 0.;
big_mu = mu >= 10.;
if(big_mu)
new_big_mu = false;
if (!(big_mu && mu == muprev)) {/* maybe compute new persistent par.s */
if (big_mu) {
new_big_mu = true;
/* Case A. (recalculation of s,d,l because mu has changed):
* The poisson probabilities pk exceed the discrete normal
* probabilities fk whenever k >= m(mu).
*/
muprev = mu;
s = sqrt(mu);
d = 6. * mu * mu;
big_l = FLOOR(mu - 1.1484);
/* = an upper bound to m(mu) for all mu >= 10.*/
}
else { /* Small mu ( < 10) -- not using normal approx. */
/* Case B. (start new table and calculate p0 if necessary) */
/*muprev = 0.;-* such that next time, mu != muprev ..*/
if (mu != muprev) {
muprev = mu;
m = std::max(1, (int) mu);
l = 0; /* pp[] is already ok up to pp[l] */
q = p0 = p = exp(-mu);
}
repeat {
/* Step U. uniform sample for inversion method */
u = unif_rand(BOOM::GlobalRng::rng);
if (u <= p0)
return 0.;
/* Step T. table comparison until the end pp[l] of the
pp-table of cumulative poisson probabilities
(0.458 > ~= pp[9](= 0.45792971447) for mu=10 ) */
if (l != 0) {
for (k = (u <= 0.458) ? 1 : std::min(l, m); k <= l; k++)
if (u <= pp[k])
return (double)k;
if (l == 35) /* u > pp[35] */
continue;
}
/* Step C. creation of new poisson
probabilities p[l..] and their cumulatives q =: pp[k] */
l++;
for (k = l; k <= 35; k++) {
p *= mu / k;
q += p;
pp[k] = q;
if (u <= q) {
l = k;
return (double)k;
}
}
l = 35;
} /* end(repeat) */
}/* mu < 10 */
} /* end {initialize persistent vars} */
/* Only if mu >= 10 : ----------------------- */
/* Step N. normal sample */
g = mu + s * norm_rand(BOOM::GlobalRng::rng);/* norm_rand() ~ N(0,1), standard normal */
if (g >= 0.) {
pois = FLOOR(g);
/* Step I. immediate acceptance if pois is large enough */
if (pois >= big_l)
return pois;
/* Step S. squeeze acceptance */
fk = pois;
difmuk = mu - fk;
u = unif_rand(BOOM::GlobalRng::rng); /* ~ U(0,1) - sample */
if (d * u >= difmuk * difmuk * difmuk)
return pois;
}
/* Step P. preparations for steps Q and H.
(recalculations of parameters if necessary) */
if (new_big_mu || mu != muprev2) {
/* Careful! muprev2 is not always == muprev
because one might have exited in step I or S
*/
muprev2 = mu;
omega = M_1_SQRT_2PI / s;
/* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite
* approximations to the discrete normal probabilities fk. */
b1 = one_24 / mu;
b2 = 0.3 * b1 * b1;
c3 = one_7 * b1 * b2;
c2 = b2 - 15. * c3;
c1 = b1 - 6. * b2 + 45. * c3;
c0 = 1. - b1 + 3. * b2 - 15. * c3;
c = 0.1069 / mu; /* guarantees majorization by the 'hat'-function. */
}
if (g >= 0.) {
/* 'Subroutine' F is called (kflag=0 for correct return) */
kflag = 0;
goto Step_F;
}
repeat {
/* Step E. Exponential Sample */
E = exp_rand(BOOM::GlobalRng::rng); /* ~ Exp(1) (standard exponential) */
/* sample t from the laplace 'hat'
(if t <= -0.6744 then pk < fk for all mu >= 10.) */
u = 2 * unif_rand(BOOM::GlobalRng::rng) - 1.;
t = 1.8 + fsign(E, u);
if (t > -0.6744) {
pois = FLOOR(mu + s * t);
fk = pois;
difmuk = mu - fk;
/* 'subroutine' F is called (kflag=1 for correct return) */
kflag = 1;
Step_F: /* 'subroutine' F : calculation of px,py,fx,fy. */
if (pois < 10) { /* use factorials from table fact[] */
px = -mu;
py = pow(mu, pois) / fact[(int)pois];
}
else {
/* Case pois >= 10 uses polynomial approximation
a0-a7 for accuracy when advisable */
del = one_12 / fk;
del = del * (1. - 4.8 * del * del);
v = difmuk / fk;
if (fabs(v) <= 0.25)
px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) *
v + a3) * v + a2) * v + a1) * v + a0)
- del;
else /* |v| > 1/4 */
px = fk * log(1. + v) - difmuk - del;
py = M_1_SQRT_2PI / sqrt(fk);
}
x = (0.5 - difmuk) / s;
x *= x;/* x^2 */
fx = -0.5 * x;
fy = omega * (((c3 * x + c2) * x + c1) * x + c0);
if (kflag > 0) {
/* Step H. Hat acceptance (E is repeated on rejection) */
if (c * fabs(u) <= py * exp(px + E) - fy * exp(fx + E))
break;
} else
/* Step Q. Quotient acceptance (rare case) */
if (fy - u * fy <= py * exp(px - fx))
break;
}/* t > -.67.. */
}
return pois;
}
void rextremalttbm(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *nugget, double *range,
double *smooth, double *DoF, double *uBound, int *nlines,
double *ans){
/* This function generates random fields from the Extremal-t model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
DoF: the degree of freedom
blockSize: simulated field is the maximum over blockSize ind. replicates
nlines: the number of lines used for the TBM algo
ans: the generated random field */
int i, neffSite, lagi = 1, lagj = 1;
double sill = 1 - *nugget;
const double irange = 1 / *range;
//rescale the coordinates
for (i=(*nSite * *dim);i--;)
coord[i] = coord[i] * irange;
double *lines = malloc(3 * *nlines * sizeof(double));
if ((*covmod == 3) && (*smooth == 2))
//This is the gaussian case
*covmod = 5;
//Generate lines
vandercorput(nlines, lines);
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *gp = malloc(neffSite * sizeof(double));
GetRNGstate();
for (i=*nObs;i--;){
int nKO = neffSite;
double poisson = 0;
while (nKO){
/* ------- Random rotation of the lines ----------*/
double u = unif_rand() - 0.5,
v = unif_rand() - 0.5,
w = unif_rand() - 0.5,
angle = runif(0, M_2PI),
inorm = 1 / sqrt(u * u + v * v + w * w);
u *= inorm;
v *= inorm;
w *= inorm;
rotation(lines, nlines, &u, &v, &w, &angle);
/* -------------- end of rotation ---------------*/
poisson += exp_rand();
double ipoisson = 1 / poisson,
thresh = *uBound * ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (int j=neffSite;j--;)
gp[j] = 0;
tbmcore(nSite, &neffSite, dim, covmod, grid, coord, nugget,
&sill, range, smooth, nlines, lines, gp);
nKO = neffSite;
for (int j=neffSite;j--;){
double dummy = R_pow(fmax2(0, gp[j]), *DoF) * ipoisson;
ans[j * lagj + i * lagi] = fmax2(dummy, ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
//Lastly we multiply by the normalizing constant
const double imean = M_SQRT_PI * R_pow(2, -0.5 * (*DoF - 2)) /
gammafn(0.5 * (*DoF + 1));
for (i=(neffSite * *nObs);i--;)
ans[i] *= imean;
free(lines); free(gp);
return;
}
void rextremaltcirc(int *nObs, int *ngrid, double *steps, int *dim,
int *covmod, double *nugget, double *range,
double *smooth, double *DoF, double *uBound, double *ans){
/* This function generates random fields from the Schlather model
nObs: the number of observations to be generated
ngrid: the number of locations along one axis
dim: the random field is generated in R^dim
covmod: the covariance model
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
DoF: the degree of freedom
blockSize: see rextremalttbm
ans: the generated random field */
int i, j, k = -1, nbar = R_pow_di(*ngrid, *dim), r, m;
const double zero = 0;
double *rho, *irho, sill = 1 - *nugget;
//Below is a table of highly composite numbers
int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240,
360, 720, 840, 1260, 1680, 2520, 5040, 7560,
10080, 15120, 20160, 25200, 27720, 45360, 50400,
55440, 83160, 110880, 166320, 221760, 277200,
332640, 498960, 554400, 665280, 720720, 1081080};
/* Find the smallest size m for the circulant embedding matrix */
{
int dummy = 2 * (*ngrid - 1);
do {
k++;
m = HCN[k];
} while (m < dummy);
}
/* ---------- beginning of the embedding stage ---------- */
int mbar = m * m, halfM = m / 2, notPosDef = 0;
do {
double *dist = (double *)R_alloc(mbar, sizeof(double));
notPosDef = 0;
//Computation of the distance
for (r=mbar;r--;){
i = r % m;
j = r / m;
if (i > halfM)
i -= m;
if (j > halfM)
j -= m;
dist[r] = hypot(steps[0] * i, steps[1] * j);
}
//Computations of the covariances
rho = (double *)R_alloc(mbar, sizeof(double));
irho = (double *)R_alloc(mbar, sizeof(double));
for (i=mbar;i--;)
irho[i] = 0;
switch (*covmod){
case 1:
whittleMatern(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 2:
cauchy(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 3:
powerExp(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 4:
bessel(dist, mbar, *dim, zero, sill, *range, *smooth, rho);
break;
}
/* Compute the eigen values to check if the circulant embbeding
matrix is positive definite */
/* Note : The next lines is only valid for 2d random fields. I
need to change if there are m_1 \neq m_2 as I suppose that m_1
= m_2 = m */
int maxf, maxp, *iwork;
double *work;
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, m, m, 1, -1, work, iwork);
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, 1, m, m, -1, work, iwork);
//Check if the eigenvalues are all positive
for (i=mbar;i--;){
notPosDef |= (rho[i] <= 0) || (fabs(irho[i]) > 0.001);
}
if (notPosDef){
k++;
m = HCN[k];
halfM = m / 2;
mbar = m * m;
}
if (k > 30)
error("Impossible to embbed the covariance matrix");
} while (notPosDef);
/* --------- end of the embedding stage --------- */
/* Computation of the square root of the eigenvalues */
for (i=mbar;i--;){
rho[i] = sqrt(rho[i]);
irho[i] = 0;//No imaginary part
}
int mdag = m / 2 + 1, mdagbar = mdag * mdag;
double isqrtMbar = 1 / sqrt(mbar);
double *a = malloc(mbar * sizeof(double)),
*ia = malloc(mbar * sizeof(double)),
*gp = malloc(nbar * sizeof(double));
GetRNGstate();
for (int i=*nObs;i--;){
int nKO = nbar;
double poisson = 0;
while (nKO){
poisson += exp_rand();
double ipoisson = 1 / poisson,
thresh = *uBound * ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
circcore(rho, a, ia, m, halfM, mdag, mdagbar, *ngrid, nbar, isqrtMbar, *nugget, gp);
nKO = nbar;
for (int j=nbar;j--;){
double dummy = R_pow(fmax2(gp[j], 0), *DoF) * ipoisson;
ans[j + i * nbar] = fmax2(dummy, ans[j + i * nbar]);
nKO -= (thresh <= ans[j + i * nbar]);
}
}
}
PutRNGstate();
//Lastly we multiply by the normalizing constant
const double imean = M_SQRT_PI * R_pow(2, -0.5 * (*DoF - 2)) /
gammafn(0.5 * (*DoF + 1));
for (i=(nbar * *nObs);i--;)
ans[i] *= imean;
free(a); free(ia); free(gp);
return;
}
SEXP GillespieDirectCR(SEXP pre, SEXP post, SEXP h, SEXP M, SEXP T, SEXP delta,
SEXP runs, SEXP place, SEXP transition, SEXP rho)
{
int k;
#ifdef RB_TIME
clock_t c0, c1;
c0 = clock();
#endif
// Get dimensions of pre
int *piTmp = INTEGER(getAttrib(pre, R_DimSymbol));
int iTransitions = piTmp[0], iPlaces = piTmp[1];
int *piPre = INTEGER(pre), *piPost = INTEGER(post);
SEXP sexpTmp;
int iTransition, iPlace, iTransitionPtr, iPlacePtr,
iTransition2, iTransitionPtr2;
// Find out which elements of h are doubles and which functions
SEXP sexpFunction;
PROTECT(sexpFunction = allocVector(VECSXP, iTransitions));
double *pdH = (double *) R_alloc(iTransitions, sizeof(double));
DL_FUNC *pCFunction = (DL_FUNC *) R_alloc(iTransitions, sizeof(DL_FUNC *));
int *piHzType = (int *) R_alloc(iTransitions, sizeof(int));
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
if (inherits(sexpTmp = VECTOR_ELT(h, iTransition), "NativeSymbol")) {
pCFunction[iTransition] = (void *) R_ExternalPtrAddr(sexpTmp);
piHzType[iTransition] = HZ_CFUNCTION;
} else if (isNumeric(sexpTmp)){
pdH[iTransition] = REAL(sexpTmp)[0];
piHzType[iTransition] = HZ_DOUBLE;
} else if (isFunction(sexpTmp)) {
SET_VECTOR_ELT(sexpFunction, iTransition, lang1(sexpTmp));
piHzType[iTransition] = HZ_RFUNCTION;
} else {
error("Unrecongnized transition function type\n");
}
}
// Setup Matrix S
int *piS = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Position of non zero cells in pre per transition
int *piPreNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in pre per transition
int *piPreNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));
// Position of non zero cells in S per transition
int *piSNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in S per transition
int *piSNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
int iPreNZxRow_col = 0;
int iSNZxRow_col = 0;
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
if (piPre[iTransition + iTransitions * iPlace]) {
piPreNZxRow[iTransition + iTransitions * iPreNZxRow_col++] = iPlace;
}
if ((piS[iTransition + iTransitions * iPlace] =
piPost[iTransition + iTransitions * iPlace] - piPre[iTransition + iTransitions * iPlace])) {
piSNZxRow[iTransition + iTransitions * iSNZxRow_col++] = iPlace;
}
}
piPreNZxRowTot[iTransition] = iPreNZxRow_col;
piSNZxRowTot[iTransition] = iSNZxRow_col;
}
// Position of non zero cells in pre per place
int *piPreNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in pre per place
int *piPreNZxColTot = (int *) R_alloc(iPlaces, sizeof(int));
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
int iPreNZxCol_row = 0;
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
if (piPre[iTransition + iTransitions * iPlace]) {
piPreNZxCol[iPreNZxCol_row++ + iTransitions * iPlace] = iTransition;
}
}
piPreNZxColTot[iPlace] = iPreNZxCol_row;
}
// Hazards that need to be recalculated if a given transition has happened
int *piHazardsToModxRow = (int *) R_alloc((iTransitions + 1) * iTransitions, sizeof(int));
// Totals of hazards to recalculate for each transition that has happened
int *piHazardsToModxRowTot = (int *) R_alloc(iTransitions + 1, sizeof(int));
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
int iHazardToCompTot = 0;
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
if (piS[iTransition + iTransitions * iPlace]) {
// Identify the transitions that need the hazards recalculated
for(iTransitionPtr2 = 0; iTransitionPtr2 < piPreNZxColTot[iPlace]; iTransitionPtr2++) {
iTransition2 = piPreNZxCol[iTransitionPtr2 + iTransitions * iPlace];
int iAddThis = TRUE;
for (k = 0; k < iHazardToCompTot; k++) {
if(piHazardsToModxRow[iTransition + (iTransitions + 1) * k] == iTransition2) {
iAddThis = FALSE;
break;
}
}
if (iAddThis)
piHazardsToModxRow[iTransition + (iTransitions + 1) * iHazardToCompTot++] = iTransition2;
}
}
}
piHazardsToModxRowTot[iTransition] = iHazardToCompTot;
}
// For the initial calculation of all hazards...
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
piHazardsToModxRow[iTransitions + (iTransitions + 1) * iTransition] = iTransition;
}
piHazardsToModxRowTot[iTransitions] = iTransitions;
SEXP sexpCrntMarking;
PROTECT(sexpCrntMarking = allocVector(REALSXP, iPlaces));
double *pdCrntMarking = REAL(sexpCrntMarking);
double dDelta = *REAL(delta);
int iTotalSteps, iSectionSteps;
double dT = 0;
void *pCManage_time = 0;
SEXP sexpRManage_time = 0;
if (inherits(T, "NativeSymbol")) {
pCManage_time = (void *) R_ExternalPtrAddr(T);
dT = ((double(*)(double, double *)) pCManage_time)(-1, pdCrntMarking);
} else if (isNumeric(T)){
dT = *REAL(T);
} else if (isFunction(T)) {
PROTECT(sexpRManage_time = lang1(T));
defineVar(install("y"), sexpCrntMarking, rho);
PROTECT(sexpTmp = allocVector(REALSXP, 1));
*REAL(sexpTmp) = -1;
defineVar(install("StartTime"), sexpTmp, rho);
UNPROTECT_PTR(sexpTmp);
dT = *REAL(VECTOR_ELT(eval(sexpRManage_time, rho),0));
} else {
error("Unrecognized time function type\n");
}
iTotalSteps = iSectionSteps = (int)(dT / dDelta) + 1;
int iRun, iRuns = *INTEGER(runs);
// Hazard vector
double *pdTransitionHazard = (double *) R_alloc(iTransitions, sizeof(double));
SEXP sexpRun;
PROTECT(sexpRun = allocVector(VECSXP, iRuns));
int iTotalUsedRandomNumbers = 0;
// DiscTime Vector
SEXP sexpD_time;
PROTECT(sexpD_time = allocVector(REALSXP, iTotalSteps));
double *pdDiscTime = REAL(sexpD_time);
double dTmp = 0;
for (k = 0; k < iTotalSteps; k++) {
pdDiscTime[k] = dTmp;
dTmp += dDelta;
}
SEXP sexpMarkingRowNames;
PROTECT(sexpMarkingRowNames = allocVector(INTSXP, iTotalSteps));
piTmp = INTEGER(sexpMarkingRowNames);
for (k = 0; k < iTotalSteps; k++)
piTmp[k] = k+1;
double **ppdMarking = (double **) R_alloc(iPlaces, sizeof(double *));
int iLevels = 7;
int iGroups = pow(2, iLevels - 1);
// Group holding the transitions that lie between boundaries
int **ppiGroup = (int **) R_alloc(iGroups, sizeof(int *));
// Number of transition each group has
int *piGroupElm = (int *) R_alloc(iGroups, sizeof(int));
// Total propensity hazard for each group
int *piTotGroupTransitions = (int *) R_alloc(iGroups, sizeof(int));
int *piTransitionInGroup = (int *) R_alloc(iTransitions, sizeof(int));
int *piTransitionPositionInGroup = (int *) R_alloc(iTransitions, sizeof(int));
int iGroup;
for (iGroup = 0; iGroup < iGroups; iGroup++) {
ppiGroup[iGroup] = (int *) R_alloc(iTransitions, sizeof(int));
}
node **ppnodeLevel = (node **) R_alloc(iLevels, sizeof(node *));
int iLevel, iNode;
int iNodesPerLevel = 1;
for (iLevel = 0; iLevel < iLevels; iLevel++) {
ppnodeLevel[iLevel] = (node *) R_alloc(iNodesPerLevel, sizeof(node));
iNodesPerLevel *= 2;
}
node *pnodeRoot = &ppnodeLevel[0][0];
pnodeRoot->parent = 0;
node *pnodeGroup = ppnodeLevel[iLevels-1];
iNodesPerLevel = 1;
for (iLevel = 0; iLevel < iLevels; iLevel++) {
for (iNode = 0; iNode < iNodesPerLevel; iNode++) {
if (iLevel < iLevels-1) {
ppnodeLevel[iLevel][iNode].iGroup = -1;
ppnodeLevel[iLevel][iNode].left = &ppnodeLevel[iLevel+1][iNode*2];
ppnodeLevel[iLevel][iNode].right = &ppnodeLevel[iLevel+1][iNode*2+1];
ppnodeLevel[iLevel+1][iNode*2].parent = ppnodeLevel[iLevel+1][iNode*2+1].parent =
&ppnodeLevel[iLevel][iNode];
} else {
ppnodeLevel[iLevel][iNode].iGroup = iNode;
ppnodeLevel[iLevel][iNode].left = ppnodeLevel[iLevel][iNode].right = 0;
}
}
iNodesPerLevel *= 2;
}
double dNewHazard = 0;
// Find minimum propensity
double dMinHazard = DBL_MAX;
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
switch(piHzType[iTransition]) {
case HZ_DOUBLE:
dNewHazard = pdH[iTransition];
for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr];
for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++)
dNewHazard *= (piPre[iTransition + iTransitions * iPlace] - k) / (double)(k+1);
}
if (dNewHazard > 0 && dNewHazard < dMinHazard)
dMinHazard = dNewHazard;
break;
case HZ_CFUNCTION:
break;
case HZ_RFUNCTION:
break;
}
}
GetRNGstate();
for (iRun = 0; iRun < iRuns; iRun++) {
int iUsedRandomNumbers = 0;
Rprintf("%d ", iRun+1);
// Totals for kind of transition vector
SEXP sexpTotXTransition;
PROTECT(sexpTotXTransition = allocVector(INTSXP, iTransitions));
int *piTotTransitions = INTEGER(sexpTotXTransition);
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
piTotTransitions[iTransition] = 0;
}
SEXP sexpMarking;
PROTECT(sexpMarking = allocVector(VECSXP, iPlaces));
//setAttrib(sexpMarking, R_NamesSymbol, place);
//setAttrib(sexpMarking, R_RowNamesSymbol, sexpMarkingRowNames);
//setAttrib(sexpMarking, R_ClassSymbol, ScalarString(mkChar("data.frame")));
// Setup initial state
double *pdTmp = REAL(M);
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
SET_VECTOR_ELT(sexpMarking, iPlace, sexpTmp = allocVector(REALSXP, iTotalSteps));
ppdMarking[iPlace] = REAL(sexpTmp);
pdCrntMarking[iPlace] = pdTmp[iPlace];
}
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
pdTransitionHazard[iTransition] = 0;
piTransitionInGroup[iTransition] = -1;
}
for (iGroup = 0; iGroup < iGroups; iGroup++) {
piGroupElm[iGroup] = 0;
piTotGroupTransitions[iGroup] = 0;
}
iNodesPerLevel = 1;
for (iLevel = 0; iLevel < iLevels; iLevel++) {
for (iNode = 0; iNode < iNodesPerLevel; iNode++) {
ppnodeLevel[iLevel][iNode].dPartialAcumHazard = 0;
}
iNodesPerLevel *= 2;
}
node *pnode;
double dTime = 0, dTarget = 0;
int iTotTransitions = 0;
int iStep = 0;
int iInterruptCnt = 10000000;
do {
if (pCManage_time || sexpRManage_time) {
double dEnd = 0;
if (pCManage_time) {
dEnd = ((double(*)(double, double *)) pCManage_time)(dTarget, pdCrntMarking);
} else {
defineVar(install("y"), sexpCrntMarking, rho);
PROTECT(sexpTmp = allocVector(REALSXP, 1));
*REAL(sexpTmp) = dTarget;
defineVar(install("StartTime"), sexpTmp, rho);
UNPROTECT_PTR(sexpTmp);
sexpTmp = eval(sexpRManage_time, rho);
dEnd = *REAL(VECTOR_ELT(sexpTmp,0));
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
pdCrntMarking[iPlace] = REAL(VECTOR_ELT(sexpTmp,1))[iPlace];
}
}
iSectionSteps = (int)(dEnd / dDelta) + 1;
}
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
ppdMarking[iPlace][iStep] = pdCrntMarking[iPlace];
}
dTime = dTarget;
dTarget += dDelta;
// For the calculation of all hazards...
int iLastTransition = iTransitions;
do {
// Get hazards only for the transitions associated with
// places whose quantities changed in the last step.
for(iTransitionPtr = 0; iTransitionPtr < piHazardsToModxRowTot[iLastTransition]; iTransitionPtr++) {
iTransition = piHazardsToModxRow[iLastTransition + (iTransitions + 1) * iTransitionPtr];
switch(piHzType[iTransition]) {
case HZ_DOUBLE:
dNewHazard = pdH[iTransition];
for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr];
for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++)
dNewHazard *= (pdCrntMarking[iPlace] - k) / (double)(k+1);
}
break;
case HZ_CFUNCTION:
dNewHazard = ((double(*)(double, double *)) pCFunction[iTransition])(dTime, pdCrntMarking);
break;
case HZ_RFUNCTION:
defineVar(install("y"), sexpCrntMarking, rho);
dNewHazard = REAL(eval(VECTOR_ELT(sexpFunction, iTransition), rho))[0];
break;
}
double dDeltaHazard;
frexp(dNewHazard/dMinHazard, &iGroup);
if (iGroup-- > 0) {
// Transition belongs to a group
if (iGroup == piTransitionInGroup[iTransition]) {
// Transitions will stay in same group as it was
dDeltaHazard = dNewHazard - pdTransitionHazard[iTransition];
pnode = &pnodeGroup[iGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
} else if (piTransitionInGroup[iTransition] != -1) {
// Transition was in another group and needs to be moved to the new one
int iOldGroup = piTransitionInGroup[iTransition];
int iOldPositionInGroup = piTransitionPositionInGroup[iTransition];
dDeltaHazard = -pdTransitionHazard[iTransition];
pnode = &pnodeGroup[iOldGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piGroupElm[iOldGroup]--; // Old group will have one less element
// Now, piGroupElm[iOldGroup] is the index to last transition in group
if (iOldPositionInGroup != piGroupElm[iOldGroup]) {
// Transition is not the last in group,
// put the last transition in place of the one to be removed
ppiGroup[iOldGroup][iOldPositionInGroup] =
ppiGroup[iOldGroup][piGroupElm[iOldGroup]];
// Update position of previous last transition in group
piTransitionPositionInGroup[ppiGroup[iOldGroup][iOldPositionInGroup]] =
iOldPositionInGroup;
}
dDeltaHazard = dNewHazard;
pnode = &pnodeGroup[iGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piTransitionInGroup[iTransition] = iGroup;
piTransitionPositionInGroup[iTransition] = piGroupElm[iGroup];
ppiGroup[iGroup][piGroupElm[iGroup]++] = iTransition;
} else if (piTransitionInGroup[iTransition] == -1) { // Transition was in no group
dDeltaHazard = dNewHazard;
pnode = &pnodeGroup[iGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piTransitionInGroup[iTransition] = iGroup;
piTransitionPositionInGroup[iTransition] = piGroupElm[iGroup];
ppiGroup[iGroup][piGroupElm[iGroup]++] = iTransition;
} else {
error("ERROR: Option not considered 1\n");
}
} else if (piTransitionInGroup[iTransition] != -1) {
// Transition will not belong to any group and needs to be removed from old
int iOldGroup = piTransitionInGroup[iTransition];
int iOldPositionInGroup = piTransitionPositionInGroup[iTransition];
dDeltaHazard = -pdTransitionHazard[iTransition];
pnode = &pnodeGroup[iOldGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piGroupElm[iOldGroup]--; // Old group will have one less element
// Now, piGroupElm[iOldGroup] is the index to last transition in group
if (iOldPositionInGroup != piGroupElm[iOldGroup]) {
// Transition is not the last in group,
// put the last transition in place of the one to be removed
ppiGroup[iOldGroup][iOldPositionInGroup] =
ppiGroup[iOldGroup][piGroupElm[iOldGroup]];
// Update position of previous last transition in group
piTransitionPositionInGroup[ppiGroup[iOldGroup][iOldPositionInGroup]] =
iOldPositionInGroup;
}
piTransitionInGroup[iTransition] = -1;
}
pdTransitionHazard[iTransition] = dNewHazard;
}
// Get Time to transition
dTime += exp_rand() / pnodeRoot->dPartialAcumHazard;
iUsedRandomNumbers++;
while (dTime >= dTarget) {
++iStep;
// Update the state for the fixed incremented time.
for(iPlace = 0; iPlace < iPlaces; iPlace++)
ppdMarking[iPlace][iStep] = pdCrntMarking[iPlace];
if (iStep == iSectionSteps - 1)
goto EXIT_LOOP;
dTarget += dDelta;
// Force check if user interrupted
iInterruptCnt = 1;
}
if (! --iInterruptCnt) {
// Allow user interruption
R_CheckUserInterrupt();
iInterruptCnt = 10000000;
}
do {
// Find group containing firing transition
double dRnd = unif_rand() * pnodeRoot->dPartialAcumHazard;
iUsedRandomNumbers++;
pnode = pnodeRoot;
do {
if (dRnd < pnode->left->dPartialAcumHazard) {
pnode = pnode->left;
} else {
dRnd -= pnode->left->dPartialAcumHazard;
pnode = pnode->right;
}
} while (pnode->left);
// Next check is because
// once in a while it is generated a number that goes past
// the last group or selects a group with zero elements
// due to accumulated truncation errors.
// Discard this random number and try again.
} while (piGroupElm[iGroup = pnode->iGroup] == 0);
double dMaxInGroup = dMinHazard * pow(2, iGroup + 1);
// Find transition in group
while (1) {
if (! --iInterruptCnt) {
// Allow user interruption
R_CheckUserInterrupt();
iInterruptCnt = 10000000;
}
iTransitionPtr = (int) (unif_rand() * piGroupElm[iGroup]);
iUsedRandomNumbers++;
iTransition = ppiGroup[iGroup][iTransitionPtr];
iUsedRandomNumbers++;
if (pdTransitionHazard[iTransition] > unif_rand() * dMaxInGroup) {
piTotTransitions[iLastTransition = iTransition]++;
for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
// Update the state
pdCrntMarking[iPlace] += piS[iTransition + iTransitions * iPlace];
}
break;
}
}
++iTotTransitions;
} while (TRUE);
EXIT_LOOP:;
Rprintf(".");
} while (iSectionSteps < iTotalSteps);
iTotalUsedRandomNumbers += iUsedRandomNumbers;
Rprintf("\t%d\t%d\t%d", iTotTransitions, iUsedRandomNumbers, iTotalUsedRandomNumbers);
#ifdef RB_SUBTIME
c1 = clock();
Rprintf ("\t To go: ");
PrintfTime((double) (c1 - c0)/CLOCKS_PER_SEC/(iRun+1)*(iRuns-iRun-1));
#endif
Rprintf ("\n");
SEXP sexpTotTransitions;
PROTECT(sexpTotTransitions = allocVector(INTSXP, 1));
INTEGER(sexpTotTransitions)[0] = iTotTransitions;
SEXP sexpThisRun;
PROTECT(sexpThisRun = allocVector(VECSXP, 3));
SET_VECTOR_ELT(sexpThisRun, 0, sexpMarking);
UNPROTECT_PTR(sexpMarking);
SET_VECTOR_ELT(sexpThisRun, 1, sexpTotXTransition);
UNPROTECT_PTR(sexpTotXTransition);
SET_VECTOR_ELT(sexpThisRun, 2, sexpTotTransitions);
UNPROTECT_PTR(sexpTotTransitions);
SEXP sexpNames;
PROTECT(sexpNames = allocVector(VECSXP, 3));
SET_VECTOR_ELT(sexpNames, 0, mkChar("M"));
SET_VECTOR_ELT(sexpNames, 1, mkChar("transitions"));
SET_VECTOR_ELT(sexpNames, 2, mkChar("tot.transitions"));
setAttrib(sexpThisRun, R_NamesSymbol, sexpNames);
UNPROTECT_PTR(sexpNames);
SET_VECTOR_ELT(sexpRun, iRun, sexpThisRun);
UNPROTECT_PTR(sexpThisRun);
}
PutRNGstate();
SEXP sexpAns;
PROTECT(sexpAns = allocVector(VECSXP, 4));
SET_VECTOR_ELT(sexpAns, 0, place);
SET_VECTOR_ELT(sexpAns, 1, transition);
SET_VECTOR_ELT(sexpAns, 2, sexpD_time);
UNPROTECT_PTR(sexpD_time);
SET_VECTOR_ELT(sexpAns, 3, sexpRun);
UNPROTECT_PTR(sexpRun);
SEXP sexpNames;
PROTECT(sexpNames = allocVector(VECSXP, 4));
SET_VECTOR_ELT(sexpNames, 0, mkChar("place"));
SET_VECTOR_ELT(sexpNames, 1, mkChar("transition"));
SET_VECTOR_ELT(sexpNames, 2, mkChar("dt"));
SET_VECTOR_ELT(sexpNames, 3, mkChar("run"));
setAttrib(sexpAns, R_NamesSymbol, sexpNames);
UNPROTECT_PTR(sexpNames);
#ifdef RB_TIME
c1 = clock();
double dCpuTime = (double) (c1 - c0)/CLOCKS_PER_SEC;
Rprintf ("Elapsed CPU time: ");
PrintfTime(dCpuTime);
Rprintf ("\t(%fs)\n", dCpuTime);
#endif
if (sexpRManage_time)
UNPROTECT_PTR(sexpRManage_time);
UNPROTECT_PTR(sexpFunction);
UNPROTECT_PTR(sexpMarkingRowNames);
UNPROTECT_PTR(sexpCrntMarking);
UNPROTECT_PTR(sexpAns);
return(sexpAns);
}
void rgeomdirect(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *sigma2, double *nugget,
double *range, double *smooth, double *uBound,
double *ans){
/* This function generates random fields for the geometric model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
sigma2: the variance of the geometric gaussian process
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
ans: the generated random field */
int i, j, neffSite, lagi = 1, lagj = 1, oneInt = 1;
const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2;
double sigma = sqrt(*sigma2), sill = 1 - *nugget;
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *covmat = malloc(neffSite * neffSite * sizeof(double)),
*gp = malloc(neffSite * sizeof(double));
buildcovmat(nSite, grid, covmod, coord, dim, nugget, &sill, range,
smooth, covmat);
/* Compute the Cholesky decomposition of the covariance matrix */
int info = 0;
F77_CALL(dpotrf)("U", &neffSite, covmat, &neffSite, &info);
if (info != 0)
error("error code %d from Lapack routine '%s'", info, "dpotrf");
GetRNGstate();
for (i=*nObs;i--;){
double poisson = 0;
int nKO = neffSite;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
poisson += exp_rand();
double ipoisson = -log(poisson), thresh = loguBound + ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (j=neffSite;j--;)
gp[j] = norm_rand();
F77_CALL(dtrmv)("U", "T", "N", &neffSite, covmat, &neffSite, gp, &oneInt);
nKO = neffSite;
double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2;
for (j=neffSite;j--;){
ans[j * lagj + i * lagi] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2,
ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
/* So fare we generate a max-stable process with standard Gumbel
margins. Switch to unit Frechet ones */
for (i=*nObs * neffSite;i--;)
ans[i] = exp(ans[i]);
free(covmat); free(gp);
return;
}
void stateDRR::initSimulation(float M)
{
std::queue<events *> eq;
r = M/(NUM_SOURCES - 1);
//SEED VALUE variation
srand48(SEED);
this->clock = 0;
this->totalArrival = 0;
this->currentPackets = 0;
this->packetid.reserve(NUM_SOURCES);
this->lastArrival.reserve(NUM_SOURCES);
this->sourceStats.reserve(NUM_SOURCES);
this->deficit.reserve(NUM_SOURCES);
this->flows.reserve(NUM_SOURCES);
/* clear globalstats */
this->globalStats.totalPackets = 0;
this->globalStats.totalSize = 0;
this->globalStats.lastDeparture = 0;
this->globalStats.totalResponse = 0;
this->globalStats.totalWait = 0;
for(int i=0;i<NUM_SOURCES;i++) {
flows.push_back(queue<events *>());
this->deficit[i] = 0; //set to zero and later check for (deficit[i]+Q)
this->packetid[i]=1;
this->lastArrival[i] = 0;
this->sourceStats[i].M = M;
this->sourceStats[i].totalPackets = 1;
this->sourceStats[i].totalResponse = 0;
this->sourceStats[i].totalWait = 0;
this->sourceStats[i].responseSqr = 0;
this->sourceStats[i].waitSqr = 0;
this->sourceStats[i].totalSize = 0;
this->sourceStats[i].lastDeparture = 0;
events *newEvent = new events(PKT_ARRIVE, i, this->packetid[i], 0, 0);
switch(i) {
case TELNET1:
case TELNET2:
case TELNET3:
case TELNET4:
newEvent->packetSize = exp_rand(L_TELNET);
break;
case FTP1:
case FTP2:
case FTP3:
case FTP4:
case FTP5:
case FTP6:
newEvent->packetSize = exp_rand(L_FTP);
break;
case ROGUE:
newEvent->packetSize = L_ROGUE;
break;
}
newEvent->eventTime = 0;
newEvent->arrivalTime = newEvent->eventTime;
newEvent->departureTime = INVAL;
/* Update stats */
this->totalArrival++;
this->eventQueue.push(newEvent);
#ifdef DEBUG
cout<<"+("<<newEvent->type<<", "<<newEvent->sourceId<<", "<<newEvent->packetId<<", "<<newEvent->packetSize<<")";
#endif
}
}
void rgeomcirc(int *nObs, int *ngrid, double *steps, int *dim,
int *covmod, double *sigma2, double *nugget, double *range,
double *smooth, double *uBound, double *ans){
/* This function generates random fields from the geometric model
nObs: the number of observations to be generated
ngrid: the number of locations along one axis
dim: the random field is generated in R^dim
covmod: the covariance model
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
uBound: the uniform upper bound for the stoch. proc.
ans: the generated random field */
int i, j, k = -1, nbar = R_pow_di(*ngrid, *dim), r, m;
const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2,
zero = 0;
double sigma = sqrt(*sigma2), sill = 1 - *nugget, *rho, *irho, *dist;
//Below is a table of highly composite numbers
int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240,
360, 720, 840, 1260, 1680, 2520, 5040, 7560,
10080, 15120, 20160, 25200, 27720, 45360, 50400,
55440, 83160, 110880, 166320, 221760, 277200,
332640, 498960, 554400, 665280, 720720, 1081080};
/* Find the smallest size m for the circulant embedding matrix */
{
int dummy = 2 * (*ngrid - 1);
do {
k++;
m = HCN[k];
} while (m < dummy);
}
/* ---------- beginning of the embedding stage ---------- */
int mbar = m * m, halfM = m / 2, notPosDef = 0;
do {
dist = (double *)R_alloc(mbar, sizeof(double));
notPosDef = 0;
//Computation of the distance
for (r=mbar;r--;){
i = r % m;
j = r / m;
if (i > halfM)
i -= m;
if (j > halfM)
j -= m;
dist[r] = hypot(steps[0] * i, steps[1] * j);
}
//Computations of the covariances
rho = (double *)R_alloc(mbar, sizeof(double));
irho = (double *)R_alloc(mbar, sizeof(double));
for (i=mbar;i--;)
irho[i] = 0;
switch (*covmod){
case 1:
whittleMatern(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 2:
cauchy(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 3:
powerExp(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 4:
bessel(dist, mbar, *dim, zero, sill, *range, *smooth, rho);
break;
}
/* Compute the eigen values to check if the circulant embbeding
matrix is positive definite */
/* Note : The next lines is only valid for 2d random fields. I
need to change if there are m_1 \neq m_2 as I suppose that m_1
= m_2 = m */
int maxf, maxp;
fft_factor(m, &maxf, &maxp);
double *work = (double *)R_alloc(4 * maxf, sizeof(double));
int *iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, m, m, 1, -1, work, iwork);
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, 1, m, m, -1, work, iwork);
//Check if the eigenvalues are all positive
for (i=mbar;i--;){
notPosDef |= (rho[i] <= 0) || (fabs(irho[i]) > 0.001);
}
if (notPosDef){
k++;
m = HCN[k];
halfM = m / 2;
mbar = m * m;
}
if (k > 30)
error("Impossible to embbed the covariance matrix");
} while (notPosDef);
/* --------- end of the embedding stage --------- */
/* Computation of the square root of the eigenvalues */
for (i=mbar;i--;){
rho[i] = sqrt(rho[i]);
irho[i] = 0;//No imaginary part
}
int mdag = m / 2 + 1, mdagbar = mdag * mdag;
double isqrtMbar = 1 / sqrt(mbar);
double *a = (double *)R_alloc(mbar, sizeof(double));
double *ia = (double *)R_alloc(mbar, sizeof(double));
GetRNGstate();
for (i=*nObs;i--;){
int nKO = nbar;
double poisson = 0;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
int j;
double *gp = (double *)R_alloc(nbar, sizeof(double));
poisson += exp_rand();
double ipoisson = -log(poisson), thresh = loguBound + ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
circcore(rho, a, ia, m, halfM, mdag, mdagbar, *ngrid, nbar, isqrtMbar, *nugget, gp);
nKO = nbar;
double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2;
for (j=nbar;j--;){
ans[j + i * nbar] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2,
ans[j + i * nbar]);
nKO -= (thresh <= ans[j + i * nbar]);
}
}
}
PutRNGstate();
/* So fare we generate a max-stable process with standard Gumbel
margins. Switch to unit Frechet ones */
for (i=*nObs * nbar;i--;)
ans[i] = exp(ans[i]);
return;
}
double rgeom(double p)
{
if (!R_FINITE(p) || p <= 0 || p > 1) ML_ERR_return_NAN;
return rpois(exp_rand() * ((1 - p) / p));
}
double rgamma(double a, double scale, JRNG *rng)
{
/* Constants : */
const static double sqrt32 = 5.656854;
const static double exp_m1 = 0.36787944117144232159;/* exp(-1) = 1/e */
/* Coefficients q[k] - for q0 = sum(q[k]*a^(-k))
* Coefficients a[k] - for q = q0+(t*t/2)*sum(a[k]*v^k)
* Coefficients e[k] - for exp(q)-1 = sum(e[k]*q^k)
*/
const static double q1 = 0.04166669;
const static double q2 = 0.02083148;
const static double q3 = 0.00801191;
const static double q4 = 0.00144121;
const static double q5 = -7.388e-5;
const static double q6 = 2.4511e-4;
const static double q7 = 2.424e-4;
const static double a1 = 0.3333333;
const static double a2 = -0.250003;
const static double a3 = 0.2000062;
const static double a4 = -0.1662921;
const static double a5 = 0.1423657;
const static double a6 = -0.1367177;
const static double a7 = 0.1233795;
/* State variables [FIXME for threading!] :*/
static double aa = 0.;
static double aaa = 0.;
static double s, s2, d; /* no. 1 (step 1) */
static double q0, b, si, c;/* no. 2 (step 4) */
double e, p, q, r, t, u, v, w, x, ret_val;
if (!R_FINITE(a) || !R_FINITE(scale) || a < 0.0 || scale <= 0.0) {
if(scale == 0.) return 0.;
ML_ERR_return_NAN;
}
if (a < 1.) { /* GS algorithm for parameters a < 1 */
if(a == 0)
return 0.;
e = 1.0 + exp_m1 * a;
repeat {
p = e * unif_rand(rng);
if (p >= 1.0) {
x = -log((e - p) / a);
if (exp_rand(rng) >= (1.0 - a) * log(x))
break;
} else {
x = exp(log(p) / a);
if (exp_rand(rng) >= x)
break;
}
}
return scale * x;
}
/* --- a >= 1 : GD algorithm --- */
/* Step 1: Recalculations of s2, s, d if a has changed */
if (a != aa) {
aa = a;
s2 = a - 0.5;
s = sqrt(s2);
d = sqrt32 - s * 12.0;
}
/* Step 2: t = standard normal deviate,
x = (s,1/2) -normal deviate. */
/* immediate acceptance (i) */
t = norm_rand(rng);
x = s + 0.5 * t;
ret_val = x * x;
if (t >= 0.0)
return scale * ret_val;
/* Step 3: u = 0,1 - uniform sample. squeeze acceptance (s) */
u = unif_rand(rng);
if (d * u <= t * t * t)
return scale * ret_val;
/* Step 4: recalculations of q0, b, si, c if necessary */
if (a != aaa) {
aaa = a;
r = 1.0 / a;
q0 = ((((((q7 * r + q6) * r + q5) * r + q4) * r + q3) * r
+ q2) * r + q1) * r;
/* Approximation depending on size of parameter a */
/* The constants in the expressions for b, si and c */
/* were established by numerical experiments */
if (a <= 3.686) {
b = 0.463 + s + 0.178 * s2;
si = 1.235;
c = 0.195 / s - 0.079 + 0.16 * s;
} else if (a <= 13.022) {
b = 1.654 + 0.0076 * s2;
si = 1.68 / s + 0.275;
c = 0.062 / s + 0.024;
} else {
b = 1.77;
si = 0.75;
c = 0.1515 / s;
}
}
/* Step 5: no quotient test if x not positive */
if (x > 0.0) {
/* Step 6: calculation of v and quotient q */
v = t / (s + s);
if (fabs(v) <= 0.25)
q = q0 + 0.5 * t * t * ((((((a7 * v + a6) * v + a5) * v + a4) * v
+ a3) * v + a2) * v + a1) * v;
else
q = q0 - s * t + 0.25 * t * t + (s2 + s2) * log(1.0 + v);
/* Step 7: quotient acceptance (q) */
if (log(1.0 - u) <= q)
return scale * ret_val;
}
repeat {
/* Step 8: e = standard exponential deviate
* u = 0,1 -uniform deviate
* t = (b,si)-double exponential (laplace) sample */
e = exp_rand(rng);
u = unif_rand(rng);
u = u + u - 1.0;
if (u < 0.0)
t = b - si * e;
else
t = b + si * e;
/* Step 9: rejection if t < tau(1) = -0.71874483771719 */
if (t >= -0.71874483771719) {
/* Step 10: calculation of v and quotient q */
v = t / (s + s);
if (fabs(v) <= 0.25)
q = q0 + 0.5 * t * t *
((((((a7 * v + a6) * v + a5) * v + a4) * v + a3) * v
+ a2) * v + a1) * v;
else
q = q0 - s * t + 0.25 * t * t + (s2 + s2) * log(1.0 + v);
/* Step 11: hat acceptance (h) */
/* (if q not positive go to step 8) */
if (q > 0.0) {
w = expm1(q);
/* ^^^^^ original code had approximation with rel.err < 2e-7 */
/* if t is rejected sample again at step 8 */
if (c * fabs(u) <= w * exp(e - 0.5 * t * t))
break;
}
}
} /* repeat .. until `t' is accepted */
x = s + 0.5 * t;
return scale * x * x;
}
double rgeom_mt(BOOM::RNG & rng, double p)
{
if (ISNAN(p) || p <= 0 || p > 1) ML_ERR_return_NAN;
return rpois_mt(rng, exp_rand(rng) * ((1 - p) / p));
}
/***** ***************************************************************************************** *****/
void
RJMCMCdeath(int* accept, double* log_AR,
int* K, double* w, double* logw, double* mu,
double* Q, double* Li, double* Sigma, double* log_dets,
int* order, int* rank, int* mixN,
int* jempty, int* err,
const int* p, const int* n,
const int* Kmax, const double* logK, const double* log_lambda, const int* priorK,
const double* logPbirth, const double* logPdeath, const double* delta)
{
//const char *fname = "NMix::RJMCMCdeath";
*err = 0;
*accept = 0;
/*** Some variables ***/
static int j, i1, i0, jstar, LTp;
static int Nempty;
static double one_wstar, log_one_wstar, erand;
/*** Some pointers ***/
static double *wstar, *logwstar;
static int *mixNP, *jemptyP;
static double *wP, *logwP, *muP, *QP, *LiP, *SigmaP, *log_detsP;
static const double *muPnext, *QPnext, *LiPnext, *SigmaPnext;
if (*K == 1){
*log_AR = R_NegInf;
return;
}
LTp = (*p * (*p + 1))/2;
/***** Compute the number of empty components and store their indeces *****/
/***** ============================================================== *****/
Nempty = 0;
jemptyP = jempty;
mixNP = mixN;
for (j = 0; j < *K; j++){
if (*mixNP == 0){
Nempty++;
*jemptyP = j;
jemptyP++;
}
mixNP++;
}
/***** Directly reject the death move if there are no empty components *****/
/***** =============================================================== *****/
if (Nempty == 0){
*log_AR = R_NegInf;
return;
}
/***** Choose at random one of empty components *****/
/***** ======================================== *****/
j = (int)(floor(unif_rand() * Nempty));
if (j == Nempty) j = Nempty - 1; // this row is needed with theoretical probability 0 (in cases when unif_rand() returns 1)
jstar = jempty[j];
/***** Log-acceptance ratio *****/
/***** ==================== *****/
wstar = w + jstar;
logwstar = logw + jstar;
one_wstar = 1 - *wstar;
log_one_wstar = AK_Basic::log_AK(one_wstar);
// *log_AR = -(logPdeath[*K - 1] - logPbirth[*K - 2] - AK_Basic::log_AK((double)(Nempty)) + lbeta(1, *K - 1) - lbeta(*delta, (*K - 1) * *delta)
// + (*delta - 1) * *logwstar + (*n + (*K - 1) * (*delta - 1) + 1) * log_one_wstar); // this is according to the original paper Richardson and Green (1997)
*log_AR = -(logPdeath[*K - 1] - logPbirth[*K - 2] - AK_Basic::log_AK((double)(Nempty)) + lbeta(1, *K - 1) - lbeta(*delta, (*K - 1) * *delta)
+ (*delta - 1) * *logwstar + (*n + (*K - 1) * (*delta - 1)) * log_one_wstar); // this is according to Corrigendum in JRSS, B (1998), p. 661
/***** log-ratio of priors on K (+ factor comming from the equivalent ways that the components can produce the same likelihood) *****/
switch (*priorK){
case NMix::K_FIXED:
case NMix::K_UNIF: /*** K * (p(K)/p(K-1)) = K ***/
*log_AR -= logK[*K - 1];
break;
case NMix::K_TPOISS: /*** K * (p(K)/p(K-1)) = K * (lambda/K) = lambda ***/
*log_AR -= *log_lambda;
break;
}
/***** Accept/reject *****/
/***** ============= *****/
if (*log_AR >= 0) *accept = 1;
else{ /** decide by sampling from the exponential distribution **/
erand = exp_rand();
*accept = (erand > -(*log_AR) ? 1 : 0);
}
/***** Update mixture values if proposal accepted *****/
/***** ========================================== *****/
if (*accept){
/***** Adjustment of the weights and their shift, new log-weights *****/
wP = w;
logwP = logw;
j = 0;
while (j < jstar){
*logwP -= log_one_wstar;
*wP = AK_Basic::exp_AK(*logwP);
wP++;
logwP++;
j++;
}
while (j < *K - 1){
*logwP = *(logwP + 1) - log_one_wstar;
*wP = AK_Basic::exp_AK(*logwP);
wP++;
logwP++;
j++;
}
/***** Mixture means, inverse variances, their Cholesky decompositions, variances, log_dets -> must be shifted *****/
/***** mixN -> must be shifted *****/
mixNP = mixN + jstar;
muP = mu + jstar * *p;
QP = Q + jstar * LTp;
LiP = Li + jstar * LTp;
SigmaP = Sigma + jstar * LTp;
log_detsP = log_dets + jstar * 2;
muPnext = muP + *p;
QPnext = QP + LTp;
LiPnext = LiP + LTp;
SigmaPnext = SigmaP + LTp;
for (j = jstar; j < *K - 1; j++){
*mixNP = *(mixNP + 1);
mixNP++;
*log_detsP = *(log_detsP + 2);
log_detsP += 2;
for (i1 = 0; i1 < *p; i1++){
*muP = *muPnext;
muP++;
muPnext++;
for (i0 = i1; i0 < *p; i0++){
*QP = *QPnext;
QP++;
QPnext++;
*LiP = *LiPnext;
LiP++;
LiPnext++;
*SigmaP = *SigmaPnext;
SigmaP++;
SigmaPnext++;
}
}
}
/***** order, rank *****/
NMix::orderComp_remove(order, rank, &jstar, K);
/***** K *****/
*K -= 1;
}
return;
}
