void poisMstat(int *x, int *nx, double *stat)
{
/* computes the Poisson mean distance statistic */
int i, j, k, n=(*nx);
double eps=1.0e-10;
double cvm, d, lambda, m, q;
double Mcdf1, Mcdf0, Mpdf1, cdf1, cdf0;
lambda = 0;
for (i=0; i<n; i++)
lambda += x[i];
lambda /= ((double) n);
q = qpois(1.0-eps, lambda, TRUE, FALSE) + 1;
m = 0.0;
for (j=0; j<n; j++) m += abs(x[j] - 1);
m /= ((double) n); /* est of m_1 = E|1 - X| */
Mcdf0 = (m + 1.0 - lambda) / 2.0; /* M-est of F(0) */
cdf0 = exp(-lambda); /* MLE of F(0) */
d = Mcdf0 - cdf0;
cvm = d * d * cdf0; /* von Mises type of distance */
for (i=1; i<q; i++) {
m = 0;
k = i + 1;
for (j=0; j<n; j++) m += abs(x[j]-k);
m /= ((double) n); /* est of m_{i+1} = E|i+1 - X| */
/* compute M-estimate of f(i) and F(i) */
Mpdf1 = (m-(k-lambda)*(2.0*Mcdf0-1.0))/((double) 2.0*k);
if (Mpdf1 < 0.0) Mpdf1 = 0.0;
Mcdf1 = Mcdf0 + Mpdf1;
if (Mcdf1 > 1) Mcdf1 = 1.0;
cdf1 = ppois(i, lambda, TRUE, FALSE); /* MLE of F(i) */
d = Mcdf1 - cdf1;
cvm += d * d * (cdf1 - cdf0);
cdf0 = cdf1;
Mcdf0 = Mcdf1;
}
cvm *= n;
*stat = cvm;
}
/*
Given prob, x, a and b, this function returns the corresponding
noncentrality parameter of the noncentral beta distribution.
I.e. the following equation
I_x(a, b, lambda) = prob
is solved for lambda with Newton iteration.
This function works just fine when supplied with meaningful input
data (and from practically meaningful range) but may easily crash
if not. Please be nice.
*/
double ncbeta(double prob, double x, double a, double b) {
double ql;
double qu;
double c;
double d;
double p;
double lambda;
double lambda_new;
double k;
double f;
double g;
double mu;
double eps;
double eps2;
int itr_cnt;
lambda_new = guess(prob, x, 2.0*a, 2.0*b);
/* FIXME: are these tolerances OK ? */
eps = 1.0e-7;
eps2 = 1.0e-6;
itr_cnt = 0;
do {
lambda = lambda_new;
mu = lambda/2.0;
ql = qpois(eps, mu, 1, 0);
qu = qpois(eps, mu, 0, 0);
k = qu;
c = pbeta(x, a+k, b, 1, 0);
d = x*(1.0-x)/(a+k-1.0)*dbeta(x, a+k-1, b, 0);
p = dpois(k, mu, 0);
f=p*c;
p = k/mu*p;
g = p*d;
for (k = qu-1; k >= ql; --k) {
c=c+d;
d=(a+k)/(x*(a+k+b-1))*d;
f=f+p*c;
p=k/mu*p;
g=g+p*d;
}
/* Newton step */
lambda_new = lambda+2.0*(f-prob)/g;
++itr_cnt;
}
while ((fabs(lambda_new-lambda) > eps2*lambda_new)&&(itr_cnt<=10));
/* FIXME: how this error is handled properly in R ? */
if (itr_cnt == 11) {
fprintf( stderr, "Newton iteration failed in ncbeta()!\n");
exit(127);
}
return lambda_new;
}
/**********************************************************************
*
* sim_ril
*
* n_chr Number of chromosomes
* n_mar Number of markers on each chromosome (vector of length n_chr)
* n_ril Number of RILs to simulate
*
* map Vector of marker locations, of length sum(n_mar)
* First marker on each chromosome should be at 0.
*
* n_str Number of parental strains (either 2, 4, or 8)
*
* m Interference parameter (0 is no interference)
* p For Stahl model, proportion of chiasmata from the NI model
*
* include_x Whether the last chromosome is the X chromosome
*
* random_cross Indicates whether the order of the strains in the cross
* should be randomized.
*
* selfing If 1, use selfing; if 0, use sib mating
*
* cross On output, the cross used for each line
* (vector of length n_ril x n_str)
*
* ril On output, the simulated data
* (vector of length sum(n_mar) x n_ril)
*
* origgeno Like ril, but with no missing data
*
* error_prob Genotyping error probability (used nly with n_str==2)
*
* missing_prob Rate of missing genotypes
*
* errors Error indicators (n_mar x n_ril)
*
**********************************************************************/
void sim_ril(int n_chr, int *n_mar, int n_ril, double *map,
int n_str, int m, double p, int include_x,
int random_cross, int selfing, int *cross, int *ril,
int *origgeno,
double error_prob, double missing_prob, int *errors)
{
int i, j, k, ngen, tot_mar, curseg;
struct individual par1, par2, kid1, kid2;
int **Ril, **Cross, **Errors, **OrigGeno;
int maxwork, isX, flag, max_xo, *firstmarker;
double **Map, maxlen, chrlen, *work;
/* count total number of markers */
for(i=0, tot_mar=0; i<n_chr; i++)
tot_mar += n_mar[i];
reorg_geno(tot_mar, n_ril, ril, &Ril);
reorg_geno(n_str, n_ril, cross, &Cross);
reorg_geno(tot_mar, n_ril, errors, &Errors);
reorg_geno(tot_mar, n_ril, origgeno, &OrigGeno);
/* allocate space */
Map = (double **)R_alloc(n_chr, sizeof(double *));
Map[0] = map;
for(i=1; i<n_chr; i++)
Map[i] = Map[i-1] + n_mar[i-1];
/* location of first marker */
firstmarker = (int *)R_alloc(n_chr, sizeof(int));
firstmarker[0] = 0;
for(i=1; i<n_chr; i++)
firstmarker[i] = firstmarker[i-1] + n_mar[i-1];
/* maximum chromosome length (in cM) */
maxlen = Map[0][n_mar[0]-1];
for(i=1; i<n_chr; i++)
if(maxlen < Map[i][n_mar[i]-1])
maxlen = Map[i][n_mar[i]-1];
/* allocate space for individuals */
max_xo = (int)qpois(1e-10, maxlen/100.0, 0, 0)*6;
if(!selfing) max_xo *= 5;
allocate_individual(&par1, max_xo);
allocate_individual(&par2, max_xo);
allocate_individual(&kid1, max_xo);
allocate_individual(&kid2, max_xo);
maxwork = (int)qpois(1e-10, (m+1)*maxlen/50.0, 0, 0)*3;
work = (double *)R_alloc(maxwork, sizeof(double));
for(i=0; i<n_ril; i++) {
/* set up cross */
for(j=0; j<n_str; j++) Cross[i][j] = j+1;
if(random_cross) int_permute(Cross[i], n_str);
for(j=0; j<n_chr; j++) {
isX = include_x && j==n_chr-1;
chrlen = Map[j][n_mar[j]-1];
par1.n_xo[0] = par1.n_xo[1] = par2.n_xo[0] = par2.n_xo[1] = 0;
/* initial generations */
if(n_str==2) {
par1.allele[0][0] = par2.allele[0][0] = 1;
par1.allele[1][0] = par2.allele[1][0] = 2;
}
else if(n_str==4) {
par1.allele[0][0] = 1;
par1.allele[1][0] = 2;
par2.allele[0][0] = 3;
par2.allele[1][0] = 4;
}
else { /* 8 strain case */
par1.allele[0][0] = 1;
par1.allele[1][0] = 2;
par2.allele[0][0] = 3;
par2.allele[1][0] = 4;
docross(par1, par2, &kid1, chrlen, m, p, 0,
&maxwork, &work);
par1.allele[0][0] = 5;
par1.allele[1][0] = 6;
par2.allele[0][0] = 7;
par2.allele[1][0] = 8;
docross(par1, par2, &kid2, chrlen, m, p, isX,
&maxwork, &work);
copy_individual(&kid1, &par1);
copy_individual(&kid2, &par2);
}
/* start inbreeding */
ngen=1;
while(1) {
R_CheckUserInterrupt(); /* check for ^C */
docross(par1, par2, &kid1, chrlen, m, p, 0,
&maxwork, &work);
if(!selfing)
docross(par1, par2, &kid2, chrlen, m, p, isX,
&maxwork, &work);
/* are we done? */
flag = 0;
if(selfing) {
if(kid1.n_xo[0] == kid1.n_xo[1]) {
for(k=0; k<kid1.n_xo[0]; k++) {
if(kid1.allele[0][k] != kid1.allele[1][k] ||
fabs(kid1.xoloc[0][k] - kid1.xoloc[1][k]) > 1e-6) {
flag = 1;
break;
}
}
if(kid1.allele[0][kid1.n_xo[0]] != kid1.allele[1][kid1.n_xo[0]])
flag = 1;
}
else flag = 1;
}
else {
if(kid1.n_xo[0] == kid1.n_xo[1] &&
kid1.n_xo[0] == kid2.n_xo[0] &&
kid1.n_xo[0] == kid2.n_xo[1]) {
for(k=0; k<kid1.n_xo[0]; k++) {
if(kid1.allele[0][k] != kid1.allele[1][k] ||
kid1.allele[0][k] != kid2.allele[0][k] ||
kid1.allele[0][k] != kid2.allele[1][k] ||
fabs(kid1.xoloc[0][k] - kid1.xoloc[1][k]) > 1e-6 ||
fabs(kid1.xoloc[0][k] - kid2.xoloc[0][k]) > 1e-6 ||
fabs(kid1.xoloc[0][k] - kid2.xoloc[1][k]) > 1e-6) {
flag = 1;
break;
}
}
if(kid1.allele[0][kid1.n_xo[0]] != kid1.allele[1][kid1.n_xo[0]] ||
kid1.allele[0][kid1.n_xo[0]] != kid2.allele[0][kid1.n_xo[0]] ||
kid1.allele[0][kid1.n_xo[0]] != kid2.allele[1][kid1.n_xo[0]])
flag = 1;
}
else flag = 1;
}
if(!flag) break; /* done inbreeding */
/* go to next generation */
copy_individual(&kid1, &par1);
if(selfing) copy_individual(&kid1, &par2);
else copy_individual(&kid2, &par2);
} /* end with inbreeding of this chromosome */
/* fill in alleles */
curseg = 0;
for(k=0; k<n_mar[j]; k++) { /* loop over markers */
while(curseg < kid1.n_xo[0] && Map[j][k] > kid1.xoloc[0][curseg])
curseg++;
OrigGeno[i][k+firstmarker[j]] =
Ril[i][k+firstmarker[j]] = Cross[i][kid1.allele[0][curseg]-1];
/* simulate missing ? */
if(unif_rand() < missing_prob) {
Ril[i][k+firstmarker[j]] = 0;
}
else if(n_str == 2 && unif_rand() < error_prob) {
/* simulate error */
Ril[i][k+firstmarker[j]] = 3 - Ril[i][k+firstmarker[j]];
Errors[i][k+firstmarker[j]] = 1;
}
}
} /* loop over chromosomes */
} /* loop over lines */
}
double F77_SUB(invcdfpoiss)(double *p, double *lambda, int *lower_tail, int *log_p)
{
return qpois(*p, *lambda, *lower_tail, *log_p);
}
