double probnew(double ***MendelM,cmatrix loci, vector r, int i, int j,char c,char crosstype,int JorC,int ADJ,int start){
if(start){
return start_prob(crosstype,loci[j][i]);
}
char compareto;
int index;
int Nrecom;
if(JorC==1){
//Rprintf("C %d %d\n",i,j);
compareto = c;
}else{
//Rprintf("loci[j+1][i] %d\n",j);
compareto = loci[j+1][i];
}
if ((crosstype=='F')&&(loci[j][i]=='1')&&(compareto=='1')){
index = 1;
}else{
index = 0;
}
Nrecom = absdouble((double)loci[j][i]-(double)compareto);
return MendelM[j+ADJ][Nrecom][index];
}
/* ML estimation of recombination frequencies via EM;
calculation of multilocus genotype probabilities;
ignorance of unlikely genotypes*/
double rmixture(cmatrix marker, vector weight, vector r,
cvector position, ivector ind,
int Nind, int Naug, int Nmark,vector *mapdistance, char reestimate,char crosstype, Mmatrix MendelM,int verbose){
int i,j;
int iem= 0;
double Nrecom, oldr=0.0, newr, rdelta=1.0;
double maximum = 0.0;
float last_step = 0.0;
vector indweight;
indweight = newvector(Nind);
vector distance;
distance= newvector(Nmark+1);
if (reestimate=='n'){
if(verbose==1){Rprintf("INFO: recombination parameters are not re-estimated\n");}
}else{
if(verbose==1){Rprintf("INFO: recombination parameters are re-estimated\n");}
//Reestimation of map now works
while ((iem<1000)&&(rdelta>0.0001)){
iem+=1;
rdelta= 0.0;
/* calculate weights = conditional genotype probabilities */
for (i=0; i<Naug; i++) weight[i]=1.0;
for (j=0; j<Nmark; j++)
{ if ((position[j]=='L')||(position[j]=='U'))
for (i=0; i<Naug; i++)
if (marker[j][i]=='1') weight[i]*= 0.5;
else weight[i]*= 0.25;
if ((position[j]=='L')||(position[j]=='M'))
for (i=0; i<Naug; i++)
{
double calc_i = prob(marker,r,i,j,marker[j+1][i],crosstype,0,0,0);
weight[i]*=calc_i;
}
}
for (i=0; i<Nind; i++){
indweight[i]= 0.0;
}
for (i=0; i<Naug; i++){
indweight[ind[i]]+=weight[i];
}
for (i=0; i<Naug; i++){
weight[i]/=indweight[ind[i]];
}
for (j=0; j<Nmark; j++)
{ if ((position[j]=='L')||(position[j]=='M'))
{ newr= 0.0;
for (i=0; i<Naug; i++)
{ Nrecom= absdouble((double)marker[j][i]-marker[j+1][i]);
if ((marker[j][i]=='1')&&(marker[j+1][i]=='1'))
Nrecom= 2.0*r[j]*r[j]/(r[j]*r[j]+(1-r[j])*(1-r[j]));
newr+= Nrecom*weight[i];
}
if (reestimate=='y' && position[j]!='R') //only update if it isn't the last marker of a chromosome ;)
{ oldr=r[j];
r[j]= newr/(2.0*Nind);
rdelta+=pow(r[j]-oldr,2.0);
}
else rdelta+=0.0;
}
}
}
/* print new estimates of recombination frequencies */
//Rprintf("INFO: Reestimate? %c\n",reestimate);
//Rprintf("INFO: looping over all markers %d\n",Nmark);
for (j=0; j<Nmark; j++){
if(position[j+1]=='R'){
last_step = (*mapdistance)[j+1]-(*mapdistance)[j];
}
if(position[j]!='L'){
if(position[j]!='R'){
(*mapdistance)[j]= -50*log(1-2.0*r[j])+(*mapdistance)[j-1];
}else{
(*mapdistance)[j]= (*mapdistance)[j-1]+last_step;
}
}else{
(*mapdistance)[j]= -50*log(1-2.0*r[j]);
}
if(maximum < (*mapdistance)[j]){
maximum = (*mapdistance)[j];
}
//Rprintf("r(%d)= %f -> %f\n",j,r[j],(*mapdistance)[j]);
}
}
if(verbose==1){Rprintf("INFO: Re-estimation of the genetic map took %d iterations, to reach a rdelta of %f\n",iem,rdelta);}
Free(indweight);
return maximum;
}
/* ML estimation of parameters in mixture model via EM;
*/
double QTLmixture(cmatrix loci, cvector cofactor, vector r, cvector position,
vector y, ivector ind, int Nind, int Naug,
int Nloci,
double *variance, int em, vector *weight,char REMLorML,char fitQTL,char dominance,char crosstype,Mmatrix MendelM,int verbose){
//if(verbose==1){Rprintf("QTLmixture called\n");}
int iem= 0, newNaug, i, j;
char varknown, biasadj='n';
double oldlogL=-10000, delta=1.0, calc_i, logP=0.0, Pscale=1.75;
double calc_ii;
vector indweight, Ploci, Fy;
indweight= newvector(Nind);
newNaug= (fitQTL=='n' ? Naug : 3*Naug);
Fy= newvector(newNaug);
logP= Nloci*log(Pscale); // only for computational accuracy
varknown= (((*variance)==-1.0) ? 'n' : 'y' );
Ploci= newvector(newNaug);
#ifndef ALONE
R_CheckUserInterrupt(); /* check for ^C */
R_ProcessEvents();
R_FlushConsole();
#endif
if ((REMLorML=='0')&&(varknown=='n')){
// Rprintf("INFO: REML\n");
}
if (REMLorML=='1') {
// Rprintf("INFO: ML\n");
varknown='n'; biasadj='n';
}
for (i=0; i<newNaug; i++){
Ploci[i]= 1.0;
}
if (fitQTL=='n'){
//Rprintf("FitQTL=N\n");
for (j=0; j<Nloci; j++){
for (i=0; i<Naug; i++)
Ploci[i]*= Pscale;
//Here we have ProbLeft
if ((position[j]=='L')||(position[j]=='U')){
for (i=0; i<Naug; i++){
calc_i= prob(loci,r,i,j,'1',crosstype,1,0,1);
//calc_ii= probnew(MendelM,loci,r,i,j,'1',crosstype,1,0,1);
Ploci[i]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
}
if ((position[j]=='L')||(position[j]=='M')){
for (i=0; i<Naug; i++){
calc_i = prob(loci,r,i,j,loci[j+1][i],'F',0,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,loci[j+1][i],'F',0,0,0);
Ploci[i]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
}
}
}else{
// Rprintf("FitQTL=Y\n");
for (j=0; j<Nloci; j++)
{ for (i=0; i<Naug; i++)
{ Ploci[i]*= Pscale; Ploci[i+Naug]*= Pscale; Ploci[i+2*Naug]*= Pscale;
// only for computational accuracy; see use of logP
}
if ((position[j]=='L')||(position[j]=='U'))
{
//Here we don't have any f2 dependancies anymore by using the prob function
if (cofactor[j]<='1')
for (i=0; i<Naug; i++)
{
calc_i= prob(loci,r,i,j,'1',crosstype,1,0,1);
//calc_ii= probnew(MendelM,loci,r,i,j,'1',crosstype,1,0,1);
Ploci[i]*= calc_i; Ploci[i+Naug]*= calc_i; Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
else
for (i=0; i<Naug; i++)
{
//startvalues for each new chromosome
Ploci[i]*= start_prob(crosstype,'0');
Ploci[i+Naug]*= start_prob(crosstype,'1');
Ploci[i+2*Naug] *= start_prob(crosstype,'2');
}
// QTL='0', '1' or'2'
}
if ((position[j]=='L')||(position[j]=='M'))
{ if ((cofactor[j]<='1')&&(cofactor[j+1]<='1'))
for (i=0; i<Naug; i++){
calc_i = prob(loci,r,i,j,loci[j+1][i],crosstype,0,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,loci[j+1][i],crosstype,0,0,0);
Ploci[i]*= calc_i; Ploci[i+Naug]*= calc_i; Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
else if (cofactor[j]<='1') // locus j+1 == QTL
for (i=0; i<Naug; i++)
{ // QTL=='0' What is the prob of finding an '0' at J=1
calc_i = prob(loci,r,i,j,'0',crosstype,1,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,'0',crosstype,1,0,0);
Ploci[i]*= calc_i;
// QTL=='1'
calc_i = prob(loci,r,i,j,'1',crosstype,1,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,'1',crosstype,1,0,0);
Ploci[i+Naug]*= calc_i;
// QTL=='2'
calc_i = prob(loci,r,i,j,'2',crosstype,1,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,'2',crosstype,1,0,0);
Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
else // locus j == QTL
for (i=0; i<Naug; i++)
{ // QTL=='0'
calc_i = prob(loci,r,i,j+1,'0',crosstype,1,-1,0);
//calc_ii = probnew(MendelM,loci,r,i,j+1,'0',crosstype,1,-1,0);
Ploci[i]*= calc_i;
// QTL=='1'
calc_i = prob(loci,r,i,j+1,'1',crosstype,1,-1,0);
//calc_ii = probnew(MendelM,loci,r,i,j+1,'1',crosstype,1,-1,0);
Ploci[i+Naug]*= calc_i;
// QTL=='2'
calc_i = prob(loci,r,i,j+1,'2',crosstype,1,-1,0);
//calc_ii = probnew(MendelM,loci,r,i,j+1,'2',crosstype,1,-1,0);
Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
}
}
}
// Rprintf("INFO: Done fitting QTL's\n");
if ((*weight)[0]== -1.0)
{ for (i=0; i<Nind; i++) indweight[i]= 0.0;
if (fitQTL=='n')
{ for (i=0; i<Naug; i++) indweight[ind[i]]+=Ploci[i];
for (i=0; i<Naug; i++) (*weight)[i]= Ploci[i]/indweight[ind[i]];
}
else
{ for (i=0; i<Naug; i++) indweight[ind[i]]+=Ploci[i]+Ploci[i+Naug]+Ploci[i+2*Naug];
for (i=0; i<Naug; i++)
{ (*weight)[i] = Ploci[i]/indweight[ind[i]];
(*weight)[i+Naug] = Ploci[i+Naug]/indweight[ind[i]];
(*weight)[i+2*Naug]= Ploci[i+2*Naug]/indweight[ind[i]];
}
}
}
//Rprintf("Weights done\n");
//Rprintf("Individual->trait->cofactor->weight\n");
//for (int j=0; j<Nind; j++){
// Rprintf("%d->%f,%d,%f %f\n",j,y[j],cofactor[j],(*weight)[j],Ploci[j]);
//}
double logL=0;
vector indL;
indL= newvector(Nind);
while ((iem<em)&&(delta>1.0e-5))
{
iem+=1;
if (varknown=='n') *variance=-1.0;
//Rprintf("Checkpoint_b\n");
logL= regression(Nind, Nloci, cofactor, loci, y,
weight, ind, Naug, variance, Fy, biasadj,fitQTL,dominance);
logL=0.0;
//Rprintf("regression ready\n");
for (i=0; i<Nind; i++) indL[i]= 0.0;
if (fitQTL=='n') // no QTL fitted
for (i=0; i<Naug; i++)
{ (*weight)[i]= Ploci[i]*Fy[i];
indL[ind[i]]= indL[ind[i]] + (*weight)[i];
}
else // QTL moved along the chromosomes
for (i=0; i<Naug; i++)
{ (*weight)[i]= Ploci[i]*Fy[i];
(*weight)[i+Naug] = Ploci[i+Naug]* Fy[i+Naug];
(*weight)[i+2*Naug]= Ploci[i+2*Naug]*Fy[i+2*Naug];
indL[ind[i]]+=(*weight)[i]+(*weight)[i+Naug]+(*weight)[i+2*Naug];
}
for (i=0; i<Nind; i++) logL+=log(indL[i])-logP;
for (i=0; i<Nind; i++) indweight[i]= 0.0;
if (fitQTL=='n')
{ for (i=0; i<Naug; i++) indweight[ind[i]]+=(*weight)[i];
for (i=0; i<Naug; i++) (*weight)[i]/=indweight[ind[i]];
}
else
{ for (i=0; i<Naug; i++)
indweight[ind[i]]+=(*weight)[i]+(*weight)[i+Naug]+(*weight)[i+2*Naug];
for (i=0; i<Naug; i++)
{ (*weight)[i] /=indweight[ind[i]];
(*weight)[i+Naug] /=indweight[ind[i]];
(*weight)[i+2*Naug]/=indweight[ind[i]];
}
}
delta= absdouble(logL-oldlogL);
oldlogL= logL;
}
//Rprintf("EM Finished\n");
// bias adjustment after finished ML estimation via EM
if ((REMLorML=='0')&&(varknown=='n'))
{
// RRprintf("Checkpoint_c\n");
*variance=-1.0;
biasadj='y';
logL= regression(Nind, Nloci, cofactor, loci, y,
weight, ind, Naug, variance, Fy, biasadj,fitQTL,dominance);
logL=0.0;
for (int _i=0; _i<Nind; _i++) indL[_i]= 0.0;
if (fitQTL=='n')
for (i=0; i<Naug; i++)
{ (*weight)[i]= Ploci[i]*Fy[i];
indL[ind[i]]+=(*weight)[i];
}
else
for (i=0; i<Naug; i++)
{ (*weight)[i]= Ploci[i]*Fy[i];
(*weight)[i+Naug]= Ploci[i+Naug]*Fy[i+Naug];
(*weight)[i+2*Naug]= Ploci[i+2*Naug]*Fy[i+2*Naug];
indL[ind[i]]+=(*weight)[i];
indL[ind[i]]+=(*weight)[i+Naug];
indL[ind[i]]+=(*weight)[i+2*Naug];
}
for (i=0; i<Nind; i++) logL+=log(indL[i])-logP;
for (i=0; i<Nind; i++) indweight[i]= 0.0;
if (fitQTL=='n')
{ for (i=0; i<Naug; i++) indweight[ind[i]]+=(*weight)[i];
for (i=0; i<Naug; i++) (*weight)[i]/=indweight[ind[i]];
}
else
{ for (i=0; i<Naug; i++)
{ indweight[ind[i]]+=(*weight)[i];
indweight[ind[i]]+=(*weight)[i+Naug];
indweight[ind[i]]+=(*weight)[i+2*Naug];
}
for (i=0; i<Naug; i++)
{ (*weight)[i] /=indweight[ind[i]];
(*weight)[i+Naug] /=indweight[ind[i]];
(*weight)[i+2*Naug]/=indweight[ind[i]];
}
}
}
//for (i=0; i<Nind; i++){
// Rprintf("IND %d Ploci: %f Fy: %f UNLOG:%f LogL:%f LogL-LogP: %f\n",i,Ploci[i],Fy[i],indL[i],log(indL[i]),log(indL[i])-logP);
//}
Free(Fy);
Free(Ploci);
Free(indweight);
Free(indL);
return logL;
}
double prob(cmatrix loci, vector r, int i, int j,char c,char crosstype,int JorC,int ADJ,int start){
//Compares loci[j][i] versus loci[j+1][i]
//OR if JorC is set to 1 loci[j][i] versus compareto
//Specify an ADJ to adjust loci[j][i] to a specific location in the r[j+ADJ]
//Rprintf("Prob called: values:\n(i,j,ADJ)=(%d,%d,%d)\nR[j+ADJ] value: %f Loci[j][i]=%c\n",i,j,ADJ,r[j+ADJ],loci[j][i]);
double calc_i=0.0;
double Nrecom;
char compareto;
if(JorC==1){
//Rprintf("C %d %d\n",i,j);
compareto = c;
}else{
//Rprintf("loci[j+1][i] %d\n",j);
compareto = loci[j+1][i];
}
switch(crosstype){
case 'F':
if(start){
return (loci[j][i]=='1' ? 0.5 : 0.25);
}
Nrecom= absdouble((double)loci[j][i]-(double)compareto);
if ((loci[j][i]=='1')&&(compareto=='1')){
//Rprintf("SCase %c <-> %c:\n",compareto,loci[j][i]);
calc_i= (r[j+ADJ]*r[j+ADJ]+(1.0-r[j+ADJ])*(1.0-r[j+ADJ]));
}else if (Nrecom==0){
//Rprintf("Nrecom=0 %c <-> %c:\n",compareto,loci[j][i]);
calc_i= (1.0-r[j+ADJ])*(1.0-r[j+ADJ]);
}else if (Nrecom==1){
//Rprintf("Nrecom=1 %c <-> %c:\n",compareto,loci[j][i]);
if(ADJ!=0){
calc_i= ((loci[j][i]=='1') ? 2.0*r[j+ADJ]*(1.0-r[j+ADJ]) : r[j+ADJ]*(1.0-r[j+ADJ]));
}else{
calc_i= ((compareto=='1') ? 2.0*r[j+ADJ]*(1.0-r[j+ADJ]) : r[j+ADJ]*(1.0-r[j+ADJ]));
}
}else {
//Rprintf("Nrecom=2 %c <-> %c:\n",compareto,loci[j][i]);
calc_i= r[j+ADJ]*r[j+ADJ];
}
//Rprintf("after IF\n",j);
break;
case 'R':
if(start){
return 0.5;
}
if(compareto=='1' && JorC){
return 0.0; // No chance in hell finding a 1 in an RIL
}
Nrecom= absdouble((double)loci[j][i]-(double)compareto);
if(Nrecom==0){
//No recombination has a chance of r[j]
calc_i = 1.0-r[j+ADJ];
}else{
// Recombination between markers has a chance of r[j-1]
calc_i = r[j+ADJ];
}
break;
case 'B':
if(start){
return 0.5;
}
if(compareto=='2' && JorC){
return 0.0; // No chance in hell finding a 2 in a BC
}
Nrecom= absdouble((double)loci[j][i]-(double)compareto);
if(Nrecom==0){
//No recombination has a chance of r[j]
calc_i = (1.0-r[j+ADJ]);
}else{
// Recombination between markers has a chance of r[j-1]
calc_i = r[j+ADJ];
}
break;
}
return calc_i;
}
double probright(char c, int jloc, cvector imarker, vector r, cvector position,char crosstype){
//This is for an F2 population, where 'c'==1 stands for H (so it has two times higher chance than A or B
double nrecom, prob0, prob1, prob2;
if ((position[jloc]=='R')||(position[jloc]=='U')){
//We're at the end of a chromosome or an unknown marker
return 1.0;
}
switch(crosstype){
case 'F':
if ((imarker[jloc+1]=='0')||(imarker[jloc+1]=='1')||(imarker[jloc+1]=='2')){
//NEXT marker is known
if ((c=='1')&&(imarker[jloc+1]=='1')){
//special case in which we observe a H after an H then we can't know if we recombinated or not
return r[jloc]*r[jloc]+(1.0-r[jloc])*(1.0-r[jloc]);
}else{
//The number of recombinations between observed marker and the next marker
nrecom = absdouble(c-imarker[jloc+1]);
if(nrecom==0){
//No recombination
return (1.0-r[jloc])*(1.0-r[jloc]);
}else if (nrecom==1){
if(imarker[jloc+1]=='1'){
//the chances of having a H after 1 recombination are 2 times the chance of being either A or B
return 2.0*r[jloc]*(1.0-r[jloc]);
}else{
//Chance of 1 recombination
return r[jloc]*(1.0-r[jloc]);
}
}else{
//Both markers could have recombinated which has a very low chance
return r[jloc]*r[jloc];
}
}
}else if (imarker[jloc+1]=='3'){
//SEMI unknown next marker known is it is not an A
if(c=='0'){
//Observed marker is an A
prob1= 2.0*r[jloc]*(1.0-r[jloc]);
prob2= r[jloc]*r[jloc];
}else if (c=='1') {
//Observed marker is an H
prob1= r[jloc]*r[jloc]+(1.0-r[jloc])*(1.0-r[jloc]);
prob2= r[jloc]*(1.0-r[jloc]);
}else{
//Observed marker is an B
prob1= 2.0*r[jloc]*(1.0-r[jloc]);
prob2= (1.0-r[jloc])*(1-r[jloc]);
}
return prob1*probright('1',jloc+1,imarker,r,position,crosstype) + prob2*probright('2',jloc+1,imarker,r,position,crosstype);
}else if (imarker[jloc+1]=='4'){
//SEMI unknown next marker known is it is not a B
if(c=='0'){
//Observed marker is an A
prob0= (1.0-r[jloc])*(1.0-r[jloc]);
prob1= 2.0*r[jloc]*(1.0-r[jloc]);
}else if (c=='1') {
//Observed marker is an H
prob0= r[jloc]*(1.0-r[jloc]);
prob1= r[jloc]*r[jloc]+(1.0-r[jloc])*(1.0-r[jloc]);
}else{
//Observed marker is an B
prob0= r[jloc]*r[jloc];
prob1= 2.0*r[jloc]*(1.0-r[jloc]);
}
return prob0*probright('0',jloc+1,imarker,r,position,crosstype) + prob1*probright('1',jloc+1,imarker,r,position,crosstype);
}else{
// Unknown next marker so estimate all posibilities (imarker[j+1]=='9')
if(c=='0'){
//Observed marker is an A
prob0= (1.0-r[jloc])*(1.0-r[jloc]);
prob1= 2.0*r[jloc]*(1.0-r[jloc]);
prob2= r[jloc]*r[jloc];
}else if (c=='1') {
//Observed marker is an H
prob0= r[jloc]*(1.0-r[jloc]);
prob1= r[jloc]*r[jloc]+(1.0-r[jloc])*(1.0-r[jloc]);
prob2= r[jloc]*(1.0-r[jloc]);
}else{
//Observed marker is an B
prob0= r[jloc]*r[jloc];
prob1= 2.0*r[jloc]*(1.0-r[jloc]);
prob2= (1.0-r[jloc])*(1.0-r[jloc]);
}
return prob0*probright('0',jloc+1,imarker,r,position,crosstype) + prob1*probright('1',jloc+1,imarker,r,position,crosstype) + prob2*probright('2',jloc+1,imarker,r,position,crosstype);
}
break;
case 'R':
if(c=='1'){
return 0.0;
}
if ((imarker[jloc+1]=='0')||(imarker[jloc+1]=='2')){
nrecom = absdouble(c-imarker[jloc+1]);
if(nrecom==0){
return (1.0-r[jloc]);
}else{
return r[jloc];
}
}else{
if(c=='0'){//Both markers could have recombinated which has a very low chance
prob0= (1.0-r[jloc]);
prob2= r[jloc];
}else{
prob0= r[jloc];
prob2= (1.0-r[jloc]);
}
return prob0*probright('0',jloc+1,imarker,r,position,crosstype) + prob2*probright('2',jloc+1,imarker,r,position,crosstype);
}
break;
case 'B':
if(c=='2'){
return 0.0;
}
if ((imarker[jloc+1]=='0')||(imarker[jloc+1]=='1')){
nrecom = absdouble(c-imarker[jloc+1]);
if(nrecom==0){
return 1.0-r[jloc];
}else{
return r[jloc];
}
}else{
if(c=='0'){//Both markers could have recombinated which has a very low chance
prob0= 1.0-r[jloc];
prob2= r[jloc];
}else{
prob0= r[jloc];
prob2= 1.0-r[jloc];
}
return prob0*probright('0',jloc+1,imarker,r,position,crosstype) + prob2*probright('1',jloc+1,imarker,r,position,crosstype);
}
break;
}
return 1.0;
}
unsigned int cmpData(char* varname, DataField *time, DataField *reftime, DataField *data, DataField *refdata, double reltol, double abstol, DiffDataField *ddf, char **cmpdiffvars, unsigned int vardiffindx)
{
unsigned int i,j,k;
double t,tr,d,dr,err;
DiffData *diffdatafild;
char increased = 0;
char interpolate = 0;
char isdifferent = 0;
j = 0;
tr = reftime->data[j];
dr = refdata->data[j];
/* fprintf(stderr, "compare: %s\n",varname); */
for (i=0;i<data->n;i++){
t = time->data[i];
d = data->data[i];
increased = 0;
/* fprintf(stderr, "i: %d t: %.6g d:%.6g\n",i,t,d); */
while(tr <= t){
if (j +1< reftime->n) {
j += 1;
tr = reftime->data[j];
increased = 1;
if (tr == t) {
break;
}
/* fprintf(stderr, "j: %d tr:%.6g\n",j,tr); */
}
else
break;
}
if (increased==1) {
if ( (absdouble((t-tr)/tr) > reltol) || (absdouble(t-tr) > absdouble(t-reftime->data[j-1]))) {
j = j- 1;
tr = reftime->data[j];
}
}
/* fprintf(stderr, "i: %d t: %.6g d:%.6g j: %d tr:%.6g\n",i,t,d,j,tr); */
/* events */
if(i>0) {
/* an event */
if (t == time->data[i-1]) {
/* fprintf(stderr, "event: %.6g %d %.6g\n",t,i,d);
goto the last */
char te = 0;
if (i+1<data->n) {
if (time->data[i+1] < t+0.00000065) {
te = 1;
}
}
while(te==1){
i +=1;
te = 0;
if (i+1<data->n) {
if (time->data[i+1] < t+0.00000065) {
te = 1;
}
}
}
t = time->data[i];
d = data->data[i];
/* fprintf(stderr, "movet to: %.6g %d %.6g\n",t,i,d);
fprintf(stderr, "1event: %.6g %d\n",tr,j); */
te == 0;
if (j+1<reftime->n) {
if (reftime->data[j+1] < tr+0.00000065) {
te = 1;
}
}
while(te==1){
j +=1;
te = 0;
if (j+1<reftime->n) {
if (reftime->data[j+1] < tr+0.00000065) {
te = 1;
}
}
}
tr = reftime->data[j];
/* fprintf(stderr, "1movet to: %.6g %d\n",tr,j); */
}
}
interpolate = 0;
/* fprintf(stderr, "interpolate? %d %.6g:%.6g %.6g:%.6g\n",i,t,tr,absdouble((t-tr)/tr),abstol); */
if (absdouble(t-tr) > 0.00001) {
interpolate = 1;
}
dr = refdata->data[j];
if (interpolate==1){
/* fprintf(stderr, "interpolate %.6g:%.6g %.6g:%.6g %d",t,d,tr,dr,j); */
unsigned int jj = j;
/* look for interpolation partner */
if (tr > t) {
if (j-1>0) {
char te=0;
jj = j-1;
increased = 0;
if (reftime->data[jj] == tr){
te = 1;
increased = 1;
}
while(te==1){
jj -= 1;
te = 0;
if (jj>0) {
if (reftime->data[jj] == tr) {
te = 1;
}
}
}
}
/* fprintf(stderr, "-> %d %.6g %.6g\n",jj,reftime->data[jj],tr); */
if (reftime->data[jj] != tr){
dr = refdata->data[jj] + ((dr-refdata->data[jj])/(tr-reftime->data[jj]))*(t-reftime->data[jj]);
}
/* fprintf(stderr, "-> dr:%.6g\n",dr); */
}
else {
if (j+1<reftime->n) {
char te=0;
jj = j+1;
increased = 0;
if (reftime->data[jj] == tr){
te = 1;
increased = 1;
}
while(te==1){
jj += 1;
te = 0;
if (jj>0) {
if (reftime->data[jj] == tr) {
te = 1;
}
}
}
}
/* fprintf(stderr, "-> %d %.6g %.6g\n",jj,reftime->data[jj],tr); */
if (reftime->data[jj] != tr){
dr = dr + ((refdata->data[jj] - dr)/(reftime->data[jj] - tr))*(t-tr);
}
/* fprintf(stderr, "-> dr:%.6g\n",dr); */
}
}
/* fprintf(stderr, "j: %d tr: %.6g dr:%.6g t:%.6g d:%.6g\n",j,tr,dr,t,d); */
err = absdouble(d-dr);
/* fprintf(stderr, "delta:%.6g reltol:%.6g\n",err,reltol); */
if ( err > reltol*fabs(dr)+abstol){
if (j+1<reftime->n) {
if (reftime->data[j+1] == tr) {
dr = refdata->data[j+1];
err = absdouble(d-dr);
}
}
if (err < reltol*fabs(dr)+abstol){
continue;
}
isdifferent = 1;
diffdatafild = (DiffData*) malloc(sizeof(DiffData)*(ddf->n+1));
for (k=0;k<ddf->n;k++)
diffdatafild[k] = ddf->data[k];
diffdatafild[ddf->n].name = varname;
diffdatafild[ddf->n].data = d;
diffdatafild[ddf->n].dataref = dr;
diffdatafild[ddf->n].time = t;
diffdatafild[ddf->n].timeref = tr;
diffdatafild[ddf->n].interpolate = interpolate?'1':'0';
ddf->n +=1;
if(ddf->data) free(ddf->data);
ddf->data = diffdatafild;
}
}
if (isdifferent)
{
cmpdiffvars[vardiffindx] = varname;
vardiffindx++;
}
return vardiffindx;
}
