void R_scantwo_imp(int *n_ind, int *same_chr, int *n_pos1, int *n_pos2,
int *n_gen1, int *n_gen2, int *n_draws, int *draws1,
int *draws2, double *addcov, int *n_addcov,
double *intcov, int *n_intcov, double *pheno, int *nphe,
double *weights, double *result, int *n_col2drop,
int *col2drop)
{
int ***Draws1, ***Draws2;
double **Addcov, **Intcov;
/* reorganize draws */
reorg_draws(*n_ind, *n_pos1, *n_draws, draws1, &Draws1);
if(!(*same_chr)) reorg_draws(*n_ind, *n_pos2, *n_draws, draws2, &Draws2);
/* reorganize addcov and intcov (if they are not empty) */
/* currently reorg_geno function is used to reorganized the data */
if(*n_addcov != 0) reorg_errlod(*n_ind, *n_addcov, addcov, &Addcov);
if(*n_intcov != 0) reorg_errlod(*n_ind, *n_intcov, intcov, &Intcov);
/* call the engine function scantwo_imp */
scantwo_imp(*n_ind, *same_chr, *n_pos1, *n_pos2, *n_gen1, *n_gen2,
*n_draws, Draws1, Draws2, Addcov, *n_addcov,
Intcov, *n_intcov, pheno, *nphe, weights, result,
*n_col2drop, col2drop);
}
void R_fitqtl_imp(int *n_ind, int *n_qtl, int *n_gen, int *n_draws,
int *draws, int *n_cov, double *cov, int *model,
int *n_int, double *pheno, int *get_ests,
/* return variables */
double *lod, int *df, double *ests, double *ests_covar,
double *design_mat, int *matrix_rank, double *residuals)
{
int ***Draws;
double **Cov=0;
/* reorganize draws */
reorg_draws(*n_ind, *n_qtl, *n_draws, draws, &Draws);
/* reorganize cov (if they are not empty) */
/* currently reorg_errlod function is used to reorganize the data */
if(*n_cov != 0) reorg_errlod(*n_ind, *n_cov, cov, &Cov);
fitqtl_imp(*n_ind, *n_qtl, n_gen, *n_draws, Draws,
Cov, *n_cov, model, *n_int, pheno, *get_ests, lod, df,
ests, ests_covar, design_mat, matrix_rank, residuals);
}
void R_scanone_imp(int *n_ind, int *n_pos, int *n_gen, int *n_draws,
int *draws, double *addcov, int *n_addcov,
double *intcov, int *n_intcov, double *pheno,
int *nphe, double *weights,
double *result, int *ind_noqtl)
{
/* reorganize draws */
int ***Draws;
double **Addcov, **Intcov, **Result;
reorg_draws(*n_ind, *n_pos, *n_draws, draws, &Draws);
reorg_errlod(*n_pos, *nphe, result, &Result);
/* reorganize addcov and intcov (if they are not empty) */
/* currently reorg_errlod function is used to reorganize the data */
if(*n_addcov != 0) reorg_errlod(*n_ind, *n_addcov, addcov, &Addcov);
if(*n_intcov != 0) reorg_errlod(*n_ind, *n_intcov, intcov, &Intcov);
scanone_imp(*n_ind, *n_pos, *n_gen, *n_draws, Draws,
Addcov, *n_addcov, Intcov, *n_intcov, pheno, *nphe, weights,
Result, ind_noqtl);
}
void sim_geno(int n_ind, int n_pos, int n_gen, int n_draws,
int *geno, double *rf, double *rf2,
double error_prob, int *draws,
double initf(int, int *),
double emitf(int, int, double, int *),
double stepf(int, int, double, double, int *))
{
int i, k, j, v, v2;
double s, **beta, *probs;
int **Geno, ***Draws, curstate;
int cross_scheme[2];
/* cross scheme hidden in draws argument; used by hmm_bcsft */
cross_scheme[0] = draws[0];
cross_scheme[1] = draws[1];
draws[0] = 0;
draws[1] = 0;
/* allocate space for beta and
reorganize geno and draws */
/* Geno indexed as Geno[pos][ind] */
/* Draws indexed as Draws[rep][pos][ind] */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_draws(n_ind, n_pos, n_draws, draws, &Draws);
allocate_alpha(n_pos, n_gen, &beta);
allocate_double(n_gen, &probs);
/* Read R's random seed */
GetRNGstate();
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* do backward equations */
/* initialize beta */
for(v=0; v<n_gen; v++) beta[v][n_pos-1] = 0.0;
/* backward equations */
for(j=n_pos-2; j>=0; j--) {
for(v=0; v<n_gen; v++) {
beta[v][j] = beta[0][j+1] + stepf(v+1,1,rf[j], rf2[j], cross_scheme) +
emitf(Geno[j+1][i],1,error_prob, cross_scheme);
for(v2=1; v2<n_gen; v2++)
beta[v][j] = addlog(beta[v][j], beta[v2][j+1] +
stepf(v+1,v2+1,rf[j],rf2[j], cross_scheme) +
emitf(Geno[j+1][i],v2+1,error_prob, cross_scheme));
}
}
for(k=0; k<n_draws; k++) { /* k = simulation replicate */
/* first draw */
/* calculate probs */
s = (probs[0] = initf(1, cross_scheme)+emitf(Geno[0][i],1,error_prob, cross_scheme)+beta[0][0]);
for(v=1; v<n_gen; v++) {
probs[v] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme) +
beta[v][0];
s = addlog(s, probs[v]);
}
for(v=0; v<n_gen; v++) probs[v] = exp(probs[v] - s);
/* make draw: returns a value from {1, 2, ..., n_gen} */
curstate = Draws[k][0][i] = sample_int(n_gen, probs);
/* move along chromosome */
for(j=1; j<n_pos; j++) {
/* calculate probs */
for(v=0; v<n_gen; v++)
probs[v] = exp(stepf(curstate,v+1,rf[j-1],rf2[j-1], cross_scheme) +
emitf(Geno[j][i],v+1,error_prob, cross_scheme) +
beta[v][j] - beta[curstate-1][j-1]);
/* make draw */
curstate = Draws[k][j][i] = sample_int(n_gen, probs);
}
} /* loop over replicates */
} /* loop over individuals */
/* write R's random seed */
PutRNGstate();
}