void binomial_rmeasure (double *y, double *x, double *p,
int *obsindex, int *stateindex, int *parindex, int *covindex,
int ncovars, double *covars, double t)
{
double ppa = (SPA);
double ppj = (SPJ);
DRECA = rbinom(DPOPA,ppa);
DRECJ = rbinom(DPOPJ,ppj);
}
void ran_multinomial (int K, int N, double p, int n)
{
size_t k;
double norm = 0.0;
double sum_p = 0.0;
unsigned int sum_n = 0;
/* p[k] may contain non-negative weights that do not sum to 1.0.
* Even a probability distribution will not exactly sum to 1.0
* due to rounding errors.
*/
for (k = 0; k < K; k++)
{
norm += p[k];
}
for (k = 0; k < K; k++)
{
if (p[k] > 0.0)
{
n[k] = rbinom(N - sum_n , p[k] / (norm - sum_p));
}
else
{
n[k] = 0;
}
sum_p += p[k];
sum_n += n[k];
}
}
/* ~~~~~~~*~*~~~ NEW CODE / MULTINOMIAL IMPLEMENTATION BEGINS HERE ~*~*~*~~~~~~~~ */
void ran_multinomial (int K, int N,
double *probs, int *coeffs)
{
int k;
double norm = 0.0;
double sum_p = 0.0;
int sum_n = 0;
/*GetRNGstate();*/
/* p[k] may contain non-negative weights that do not sum to 1.0.
* Even a probability distribution will not exactly sum to 1.0
* due to rounding errors.
*/
for (k = 0; k < K; k++)
{
norm += probs[k];
}
for (k = 0; k < K; k++)
{
if (probs[k] > 0.0)
{
/*coeffs[k] = 10;*/
coeffs[k] = rbinom(N - sum_n, probs[k] / (norm - sum_p));
}
else
{
coeffs[k] = 0;
}
sum_p += probs[k];
sum_n += coeffs[k];
}
/*PutRNGstate();*/
}
int rmultinom(const double p_trans[], int numTrans, boost::mt19937& rng)
{
double sumTrans = 0;
int ageAtDeath = numTrans - 1;
for(int i = 0; i < numTrans; i++) {
sumTrans += p_trans[i];
}
int numLeaving = 1;
// Implement multinomial through binom iterations
numTrans -= 1;
for(int k = 0; k < numTrans; k++) {
if(numLeaving == 1) {
double tmp;
if(p_trans[k] > sumTrans) {
sumTrans = p_trans[k];
}
tmp = ((numLeaving > 0) && (sumTrans > 0)) ? rbinom(numLeaving, p_trans[k] / sumTrans, rng) : 0;
numLeaving -= (int)tmp;
if(numLeaving == 0) {
ageAtDeath = k;
}
sumTrans -= p_trans[k];
} // end while numLeaving == 1
} // end for k in numTrans
return ageAtDeath;
}
//' Samples from the Antoniak distribution
//'
//' It's done by sampling \eqn{N} Bernoulli variables
//'
//' References:
//'
//' http://www.jmlr.org/papers/volume10/newman09a/newman09a.pdf
//'
//' @param N Number of samples
//' @param alpha strength parameter
//'
//' @export
//'
//' @family utils
//'
//' @note
//'
//' Created on: May 19, 2016
//'
//' Created by: Clint P. George
//'
// [[Rcpp::export]]
double sample_antoniak(unsigned int N, double alpha){
vec bs = zeros<vec>(N);
for (unsigned int l = 0; l < N; l++){
bs(l) = rbinom(1, 1, (alpha / (alpha + l)))(0);
}
return sum(bs);
}
void rmultinom(int n, double* prob, int K, int* rN)
/* `Return' vector rN[1:K] {K := length(prob)}
* where rN[j] ~ Bin(n, prob[j]) , sum_j rN[j] == n, sum_j prob[j] == 1,
*/
{
int k;
double pp;
LDOUBLE p_tot = 0.;
/* This calculation is sensitive to exact values, so we try to
ensure that the calculations are as accurate as possible
so different platforms are more likely to give the same
result. */
#ifdef MATHLIB_STANDALONE
if (K < 1) {
ML_ERROR(ME_DOMAIN, "rmultinom");
return;
}
if (n < 0) ML_ERR_ret_NAN(0);
#else
if (K == NA_INTEGER || K < 1) {
ML_ERROR(ME_DOMAIN, "rmultinom");
return;
}
if (n == NA_INTEGER || n < 0) ML_ERR_ret_NAN(0);
#endif
/* Note: prob[K] is only used here for checking sum_k prob[k] = 1 ;
* Could make loop one shorter and drop that check !
*/
for(k = 0; k < K; k++) {
pp = prob[k];
if (!R_FINITE(pp) || pp < 0. || pp > 1.) ML_ERR_ret_NAN(k);
p_tot += pp;
rN[k] = 0;
}
if(fabs((double)(p_tot - 1.)) > 1e-7)
MATHLIB_ERROR(_("rbinom: probability sum should be 1, but is %g"),
(double) p_tot);
if (n == 0) return;
if (K == 1 && p_tot == 0.) return;/* trivial border case: do as rbinom */
/* Generate the first K-1 obs. via binomials */
for(k = 0; k < K-1; k++) { /* (p_tot, n) are for "remaining binomial" */
if(prob[k]) {
pp = (double)(prob[k] / p_tot);
/* printf("[%d] %.17f\n", k+1, pp); */
rN[k] = ((pp < 1.) ? (int) rbinom((double) n, pp) :
/*>= 1; > 1 happens because of rounding */
n);
n -= rN[k];
}
else rN[k] = 0;
if(n <= 0) /* we have all*/ return;
p_tot -= prob[k]; /* i.e. = sum(prob[(k+1):K]) */
}
rN[K-1] = n;
return;
}
// Ricker model with log-normal process noise
static void _blowfly_simulator (double *x, const double *p,
const int *stateindex, const int *parindex, const int *covindex,
int covdim, const double *covar,
double t, double dt, int tau)
{
double e = rgammawn(SIGMAP,dt)/dt;
double eps = rgammawn(SIGMAD,dt)/dt;
int k;
R = rpois(P*N[tau]*exp(-N[tau]/N0)*dt*e);
S = rbinom(N[0],exp(-DELTA*dt*eps));
E = e;
EPS = eps;
for (k = tau; k > 0; k--) N[k] = N[k-1];
N[0] = R+S;
}
Vector SSLM::simulate_forecast(const Matrix &forecast_predictors,
const Vector &trials,
const Vector &final_state) {
StateSpaceModelBase::set_state_model_behavior(StateModel::MARGINAL);
Vector ans(nrow(forecast_predictors));
Vector state = final_state;
int t0 = dat().size();
for (int t = 0; t < ans.size(); ++t) {
state = simulate_next_state(state, t + t0);
double eta = observation_matrix(t + t0).dot(state)
+ observation_model_->predict(forecast_predictors.row(t));
double probability = plogis(eta);
ans[t] = rbinom(lround(trials[t]), probability);
}
return ans;
}
HHRESULT CGaussianMDP::sample_alpha
(
double par1,
double par2,
int n,
int k,
double &alpha
)
{
double b,odds,prob;
int ind;
HHRESULT hr = HH_OK;
b = rbeta(alpha+1,n);
odds = (par1+k-1)/(n*(par2-log(b)));
prob = odds/(odds+1);
ind = (int)rbinom(1,prob);
alpha = ind * rgamma2(par1+k, (par2-log(b))) +
(1-ind) * rgamma2(par1+k-1, (par2-log(b)));
return hr;
}
// This function updates array of # individuals making each transition (for >2 transitions, i.e., multinomial)
void rmultinom(const double p_trans[], const int numTrials, int numTrans, int numEachTrans[], boost::mt19937& rng)
{
double sumTrans = 0;
for(int i = 0; i < numTrans; i++) {
sumTrans += p_trans[i];
}
int numLeaving = numTrials;
// Implement multinomial through binom iterations
numTrans -= 1;
for(int k = 0; k < numTrans; k++) {
double tmp;
if(p_trans[k] > sumTrans) {
sumTrans = p_trans[k];
}
tmp = ((numLeaving > 0) && (sumTrans > 0)) ? rbinom(numLeaving, p_trans[k] / sumTrans, rng) : 0;
numEachTrans[k] = (int)tmp;
numLeaving -= numEachTrans[k];
sumTrans -= p_trans[k];
}
numEachTrans[numTrans] = numLeaving;
}
// rhyper(NR, NB, n) -- NR 'red', NB 'blue', n drawn, how many are 'red'
double rhyper(double nn1in, double nn2in, double kkin)
{
/* extern double afc(int); */
int nn1, nn2, kk;
int ix; // return value (coerced to double at the very end)
Rboolean setup1, setup2;
/* These should become 'thread_local globals' : */
static int ks = -1, n1s = -1, n2s = -1;
static int m, minjx, maxjx;
static int k, n1, n2; // <- not allowing larger integer par
static double tn;
// II :
static double w;
// III:
static double a, d, s, xl, xr, kl, kr, lamdl, lamdr, p1, p2, p3;
/* check parameter validity */
if(!R_FINITE(nn1in) || !R_FINITE(nn2in) || !R_FINITE(kkin))
ML_ERR_return_NAN;
nn1in = R_forceint(nn1in);
nn2in = R_forceint(nn2in);
kkin = R_forceint(kkin);
if (nn1in < 0 || nn2in < 0 || kkin < 0 || kkin > nn1in + nn2in)
ML_ERR_return_NAN;
if (nn1in >= INT_MAX || nn2in >= INT_MAX || kkin >= INT_MAX) {
/* large n -- evade integer overflow (and inappropriate algorithms)
-------- */
// FIXME: Much faster to give rbinom() approx when appropriate; -> see Kuensch(1989)
// Johnson, Kotz,.. p.258 (top) mention the *four* different binomial approximations
if(kkin == 1.) { // Bernoulli
return rbinom(kkin, nn1in / (nn1in + nn2in));
}
// Slow, but safe: return F^{-1}(U) where F(.) = phyper(.) and U ~ U[0,1]
return qhyper(unif_rand(), nn1in, nn2in, kkin, FALSE, FALSE);
}
nn1 = (int)nn1in;
nn2 = (int)nn2in;
kk = (int)kkin;
/* if new parameter values, initialize */
if (nn1 != n1s || nn2 != n2s) {
setup1 = TRUE; setup2 = TRUE;
} else if (kk != ks) {
setup1 = FALSE; setup2 = TRUE;
} else {
setup1 = FALSE; setup2 = FALSE;
}
if (setup1) {
n1s = nn1;
n2s = nn2;
tn = nn1 + nn2;
if (nn1 <= nn2) {
n1 = nn1;
n2 = nn2;
} else {
n1 = nn2;
n2 = nn1;
}
}
if (setup2) {
ks = kk;
if (kk + kk >= tn) {
k = (int)(tn - kk);
} else {
k = kk;
}
}
if (setup1 || setup2) {
m = (int) ((k + 1.) * (n1 + 1.) / (tn + 2.));
minjx = imax2(0, k - n2);
maxjx = imin2(n1, k);
#ifdef DEBUG_rhyper
REprintf("rhyper(nn1=%d, nn2=%d, kk=%d), setup: floor(mean)= m=%d, jx in (%d..%d)\n",
nn1, nn2, kk, m, minjx, maxjx);
#endif
}
/* generate random variate --- Three basic cases */
if (minjx == maxjx) { /* I: degenerate distribution ---------------- */
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch I (degenerate)\n");
#endif
ix = maxjx;
goto L_finis; // return appropriate variate
} else if (m - minjx < 10) { // II: (Scaled) algorithm HIN (inverse transformation) ----
const static double scale = 1e25; // scaling factor against (early) underflow
const static double con = 57.5646273248511421;
// 25*log(10) = log(scale) { <==> exp(con) == scale }
if (setup1 || setup2) {
double lw; // log(w); w = exp(lw) * scale = exp(lw + log(scale)) = exp(lw + con)
if (k < n2) {
lw = afc(n2) + afc(n1 + n2 - k) - afc(n2 - k) - afc(n1 + n2);
} else {
lw = afc(n1) + afc( k ) - afc(k - n2) - afc(n1 + n2);
}
w = exp(lw + con);
}
double p, u;
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch II; w = %g > 0\n", w);
#endif
L10:
p = w;
ix = minjx;
u = unif_rand() * scale;
#ifdef DEBUG_rhyper
REprintf(" _new_ u = %g\n", u);
#endif
while (u > p) {
u -= p;
p *= ((double) n1 - ix) * (k - ix);
ix++;
p = p / ix / (n2 - k + ix);
#ifdef DEBUG_rhyper
REprintf(" ix=%3d, u=%11g, p=%20.14g (u-p=%g)\n", ix, u, p, u-p);
#endif
if (ix > maxjx)
goto L10;
// FIXME if(p == 0.) we also "have lost" => goto L10
}
} else { /* III : H2PE Algorithm --------------------------------------- */
double u,v;
if (setup1 || setup2) {
s = sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn);
/* remark: d is defined in reference without int. */
/* the truncation centers the cell boundaries at 0.5 */
d = (int) (1.5 * s) + .5;
xl = m - d + .5;
xr = m + d + .5;
a = afc(m) + afc(n1 - m) + afc(k - m) + afc(n2 - k + m);
kl = exp(a - afc((int) (xl)) - afc((int) (n1 - xl))
- afc((int) (k - xl))
- afc((int) (n2 - k + xl)));
kr = exp(a - afc((int) (xr - 1))
- afc((int) (n1 - xr + 1))
- afc((int) (k - xr + 1))
- afc((int) (n2 - k + xr - 1)));
lamdl = -log(xl * (n2 - k + xl) / (n1 - xl + 1) / (k - xl + 1));
lamdr = -log((n1 - xr + 1) * (k - xr + 1) / xr / (n2 - k + xr));
p1 = d + d;
p2 = p1 + kl / lamdl;
p3 = p2 + kr / lamdr;
}
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch III {accept/reject}: (xl,xr)= (%g,%g); (lamdl,lamdr)= (%g,%g)\n",
xl, xr, lamdl,lamdr);
REprintf("-------- p123= c(%g,%g,%g)\n", p1,p2, p3);
#endif
int n_uv = 0;
L30:
u = unif_rand() * p3;
v = unif_rand();
n_uv++;
if(n_uv >= 10000) {
REprintf("rhyper() branch III: giving up after %d rejections", n_uv);
ML_ERR_return_NAN;
}
#ifdef DEBUG_rhyper
REprintf(" ... L30: new (u=%g, v ~ U[0,1])[%d]\n", u, n_uv);
#endif
if (u < p1) { /* rectangular region */
ix = (int) (xl + u);
} else if (u <= p2) { /* left tail */
ix = (int) (xl + log(v) / lamdl);
if (ix < minjx)
goto L30;
v = v * (u - p1) * lamdl;
} else { /* right tail */
ix = (int) (xr - log(v) / lamdr);
if (ix > maxjx)
goto L30;
v = v * (u - p2) * lamdr;
}
/* acceptance/rejection test */
Rboolean reject = TRUE;
if (m < 100 || ix <= 50) {
/* explicit evaluation */
/* The original algorithm (and TOMS 668) have
f = f * i * (n2 - k + i) / (n1 - i) / (k - i);
in the (m > ix) case, but the definition of the
recurrence relation on p134 shows that the +1 is
needed. */
int i;
double f = 1.0;
if (m < ix) {
for (i = m + 1; i <= ix; i++)
f = f * (n1 - i + 1) * (k - i + 1) / (n2 - k + i) / i;
} else if (m > ix) {
for (i = ix + 1; i <= m; i++)
f = f * i * (n2 - k + i) / (n1 - i + 1) / (k - i + 1);
}
if (v <= f) {
reject = FALSE;
}
} else {
const static double deltal = 0.0078;
const static double deltau = 0.0034;
double e, g, r, t, y;
double de, dg, dr, ds, dt, gl, gu, nk, nm, ub;
double xk, xm, xn, y1, ym, yn, yk, alv;
#ifdef DEBUG_rhyper
REprintf(" ... accept/reject 'large' case v=%g\n", v);
#endif
/* squeeze using upper and lower bounds */
y = ix;
y1 = y + 1.0;
ym = y - m;
yn = n1 - y + 1.0;
yk = k - y + 1.0;
nk = n2 - k + y1;
r = -ym / y1;
s = ym / yn;
t = ym / yk;
e = -ym / nk;
g = yn * yk / (y1 * nk) - 1.0;
dg = 1.0;
if (g < 0.0)
dg = 1.0 + g;
gu = g * (1.0 + g * (-0.5 + g / 3.0));
gl = gu - .25 * (g * g * g * g) / dg;
xm = m + 0.5;
xn = n1 - m + 0.5;
xk = k - m + 0.5;
nm = n2 - k + xm;
ub = y * gu - m * gl + deltau
+ xm * r * (1. + r * (-0.5 + r / 3.0))
+ xn * s * (1. + s * (-0.5 + s / 3.0))
+ xk * t * (1. + t * (-0.5 + t / 3.0))
+ nm * e * (1. + e * (-0.5 + e / 3.0));
/* test against upper bound */
alv = log(v);
if (alv > ub) {
reject = TRUE;
} else {
/* test against lower bound */
dr = xm * (r * r * r * r);
if (r < 0.0)
dr /= (1.0 + r);
ds = xn * (s * s * s * s);
if (s < 0.0)
ds /= (1.0 + s);
dt = xk * (t * t * t * t);
if (t < 0.0)
dt /= (1.0 + t);
de = nm * (e * e * e * e);
if (e < 0.0)
de /= (1.0 + e);
if (alv < ub - 0.25 * (dr + ds + dt + de)
+ (y + m) * (gl - gu) - deltal) {
reject = FALSE;
}
else {
/* * Stirling's formula to machine accuracy
*/
if (alv <= (a - afc(ix) - afc(n1 - ix)
- afc(k - ix) - afc(n2 - k + ix))) {
reject = FALSE;
} else {
reject = TRUE;
}
}
}
} // else
if (reject)
goto L30;
}
L_finis:
/* return appropriate variate */
if (kk + kk >= tn) {
if (nn1 > nn2) {
ix = kk - nn2 + ix;
} else {
ix = nn1 - ix;
}
} else {
if (nn1 > nn2)
ix = kk - ix;
}
return ix;
}
int main (int argc, char **argv)
{
// Default simulation parameters
char filename[100] = "";
double Tmax = 10000; // length of simulation
double Tsample = 1000; // time of first sample (and intervals)
int sampleSize = 10; // number of seqs sampled
double dt = 1.0; // time-step
// Default epidemiological parameters
int hostPopSize = 10000;
int N0 = 10; // initial viral pop size
double gamma = 0.1; // decay of immunity
double beta = 0.5; // transmission rate
double delta = 0.1; // recovery rate
// Default sequence parameters
double kappa = 3.0;
double mut_rate = 1e-5;
int Ld = 0;
int Lb = 2;
double sb = 0.01;
double sd = 1e-3;
double sigma = 1.0;
// User-specified arguments
int opt_char;
while ((opt_char = getopt(argc, argv, "ho:T:S:Z:t:H:N:g:b:d:L:u:k:l:a:s:c:")) != -1)
{
switch (opt_char)
{
case 'h':
printf("%s\n", helpStr);
exit(0);
break;
case 'o':
strcpy(filename, optarg);
break;
case 'T':
if ((Tmax = strtod(optarg, NULL)) <= 0.0)
{
fprintf (stderr, "Invalid -T parameter: %s\n", optarg);
exit(1);
}
break;
case 'S':
if ((Tsample = strtod(optarg, NULL)) <= 0.0)
{
fprintf (stderr, "Invalid -S parameter: %s\n", optarg);
exit(1);
}
break;
case 'Z':
sampleSize = atoi(optarg);
break;
case 't':
if ((dt = strtod(optarg, NULL)) <= 0.0)
{
fprintf (stderr, "Invalid -t parameter: %s\n", optarg);
exit(1);
}
break;
case 'N':
if ((N0 = atoi(optarg)) <= 0)
{
fprintf (stderr, "Invalid -N parameter: %s\n", optarg);
exit(1);
}
break;
case 'H':
if ((hostPopSize = atoi(optarg)) <= 0)
{
fprintf (stderr, "Invalid -H parameter: %s\n", optarg);
exit(1);
}
break;
case 'g':
if ((gamma = strtod(optarg, NULL)) < 0.0)
{
fprintf (stderr, "Invalid -g parameter: %s\n", optarg);
exit(1);
}
break;
case 'b':
if ((beta = strtod(optarg, NULL)) <= 0.0)
{
fprintf (stderr, "Invalid -b parameter: %s\n", optarg);
exit(1);
}
break;
case 'd':
if ((delta = strtod(optarg, NULL)) <= 0.0)
{
fprintf (stderr, "Invalid -d parameter: %s\n", optarg);
exit(1);
}
break;
case 'L':
if ((Ld = atoi(optarg)) < 0)
{
fprintf (stderr, "Invalid -L parameter: %s\n", optarg);
exit(1);
}
break;
case 'u':
if ((mut_rate = strtod(optarg, NULL)) < 0.0)
{
fprintf (stderr, "Invalid -u parameter: %s\n", optarg);
exit(1);
}
break;
case 'k':
if ((kappa = strtod(optarg, NULL)) < 0.0)
{
fprintf (stderr, "Invalid -k parameter: %s\n", optarg);
exit(1);
}
break;
case 'l':
if ((Lb = atoi(optarg)) < 0)
{
fprintf (stderr, "Invalid -l parameter: %s\n", optarg);
exit(1);
}
break;
case 'a':
sb = strtod(optarg, NULL);
break;
case 's':
sd = strtod(optarg, NULL);
break;
case 'c':
if ((sigma = strtod(optarg, NULL)) < 0.0)
{
fprintf (stderr, "Invalid -c parameter: %s\n", optarg);
exit(1);
}
break;
case '?':
fprintf (stderr, "Unrecognized argument\n");
exit(1);
}
}
if (filename[0] == '\0')
{
fprintf (stderr, "Output filename (option -o) must be specified\n");
exit(1);
}
FILE *outfile;
if ((outfile = fopen(filename, "w")) == NULL)
{
fprintf (stderr, "Cannot open %s\n", filename);
exit(1);
}
seed_time();
codonString::init_trans_matrix (kappa);
codonString viralPop(N0, Lb, Ld, sb, sd, sigma);
double t = 0.0;
int N = 0;
while ((N = viralPop.popSize()) > 0 && t < Tmax)
{
viralPop.mutate(mut_rate * dt);
viralPop.transmit(beta * dt, hostPopSize);
viralPop.recover(rbinom(N, delta * dt));
if (gamma > 0)
viralPop.immuneDecay(gamma * dt);
if (fmod(t, Tsample) < 1e-4)
viralPop.printSample(outfile, t, sampleSize);
t += dt;
}
fclose(outfile);
}
/* version when nu = m+1 is an integer
*
* m = interference parameter (m=0 gives no interference)
* p = proportion of chiasmata from no interference process
* L = length of chromosome (in cM)
* Lstar = revised length for simulating numbers of chiasmata, for case of obligate chiasma
* on same scale as L
* nxo = on output, the number of crossovers
* Loc = on output, the locations of the crossovers
* max_nxo = maximum no. crossovers allowed (length of loc)
* obligate_chiasma = 1 if require at least one chiasma (0 otherwise)
*
*/
void simStahl_int(int n_sim, int m, double p, double L,
double Lstar, int *nxo, double **Loc,
int max_nxo, int obligate_chiasma)
{
int i, j, k, n_nichi, n_pts, n_ichi, first, max_pts;
double *ptloc;
double lambda1, lambda2;
/* space for locations of chiasmata and intermediate pts */
max_pts = 2*max_nxo*(m+1);
ptloc = (double *)R_alloc(max_pts, sizeof(double));
GetRNGstate();
if(m==0) { /* looks like a Poisson model */
for(i=0; i< n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
if(obligate_chiasma) {
/* no. chiasmata, required >= 1 */
while((n_ichi = rpois(Lstar/50.0)) == 0);
/* no crossovers by thinning 1/2 */
nxo[i] = rbinom((double)n_ichi, 0.5);
}
else
nxo[i] = rpois(Lstar/100.0);
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 {
lambda1 = Lstar/50.0 * (m+1) * (1.0 - p);
lambda2 = Lstar/50.0 * p;
for(i=0; i< n_sim; i++) {
while(1) {
R_CheckUserInterrupt(); /* check for ^C */
/* simulate no. chiasmata + intermediate pts from interference process */
n_pts = rpois(lambda1);
/* simulate location of the first */
first = random_int(0, m);
if(first > n_pts) n_ichi = 0;
else n_ichi = n_pts/(m+1) + (int)(first < (n_pts % (m+1)));
/* simulate no. chiamata from the no-interference model */
n_nichi = rpois(lambda2);
if(!obligate_chiasma || n_ichi + n_nichi > 0) break;
}
/* simulate no. chiasmta + intermediate points */
/* first check if we have space */
if(n_pts > max_pts) {
ptloc = (double *)S_realloc((char *)ptloc, n_pts*2, max_pts, sizeof(double));
max_pts = n_pts*2;
}
for(j=0; j<n_pts; j++)
ptloc[j] = runif(0.0, L);
/* sort them */
R_rsort(ptloc, n_pts);
/* take every (m+1)st */
for(j=first, k=0; j<n_pts; j += (m+1), k++)
ptloc[k] = ptloc[j];
n_ichi = k;
/* simulate chiasmata from no-interference model */
for(j=0; j<n_nichi; j++)
ptloc[n_ichi + j] = runif(0.0, L);
/* sort the combined ones */
R_rsort(ptloc, n_ichi + n_nichi);
/* thin by 1/2 */
nxo[i] = 0;
for(j=0; j<n_ichi + n_nichi; j++) {
if(unif_rand() < 0.5) {
Loc[i][nxo[i]] = ptloc[j];
(nxo[i])++;
}
}
} /* loop over no. simulations */
} /* m > 0 */
PutRNGstate();
}
static void bic_seq_resample(double *tumor, int n_tumor, double *normal, int n_nml, SRM_binning args)
{ SEG_PERMUTE segs = NULL;
int *tumor_bin, *normal_bin, nbins;
int n_tumor_sample, n_normal_sample,i,k, total,start,end, kmin;
double tmp, freq, N_tumor, N_normal;
struct timeval tv;
int seed;
gettimeofday(&tv, NULL);
seed = tv.tv_sec * 1000000 + tv.tv_usec;
seed_set(seed);
srand48(seed);
segs = SEG_PERMUTE_create(args.B);
tmp = tumor[n_tumor-1] > normal[n_nml-1] ? tumor[n_tumor-1]:normal[n_nml-1];
nbins = floor(tmp/args.bin_size)+10;
nbins = nbins>10?nbins:10;
tumor_bin = (int *) malloc(sizeof(int)*nbins);
normal_bin = (int *)malloc(sizeof(int)*nbins);
if(tumor_bin==NULL||normal_bin==NULL){
fprintf(stderr,"Error in bic_seq_resample: memory allocation failed\n");
exit(1);
}
tmp = tumor[0] < normal[0] ? tumor[0]:normal[0];
kmin = (int) floor(tmp/args.bin_size)-1;
kmin = (kmin>0? kmin:0);
for(i=0;i<segs->size;i++){
n_tumor_sample = rbinom(args.tumor_freq,n_tumor+n_nml);
n_normal_sample = rbinom(1-args.tumor_freq,n_tumor+n_nml);
random_sample(tumor, n_tumor, normal, n_nml, n_tumor_sample, args.bin_size ,tumor_bin, nbins, args.paired, args.insert, args.sd);
random_sample(tumor, n_tumor, normal, n_nml, n_normal_sample, args.bin_size ,normal_bin,nbins, args.paired, args.insert, args.sd);
N_tumor=0.0; N_normal = 0.0;
for(k=kmin;k<nbins;k++){
start = k*args.bin_size+1;
end = start+args.bin_size;
total = tumor_bin[k] + normal_bin[k];
freq = ((double) tumor_bin[k])/((double) total);
if(total>0) ll_append(segs->bins_perm[i], bin_new(tumor_bin[k], total, freq, start, end));
N_tumor += tumor_bin[k];
N_normal += normal_bin[k];
}
set_BinList(segs->bins_perm[i]);
set_totalreadcount(N_tumor,N_normal);
if(args.autoselect_lambda!=1){
bic_seq(args.paired);
//bic_seq(0);
}else{
bic_seq_auto(ll_length(segs->bins_perm[i]),args.FP,args.paired);
//bic_seq_auto(ll_length(segs->bins_perm[i]),args.FP,0);
}
segs->bins_perm[i] = get_BinList();
}
print_SEG_PERMUTE(segs,args.output);
SEG_PERMUTE_destroy(segs); segs = NULL;
free(tumor_bin); tumor_bin = NULL;
free(normal_bin);normal_bin = NULL;
return;
}
void isevect(double *t, int *delta, int *n, int *nboot, double *gridise, int *legridise, double *gridbw1, int *legridbw1, double *gridbw2, int *legridbw2, int *nkernel, int * dup, int *nestimand, double *phat, double *estim, int* presmoothing, double *isev){
int i, j, k, boot, *indices, *deltaboot, *pnull;
double *pnull2, *ptemp, *estimboot, *tboot, *integrand, *isecomp, *deltabootdbl;
indices = malloc(*n * sizeof(int));
ptemp = malloc(*n * sizeof(double));
estimboot = malloc(*legridise * sizeof(double));
tboot = malloc(*n * sizeof(double));
integrand = malloc(*legridise * sizeof(double));
isecomp = malloc(sizeof(double));
GetRNGstate();
if(*presmoothing == 1){ // with presmoothing
deltaboot = malloc(*n * sizeof(int));
switch(*nestimand){
// S
case 1:
pnull = calloc(1, sizeof(int));
pnull2 = calloc(1, sizeof(double));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, pnull2, pnull, pnull, ptemp, pnull, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
free(pnull2);
break;
// H
case 2:
pnull = calloc(1, sizeof(int));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, gridbw2, nkernel, pnull, ptemp, dup, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
break;
// f
case 3:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
// h
case 4:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, dup, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
default:
break;
}
free(deltaboot);
}
else{ // without presmoothing
deltabootdbl = malloc(*n * sizeof(double));
if(*nestimand == 3){
// f
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
else{
// h
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, dup, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
free(deltabootdbl);
}
PutRNGstate();
free(indices);
free(ptemp);
free(estimboot);
free(tboot);
free(integrand);
free(isecomp);
}
uint BM::sim()const{ return rbinom(n_, prob()); }
