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 */ }