void indexx(unsigned int n, double *arr, unsigned int *indx) {
unsigned int i, j, k, l;
unsigned int indxt, itemp, ir;
unsigned int *istack, jstack;
double a;
if (n < 1) nrerror("\n n of zero (0) length in indexx().");
l = 1;
ir = n;
jstack = 0;
istack = uivector(1, NSTACK);
for (j=1; j<=n; j++) indx[j]=j;
for (;;) {
if (ir-l < M) {
for (j = l+1; j <= ir; j++) {
indxt = indx[j];
a = arr[indxt];
for (i=j-1; i>=l; i--) {
if (arr[indx[i]] <= a) break;
indx[i+1] = indx[i];
}
indx[i+1] = indxt;
}
if (jstack == 0) break;
ir = istack[jstack--];
l = istack[jstack--];
}
else {
k = (l+ir) >> 1;
SWAP(indx[k], indx[l+1]);
if (arr[indx[l]] > arr[indx[ir]]) {
SWAP(indx[l], indx[ir])
}
if (arr[indx[l+1]] > arr[indx[ir]]) {
SWAP(indx[l+1], indx[ir])
}
if (arr[indx[l]] > arr[indx[l+1]]) {
SWAP(indx[l], indx[l+1])
}
i = l+1;
j = ir;
indxt = indx[l+1];
a = arr[indxt];
for (;;) {
do i++; while (arr[indx[i]] < a);
do j--; while (arr[indx[j]] > a);
if (j < i) break;
SWAP(indx[i], indx[j])
}
indx[l+1] = indx[j];
indx[j] = indxt;
jstack += 2;
if (jstack > NSTACK) nrerror("NSTACK too small in indexx().");
if (ir-i+1 >= j-l) {
istack[jstack] = ir;
istack[jstack-1] = i;
ir = j-1;
}
else {
istack[jstack] = j-1;
istack[jstack-1] = l;
l = i;
}
}
}
free_uivector(istack, 1, NSTACK);
}
void getCRPerformance (uint mode,
uint obsSize,
double **responsePtr,
double **conditionalMortality,
uint *ensembleDenPtr,
double *performanceVector) {
uint mRecordSize;
int **mpSign;
uint *mRecordIndex;
uint *meIndividualSize;
uint **eIndividual;
double concordanceIndex;
uint j;
if (!(RF_opt & OPT_COMP_RISK)) {
Rprintf("\nRF-SRC: *** ERROR *** ");
Rprintf("\nRF-SRC: Attempt at conditional performance updates in a non-CR analysis.");
Rprintf("\nRF-SRC: Please Contact Technical Support.");
error("\nRF-SRC: The application will now exit.\n");
}
if (RF_mStatusSize > 0) {
if (mode != RF_PRED) {
mRecordSize = RF_mRecordSize;
mpSign = RF_mpSign;
mRecordIndex = RF_mRecordIndex;
}
else {
mRecordSize = RF_fmRecordSize;
mpSign = RF_fmpSign;
mRecordIndex = RF_fmRecordIndex;
}
meIndividualSize = uivector(1, RF_eventTypeSize);
eIndividual = (uint **) new_vvector(1, RF_eventTypeSize, NRUTIL_UPTR);
for (j = 1; j <= RF_eventTypeSize; j++) {
eIndividual[j] = uivector(1, RF_eIndividualSize[j] + RF_mStatusSize + 1);
}
updateEventTypeSubsets(responsePtr[RF_statusIndex], mRecordSize, mpSign, mRecordIndex, meIndividualSize, eIndividual);
}
else {
meIndividualSize = RF_eIndividualSize;
eIndividual = RF_eIndividualIn;
}
double *subsettedTime = dvector(1, obsSize);
double *subsettedStatus = dvector(1, obsSize);
double *subsettedMortality = dvector(1, obsSize);
uint *subsettedEnsembleDen = uivector(1, obsSize);
for (j = 1; j <= RF_eventTypeSize; j++) {
getConditionalConcordanceArrays(j,
responsePtr[RF_timeIndex],
responsePtr[RF_statusIndex],
conditionalMortality[j],
ensembleDenPtr,
meIndividualSize,
eIndividual,
subsettedTime,
subsettedStatus,
subsettedMortality,
subsettedEnsembleDen);
concordanceIndex = getConcordanceIndex(1,
meIndividualSize[j],
subsettedTime,
subsettedStatus,
subsettedMortality,
subsettedEnsembleDen);
if (ISNA(concordanceIndex)) {
performanceVector[j] = NA_REAL;
}
else {
performanceVector[j] = concordanceIndex;
}
}
if (RF_mStatusSize > 0) {
free_uivector(meIndividualSize, 1, RF_eventTypeSize);
for (j = 1; j <= RF_eventTypeSize; j++) {
free_uivector(eIndividual[j], 1, RF_eIndividualSize[j] + RF_mStatusSize + 1);
}
free_new_vvector(eIndividual, 1, RF_eventTypeSize, NRUTIL_UPTR);
}
free_dvector(subsettedTime, 1, obsSize);
free_dvector(subsettedStatus, 1, obsSize);
free_dvector(subsettedMortality, 1, obsSize);
free_uivector(subsettedEnsembleDen, 1, obsSize);
}
void getVimpPermute(uint mode,
Node *rootPtr,
double **predictorPtr,
uint b,
uint obsSize,
uint varCount,
char selectionFlag) {
Node *terminalNode;
uint permuteObsSize = 0;
uint *indexVIMP;
uint *permuteVIMP;
uint i, j, k, p;
switch (mode) {
case RSF_GROW:
permuteObsSize = _oobSampleSize[b];
break;
case RSF_PRED:
permuteObsSize = _fobservationSize;
break;
case RSF_INTR:
permuteObsSize = _foobSampleSize[b];
break;
default:
Rprintf("\nRSF: *** ERROR *** ");
Rprintf("\nRSF: Unknown case in switch encountered. ");
Rprintf("\nRSF: Please Contact Technical Support.");
error("\nRSF: The application will now exit.\n");
break;
}
indexVIMP = uivector(1, permuteObsSize);
permuteVIMP = uivector(1, permuteObsSize);
k = 0;
for (i=1; i <= obsSize; i++) {
if ((_genericMembershipFlag[_individualIndex[i]] == selectionFlag) || (selectionFlag == ACTIVE)) {
k++;
indexVIMP[k] = i;
}
}
if (k != permuteObsSize) {
Rprintf("\nRSF: *** ERROR *** ");
Rprintf("\nRSF: VIMP candidate selection failed.");
Rprintf("\nRSF: %10d available, %10d selected.", permuteObsSize, k);
Rprintf("\nRSF: Please Contact Technical Support.");
error("\nRSF: The application will now exit.\n");
}
if (!(_opt & (~OPT_VIMP) & OPT_VIMP_JOIN)) {
double *originalVIMP = dvector(1, permuteObsSize);
for (p=1; p <= varCount; p++) {
for (k=1; k<= permuteObsSize; k++) {
originalVIMP[k] = predictorPtr[_predictorIndex[p]][indexVIMP[k]];
}
permute(permuteObsSize, permuteVIMP);
for (k=1; k <= permuteObsSize; k++) {
predictorPtr[_predictorIndex[p]][indexVIMP[k]] = originalVIMP[permuteVIMP[k]];
}
for (i=1; i <= obsSize; i++) {
if ((_genericMembershipFlag[_individualIndex[i]] == selectionFlag) || (selectionFlag == ACTIVE)) {
terminalNode = getProxyMember(rootPtr, predictorPtr, i);
if (!ISNA(terminalNode -> mortality)) {
_vimpMortality[p][i] += terminalNode -> mortality;
if (_eventTypeSize > 1) {
for (j=1; j<= _eventTypeSize; j++) {
_crVimpPOE[p][j][i] += (double) (terminalNode -> poe)[j] / (terminalNode -> eventCount);
for (k=1; k <= _sortedTimeInterestSize; k++) {
_crVimpEnsemble[p][j][k][i] += terminalNode -> subSurvival[j][k];
}
}
}
}
else {
if (_opt & OPT_VOUT_TYPE) {
_oobVimpInvalidDen[p][i] ++;
}
else {
Rprintf("\nRSF: *** ERROR *** ");
Rprintf("\nRSF: NA encountered for mortality in VIMP.");
Rprintf("\nRSF: Please Contact Technical Support.");
error("\nRSF: The application will now exit.\n");
}
}
}
}
for (k=1; k <= permuteObsSize; k++) {
predictorPtr[_predictorIndex[p]][indexVIMP[k]] = originalVIMP[k];
}
}
free_dvector(originalVIMP, 1, permuteObsSize);
}
else {
double **intrOriginalVIMP = dmatrix(1, _intrPredictorSize, 1, permuteObsSize);
for (p=1; p <= _intrPredictorSize; p++) {
for (k=1; k<= permuteObsSize; k++) {
intrOriginalVIMP[p][k] = predictorPtr[_intrPredictor[p]][indexVIMP[k]];
}
permute(permuteObsSize, permuteVIMP);
for (k=1; k <= permuteObsSize; k++) {
predictorPtr[_intrPredictor[p]][indexVIMP[k]] = intrOriginalVIMP[p][permuteVIMP[k]];
}
}
for (i=1; i <= _fobservationSize; i++) {
if ( _bootMembershipFlag[_intrIndividual[i]] == FALSE ) {
terminalNode = getProxyMember(rootPtr, predictorPtr, i);
if (!ISNA(terminalNode -> mortality)) {
_vimpMortality[1][i] += terminalNode -> mortality;
if (_eventTypeSize > 1) {
for (j=1; j<= _eventTypeSize; j++) {
_crVimpPOE[1][j][i] += (double) (terminalNode -> poe)[j] / (terminalNode -> eventCount);
for (k=1; k <= _sortedTimeInterestSize; k++) {
_crVimpEnsemble[1][j][k][i] += terminalNode -> subSurvival[j][k];
}
}
}
}
else {
if (_opt & OPT_VOUT_TYPE) {
_oobVimpInvalidDen[1][i] ++;
}
else {
Rprintf("\nRSF: *** ERROR *** ");
Rprintf("\nRSF: NA encountered for mortality in VIMP.");
Rprintf("\nRSF: Please Contact Technical Support.");
error("\nRSF: The application will now exit.\n");
}
}
}
}
for (p=1; p <= _intrPredictorSize; p++) {
for (k=1; k <= permuteObsSize; k++) {
predictorPtr[_intrPredictor[p]][indexVIMP[k]] = intrOriginalVIMP[p][k];
}
}
free_dmatrix(intrOriginalVIMP, 1, _intrPredictorSize, 1, permuteObsSize);
}
free_uivector(indexVIMP, 1, permuteObsSize);
free_uivector(permuteVIMP, 1, permuteObsSize);
}
void finalizeVariableImportance(uint mode,
uint rejectedTreeCount,
char **dmRecordBootFlag,
double ***dmvImputation) {
uint obsSize = 0;
uint varCount = 0;
double *statusPtr = NULL;
double *timePtr = NULL;
uint *ensembleDenPtr = NULL;
double concordanceIndex;
int concordancePolarity;
char concordanceImputeFlag;
double *crPerformanceVector;
double ***crVimpMortality;
double value;
uint *denominatorCount;
uint i, j, k, p;
if (!(rejectedTreeCount < _forestSize)) {
Rprintf("\nRSF: *** WARNING *** ");
Rprintf("\nRSF: Insufficient trees for VIMP analysis. \n");
return;
}
if (!(_opt & OPT_VIMP)) {
Rprintf("\nRSF: *** WARNING *** ");
Rprintf("\nRSF: VIMP analysis requested while OPT bit not set. \n");
return;
}
crPerformanceVector = NULL;
crVimpMortality = NULL;
if (_opt & (OPT_POUT_TYPE)) {
concordancePolarity = -1;
}
else {
concordancePolarity = 1;
}
concordanceImputeFlag = FALSE;
switch (mode) {
case RSF_GROW:
obsSize = _observationSize;
varCount = _xSize;
statusPtr = _status;
timePtr = _time;
ensembleDenPtr = _oobEnsembleDen;
if (_mRecordSize > 0) {
concordanceImputeFlag = TRUE;
}
break;
case RSF_PRED:
obsSize = _fobservationSize;
varCount = _xSize;
statusPtr = _fstatus;
timePtr = rsf_ftime;
ensembleDenPtr = _fullEnsembleDen;
if (_fmRecordSize > 0) {
concordanceImputeFlag = TRUE;
}
break;
case RSF_INTR:
obsSize = _fobservationSize;
if (_opt & (~OPT_VIMP) & OPT_VIMP_JOIN) {
varCount = 1;
}
else {
varCount = _intrPredictorSize;
}
statusPtr = _fstatus;
timePtr = rsf_ftime;
ensembleDenPtr = _oobEnsembleDen;
if (_fmRecordSize > 0) {
concordanceImputeFlag = TRUE;
}
break;
default:
Rprintf("\nRSF: *** ERROR *** ");
Rprintf("\nRSF: Unknown case in switch encountered. ");
Rprintf("\nRSF: Please Contact Technical Support.");
error("\nRSF: The application will now exit.\n");
break;
}
if (_opt & OPT_VOUT_TYPE) {
denominatorCount = uivector(1, obsSize);
}
else {
denominatorCount = ensembleDenPtr;
}
if (_eventTypeSize > 1) {
crVimpMortality = dmatrix3(1, varCount, 1, _eventTypeSize, 1, obsSize);
crPerformanceVector = dvector(1, _eventTypeSize);
for (p=1; p <= varCount; p++) {
for (i = 1; i <= obsSize; i++) {
for (j = 1; j <= _eventTypeSize; j++) {
for (k = 1; k <= _sortedTimeInterestSize; k++) {
if(_crVimpEnsemble[p][j][k][i] > 0) {
if (_crVimpPOE[p][j][i] > 0) {
value = _crVimpEnsemble[p][j][k][i] / _crVimpPOE[p][j][i];
value = (value <= 1.0) ? value : 1.0;
_crVimpEnsemble[p][j][k][i] = - log (value);
}
else {
value = _crVimpEnsemble[p][j][k][i] / 1.0;
value = (value <= 1.0) ? value : 1.0;
_crVimpEnsemble[p][j][k][i] = - log (value);
}
}
else {
if (_crVimpPOE[p][j][i] > 0) {
if (k > 1) {
_crVimpEnsemble[p][j][k][i] = _crVimpEnsemble[p][j][k-1][i];
}
else {
_crVimpEnsemble[p][j][k][i] = 0.0;
}
}
else {
_crVimpEnsemble[p][j][k][i] = 1.0;
}
}
}
}
}
}
for (p = 1; p <= varCount; p++) {
for (j = 1; j <= _eventTypeSize; j++) {
for (i = 1; i <= obsSize; i++) {
crVimpMortality[p][j][i] = 0.0;
for (k = 1; k <= _sortedTimeInterestSize; k++) {
crVimpMortality[p][j][i] += _crVimpEnsemble[p][j][k][i];
}
}
}
}
}
if (concordanceImputeFlag == TRUE) {
imputeConcordance(mode,
_forestSize,
dmRecordBootFlag,
dmvImputation,
statusPtr,
timePtr);
}
for (p=1; p <= varCount; p++) {
for (i = 1; i <= obsSize; i++) {
if (_opt & OPT_VOUT_TYPE) {
denominatorCount[i] = ensembleDenPtr[i] - _oobVimpInvalidDen[p][i];
}
if (denominatorCount[i] != 0) {
_vimpMortality[p][i] = _vimpMortality[p][i] / denominatorCount[i];
}
}
concordanceIndex = getConcordanceIndex(concordancePolarity,
obsSize,
statusPtr,
timePtr,
_vimpMortality[p],
denominatorCount);
if (ISNA(concordanceIndex)) {
_importancePtr[1][p] = NA_REAL;
}
else {
_importancePtr[1][p] = 1 - concordanceIndex;
}
if (_eventTypeSize > 1) {
getConditionalPerformance(mode,
concordancePolarity,
obsSize,
statusPtr,
timePtr,
crVimpMortality[p],
denominatorCount,
crPerformanceVector);
for (j=1; j <=_eventTypeSize; j++) {
_importancePtr[1+j][p] = crPerformanceVector[j];
}
}
}
if (_eventTypeSize > 1) {
free_dvector(crPerformanceVector, 1, _eventTypeSize);
free_dmatrix3(crVimpMortality, 1, varCount, 1, _eventTypeSize, 1, obsSize);
}
if (_opt & OPT_VOUT_TYPE) {
free_uivector(denominatorCount, 1, obsSize);
}
}
void itegeppXXR(int *tog, double *lim, char **gent, double *qtrait,
int *xnp, double *likeres, char **freqres, char **hapres, char **desres)
{
char lino[10000], lin[10000];
char* CharNull = "\0"; /* 06.11.2014/SKn */
double likold,
pe, pex, /* 10.3. 2000 ROHDE */
*p2max,
gsum; /* 10.3. 2000 ROHDE */
int i, inp, it, j, k, ki, kj, h, s, glev, non,
ac[2],
drei,
null,
df = 0 /*SKn*/,
combinations,
nz,
iqual,
nhap,
*hlist,
**pimax,
h1x, h2x;
uint iterations, h1, h2;
bool loop;
// new for create design matrix (tog=0)
double pehh,
*peh;
/* Max. 16 SNPs */
if ( strlen(gent[0]) > 16 ) error ("Number of SNPs should smaller than 17.") ;
np = *xnp;
len = (int) (strlen(gent[0]) + 1);
mg = ivector(np);
merke = ivector(np);
nulmer = ivector(np);
ge = ivector(np);
hlist = ivector(np);
po = uivector(len);
geno = cmatrix(np, len);
max_prob = init_dvector(NULL, 0.0, np);
prob = init_dvector(NULL, 0.0, np);
hap = init_dvector (NULL, 0.0, Hapco);
hc = init_ivector (NULL, -1,Hapco);
po[0]=1;
for(i=1;i<len;i++)po[i] = 2*po[i-1];
combinations = po[len-1];
init_dvector(hap, 0.0, Hapco);
init_ivector (hc, -1,Hapco);
ng = 0;
/* read input data */
for(inp=0;inp<np;inp++){
drei = 0;
null = 0;
for (i=0; i<len-1; i++) {
if(i < len-1 && (gent[inp][i] < 48 || gent[inp][i] > 51) ){
Rprintf("%d %d %d\n",inp, i, gent[inp][i]);
//Rprintf("\n Error in data person %d\n",inp+1); /* ROHDE 15.03.2000 */
error("\n Error in data person %d\n",inp+1);;
}
if ( gent[inp][i] == '3' ) drei ++;
if ( gent[inp][i] == '0' ) null ++;
}
gent[inp][len-1] = '\0';
it = 1;
for (i=0; i<ng; i++) {
if ( strncmp (geno[i], gent[inp], len) == 0 ) {
/*** a certain genotype was found more than just once ***/
ge[inp] = i;
mg[i] ++;
it = 0;
merke[i] = drei;
break;
}
}
if (it) {
/*** a certain genotype was encountered the first time ***/
strcpy (geno[ng], gent[inp]);
ge[inp] = ng;
mg[ng] = 1;
merke[ng] = drei;
nulmer[ng] = null;
ng ++;
}
} /* end while */
People = np;
Loci = len-1;
/* end of reading sample data */
nall = 2 * np;
nstate = init_ivector (NULL, 0, ng);
mstate = init_ivector (NULL, 0, ng);
state = (uint***) calloc(ng , sizeof(uint**));
for (i=0; i<ng; i++) {
nz = po[merke[i]] * po[nulmer[i]] * po[nulmer[i]];
state[i] = uimatrix(nz, 2);
}
/*** sort genotypes by weights *******************************************/
genoProb = dvector(ng);
genoId = ivector(ng);
for (i=0; i<ng; i++) {
genoId[i] = i;
genoProb[i] = ((double)mg[i])/((double) po[merke[i]])/pow(4.0,nulmer[i]);
}
sortByProb(genoProb, genoId, ng);
glev=0;
for(i=0;i<ng;i++)if(genoProb[i] >= SignificanceLevel)glev++;
/*** process sorted genotypes ********************************************/
nh = 0;
for (i=0; i<glev; i++) {
/* printf("\n ng: %d glev: %d i: %d",ng,glev+1,i+1); */
rechap(genoId[i], 0, len-1);
/* printf("\n %s >> %d\n",geno[genoId[i]],mg[genoId[i]]);
for(k=0;k<16;k++)printf("%2d:%g ",hc[k],hap[k]);
printf("\n"); */
}
for (i=glev; i<ng; i++) {
s = 0;
/* printf("\n ng: %d glev: %d i: %d",ng,glev+1,i+1); */
for (j=0; j<nh; j++) {
ac[0] = hc[j];
for (k=j; k<nh; k++) {
ac[1] = hc[k];
if ( compatible(geno[genoId[i]], ac) ) {
state[genoId[i]][s][0] = j;
state[genoId[i]][s][1] = k;
s ++;
if ( j != k ) {
state[genoId[i]][s][0] = k;
state[genoId[i]][s][1] = j;
s ++;
}
}
}
}
nstate[genoId[i]] = s;
}
for (i=glev; i<ng; i++) {
addon(genoId[i]);
}
/* printf("\n");
printf("\ngloop: %d ng: %d glev: %d nh: %d\n",gloop,ng,glev,nh); */
/*** now comes the output that does not need simulated annealing *********/
first = 1; /*** start likelihood outside of annealing loops ***/
df = nh;
hapnew = init_dvector(NULL, 0.0, nh );
haptmp = init_dvector(NULL, 0.0, nh );
for (i=0; i<ng; i++)selprob(i);
likold = likea();
/* Continue computation of mean probabilities */
for(i=0;i<ng;i++)
for(j=0;j<mstate[i];j++) {
double pp = 0.0;
if ( nstate[i] > 1 ) {
h = state[i][j][0];
hapnew[h] += (double)mg[i] / (double)mstate[i];
h = state[i][j][1];
pp += hapnew[h];
hapnew[h] += ((double) mg[i]) / ((double) mstate[i]);
pp += hapnew[h];
}
else {
h = state[i][j][0];
hapnew[h] += 2.0 * ((double) mg[i]) / ((double) mstate[i]);
pp += hapnew[h];
}
}
non = 0;
for (i=0; i<nh; i++) {
if(hapnew[i]==0.0)non++;
else hapnew[i] /= (double) nall;
}
for (i=0; i<nh; i++) {
if(hapnew[i]==0.0)hapnew[i] = 0.0001/(double)non;
else hapnew[i] *= 0.9999;
}
iterations = 0;
first = 0;
do {
loop = 0;
iterations ++;
/* printf("gloop:%3d count: %d\n",gloop,iterations); */
/* Recompute mean probabilities */
for (i=0; i<nh; i++) {
if ( fabs(hap[i] - hapnew[i]) > LoopPrecision )
loop = 1;
hap[i] = hapnew[i];
}
init_dvector(prob, 0.0, np);
init_dvector(haptmp, 0.0, nh);
init_dvector(hapnew, 0.0, nh);
likold = likea();
for (i=0; i<nh; i++)
hapnew[i] /= (double) nall;
} while (loop);
/* Rprintf("\n");
Rprintf(" Results Ensemble means: \n\n"); */
nhap = 0;
j = 0;
for (i=0; i<nh; i++)
{
if ( hapnew[i] >= *lim ) {
/* 07.06.2007 S.Kn|ppel > Beschrdnken der geschdtzten Haplotypen. */
if ( (*tog==0) && ((nhap+1) > 1500) ) {
error ("Error in itegeppXXR: Too much estimated haplotypes. Increase option lim.") ;
}
if ( (*tog==1) && ((nhap+1) > 1500) ) {
error ("Error in itegeppXXR: Too much estimated haplotypes. Increase option lim.") ;
}
/* sprintf(lino,"\0"); 02.06.2015/SKn */
/* sprintf("%s", "%s", *lino, *CharNull);*/
sprintf(lino, "%s", CharNull);
printHaplotype(hc[i], len, lino);
/*
printf(" hapnew[%8d] = %7.4f (%7.4f)\n",
hc[i], hapnew[i], hap[i]);
*/
/* sprintf(lin,"%9.6f\0", hapnew[i]); 06.11.2014/SKn */
sprintf(lin,"%9.6f%s", hapnew[i], CharNull); /* 06.11.2014/SKn */
strcat(lino,lin);
strcpy(freqres[j],lino);
j++;
hlist[nhap++] = i;
}
}
k = 0;
htpp = init_uimatrix(NULL,0,nhap+1,nhap+1);
for(i=0;i<nhap+1;i++)
for(j=i;j<nhap+1;j++)htpp[i][j]=k++;
pgen = init_dmatrix(NULL,0.0,ng,(nhap+1)*(nhap+2)/2);
/* start find best states after MLE 10.3.2000 ROHDE */
pimax = imatrix(ng,10); /* ROHDE 10.3.2000 */
p2max = init_dvector(NULL,0.0,ng); /* ROHDE 10.3.2000 */
for(i=0;i<ng;i++)max_prob[i] = 0.0; /* ROHDE 10.3.2000 */
for (i=0;i<ng;i++){
for(j=0;j<10;j++)pimax[genoId[i]][j] = -1;
iqual=1;
for (j=0;j<nstate[genoId[i]];j++){
pe = hapnew[state[genoId[i]][j][0]] * hapnew[state[genoId[i]][j][1]];
if( state[genoId[i]][j][0] != state[genoId[i]][j][1] ) pe += pe;
if(pe > p2max[genoId[i]]){
if (pe > max_prob[genoId[i]]){
p2max[genoId[i]] = max_prob[genoId[i]];
max_prob[genoId[i]] = pe;
pimax[genoId[i]][0]=j;
for(k=1;k<10;k++)pimax[genoId[i]][k]=-1;
iqual = 1; /*** ROHDE 04.09.2001 ***/
}
else{
if (pe == max_prob[genoId[i]] && iqual < 9){
for(k=0;k<iqual;k++) if(state[genoId[i]][j][0] ==
state[genoId[i]][pimax[genoId[i]][k]][1]) pe=0.0;
if(pe > 0.0)pimax[genoId[i]][iqual++]=j;
}
else p2max[genoId[i]] = pe;
}
}
}
} /* end of maximum state search */
/* Rprintf("\n Haplotypes after MLE\n"); */
jjx = 0;
for(i=0;i<np;i++){
/* sprintf(lino,"%i %s >> \0",i, geno[ge[i]]); 06.11.2014/SKn */
sprintf(lino,"%i %s >> %s",i, geno[ge[i]], CharNull);
for(k=0;k<10;k++){
j = pimax[ge[i]][k];
if(j > -1){
if(k>0)pspace(len+3,lino); /*** ROHDE 11.09.2001 ***/
printHaplotype(hc[state[ge[i]][j][0]],len,lino);
strcat(lino," <> \0");
printHaplotype(hc[state[ge[i]][j][1]],len,lino);
sprintf(lin," P>> %9.7f D>> %9.7f",
max_prob[ge[i]],max_prob[ge[i]]-p2max[ge[i]]);
strcat(lino,lin);
} else break;
}
strcpy(hapres[jjx++],lino);
}
/* endfind best states after MLE 10.3.2000 ROHDE */
/* Rprintf("\n\n Likelihood = %f\n", likold);
Rprintf("\n"); */
/* sprintf(lino,"Likelihood = %f\0", likold); 06.11.2014/SKn */
sprintf(lino,"Likelihood = %f%s", likold, CharNull);
// strcpy(likeres[0],lino);
(*likeres) = likold ;
/* Sample over states for each genotype ***********************************/
for(i=0;i<ng;i++){
gsum = 0.0;
for(j=0;j<nstate[genoId[i]];j++){
h1 = state[genoId[i]][j][0];
h2 = state[genoId[i]][j][1];
h1x = h2x = 0;
for(ki=1;ki<=nhap;ki++) if( h1 == hlist[ki-1] ) h1x=ki;
for(kj=1;kj<=nhap;kj++) if( h2 == hlist[kj-1] ) h2x=kj;
if(h1x>0 && h2x>0){
if(h2x < h1x){ k=h1x; h1x=h2x; h2x=k;}
pgen[genoId[i]][htpp[h1x-1][h2x-1]] += hapnew[h1]*hapnew[h2];
gsum += hapnew[h1]*hapnew[h2];
}
else{ pgen[genoId[i]][htpp[nhap][nhap]] += hapnew[h1]*hapnew[h2];
gsum += hapnew[h1]*hapnew[h2];
}
}
for(k=0;k<(nhap+1)*(nhap+2)/2;k++)pgen[genoId[i]][k] /= gsum;
}
/* for(i=0;i<ng;i++){
Rprintf("i:%2d %s\t",i,geno[genoId[i]]);
for(ki=0;ki<nhap+1;ki++){
for(kj=ki;kj<nhap+1;kj++)
Rprintf("%4.2f ",pgen[genoId[i]][htpp[ki][kj]]);
if(kj<ki)printf("0.000\t ");
else printf("%4.2f\t",pgen[genoId[i]][htpp[ki][kj]]);
Rprintf("\t");
}
Rprintf("\n");
}
*/
jjx = 0;
if (*tog == 1){
for(i=0;i<np;i++){
/*
printf("\n%4s %s %4.2f >> ",pid[i],geno[ge[i]],qtrait[i]);
*/
strcpy(lino,"\0");
for(ki=0;ki<nhap;ki++){ /* each haplotype alone */
for(kj=ki;kj<nhap;kj++){
/* sprintf(lin,"%8.6f \0",pgen[ge[i]][htpp[ki][kj]]); 06.11.2014/SKn */
sprintf(lin,"%8.6f %s",pgen[ge[i]][htpp[ki][kj]], CharNull);
strcat(lino,lin);
}
}
/* sprintf(lin,"%8.6f\0",pgen[ge[i]][htpp[nhap][nhap]]); 06.11.2014/SKn */
sprintf(lin,"%8.6f%s",pgen[ge[i]][htpp[nhap][nhap]], CharNull);
strcat(lino,lin);
strcpy(desres[jjx],lino);
jjx++;
}
}
/* gedndert nach Klaus; Bildung Designmatrix
16.09.2008 */
/* if(*tog == 0){
for(i=0;i<np;i++){
//
//printf("\n%4s %s %4.2f >> ",id[i],geno[ge[i]],qtrait[i]);
//
strcpy(lino,"\0");
pex = 0.0;
for(j=0;j<nhap;j++){
pe = 0.0;
for(ki=0;ki<nhap;ki++){ // over all haplotype pairs
for(kj=ki;kj<nhap;kj++){
if(ki==j && kj==j && pgen[ge[i]][htpp[ki][kj]] > 0.0)
pe +=2.0*pgen[ge[i]][htpp[ki][kj]];
else if ((ki==j || kj==j) && pgen[ge[i]][htpp[ki][kj]] > 0.0)
pe += pgen[ge[i]][htpp[ki][kj]];
}
}
pex += pe;
sprintf(lin,"%8.6f \0",pe);
strcat(lino,lin);
}
sprintf(lin,"%8.6f\0",2.0-pex);
strcat(lino,lin);
strcpy(desres[jjx],lino);
jjx++;
}
}
*/
/* new: nach Klaus; 17.09.2008 */
if(*tog == 0){
peh = init_dvector(NULL, 0.0, nhap+1);
for(i=0;i<np;i++){
/*
printf("\n%4s %s %4.2f >> ",id[i],geno[ge[i]],qtrait[i]);
*/
strcpy(lino,"\0");
for(j=0;j<nhap;j++){
gsum = 0.0;
/*
for(ki=0;ki<nhap;ki++){ * over all haplotype pairs *
for(kj=ki;kj<nhap;kj++){
if(ki==j && kj==j && pgen[ge[i]][htpp[ki][kj]] > 0.0)
pe +=2.0*pgen[ge[i]][htpp[ki][kj]];
else if ((ki==j || kj==j) && pgen[ge[i]][htpp[ki][kj]] > 0.0)
pe += pgen[ge[i]][htpp[ki][kj]];
}
}
*/
for(ki=0;ki<nstate[ge[i]];ki++){
h1 = state[ge[i]][ki][0];
h2 = state[ge[i]][ki][1];
h = hlist[j];
pex = hapnew[h1]*hapnew[h2];
gsum += 2*pex;
if((h == h1) && (h == h2))peh[j] += 2*pex;
else if((h == h1) || (h == h2))peh[j] += pex;
} /* end nstate */
} /* end nhap */
pehh = 0.0;
for(j=0;j<nhap;j++){
pehh += 2*peh[j];
/* sprintf(lin,"%8.6f \0",2*peh[j]/gsum); 06.11.2014/SKn */
sprintf(lin,"%8.6f %s",2*peh[j]/gsum, CharNull);
strcat(lino,lin);
} /* end print */
/* sprintf(lin,"%8.6f\0",2.0-pehh/gsum); 06.11.2014/SKn */
sprintf(lin,"%8.6f%s",2.0-pehh/gsum, CharNull);
strcat(lino,lin);
strcpy(desres[jjx],lino);
jjx++;
init_dvector(peh, 0.0, nhap+1);
} /* end np */
destroy_d_array(peh);
}
destroy_c_array2(geno);
destroy_u_array(po);
for ( i=0;i<ng;i++) { destroy_u_array2(state[i]) ; }
free((uint***)state);
destroy_u_array2(htpp);
destroy_i_array(nstate);
destroy_i_array(mstate);
destroy_i_array(genoId);
destroy_i_array(mg);
destroy_i_array(merke);
destroy_i_array(nulmer);
destroy_i_array(ge);
destroy_i_array(hlist);
destroy_d_array(prob);
destroy_d_array(max_prob);
destroy_d_array(hapnew);
destroy_d_array(haptmp);
destroy_d_array(hap);
destroy_d_array(genoProb);
destroy_d_array2(pgen);
destroy_i_array(hc);
destroy_d_array(p2max);
destroy_i_array2(pimax);
}
