//1999-02-18，鲍捷，快速浮雕效果
//只对灰度图像有效
BOOL VPicEx::QuickEmboss()
{
imgdes *srcimg=GetImgDes();
imgdes image1;
imgdes tmpsrc;
int cols, rows, rcode;
cols = CALC_WIDTH(srcimg);
rows = CALC_HEIGHT(srcimg);
allocimage(&tmpsrc, cols, rows, 8);
copyimage(srcimg, &tmpsrc);
allocimage(&image1, cols, rows, 8);
negative(&tmpsrc, &image1);
image1.stx = 1; image1.sty = 1;
wtaverage(50, &tmpsrc, &image1, &tmpsrc);
expandcontrast(100, 155, &tmpsrc, &tmpsrc);
rcode = copyimage(&tmpsrc, srcimg);
freeimage(&image1);
freeimage(&tmpsrc);
return(rcode == NO_ERROR);
}
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 fitqtl_imp_binary(int n_ind, int n_qtl, int *n_gen, int n_draws,
int ***Draws, double **Cov, int n_cov,
int *model, int n_int, double *pheno, int get_ests,
double *lod, int *df, double *ests, double *ests_covar,
double *design_mat, double tol, int maxit, int *matrix_rank)
{
/* create local variables */
int i, j, ii, jj, n_qc, itmp; /* loop variants and temp variables */
double llik, llik0, *LOD_array;
double *the_ests, *the_covar, **TheEsts, ***TheCovar;
double *dwork, **Ests_covar, tot_wt=0.0, *wts;
double **Covar_mean, **Mean_covar, *mean_ests; /* for ests and cov matrix */
int *iwork, sizefull, n_trim, *index;
/* number to trim from each end of the imputations */
n_trim = (int) floor( 0.5*log(n_draws)/log(2.0) );
/* initialization */
sizefull = 1;
/* calculate the dimension of the design matrix for full model */
n_qc = n_qtl+n_cov; /* total number of QTLs and covariates */
/* for additive QTLs and covariates*/
for(i=0; i<n_qc; i++)
sizefull += n_gen[i];
/* for interactions, loop thru all interactions */
for(i=0; i<n_int; i++) {
for(j=0, itmp=1; j<n_qc; j++) {
if(model[i*n_qc+j])
itmp *= n_gen[j];
}
sizefull += itmp;
}
/* reorganize Ests_covar for easy use later */
/* and make space for estimates and covariance matrix */
if(get_ests) {
reorg_errlod(sizefull, sizefull, ests_covar, &Ests_covar);
allocate_double(sizefull*n_draws, &the_ests);
allocate_double(sizefull*sizefull*n_draws, &the_covar);
/* I need to save all of the estimates and covariance matrices */
reorg_errlod(sizefull, n_draws, the_ests, &TheEsts);
reorg_genoprob(sizefull, sizefull, n_draws, the_covar, &TheCovar);
allocate_dmatrix(sizefull, sizefull, &Mean_covar);
allocate_dmatrix(sizefull, sizefull, &Covar_mean);
allocate_double(sizefull, &mean_ests);
allocate_double(n_draws, &wts);
}
/* allocate memory for working arrays, total memory is
sizefull*n_ind+6*n_ind+4*sizefull for double array,
and sizefull for integer array.
All memory will be allocated one time and split later */
dwork = (double *)R_alloc(sizefull*n_ind+6*n_ind+4*sizefull,
sizeof(double));
iwork = (int *)R_alloc(sizefull, sizeof(int));
index = (int *)R_alloc(n_draws, sizeof(int));
LOD_array = (double *)R_alloc(n_draws, sizeof(double));
/* calculate null model log10 likelihood */
llik0 = nullLODbin(pheno, n_ind);
*matrix_rank = n_ind;
/* loop over imputations */
for(i=0; i<n_draws; i++) {
R_CheckUserInterrupt(); /* check for ^C */
/* calculate alternative model RSS */
llik = galtLODimpbin(pheno, n_ind, n_gen, n_qtl, Draws[i],
Cov, n_cov, model, n_int, dwork, iwork, sizefull,
get_ests, ests, Ests_covar, design_mat,
tol, maxit, matrix_rank);
/* calculate the LOD score in this imputation */
LOD_array[i] = (llik - llik0);
/* if getting estimates, calculate the weights */
if(get_ests) {
wts[i] = LOD_array[i]*log(10.0);
if(i==0) tot_wt = wts[i];
else tot_wt = addlog(tot_wt, wts[i]);
for(ii=0; ii<sizefull; ii++) {
TheEsts[i][ii] = ests[ii];
for(jj=ii; jj<sizefull; jj++)
TheCovar[i][ii][jj] = Ests_covar[ii][jj];
}
}
} /* end loop over imputations */
/* sort the lod scores, and trim the weights */
if(get_ests) {
for(i=0; i<n_draws; i++) {
index[i] = i;
wts[i] = exp(wts[i]-tot_wt);
}
rsort_with_index(LOD_array, index, n_draws);
for(i=0; i<n_trim; i++)
wts[index[i]] = wts[index[n_draws-i-1]] = 0.0;
/* re-scale wts */
tot_wt = 0.0;
for(i=0; i<n_draws; i++) tot_wt += wts[i];
for(i=0; i<n_draws; i++) wts[i] /= tot_wt;
}
/* calculate the result LOD score */
*lod = wtaverage(LOD_array, n_draws);
/* degree of freedom equals to the number of columns of x minus 1 (mean) */
*df = sizefull - 1;
/* get means and variances and covariances of estimates */
if(get_ests) {
for(i=0; i<n_draws; i++) {
if(i==0) {
for(ii=0; ii<sizefull; ii++) {
mean_ests[ii] = TheEsts[i][ii] * wts[i];
for(jj=ii; jj<sizefull; jj++) {
Mean_covar[ii][jj] = TheCovar[i][ii][jj] * wts[i];
Covar_mean[ii][jj] = 0.0;
}
}
}
else {
for(ii=0; ii<sizefull; ii++) {
mean_ests[ii] += TheEsts[i][ii]*wts[i];
for(jj=ii; jj<sizefull; jj++) {
Mean_covar[ii][jj] += TheCovar[i][ii][jj]*wts[i];
Covar_mean[ii][jj] += (TheEsts[i][ii]-TheEsts[0][ii])*
(TheEsts[i][jj]-TheEsts[0][jj])*wts[i];
}
}
}
}
for(i=0; i<sizefull; i++) {
ests[i] = mean_ests[i];
for(j=i; j<sizefull; j++) {
Covar_mean[i][j] = (Covar_mean[i][j] - (mean_ests[i]-TheEsts[0][i])*
(mean_ests[j]-TheEsts[0][j]))*(double)n_draws/(double)(n_draws-1);
Ests_covar[i][j] = Ests_covar[j][i] = Mean_covar[i][j] + Covar_mean[i][j];
}
}
} /* done getting estimates */
}
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 */
}
