void 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)
{
/* create local variables */
int i, i1, i2, j, k; /* loop variants */
double **lrss0, **lrss1, **LODfull, **LODadd,*lod_tmp;
double *dwork_null, *dwork_add, *dwork_full, *tmppheno, dtmp;
int nrss, n_col_null, n_col_a, n_col_f, n_gen_sq, idx;
int lwork, nlod_per_draw, multivar=0;
int *allcol2drop;
/* if number of pheno is 1 or do multivariate model,
we have only one rss at each position. Otherwise,
we have one rss for each phenotype */
if( (nphe==1) || (multivar==1) )
nrss = 1;
else
nrss = nphe;
/* constants */
n_gen_sq = n_gen1*n_gen2;
/* number of columns of X for null model */
n_col_null = 1 + n_addcov;
/* number of columns of X for additive model */
n_col_a = (n_gen1+n_gen2-1) + n_addcov + n_intcov*(n_gen1+n_gen2-2);
/* number of columns of X for full model */
n_col_f = n_gen_sq + n_addcov + n_intcov*(n_gen_sq-1);
/* expand col2drop */
if(n_col2drop) {
allocate_int(n_col_f, &allcol2drop);
expand_col2drop(n_gen1, n_addcov, n_intcov,
col2drop, allcol2drop);
}
/*********************
* allocate memory
*********************/
tmppheno = (double *)R_alloc(n_ind*nphe, sizeof(double));
/* for rss' and lod scores - we might not need all of this memory */
lrss0 = (double **)R_alloc(n_draws, sizeof(double*));
lrss1 = (double **)R_alloc(n_draws, sizeof(double*));
LODadd = (double **)R_alloc(n_draws, sizeof(double*));
LODfull = (double **)R_alloc(n_draws, sizeof(double*));
for(i=0; i<n_draws; i++) {
lrss0[i] = (double *)R_alloc(nrss, sizeof(double));
lrss1[i] = (double *)R_alloc(2*nrss, sizeof(double));
LODadd[i] = (double *)R_alloc(nrss, sizeof(double));
LODfull[i] = (double *)R_alloc(nrss, sizeof(double));
}
/* the working arrays for the calling of dgelss */
/* allocate memory */
/* for null model */
lod_tmp = (double *)R_alloc(n_draws, sizeof(double));
lwork = 3*n_col_null + MAX(n_ind, nphe);
if(multivar == 1) /* request to do multivariate normal model */
dwork_null = (double *)R_alloc(n_col_null+lwork+2*n_ind*n_col_null+n_ind*nphe+
nphe*nphe+n_col_null*nphe,
sizeof(double));
else
dwork_null = (double *)R_alloc(n_col_null+lwork+2*n_ind*n_col_null+n_ind*nphe+n_col_null*nphe,
sizeof(double));
/* for additive model */
lwork = 3*n_col_a + MAX(n_ind, nphe);;
if(multivar == 1) /* request to do multivariate normal model */
dwork_add = (double *)R_alloc(n_col_a+lwork+2*n_ind*n_col_a+n_ind*nphe+nphe*nphe+n_col_a*nphe,
sizeof(double));
else
dwork_add = (double *)R_alloc(n_col_a+lwork+2*n_ind*n_col_a+n_ind*nphe+n_col_a*nphe,
sizeof(double));
/* for full model */
lwork = 3*n_col_f + MAX(n_ind, nphe);;
if(multivar == 1) /* request to do multivariate normal model */
dwork_full = (double *)R_alloc(n_col_f+lwork+2*n_ind*n_col_f+n_ind*nphe+nphe*nphe+n_col_f*nphe,
sizeof(double));
else
dwork_full = (double *)R_alloc(n_col_f+lwork+2*n_ind*n_col_f+n_ind*nphe+n_col_f*nphe,
sizeof(double));
/***************************
* finish memory allocation
***************************/
/* adjust phenotypes and covariates using weights */
/* Note: these are actually square-root of weights */
for(i=0; i<n_ind; i++) {
for(j=0; j<nphe; j++) pheno[i+j*n_ind] *= weights[i];
for(j=0; j<n_addcov; j++) Addcov[j][i] *= weights[i];
for(j=0; j<n_intcov; j++) Intcov[j][i] *= weights[i];
}
/* Note that lrss0 is the log10(RSS) for model E(Yi) = b0;
lrss_add is the log10(RSS) for model
E(Yi) = b0 + b1*q1 + b2*q2;
lrss_full is the log10(RSS) for model
E(Yi) = b0 + b1*q1 + b2*q2 + b3*(q1*q2);
Additive and interactive covariates are included (if any) */
dtmp = (double)n_ind/2.0; /* this will be used in calculating LOD score */
/* Call nullRss to calculate the RSS for the null model */
for (i=0; i<n_draws; i++) {
/* make a copy of phenotypes. I'm doing this because
dgelss will destroy the input rhs array */
memcpy(tmppheno, pheno, n_ind*nphe*sizeof(double));
nullRss(tmppheno, pheno, nphe, n_ind, Addcov, n_addcov,
dwork_null, multivar, lrss0[i], weights);
}
/* calculate the LOD score for each pair of markers */
if(same_chr) { /* if the pair is on the same chromesome */
/* number of lod scores per draw */
nlod_per_draw = n_pos1 * n_pos1;
for(i1=0; i1<n_pos1-1; i1++) {
for (i2=i1+1; i2<n_pos1; i2++) {
for(j=0; j<n_draws; j++) { /* loop over imputations */
R_CheckUserInterrupt(); /* check for ^C */
/* calculate rss */
memcpy(tmppheno, pheno, n_ind*nphe*sizeof(double));
altRss2(tmppheno, pheno, nphe, n_ind, n_gen1, n_gen1, Draws1[j][i1],
Draws1[j][i2], Addcov, n_addcov, Intcov, n_intcov,
lrss1[j], dwork_add, dwork_full, multivar, weights,
n_col2drop, allcol2drop);
/* calculate 2 different LOD scores */
for(k=0; k<nrss; k++) {
LODadd[j][k] = dtmp*(lrss0[j][k]-lrss1[j][k]);
LODfull[j][k] = dtmp*(lrss0[j][k]-lrss1[j][k+nrss]);
}
}
/* calculate the weight average on the two LOD score vector
and fill the result matrix */
if(n_draws > 1) {
for(k=0; k<nrss; k++) { /* loop for phenotypes */
/* for full model LOD */
for(j=0; j<n_draws; j++)
lod_tmp[j] = LODfull[j][k];
result[k*nlod_per_draw+i1*n_pos2+i2] = wtaverage(lod_tmp, n_draws);
/* for epistasis LOD */
for(j=0; j<n_draws; j++)
lod_tmp[j] = LODadd[j][k];
result[k*nlod_per_draw+i2*n_pos1+i1] = wtaverage(lod_tmp, n_draws);
}
}
else { /* only one draw */
for(k=0;k<nrss; k++) {
result[k*nlod_per_draw+i1*n_pos2+i2] = LODfull[0][k];
result[k*nlod_per_draw+i2*n_pos1+i1] = LODadd[0][k];
}
}
} /* end loop over position 1 */
} /* end loop over position 2 */
}
else { /* the pair is for different chromesome */
nlod_per_draw = n_pos1*n_pos2;
idx = n_pos1*n_pos2;
for(i1=0; i1<n_pos1; i1++) { /* loop over markers on chr 1 */
for(i2=0; i2<n_pos2; i2++) { /* loop over markers on chr 2 */
for(j=0; j<n_draws; j++) { /* loop over imputations */
R_CheckUserInterrupt(); /* check for ^C */
/* rss for alternative model */
altRss2(tmppheno, pheno, nphe, n_ind, n_gen1, n_gen2, Draws1[j][i1],
Draws2[j][i2], Addcov, n_addcov, Intcov, n_intcov,
lrss1[j], dwork_add, dwork_full,multivar, weights,
n_col2drop, allcol2drop);
/* calculate 2 different LOD scores */
for(k=0; k<nrss; k++) {
LODadd[j][k] = dtmp*(lrss0[j][k]-lrss1[j][k]);
LODfull[j][k] = dtmp*(lrss0[j][k]-lrss1[j][k+nrss]);
}
}
/* calculate the weight average on the two LOD score vector
and fill the result matrix */
if(n_draws > 1) {
for(k=0; k<nrss; k++) {
/* for full model LOD */
for(j=0; j<n_draws; j++)
lod_tmp[j] = LODfull[j][k];
result[(k+nrss)*nlod_per_draw+i1*n_pos2+i2] = wtaverage(lod_tmp, n_draws);
/* for epistasis LOD */
for(j=0; j<n_draws; j++)
lod_tmp[j] = LODadd[j][k];
result[k*nlod_per_draw+i2*n_pos1+i1] = wtaverage(lod_tmp, n_draws);
}
}
else { /* only one draw */
for(k=0;k<nrss; k++) {
result[(k+nrss)*nlod_per_draw+i1*n_pos2+i2] = LODfull[0][k];
result[k*nlod_per_draw+i2*n_pos1+i1] = LODadd[0][k];
}
}
} /* end loop over chromesome 2 */
} /* end loop over chromesome 1 */
}
/* end of scantwo_imp() */
}
void 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)
{
/* create local variables */
int i, j, k, nrss, sizefull, sizenull, lwork, multivar=0;
double **lrss0, **lrss1, *LOD, dtmp, *tmppheno, *dwork_null, *dwork_full;
/* if number of pheno is 1 or do multivariate model,
we have only one rss at each position. Otherwise,
we have one rss for each phenotype */
if( (nphe==1) || (multivar==1) )
nrss = 1;
else
nrss = nphe;
/* number of columns in design matrices for null and full model */
sizenull = 1 + n_addcov;
sizefull = n_gen + n_addcov + n_intcov*(n_gen-1);
/* allocate memory */
tmppheno = (double *) R_alloc(n_ind*nphe, sizeof(double));
/* for null model */
lwork = 3*sizenull + MAX(n_ind, nphe);
if(multivar == 1) /* request to do multivariate normal model */
dwork_null = (double *)R_alloc(sizenull+lwork+2*n_ind*sizenull+n_ind*nphe+nphe*nphe+sizenull*nphe,
sizeof(double));
else /* normal model, don't need to allocate memory for rss_det, which is nphe^2 */
dwork_null = (double *)R_alloc(sizenull+lwork+2*n_ind*sizenull+n_ind*nphe+sizenull*nphe,
sizeof(double));
/* for full model */
lwork = 3*sizefull + MAX(n_ind, nphe);
if(multivar == 1) /* request to do multivariate normal model */
dwork_full = (double *)R_alloc(sizefull+lwork+2*n_ind*sizefull+n_ind*nphe+nphe*nphe+sizefull*nphe,
sizeof(double));
else /* normal model, don't need to allocate memory for rss_det, which is nphe^2 */
dwork_full = (double *)R_alloc(sizefull+lwork+2*n_ind*sizefull+n_ind*nphe+sizefull*nphe,
sizeof(double));
/* for rss' and lod scores - we might not need all of this memory */
lrss0 = (double **)R_alloc(n_draws, sizeof(double*));
lrss1 = (double **)R_alloc(n_draws, sizeof(double*));
/*LOD = (double **)R_alloc(n_draws, sizeof(double*));*/
for(i=0; i<n_draws; i++) {
lrss0[i] = (double *)R_alloc(nrss, sizeof(double));
lrss1[i] = (double *)R_alloc(nrss, sizeof(double));
/*LOD[i] = (double *)R_alloc(nrss, sizeof(double));*/
}
/* LOD matrix - allocate LOD matrix as a pointer to double, then I can call wtaverage
directly using pointer operation without looping. This will save some time if there are
lots of phenotypes */
LOD = (double *)R_alloc(n_draws*nrss, sizeof(double));
/* adjust phenotypes and covariates using weights */
/* Note: these are actually square-root of weights */
for(i=0; i<n_ind; i++) {
for(j=0; j<nphe; j++)
pheno[i+j*n_ind] *= weights[i];
for(j=0; j<n_addcov; j++)
Addcov[j][i] *= weights[i];
for(j=0; j<n_intcov; j++)
Intcov[j][i] *= weights[i];
}
/* Call nullRss to calculate the RSS for the null model */
for (i=0; i<n_draws; i++) {
R_CheckUserInterrupt(); /* check for ^C */
/* make a copy of phenotypes. I'm doing this because
dgelss will destroy the input rhs array */
memcpy(tmppheno, pheno, n_ind*nphe*sizeof(double));
nullRss(tmppheno, pheno, nphe, n_ind, Addcov, n_addcov,
dwork_null, multivar, lrss0[i], weights);
}
/* calculate the LOD score for each marker */
dtmp = (double)n_ind/2.0; /* this will be used in calculating LOD score */
for(i=0; i<n_pos; i++) { /* loop over positions */
for(j=0; j<n_draws; j++) { /* loop over imputations */
R_CheckUserInterrupt(); /* check for ^C */
/* loop over imputations */
/* call altRss to calcualte the RSS for alternative model,
given marker and imputatin number */
memcpy(tmppheno, pheno, n_ind*nphe*sizeof(double));
altRss1(tmppheno, pheno, nphe, n_ind, n_gen, Draws[j][i], Addcov,
n_addcov, Intcov, n_intcov, dwork_full, multivar, lrss1[j], weights,
ind_noqtl);
/* calculate the LOD score for this marker in this imputation */
for(k=0; k<nrss; k++)
LOD[j+k*n_draws] = dtmp*(lrss0[j][k]-lrss1[j][k]);
} /* end loop over imputations */
/* calculate the weight average on the LOD score vector
and fill the result matrix. Note that result is a matrix
by ROW. I figured this is the most efficient way to calculate it.
On exit, we need to use matrix(..., byrow=T) to get the correct one */
if(n_draws > 1) {
for(k=0; k<nrss; k++)
Result[k][i] = wtaverage(LOD+k*n_draws, n_draws);
}
else {
for(k=0; k<nrss; k++)
Result[k][i] = LOD[k];
}
} /* end loop over positions */
}
