void scantwo_1chr_em(int n_ind, int n_pos, int n_gen,
double *****Pairprob, double **Addcov, int n_addcov,
double **Intcov, int n_intcov, double *pheno,
double *weights,
double **Result, int maxit, double tol, int verbose,
int n_col2drop, int *col2drop)
{
int error_flag, i, i1, i2, k1, k2, j, m, n_col[2], n_col_rev[2], nit[2], r, flag=0;
double *param, *oldparam, ***Wts12, **Wts1, **Wts2;
double *wts, *work1, *work2, temp, ***Probs, oldllik=0.0, llik[2], sw;
int *allcol2drop;
n_col[0] = (2*n_gen-1) + n_addcov + 2*(n_gen-1)*n_intcov;
n_col[1] = n_gen*n_gen + n_addcov + (n_gen*n_gen-1)*n_intcov;
/* expand col2drop */
if(n_col2drop) {
allocate_int(n_col[1], &allcol2drop);
expand_col2drop(n_gen, n_addcov, n_intcov,
col2drop, allcol2drop);
}
/* revised numbers of parameters */
if(n_col2drop) {
n_col_rev[0] = 0;
for(i=0; i<n_col[0]; i++)
if(!allcol2drop[i]) n_col_rev[0]++;
n_col_rev[1] = n_col_rev[0];
for(i=n_col[0]; i<n_col[1]; i++)
if(!allcol2drop[i]) n_col_rev[1]++;
}
else {
n_col_rev[0] = n_col[0];
n_col_rev[1] = n_col[1];
}
/* allocate workspaces */
wts = (double *)R_alloc(2*n_gen*(n_gen+1)*n_ind, sizeof(double));
reorg_errlod(n_ind, n_gen, wts, &Wts1);
reorg_errlod(n_ind, n_gen, wts+n_gen*n_ind, &Wts2);
reorg_genoprob(n_ind, n_gen, n_gen, wts+2*n_gen*n_ind, &Wts12);
reorg_genoprob(n_ind, n_gen, n_gen, wts+n_gen*(n_gen+2)*n_ind, &Probs);
work1 = (double *)R_alloc(n_col[1]*n_col[1], sizeof(double));
work2 = (double *)R_alloc(n_col[1], sizeof(double));
param = (double *)R_alloc(n_col[1]+1, sizeof(double));
oldparam = (double *)R_alloc(n_col[1]+1, sizeof(double));
/* recenter phenotype to have mean 0, for
possibly increased numerical stability */
for(j=0, temp=0.0; j<n_ind; j++) temp += pheno[j];
temp /= (double)n_ind;
for(j=0; j<n_ind; j++) pheno[j] -= temp;
/* adjust phenotypes and covariates with weights */
/* Note: weights are actually sqrt(weights) */
sw = 0.0;
for(i=0; i<n_ind; i++) {
pheno[i] *= 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];
sw += log(weights[i]); /* sum of log weights */
}
sw /= log(10.0); /* make log 10 */
/* begin loop over pairs of positions */
for(i1=0; i1<n_pos-1; i1++) {
for(i2=i1+1; i2<n_pos; i2++) { /* loop over positions */
nit[0] = nit[1] = 0;
llik[0] = llik[1] = NA_REAL;
/* copy the parts from Pairprob into Probs */
for(j=0; j<n_ind; j++)
for(k1=0; k1<n_gen; k1++)
for(k2=0; k2<n_gen; k2++)
Probs[k1][k2][j] = Pairprob[k1][k2][i1][i2][j];
for(m=0; m<2; m++) { /* loop over add've model and full model */
/* initial estimates */
for(j=0; j<n_ind; j++) {
for(k1=0; k1<n_gen; k1++) {
Wts1[k1][j] = Wts2[k1][j] = 0.0;
for(k2=0; k2<n_gen; k2++) {
Wts1[k1][j] += Probs[k1][k2][j];
Wts2[k1][j] += Probs[k2][k1][j];
}
}
}
scantwo_em_mstep(n_ind, n_gen, n_gen, Addcov, n_addcov,
Intcov, n_intcov, pheno, weights, Probs, Wts1, Wts2,
oldparam, m, work1, work2, &error_flag,
n_col2drop, allcol2drop, verbose);
if(error_flag) {
if(verbose>1)
Rprintf(" [%3d %3d] %1d: Initial model had error.\n",
i1+1, i2+1, m+1);
}
else { /* only proceed if there's no error */
oldllik = scantwo_em_loglik(n_ind, n_gen, n_gen, Probs, Wts12,
Wts1, Wts2, Addcov, n_addcov, Intcov,
n_intcov, pheno, weights, oldparam, m,
n_col2drop, allcol2drop);
if(verbose>2)
Rprintf(" [%3d %3d] %1d %9.3lf\n",
i1+1, i2+1, m+1, oldllik);
for(r=0; r<maxit; r++) { /* loop over iterations */
R_CheckUserInterrupt(); /* check for ^C */
scantwo_em_estep(n_ind, n_gen, n_gen, Probs, Wts12,
Wts1, Wts2, Addcov, n_addcov, Intcov,
n_intcov, pheno, weights, oldparam, m, 1,
n_col2drop, allcol2drop);
scantwo_em_mstep(n_ind, n_gen, n_gen, Addcov, n_addcov,
Intcov, n_intcov, pheno, weights, Wts12, Wts1,
Wts2, param, m, work1, work2, &error_flag,
n_col2drop, allcol2drop, verbose);
if(error_flag) {
flag=0;
if(verbose>1)
Rprintf(" [%3d %3d] %1d %4d: Error in mstep\n",
i1+1, i2+1, m+1, r+1);
break;
}
llik[m] = scantwo_em_loglik(n_ind, n_gen, n_gen, Probs, Wts12,
Wts1, Wts2, Addcov, n_addcov, Intcov,
n_intcov, pheno, weights, param, m,
n_col2drop, allcol2drop);
if(verbose>1) { /* print log likelihood */
if(verbose>2)
Rprintf(" [%3d %3d] %1d %4d %9.6lf\n",
i1+1, i2+1, m+1, r+1, (llik[m]-oldllik));
if(llik[m] < oldllik-tol)
Rprintf("** [%3d %3d] %1d %4d %9.6lf **\n",
i1+1, i2+1, m+1, r+1, (llik[m]-oldllik));
if(verbose>3) { /* print parameters */
for(j=0; j<n_col_rev[m]; j++)
Rprintf(" %7.3lf", param[j]);
Rprintf("\n");
}
}
flag = 1;
/* use log likelihood only to check for convergence */
if(llik[m]-oldllik < tol) {
flag = 0;
break;
}
oldllik = llik[m];
for(j=0; j<n_col[m]+1; j++) oldparam[j] = param[j];
} /* loop over EM iterations */
nit[m] = r+1;
if(flag) {
if(verbose>1)
Rprintf("** [%3d %3d] %1d Didn't converge! **\n",
i1+1, i2+1, m+1);
warning("Didn't converge!\n");
}
} /* no error in getting initial estimates */
} /* loop over model */
if(verbose>1) { /* print likelihoods */
Rprintf(" [%3d %3d] %4d %4d %9.6lf",
i1+1, i2+1, nit[0], nit[1], llik[1]-llik[0]);
if(llik[1] < llik[0]) Rprintf(" ****");
Rprintf("\n");
}
Result[i2][i1] = -(llik[0]+sw);
Result[i1][i2] = -(llik[1]+sw); /* sw = sum[log10(weights)] */
} /* position 2 */
} /* position 1 */
}
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 scantwo_1chr_hk(int n_ind, int n_pos, int n_gen, double ***Genoprob,
double *****Pairprob, double **Addcov, int n_addcov,
double **Intcov, int n_intcov, double *pheno, int nphe,
double *weights, double ***Result, int n_col2drop,
int *col2drop)
{
int n_col_a, n_col_f, n_gen_sq, multivar=0, rank=0, n_col_a_temp, n_col_f_temp;
int itmp, i, i2, j, k, k2, k3, s, nrss, lwork, info, ind_idx;
/* additive model working arrays */
/* double *dwork_add, *x_add, *x_bk_add, *singular_add, *work_add,
*yfit_add, *coef_add; */
/* full model working arrays */
/* double *dwork_full, *x_full, *x_bk_full, *singular_full, *work_full,
*yfit_full, *coef_full;*/
double *dwork, *x, *x_bk, *singular, *work, *yfit, *coef, *tmppheno;
double tol=TOL, dtmp=0;
int *allcol2drop;
/* number of rss */
if( (nphe==1) || (multivar==1) )
nrss = 1;
else
nrss = nphe;
/* tolerance for linear regression */
tol = TOL;
n_gen_sq = n_gen*n_gen;
/* no. param in additive QTL model */
n_col_a = (n_gen*2-1)+n_addcov+n_intcov*(n_gen-1)*2;
/* no. param 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_gen, n_addcov, n_intcov,
col2drop, allcol2drop);
}
/* allocate space and set things up - I will leave multivariate model at this time */
tmppheno = (double *)R_alloc(n_ind*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 = (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 = (double *)R_alloc(n_col_f + lwork + 2*n_ind*n_col_f + n_ind*nphe + n_col_f*nphe,
sizeof(double));
/* split memory block */
lwork = 3*n_col_f + MAX(n_ind, nphe);
singular = dwork;
work = singular + n_col_f;
x = work + lwork;
x_bk = x + n_ind*n_col_f;
yfit = x_bk + n_ind*n_col_f;
coef = yfit + n_ind*nphe;
/***************************
* finish memory allocation
***************************/
/* modify pheno, Addcov and Intcov with 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];
}
for(i=0; i<n_pos-1; i++) {
for(i2=i+1; i2<n_pos; i2++) { /* loop over pairs of positions */
R_CheckUserInterrupt(); /* check for ^C */
/* ADDITIVE MODEL */
rank = n_col_a;
/* fill up X matrix */
for(j=0; j<n_ind; j++) {
for(k=0, s=0; k<n_gen; k++, s++) /* QTL 1 */
x[j+s*n_ind] = Genoprob[k][i][j]*weights[j]; /* s keeps track of column */
for(k=0; k<n_gen-1; k++,s++) /* QTL 2 */
x[j+s*n_ind] = Genoprob[k][i2][j]*weights[j];
for(k=0; k<n_addcov; k++, s++) /* additive covariates */
x[j+s*n_ind] = Addcov[k][j];
for(k2=0; k2<n_intcov; k2++) {
for(k=0; k<n_gen-1; k++, s++) /* interactive x QTL 1 */
x[j+s*n_ind] = Genoprob[k][i][j]*Intcov[k2][j];
for(k=0; k<n_gen-1; k++, s++) /* interactive x QTL 2 */
x[j+s*n_ind] = Genoprob[k][i2][j]*Intcov[k2][j];
}
}
/* drop cols */
n_col_a_temp = n_col_a;
if(n_col2drop)
dropcol_x(&n_col_a_temp, n_ind, allcol2drop, x);
rank = n_col_a_temp;
/* linear regression of phenotype on QTL genotype probabilities */
/* make a copy of x matrix, we may need it */
memcpy(x_bk, x, n_ind*n_col_a_temp*sizeof(double));
/* copy pheno to tmppheno, because dgelss will destroy
the input pheno array */
memcpy(tmppheno, pheno, n_ind*nphe*sizeof(double));
/* Call LAPACK engine DGELSS to do linear regression.
Note that DGELSS doesn't have the assumption that X is full rank. */
/* Pass all arguments to Fortran by reference */
mydgelss (&n_ind, &n_col_a_temp, &nphe, x, x_bk, pheno, tmppheno,
singular, &tol, &rank, work, &lwork, &info);
/*
F77_CALL(dqrls)(x, &n_ind, &n_col_a, pheno, &ny, &tol, coef, resid,
qty, &k, jpvt, qraux, work);*/
/* RSS */
/* calculate residual sum of squares */
if(nphe == 1) { /*only one phenotype */
/* if the design matrix is full rank */
if(rank == n_col_a_temp) {
for (itmp=rank, dtmp=0.0; itmp<n_ind; itmp++)
dtmp += tmppheno[itmp]*tmppheno[itmp];
}
else {
/* the design matrix is not full rank, this is trouble */
/* calculate the fitted value */
matmult(yfit, x_bk, n_ind, n_col_a_temp, tmppheno, 1);
/* calculate rss */
for (itmp=0, dtmp=0.0; itmp<n_ind; itmp++)
dtmp += (pheno[itmp]-yfit[itmp]) * (pheno[itmp]-yfit[itmp]);
}
Result[0][i2][i] = log10(dtmp);
}
else { /* multiple phenotypes */
if(multivar == 1) { /* multivariate model, I will leave it now */
}
else{
if(rank == n_col_a_temp) { /* design matrix is of full rank, this is easier */
for(itmp=0, ind_idx=0; itmp<nrss; itmp++, ind_idx+=n_ind) { /* loop thru phenotypes */
for(j=rank, dtmp=0.0; j<n_ind; j++)
dtmp += tmppheno[ind_idx+j] * tmppheno[ind_idx+j];
Result[itmp][i2][i] = log10(dtmp);
}
}
else { /* design matrix is singular, this is troubler */
/* note that the result tmppheno has dimension n_ind x nphe,
the first ncolx rows contains the estimates. */
for (itmp=0; itmp<nphe; itmp++)
memcpy(coef+itmp*n_col_a_temp, tmppheno+itmp*n_ind, n_col_a_temp*sizeof(double));
/* calculate yfit */
matmult(yfit, x_bk, n_ind, n_col_a_temp, coef, nphe);
/* calculate residual, put the result in tmppheno */
for (itmp=0; itmp<n_ind*nphe; itmp++)
tmppheno[itmp] = pheno[itmp] - yfit[itmp];
for(itmp=0; itmp<nrss; itmp++) { /* loop thru phenotypes */
ind_idx = itmp*n_ind;
for(j=0, dtmp=0.0; j<n_ind; j++)
dtmp += tmppheno[ind_idx+j] * tmppheno[ind_idx+j];
Result[itmp][i2][i] = log10(dtmp);
}
}
}
}
/* INTERACTIVE MODEL */
rank = n_col_f;
/* fill up X matrix */
for(j=0; j<n_ind; j++) {
for(k=0, s=0; k<n_gen; k++, s++) /* QTL 1 */
x[j+s*n_ind] = Genoprob[k][i][j]*weights[j]; /* s keeps track of column */
for(k=0; k<n_gen-1; k++,s++) /* QTL 2 */
x[j+s*n_ind] = Genoprob[k][i2][j]*weights[j];
for(k=0; k<n_addcov; k++, s++) /* additive covariates */
x[j+s*n_ind] = Addcov[k][j];
for(k2=0; k2<n_intcov; k2++) {
for(k=0; k<n_gen-1; k++,s++) /* interactive x QTL 1 */
x[j+s*n_ind] = Genoprob[k][i][j]*Intcov[k2][j];
for(k=0; k<n_gen-1; k++,s++) /* interactive x QTL 2 */
x[j+s*n_ind] = Genoprob[k][i2][j]*Intcov[k2][j];
}
for(k=0; k<n_gen-1; k++)
for(k2=0; k2<n_gen-1; k2++,s++) /* QTL 1 x QTL 2 */
x[j+s*n_ind] = Pairprob[k][k2][i][i2][j]*weights[j];
for(k3=0; k3<n_intcov; k3++)
for(k=0; k<n_gen-1; k++) /* interactive x QTL 1 x QTL 2 */
for(k2=0; k2<n_gen-1; k2++,s++)
x[j+s*n_ind] = Pairprob[k][k2][i][i2][j]*Intcov[k3][j];
}
/* drop x's */
n_col_f_temp = n_col_f;
if(n_col2drop)
dropcol_x(&n_col_f_temp, n_ind, allcol2drop, x);
rank = n_col_f_temp;
/* linear regression of phenotype on QTL genotype probabilities */
/* make a copy of x matrix, we may need it */
memcpy(x_bk, x, n_ind*n_col_f_temp*sizeof(double));
/* copy pheno to tmppheno, because dgelss will destroy
the input pheno array */
memcpy(tmppheno, pheno, n_ind*nphe*sizeof(double));
/* Call LAPACK engine DGELSS to do linear regression.
Note that DGELSS doesn't have the assumption that X is full rank. */
/* Pass all arguments to Fortran by reference */
mydgelss (&n_ind, &n_col_f_temp, &nphe, x, x_bk, pheno, tmppheno,
singular, &tol, &rank, work, &lwork, &info);
/* calculate residual sum of squares */
if(nphe == 1) { /*only one phenotype */
/* if the design matrix is full rank */
if(rank == n_col_f_temp) {
for (itmp=rank, dtmp=0.0; itmp<n_ind; itmp++)
dtmp += tmppheno[itmp]*tmppheno[itmp];
}
else {
/* the design matrix is not full rank, this is trouble */
/* calculate the fitted value */
/* matmult(yfit, x_bk, n_ind, n_col_f_temp, tmppheno, 1); */
matmult(yfit, x_bk, n_ind, n_col_f_temp, tmppheno, 1);
/* calculate rss */
for (itmp=0, dtmp=0.0; itmp<n_ind; itmp++)
dtmp += (pheno[itmp]-yfit[itmp]) * (pheno[itmp]-yfit[itmp]);
}
Result[0][i][i2] = log10(dtmp);
}
else { /* multiple phenotypes */
if(multivar == 1) { /* multivariate model */
}
else{
if(rank == n_col_f_temp) { /* design matrix is of full rank, this is easier */
for(itmp=0; itmp<nrss; itmp++) { /* loop thru phenotypes */
ind_idx = itmp*n_ind;
for(j=rank, dtmp=0.0; j<n_ind; j++)
dtmp += tmppheno[ind_idx+j] * tmppheno[ind_idx+j];
Result[itmp][i][i2] = log10(dtmp);
}
}
else { /* design matrix is singular, this is troubler */
/* note that the result tmppheno has dimension n_ind x nphe,
the first ncolx rows contains the estimates. */
for (itmp=0; itmp<nphe; itmp++)
memcpy(coef+itmp*n_col_f_temp, tmppheno+itmp*n_ind, n_col_f_temp*sizeof(double));
/* calculate yfit */
matmult(yfit, x_bk, n_ind, n_col_f_temp, coef, nphe);
/* calculate residual, put the result in tmppheno */
for (itmp=0; itmp<n_ind*nphe; itmp++)
tmppheno[itmp] = pheno[itmp] - yfit[itmp];
for(itmp=0; itmp<nrss; itmp++) { /* loop thru phenotypes */
ind_idx = itmp*n_ind;
for(j=0, dtmp=0.0; j<n_ind; j++)
dtmp += tmppheno[ind_idx+j] * tmppheno[ind_idx+j];
Result[itmp][i][i2] = log10(dtmp);
}
}
}
}
/* convert to LODs */
for(itmp=0; itmp < nphe; itmp++) {
Result[itmp][i2][i] = (double)n_ind/2.0*Result[itmp][i2][i];
Result[itmp][i][i2] = (double)n_ind/2.0*
Result[itmp][i][i2];
}
} /* end loop over positions */
}
}
