double nxy(int x, int y, int n,double* D) { int sCXY=0; int i=0; int j=0; double nMeanXY=0; //Rprintf("N[%i,%i]\n",x,y); for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; sCXY++; //Rprintf("considered pair (%i,%i)\n",i,j); nMeanXY+=H(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]); //Rprintf("nMeanXY after (%i,%i)=%f\n",i,j,nMeanXY); } } //Rprintf("sCXY=%i",sCXY); if(sCXY==0) return 0; return nMeanXY/sCXY; }
void ultrametric(double *dd, int* np,int* mp,double *ret)//d received as dist object, -1 for missing entries { int n=*np; int m=*mp; int i=0,j=0; double max=dd[0]; double d[n][n]; for(i=1;i<n;i++) {d[i-1][i-1]=0; for(j=i+1;j<=n;j++) { d[i-1][j-1]=d[j-1][i-1]=dd[give_index(i,j,n)]; if(dd[give_index(i,j,n)]>max) { max=dd[give_index(i,j,n)]; } } } d[n-1][n-1]=0; int entrCh=0; do{ entrCh=0; for(i=0;i<n-1;i++) for(j=i+1;j<n;j++) { if(d[i][j]!=-1)continue; double minimax=max; int k=0; int sw=0; for(k=0;k<n;k++) { if(d[i][k]==-1 || d[j][k]==-1)continue; sw=1; double mx=d[i][k]>d[j][k]?d[i][k]:d[j][k]; if(mx<minimax){minimax=mx;} } if(sw==1) { d[i][j]=d[j][i]=minimax; m--; entrCh=1; } } }while(entrCh==1); int ij=0; for(i=0;i<n;i++) for(j=0;j<n;j++) { ret[ij++]=d[i][j]; } }
int mxy(int x,int y,int n,double* D) { int i=0; int mx[n+1]; int my[n+1]; for(i=1;i<=n;i++) { mx[i]=0;my[i]=0; } for(i=1;i<=n;i++) { if(i!=x && D[give_index(x,i,n)]==-1) { mx[i]=1; } if(i!=y && D[give_index(y,i,n)]==-1) { my[i]=1; } } /*for(i=1;i<=n;i++) { Rprintf("mx[%i]=%i ",i,mx[i]); } Rprintf("\n"); for(i=1;i<=n;i++) { Rprintf("my[%i]=%i ",i,my[i]); } Rprintf("\n");*/ int xmy=0; int ymx=0; for(i=1;i<=n;i++) { if(i!=x && mx[i]==1 && my[i]==0) { xmy++; } if(i!=y && my[i]==1 && mx[i]==0) { ymx++; } } //Rprintf("xmy=%i, ymx=%i, xmy+ymx=%i\n",xmy,ymx,xmy+ymx); return xmy+ymx; }
void PD(int *x, int *y, int *n, int *weight){ int i, k; //n =length(x) for(i=0; i< *n; i++){ k=give_index(x[i], y[i], *n); weight[k]++; } }
void giveIndex(int *left, int* right, int *ll, int *lr, int *n, int *res){ int i, j, k; k=0; for (i = 0; i < *ll; i++){ for (j = 0; j < *lr; j++){ res[k] = give_index(left[i], right[j], *n); k++; } } }
int cxy(int x, int y, int n,double* D) { int sCXY=0; int i=0; int j=0; for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; sCXY++; } } return sCXY; }
double cnxy(int x, int y, int n,double* D) { int i=0; int j=0; double nMeanXY=0; //Rprintf("cN[%i,%i]\n",x,y); for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; nMeanXY+=(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]); //Rprintf("cnMeanXY after (%i,%i)=%f\n",i,j,nMeanXY); } } return nMeanXY; }
void nj(double *D, int *N, int *edge1, int *edge2, double *edge_length) { double *S, Sdist, Ndist, *new_dist, A, B, smallest_S, x, y; int n, i, j, k, ij, smallest, OTU1, OTU2, cur_nod, o_l, *otu_label; S = &Sdist; new_dist = &Ndist; otu_label = &o_l; n = *N; cur_nod = 2*n - 2; S = (double*)R_alloc(n + 1, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; while (n > 3) { for (i = 1; i <= n; i++) S[i] = sum_dist_to_i(n, D, i); /* S[0] is not used */ ij = 0; smallest_S = 1e50; B = n - 2; for (i = 1; i < n; i++) { for (j = i + 1; j <= n; j++) { A = B*D[ij] - S[i] - S[j]; if (A < smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; smallest = ij; } ij++; } } edge2[k] = otu_label[OTU1]; edge2[k + 1] = otu_label[OTU2]; edge1[k] = edge1[k + 1] = cur_nod; /* get the distances between all OTUs but the 2 selected ones and the latter: a) get the sum for both b) compute the distances for the new OTU */ A = D[smallest]; ij = 0; for (i = 1; i <= n; i++) { if (i == OTU1 || i == OTU2) continue; x = D[give_index(i, OTU1, n)]; /* dist between OTU1 and i */ y = D[give_index(i, OTU2, n)]; /* dist between OTU2 and i */ new_dist[ij] = (x + y - A)/2; ij++; } /* compute the branch lengths */ B = (S[OTU1] - S[OTU2])/B; /* don't need B anymore */ edge_length[k] = (A + B)/2; edge_length[k + 1] = (A - B)/2; /* update before the next loop (we are sure that OTU1 < OTU2) */ if (OTU1 != 1) for (i = OTU1; i > 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; ij++; } } n--; for (i = 0; i < n*(n - 1)/2; i++) D[i] = new_dist[i]; cur_nod--; k = k + 2; } for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; }
void ape_nj(double *D, int *N, int *edge1, int *edge2, double *edge_length) { double *S, Sdist, Ndist, *new_dist, A, B, smallest_S, *DI, d_i, x, y; int n, i, j, k, ij, smallest, OTU1, OTU2, cur_nod, o_l, *otu_label; OTU1 = 0; OTU2 = 0; smallest = 0; S = &Sdist; new_dist = &Ndist; otu_label = &o_l; DI = &d_i; n = *N; cur_nod = 2*n - 2; /* S = (double*)R_alloc(n, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n, sizeof(int)); DI = (double*)R_alloc(n - 2, sizeof(double)); */ S = (double*) malloc(n * sizeof(double)); new_dist = (double*) malloc(n*(n - 1)/2 * sizeof(double)); otu_label = (int*) malloc(n * sizeof(int)); DI = (double*) malloc((n - 2) * sizeof(double)); if(S == NULL || new_dist == NULL || otu_label == NULL || DI == NULL){ printf("Memory allocation fails!\n"); exit(1); } for (i = 0; i < n; i++) otu_label[i] = i + 1; k = 0; while (n > 3) { for (i = 0; i < n; i++) S[i] = sum_dist_to_i(n, D, i + 1); ij = 0; smallest_S = 1e50; B = n - 2; for (i = 0; i < n - 1; i++) { for (j = i + 1; j < n; j++) { A = D[ij] - (S[i] + S[j])/B; if (A < smallest_S) { OTU1 = i + 1; OTU2 = j + 1; smallest_S = A; smallest = ij; } ij++; } } edge2[k] = otu_label[OTU1 - 1]; edge2[k + 1] = otu_label[OTU2 - 1]; edge1[k] = edge1[k + 1] = cur_nod; /* get the distances between all OTUs but the 2 selected ones and the latter: a) get the sum for both b) compute the distances for the new OTU */ A = B = ij = 0; for (i = 1; i <= n; i++) { if (i == OTU1 || i == OTU2) continue; x = D[give_index(i, OTU1, n)]; /* dist between OTU1 and i */ y = D[give_index(i, OTU2, n)]; /* dist between OTU2 and i */ new_dist[ij] = (x + y)/2; A += x; B += y; ij++; } /* compute the branch lengths */ A /= n - 2; B /= n - 2; edge_length[k] = (D[smallest] + A - B)/2; edge_length[k + 1] = (D[smallest] + B - A)/2; DI[cur_nod - *N - 1] = D[smallest]; /* update before the next loop */ if (OTU1 > OTU2) { /* make sure that OTU1 < OTU2 */ i = OTU1; OTU1 = OTU2; OTU2 = i; } if (OTU1 != 1) for (i = OTU1 - 1; i > 0; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i - 1] = otu_label[i]; otu_label[0] = cur_nod; for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; ij++; } } n--; for (i = 0; i < n*(n - 1)/2; i++) D[i] = new_dist[i]; cur_nod--; k = k + 2; } for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i]; } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; for (i = 0; i < *N*2 - 3; i++) { if (edge2[i] <= *N) continue; /* In case there are zero branch lengths: */ if (DI[edge2[i] - *N - 1] == 0) continue; edge_length[i] -= DI[edge2[i] - *N - 1]/2; } free(S); free(new_dist); free(otu_label); free(DI); } /* End of ape_nj(). */
void C_njs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int *fsS) { //assume missing values are denoted by -1 double *S,*R, Sdist, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label; /*for(i=0;i<n*(n-1)/2;i++) {if(isNA(D[i])){D[i]=-1;} }*/ int *s;//s contains |Sxy|, which is all we need for agglomeration double *newR; int *newS; int fS=*fsS; R = &Sdist; new_dist = &Ndist; otu_label = &o_l; n = *N; cur_nod = 2*n - 2; R = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); S = (double*)R_alloc(n + 1, sizeof(double)); newR = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); s = (int*)R_alloc(n*(n - 1)/2, sizeof(int)); newS = (int*)R_alloc(n*(n - 1)/2, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; //compute Sxy and Rxy for(i=0;i<n*(n-1)/2;i++) {newR[i]=0; newS[i]=0; s[i]=0; R[i]=0; } for(i=1;i<n;i++) for(j=i+1;j<=n;j++) {//algorithm assumes i,j /in Sij, so skip pair if it is not known if(D[give_index(i,j,n)]==-1) { continue; } //Rprintf("for %i and %i :\n",i,j); for(k=1;k<=n;k++) {//ij is the pair for which we compute //skip k if we do not know the distances between it and i AND j if(k==i || k==j) { s[give_index(i,j,n)]++; if(i!=k)R[give_index(i,j,n)]+=D[give_index(i,k,n)]; if(j!=k)R[give_index(i,j,n)]+=D[give_index(j,k,n)]; continue; } if(D[give_index(i,k,n)]==-1 || D[give_index(j,k,n)]==-1)continue; //Rprintf("%i\n",k); s[give_index(i,j,n)]++; R[give_index(i,j,n)]+=D[give_index(i,k,n)]; R[give_index(i,j,n)]+=D[give_index(j,k,n)]; } } /*for(i=1;i<n;i++) { for(j=i+1;j<=n;j++) { Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]); } Rprintf("\n"); } for(i=1;i<n;i++) { for(j=i+1;j<=n;j++) { Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]); } Rprintf("\n"); }*/ k=0; int sw=1;//if 1 then incomplete while (n > 3) { ij = 0; for(i=1;i<n;i++) for(j=i+1;j<=n;j++) {newR[give_index(i,j,n)]=0; newS[give_index(i,j,n)]=0; } smallest_S = -1e50; if(sw==0) for(i=1;i<=n;i++) {S[i]=0; } B=n-2; if(sw==1) { choosePair(D,n,R,s,&sw,&OTU1,&OTU2,fS); } else{ //Rprintf("distance matrix is now complete\n"); for (i=1;i<=n;i++) for(j=1;j<=n;j++) {if(i==j)continue; //Rprintf("give_index(%i,%i)=%i\n",i,j,give_index(i,j,n)); //Rprintf("D[%i,%i]=%f\n",i,j,D[give_index(i,j,n)]); S[i]+=D[give_index(i,j,n)]; } B=n-2; //Rprintf("n=%i,B=%f",n,B); for (i = 1; i < n; i++) { for (j = i + 1; j <= n; j++) { //Rprintf("S[%i]=%f, S[%i]=%f, D[%i,%i]=%f, B=%f",i,S[i],j,S[j],i,j,D[give_index(i,j,n)],B); A=S[i]+S[j]-B*D[give_index(i,j,n)]; //Rprintf("Q[%i,%i]=%f\n",i,j,A); if (A > smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; /* smallest = ij; */ } ij++; } } } /*Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S); for(i=1;i<n;i++) { for(j=i+1;j<=n;j++) { Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]); } Rprintf("\n"); } for(i=1;i<n;i++) { for(j=i+1;j<=n;j++) { Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]); } Rprintf("\n"); } for(i=1;i<n;i++) { for(j=i+1;j<=n;j++) { Rprintf("d[%i,%i]=%f ",i,j,D[give_index(i,j,n)]); } Rprintf("\n"); }*/ //update Rxy and Sxy, only if matrix still incomplete if(sw==1) for(i=1;i<n;i++) {if(i==OTU1 || i==OTU2)continue; for(j=i+1;j<=n;j++) {if(j==OTU1 || j==OTU2)continue; if(D[give_index(i,j,n)]==-1)continue; if(D[give_index(i,OTU1,n)]!=-1 && D[give_index(j,OTU1,n)]!=-1) {//OTU1 was considered for Rij, so now subtract R[give_index(i,j,n)]-=(D[give_index(i,OTU1,n)]+D[give_index(j,OTU1,n)]); s[give_index(i,j,n)]--; } if(D[give_index(i,OTU2,n)]!=-1 && D[give_index(j,OTU2,n)]!=-1) {//OTU2 was considered for Rij, so now subtract R[give_index(i,j,n)]-=(D[give_index(i,OTU2,n)]+D[give_index(j,OTU2,n)]); s[give_index(i,j,n)]--; } } } edge2[k] = otu_label[OTU1]; edge2[k + 1] = otu_label[OTU2]; edge1[k] = edge1[k + 1] = cur_nod; /* get the distances between all OTUs but the 2 selected ones and the latter: a) get the sum for both b) compute the distances for the new OTU */ double sum=0; for(i=1;i<=n;i++) {if(i==OTU1 || i==OTU2)continue; if(D[give_index(OTU1,i,n)]==-1 || D[give_index(OTU2,i,n)]==-1)continue; sum+=(D[give_index(OTU1,i,n)]-D[give_index(OTU2,i,n)]); } //although s was updated above, s[otu1,otu2] has remained unchanged //so it is safe to use it here //if complete distanes, use N-2, else use S int down=B; if(sw==1){down=s[give_index(OTU1,OTU2,n)]-2;} if(down<=0) {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2); } //Rprintf("down=%i\n",down); sum*=(1.0/(2*(down))); //Rprintf("sum=%f\n",sum); double dxy=D[give_index(OTU1,OTU2,n)]/2; //Rprintf("R[%i,%i]:%f \n",OTU1,OTU2,sum); edge_length[k] = dxy+sum;//OTU1 //Rprintf("l1:%f \n",edge_length[k]); edge_length[k + 1] = dxy-sum;//OTU2 //Rprintf("l2:%f \n",edge_length[k+1]); //no need to change distance matrix update for complete distance //case, as pairs will automatically fall in the right cathegory A = D[give_index(OTU1,OTU2,n)]; ij = 0; for (i = 1; i <= n; i++) { if (i == OTU1 || i == OTU2) continue; if(D[give_index(OTU1,i,n)]!=-1 && D[give_index(OTU2,i,n)]!=-1) { new_dist[ij]=0.5*(D[give_index(OTU1,i,n)]-edge_length[k]+D[give_index(OTU2,i,n)]-edge_length[k+1]); }else{ if(D[give_index(OTU1,i,n)]!=-1) { new_dist[ij]=D[give_index(OTU1,i,n)]-edge_length[k]; }else{ if(D[give_index(OTU2,i,n)]!=-1) { new_dist[ij]=D[give_index(OTU2,i,n)]-edge_length[k+1]; }else{new_dist[ij]=-1;} } } ij++; } for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; ij++; } } /*for(i=1;i<n-1;i++) { for(j=i+1;j<=n-1;j++) {Rprintf("%f ",new_dist[give_index(i,j,n-1)]); } Rprintf("\n"); }*/ //compute Rui, only if distance matrix is still incomplete ij=0; if(sw==1) for(i=2;i<n;i++) { ij++; if(new_dist[give_index(i,1,n-1)]==-1)continue; for(j=1;j<n;j++) { if(j==1 || j==i) { if(i!=j)newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)]; if(j!=1)newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)]; newS[give_index(1,i,n-1)]++; continue; } if(new_dist[give_index(i,j,n-1)]!=-1 && new_dist[give_index(1,j,n-1)]!=-1) { newS[give_index(1,i,n-1)]++; newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)]; newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)]; } } } //fill in the rest of R and S, again only if distance matrix still //incomplete if(sw==1) /* added 2012-04-02 */ for(i=1;i<n;i++) {if(i==OTU1 || i==OTU2)continue; for(j=i+1;j<=n;j++) {if(j==OTU1 || j==OTU2)continue; newR[ij]=R[give_index(i,j,n)]; newS[ij]=s[give_index(i,j,n)]; ij++; } } //update newR and newS with the new taxa, again only if distance //matrix is still incomplete if(sw==1) for(i=2;i<n-1;i++) {if(new_dist[give_index(1,i,n-1)]==-1)continue; for(j=i+1;j<=n-1;j++) {if(new_dist[give_index(1,j,n-1)]==-1)continue; if(new_dist[give_index(i,j,n-1)]==-1)continue; newR[give_index(i,j,n-1)]+=(new_dist[give_index(1,i,n-1)]+new_dist[give_index(1,j,n-1)]); newS[give_index(i,j,n-1)]++; } } /* update before the next loop (we are sure that OTU1 < OTU2) */ if (OTU1 != 1) for (i = OTU1; i > 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; n--; for (i = 0; i < n*(n - 1)/2; i++) { D[i] = new_dist[i]; if(sw==1) { R[i] = newR[i]; s[i] = newS[i]; } } cur_nod--; k = k + 2; } int dK=0;//number of known distances in final distance matrix int iUK=-1;//index of unkown distance, if we have one missing distance int iK=-1;//index of only known distance, only needed if dK==1 for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; if(D[i]!=-1){dK++;iK=i;}else{iUK=i;} } if(dK==2) {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown //and edge weights of three edges are a,b,c, then any b,c>0 that //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for //simplicity we assume a=c if d(yz)<d(xy) a=b otherwise, and after some //algebra we get that we can set the missing distance equal to the //maximum of the already present distances double max=-1e50; for(i=0;i<3;i++) {if(i==iUK)continue; if(D[i]>max)max=D[i]; } D[iUK]=max; } if(dK==1) {//through similar motivation as above, if we have just one known distance //we set the other two distances equal to it for(i=0;i<3;i++) {if(i==iK)continue; D[i]=D[iK]; } } if(dK==0) {//no distances are known, we just set them to 1 for(i=0;i<3;i++) {D[i]=1; } } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; }
void choosePair(double* D,int n,double* R,int* s, int* sw, int* x, int* y, int fS) { int i=0,j=0,k=0; int sww=0; double cFS[fS]; int iFS[fS]; int jFS[fS]; for(k=0;k<fS;k++) {cFS[k]=-1e50; iFS[k]=0; jFS[k]=0; } double max=-1e50; for (i = 1; i < n; i++) { for (j = i + 1; j <= n; j++) {if(D[give_index(i,j,n)]==-1){sww=1;continue;} if(s[give_index(i,j,n)]<=2)continue; //Rprintf("R[%i,%i]=%f\n",i,j,R[give_index(i,j,n)]); //Rprintf("s[%i,%i]=%i\n",i,j,s[give_index(i,j,n)]); //Rprintf("D[%i,%i]=%f\n",i,j,D[give_index(i,j,n)]); int tr=0; double numb=((R[give_index(i,j,n)])/(s[give_index(i,j,n)]-2))-D[give_index(i,j,n)]; //Rprintf("numb(%i,%i)=%f\n",i,j,numb); for(k=0;k<fS && cFS[k]>numb;k++); //Rprintf("k=%i ",k); for(tr=fS-1;tr>k;tr--) {cFS[tr]=cFS[tr-1]; iFS[tr]=iFS[tr-1]; jFS[tr]=jFS[tr-1]; } if(k<fS){cFS[k]=numb; iFS[k]=i; jFS[k]=j; } } } //no missing distances, just return the one with maximal Q-criterion if(sww==0){*x=iFS[0];*y=jFS[0];*sw=0;return; } /*for(k=0;k<fS;k++) {Rprintf("value[%i]=%f ",k,cFS[k]); Rprintf("i=%i ",iFS[k]); Rprintf("j=%i ",jFS[k]); Rprintf("\n"); }*/ //calculate N*(x,y) for(i=0;i<fS;i++) { if(iFS[i]==0 || jFS[i]==0)continue; double nb=nxy(iFS[i],jFS[i],n,D); if(nb>max){max=nb;} cFS[i]=nb; } /*Rprintf("all N*(x,y)\n"); for(k=0;k<fS;k++) {Rprintf("value[%i]=%f ",k,cFS[k]); Rprintf("i=%i ",iFS[k]); Rprintf("j=%i ",jFS[k]); Rprintf("\n"); }*/ int dk=0; //shift the max N*xy to the front of the array for(i=0;i<fS;i++) { if(cFS[i]==max) { cFS[dk]=cFS[i]; iFS[dk]=iFS[i]; jFS[dk]=jFS[i]; dk++; } } //if just one pair realises max N*xy, return it if(dk==1){*x=iFS[0];*y=jFS[0];return;} fS=dk; /*Rprintf("max n*xy values\n"); for(k=0;k<fS;k++) {Rprintf("value[%i]=%f ",k,cFS[k]); Rprintf("i=%i ",iFS[k]); Rprintf("j=%i ",jFS[k]); Rprintf("\n"); }*/ max=-1e50; //on the front of the array containing max N*xy values compute cxy for(i=0;i<fS;i++) { if(iFS[i]==0 || jFS[i]==0)continue; double nb=cxy(iFS[i],jFS[i],n,D); if(nb>max){max=nb;} cFS[i]=nb; } /*Rprintf("all c*xy values\n"); for(k=0;k<fS;k++) {Rprintf("value[%i]=%f ",k,cFS[k]); Rprintf("i=%i ",iFS[k]); Rprintf("j=%i ",jFS[k]); Rprintf("\n"); }*/ //and again shift maximal C*xy values at the fron of the array dk=0; for(i=0;i<fS;i++) { if(cFS[i]==max) { cFS[dk]=cFS[i]; iFS[dk]=iFS[i]; jFS[dk]=jFS[i]; dk++; } } //if just one C*xy with maximal value, return pair realising it if(dk==1){*x=iFS[0];*y=jFS[0];return;} fS=dk; /*Rprintf("max c*xy values\n"); for(k=0;k<fS;k++) {Rprintf("value[%i]=%f ",k,cFS[k]); Rprintf("i=%i ",iFS[k]); Rprintf("j=%i ",jFS[k]); Rprintf("\n"); }*/ max=-1e50; //on the front of the array containing max C*xy compute m*xy for(i=0;i<fS;i++) { if(iFS[i]==0 || jFS[i]==0)continue; double nb=mxy(iFS[i],jFS[i],n,D); if(nb>max){max=nb;} cFS[i]=nb; } /*Rprintf("all m*xy values\n"); for(k=0;k<fS;k++) {Rprintf("value[%i]=%f ",k,cFS[k]); Rprintf("i=%i ",iFS[k]); Rprintf("j=%i ",jFS[k]); Rprintf("\n"); }*/ //again shift maximal m*xy values to the fron of the array dk=0; for(i=0;i<fS;i++) { if(cFS[i]==max) { cFS[dk]=cFS[i]; iFS[dk]=iFS[i]; jFS[dk]=jFS[i]; dk++; } } //if just one maximal value for m*xy return the pair realising it, found at 0 if(dk==1){*x=iFS[0];*y=jFS[0];return;} fS=dk; /*Rprintf("max m*xy values\n"); for(k=0;k<fS;k++) {Rprintf("value[%i]=%f ",k,cFS[k]); Rprintf("i=%i ",iFS[k]); Rprintf("j=%i ",jFS[k]); Rprintf("\n"); }*/ //and calculate cnxy on these values, but this time we do not shift, but simply //return the pair realising the maximum, stored at iPos max=-1e50; int iPos=0; for(i=0;i<fS;i++) { if(iFS[i]==0 || jFS[i]==0)continue; double nb=cnxy(iFS[i],jFS[i],n,D); if(nb>max){max=nb;iPos=i;} cFS[i]=nb; } /*Rprintf("cN*xy\n"); Rprintf("value[%i]=%f ",0,cFS[0]); Rprintf("i=%i ",iFS[0]); Rprintf("j=%i ",jFS[0]); Rprintf("\n");*/ if(iFS[iPos]==0 || jFS[iPos]==0) { error("distance information insufficient to construct a tree, cannot calculate agglomeration criterion"); } *x=iFS[iPos];*y=jFS[iPos]; }