| 1 | /* |
|---|
| 2 | |
|---|
| 3 | PhyML: a program that computes maximum likelihood phylogenies from |
|---|
| 4 | DNA or AA homologous sequences. |
|---|
| 5 | |
|---|
| 6 | Copyright (C) Stephane Guindon. Oct 2003 onward. |
|---|
| 7 | |
|---|
| 8 | All parts of the source except where indicated are distributed under |
|---|
| 9 | the GNU public licence. See http://www.opensource.org for details. |
|---|
| 10 | |
|---|
| 11 | */ |
|---|
| 12 | |
|---|
| 13 | #include "stats.h" |
|---|
| 14 | |
|---|
| 15 | |
|---|
| 16 | ////////////////////////////////////////////////////////////// |
|---|
| 17 | ////////////////////////////////////////////////////////////// |
|---|
| 18 | |
|---|
| 19 | /* RANDOM VARIATES GENERATORS */ |
|---|
| 20 | ////////////////////////////////////////////////////////////// |
|---|
| 21 | ////////////////////////////////////////////////////////////// |
|---|
| 22 | |
|---|
| 23 | |
|---|
| 24 | /*********************************************************************/ |
|---|
| 25 | /* A C-function for TT800 : July 8th 1996 Version */ |
|---|
| 26 | /* by M. Matsumoto, email: matumoto@math.keio.ac.jp */ |
|---|
| 27 | /* tt800() generate one pseudorandom number with double precision */ |
|---|
| 28 | /* which is uniformly distributed on [0,1]-interval */ |
|---|
| 29 | /* for each call. One may choose any initial 25 seeds */ |
|---|
| 30 | /* except all zeros. */ |
|---|
| 31 | |
|---|
| 32 | /* See: ACM Transactions on Modelling and Computer Simulation, */ |
|---|
| 33 | /* Vol. 4, No. 3, 1994, pages 254-266. */ |
|---|
| 34 | |
|---|
| 35 | phydbl tt800() |
|---|
| 36 | { |
|---|
| 37 | int M=7; |
|---|
| 38 | unsigned long y; |
|---|
| 39 | static int k = 0; |
|---|
| 40 | static unsigned long x[25]={ /* initial 25 seeds, change as you wish */ |
|---|
| 41 | 0x95f24dab, 0x0b685215, 0xe76ccae7, 0xaf3ec239, 0x715fad23, |
|---|
| 42 | 0x24a590ad, 0x69e4b5ef, 0xbf456141, 0x96bc1b7b, 0xa7bdf825, |
|---|
| 43 | 0xc1de75b7, 0x8858a9c9, 0x2da87693, 0xb657f9dd, 0xffdc8a9f, |
|---|
| 44 | 0x8121da71, 0x8b823ecb, 0x885d05f5, 0x4e20cd47, 0x5a9ad5d9, |
|---|
| 45 | 0x512c0c03, 0xea857ccd, 0x4cc1d30f, 0x8891a8a1, 0xa6b7aadb |
|---|
| 46 | }; |
|---|
| 47 | static unsigned long mag01[2]={ |
|---|
| 48 | 0x0, 0x8ebfd028 /* this is magic vector `a', don't change */ |
|---|
| 49 | }; |
|---|
| 50 | if (k==25) { /* generate 25 words at one time */ |
|---|
| 51 | int kk; |
|---|
| 52 | for (kk=0;kk<25-M;kk++) { |
|---|
| 53 | x[kk] = x[kk+M] ^ (x[kk] >> 1) ^ mag01[x[kk] % 2]; |
|---|
| 54 | } |
|---|
| 55 | for (; kk<25;kk++) { |
|---|
| 56 | x[kk] = x[kk+(M-25)] ^ (x[kk] >> 1) ^ mag01[x[kk] % 2]; |
|---|
| 57 | } |
|---|
| 58 | k=0; |
|---|
| 59 | } |
|---|
| 60 | y = x[k]; |
|---|
| 61 | y ^= (y << 7) & 0x2b5b2500; /* s and b, magic vectors */ |
|---|
| 62 | y ^= (y << 15) & 0xdb8b0000; /* t and c, magic vectors */ |
|---|
| 63 | y &= 0xffffffff; /* you may delete this line if word size = 32 */ |
|---|
| 64 | /* |
|---|
| 65 | the following line was added by Makoto Matsumoto in the 1996 version |
|---|
| 66 | to improve lower bit's corellation. |
|---|
| 67 | Delete this line to o use the code published in 1994. |
|---|
| 68 | */ |
|---|
| 69 | y ^= (y >> 16); /* added to the 1994 version */ |
|---|
| 70 | k++; |
|---|
| 71 | return((phydbl)y / (unsigned long) 0xffffffff); |
|---|
| 72 | } |
|---|
| 73 | |
|---|
| 74 | /*********************************************************************/ |
|---|
| 75 | |
|---|
| 76 | phydbl Uni() |
|---|
| 77 | { |
|---|
| 78 | phydbl r,mx; |
|---|
| 79 | mx = (phydbl)RAND_MAX; |
|---|
| 80 | r = (phydbl)rand(); |
|---|
| 81 | r /= mx; |
|---|
| 82 | /* r = tt800(); */ |
|---|
| 83 | return r; |
|---|
| 84 | } |
|---|
| 85 | |
|---|
| 86 | /*********************************************************************/ |
|---|
| 87 | |
|---|
| 88 | int Rand_Int(int min, int max) |
|---|
| 89 | { |
|---|
| 90 | /* phydbl u; */ |
|---|
| 91 | /* u = (phydbl)rand(); */ |
|---|
| 92 | /* u /= (RAND_MAX); */ |
|---|
| 93 | /* u *= (max - min + 1); */ |
|---|
| 94 | /* u += min; */ |
|---|
| 95 | /* return (int)FLOOR(u); */ |
|---|
| 96 | |
|---|
| 97 | int u; |
|---|
| 98 | u = rand(); |
|---|
| 99 | return (u%(max+1-min)+min); |
|---|
| 100 | |
|---|
| 101 | } |
|---|
| 102 | |
|---|
| 103 | ////////////////////////////////////////////////////////////// |
|---|
| 104 | ////////////////////////////////////////////////////////////// |
|---|
| 105 | |
|---|
| 106 | |
|---|
| 107 | |
|---|
| 108 | /********************* random Gamma generator ************************ |
|---|
| 109 | * Properties: |
|---|
| 110 | * (1) X = Gamma(alpha,lambda) = Gamma(alpha,1)/lambda |
|---|
| 111 | * (2) X1 = Gamma(alpha1,1), X2 = Gamma(alpha2,1) independent |
|---|
| 112 | * then X = X1+X2 = Gamma(alpha1+alpha2,1) |
|---|
| 113 | * (3) alpha = k = integer then |
|---|
| 114 | * X = Gamma(k,1) = Erlang(k,1) = -sum(LOG(Ui)) = -LOG(prod(Ui)) |
|---|
| 115 | * where U1,...Uk iid uniform(0,1) |
|---|
| 116 | * |
|---|
| 117 | * Decompose alpha = k+delta with k = [alpha], and 0<delta<1 |
|---|
| 118 | * Apply (3) for Gamma(k,1) |
|---|
| 119 | * Apply Ahrens-Dieter algorithm for Gamma(delta,1) |
|---|
| 120 | */ |
|---|
| 121 | |
|---|
| 122 | phydbl Ahrensdietergamma(phydbl alpha) |
|---|
| 123 | { |
|---|
| 124 | phydbl x = 0.; |
|---|
| 125 | |
|---|
| 126 | if (alpha>0.) |
|---|
| 127 | { |
|---|
| 128 | phydbl y = 0.; |
|---|
| 129 | phydbl b = (alpha+EXP(1.))/EXP(1.); |
|---|
| 130 | phydbl p = 1./alpha; |
|---|
| 131 | int go = 0; |
|---|
| 132 | while (go==0) |
|---|
| 133 | { |
|---|
| 134 | phydbl u = Uni(); |
|---|
| 135 | phydbl w = Uni(); |
|---|
| 136 | phydbl v = b*u; |
|---|
| 137 | if (v<=1.) |
|---|
| 138 | { |
|---|
| 139 | x = POW(v,p); |
|---|
| 140 | y = EXP(-x); |
|---|
| 141 | } |
|---|
| 142 | else |
|---|
| 143 | { |
|---|
| 144 | x = -LOG(p*(b-v)); |
|---|
| 145 | y = POW(x,alpha-1.); |
|---|
| 146 | } |
|---|
| 147 | go = (w<y); // x is accepted when go=1 |
|---|
| 148 | } |
|---|
| 149 | } |
|---|
| 150 | return x; |
|---|
| 151 | } |
|---|
| 152 | |
|---|
| 153 | ////////////////////////////////////////////////////////////// |
|---|
| 154 | ////////////////////////////////////////////////////////////// |
|---|
| 155 | |
|---|
| 156 | |
|---|
| 157 | phydbl Rgamma(phydbl shape, phydbl scale) |
|---|
| 158 | { |
|---|
| 159 | int i; |
|---|
| 160 | phydbl x1 = 0.; |
|---|
| 161 | phydbl delta = shape; |
|---|
| 162 | if (shape>=1.) |
|---|
| 163 | { |
|---|
| 164 | int k = (int)FLOOR(shape); |
|---|
| 165 | delta = shape - k; |
|---|
| 166 | phydbl u = 1.; |
|---|
| 167 | for (i=0; i<k; i++) |
|---|
| 168 | u *= Uni(); |
|---|
| 169 | x1 = -LOG(u); |
|---|
| 170 | } |
|---|
| 171 | phydbl x2 = Ahrensdietergamma(delta); |
|---|
| 172 | return (x1 + x2)*scale; |
|---|
| 173 | } |
|---|
| 174 | |
|---|
| 175 | ////////////////////////////////////////////////////////////// |
|---|
| 176 | ////////////////////////////////////////////////////////////// |
|---|
| 177 | |
|---|
| 178 | |
|---|
| 179 | phydbl Rexp(phydbl lambda) |
|---|
| 180 | { |
|---|
| 181 | return -LOG(Uni()+1.E-30)/lambda; |
|---|
| 182 | } |
|---|
| 183 | |
|---|
| 184 | ////////////////////////////////////////////////////////////// |
|---|
| 185 | ////////////////////////////////////////////////////////////// |
|---|
| 186 | |
|---|
| 187 | |
|---|
| 188 | phydbl Rnorm(phydbl mean, phydbl sd) |
|---|
| 189 | { |
|---|
| 190 | /* Box-Muller transformation */ |
|---|
| 191 | phydbl u1, u2, res; |
|---|
| 192 | |
|---|
| 193 | /* u1=Uni(); */ |
|---|
| 194 | /* u2=Uni(); */ |
|---|
| 195 | /* u1 = SQRT(-2.*LOG(u1))*COS(6.28318530717959f*u2); */ |
|---|
| 196 | |
|---|
| 197 | /* Polar */ |
|---|
| 198 | phydbl d,x,y; |
|---|
| 199 | |
|---|
| 200 | do |
|---|
| 201 | { |
|---|
| 202 | u1=Uni(); |
|---|
| 203 | u2=Uni(); |
|---|
| 204 | x = 2.*u1-1.; |
|---|
| 205 | y = 2.*u2-1.; |
|---|
| 206 | d = x*x + y*y; |
|---|
| 207 | if(d>.0 && d<1.) break; |
|---|
| 208 | } |
|---|
| 209 | while(1); |
|---|
| 210 | u1 = x*SQRT((-2.*LOG(d))/d); |
|---|
| 211 | |
|---|
| 212 | res = u1*sd+mean; |
|---|
| 213 | |
|---|
| 214 | if(isnan(res) || isinf(res)) |
|---|
| 215 | { |
|---|
| 216 | printf("\n. res=%f sd=%f mean=%f u1=%f u2=%f",res,sd,mean,u1,u2); |
|---|
| 217 | } |
|---|
| 218 | return res; |
|---|
| 219 | } |
|---|
| 220 | |
|---|
| 221 | ////////////////////////////////////////////////////////////// |
|---|
| 222 | ////////////////////////////////////////////////////////////// |
|---|
| 223 | |
|---|
| 224 | |
|---|
| 225 | phydbl *Rnorm_Multid(phydbl *mu, phydbl *cov, int dim) |
|---|
| 226 | { |
|---|
| 227 | phydbl *L,*x,*y; |
|---|
| 228 | int i,j; |
|---|
| 229 | |
|---|
| 230 | x = (phydbl *)mCalloc(dim,sizeof(phydbl)); |
|---|
| 231 | y = (phydbl *)mCalloc(dim,sizeof(phydbl)); |
|---|
| 232 | |
|---|
| 233 | L = (phydbl *)Cholesky_Decomp(cov,dim); |
|---|
| 234 | |
|---|
| 235 | For(i,dim) x[i]=Rnorm(0.0,1.0); |
|---|
| 236 | For(i,dim) For(j,dim) y[i] += L[i*dim+j]*x[j]; |
|---|
| 237 | For(i,dim) y[i] += mu[i]; |
|---|
| 238 | |
|---|
| 239 | Free(L); |
|---|
| 240 | Free(x); |
|---|
| 241 | |
|---|
| 242 | return(y); |
|---|
| 243 | } |
|---|
| 244 | |
|---|
| 245 | ////////////////////////////////////////////////////////////// |
|---|
| 246 | ////////////////////////////////////////////////////////////// |
|---|
| 247 | |
|---|
| 248 | |
|---|
| 249 | phydbl Rnorm_Trunc_Inverse(phydbl mean, phydbl sd, phydbl min, phydbl max, int *error) |
|---|
| 250 | { |
|---|
| 251 | |
|---|
| 252 | phydbl u, ret_val,eps; |
|---|
| 253 | phydbl z; |
|---|
| 254 | phydbl z_min,z_max; |
|---|
| 255 | phydbl cdf_min, cdf_max; |
|---|
| 256 | |
|---|
| 257 | z = 0.0; |
|---|
| 258 | u = -1.0; |
|---|
| 259 | *error = 0; |
|---|
| 260 | |
|---|
| 261 | if(sd < 1.E-100) |
|---|
| 262 | { |
|---|
| 263 | PhyML_Printf("\n. Small variance detected in Rnorm_Trunc."); |
|---|
| 264 | PhyML_Printf("\n. mean=%f sd=%f min=%f max=%f",mean,sd,min,max); |
|---|
| 265 | *error = 1; |
|---|
| 266 | return -1.0; |
|---|
| 267 | } |
|---|
| 268 | |
|---|
| 269 | z_min = (min - mean)/sd; |
|---|
| 270 | z_max = (max - mean)/sd; |
|---|
| 271 | |
|---|
| 272 | eps = (z_max-z_min)/1E+6; |
|---|
| 273 | |
|---|
| 274 | |
|---|
| 275 | /* Simple inversion method. Seems to work well. Needs more thorough testing though... */ |
|---|
| 276 | cdf_min = Pnorm(z_min,0.0,1.0); |
|---|
| 277 | cdf_max = Pnorm(z_max,0.0,1.0); |
|---|
| 278 | u = cdf_min + (cdf_max-cdf_min) * Uni(); |
|---|
| 279 | z = PointNormal(u); |
|---|
| 280 | |
|---|
| 281 | if((z < z_min-eps) || (z > z_max+eps)) |
|---|
| 282 | { |
|---|
| 283 | *error = 1; |
|---|
| 284 | PhyML_Printf("\n. Numerical precision issue detected in Rnorm_Trunc."); |
|---|
| 285 | PhyML_Printf("\n. z = %f",z); |
|---|
| 286 | PhyML_Printf("\n. mean=%f sd=%f z_min=%f z_max=%f min=%f max=%f",mean,sd,z_min,z_max,min,max); |
|---|
| 287 | ret_val = (max - min)/2.; |
|---|
| 288 | Exit("\n"); |
|---|
| 289 | } |
|---|
| 290 | |
|---|
| 291 | ret_val = z*sd+mean; |
|---|
| 292 | |
|---|
| 293 | return ret_val; |
|---|
| 294 | } |
|---|
| 295 | |
|---|
| 296 | ////////////////////////////////////////////////////////////// |
|---|
| 297 | ////////////////////////////////////////////////////////////// |
|---|
| 298 | |
|---|
| 299 | |
|---|
| 300 | phydbl Rnorm_Trunc(phydbl mean, phydbl sd, phydbl min, phydbl max, int *error) |
|---|
| 301 | { |
|---|
| 302 | |
|---|
| 303 | phydbl ret_val,eps; |
|---|
| 304 | int iter; |
|---|
| 305 | phydbl z; |
|---|
| 306 | phydbl z_min,z_max; |
|---|
| 307 | |
|---|
| 308 | z = 0.0; |
|---|
| 309 | *error = NO; |
|---|
| 310 | |
|---|
| 311 | if(sd < 1.E-100) |
|---|
| 312 | { |
|---|
| 313 | PhyML_Printf("\n. Small variance detected in Rnorm_Trunc."); |
|---|
| 314 | PhyML_Printf("\n. mean=%f sd=%f min=%f max=%f",mean,sd,min,max); |
|---|
| 315 | *error = YES; |
|---|
| 316 | return -1.0; |
|---|
| 317 | } |
|---|
| 318 | |
|---|
| 319 | if(max < min) |
|---|
| 320 | { |
|---|
| 321 | PhyML_Printf("\n. Max < Min"); |
|---|
| 322 | PhyML_Printf("\n. mean=%f sd=%f min=%f max=%f",mean,sd,min,max); |
|---|
| 323 | *error = YES; |
|---|
| 324 | return -1.0; |
|---|
| 325 | } |
|---|
| 326 | |
|---|
| 327 | z_min = (min - mean)/sd; |
|---|
| 328 | z_max = (max - mean)/sd; |
|---|
| 329 | |
|---|
| 330 | eps = (z_max-z_min)/1E+6; |
|---|
| 331 | |
|---|
| 332 | /* Damien and Walker (2001) method */ |
|---|
| 333 | phydbl y,slice_min,slice_max; |
|---|
| 334 | |
|---|
| 335 | /* if((z_min < -10.) && (z_max > +10.)) /\* cdf < 1.E-6, we should be safe. *\/ */ |
|---|
| 336 | /* { */ |
|---|
| 337 | /* z = Rnorm(0.0,1.0); */ |
|---|
| 338 | /* } */ |
|---|
| 339 | /* else */ |
|---|
| 340 | /* { */ |
|---|
| 341 | |
|---|
| 342 | |
|---|
| 343 | iter = 0; |
|---|
| 344 | do |
|---|
| 345 | { |
|---|
| 346 | y = Uni()*EXP(-(z*z)/2.); |
|---|
| 347 | slice_min = MAX(z_min,-SQRT(-2.*LOG(y))); |
|---|
| 348 | slice_max = MIN(z_max, SQRT(-2.*LOG(y))); |
|---|
| 349 | z = Uni()*(slice_max - slice_min) + slice_min; |
|---|
| 350 | iter++; |
|---|
| 351 | if(iter > 1000) break; |
|---|
| 352 | } |
|---|
| 353 | while(slice_max < slice_min || iter < 10); |
|---|
| 354 | |
|---|
| 355 | if(iter > 1000) |
|---|
| 356 | { |
|---|
| 357 | PhyML_Printf("\n. Too many iterations in Rnorm_Trunc..."); |
|---|
| 358 | *error = 1; |
|---|
| 359 | } |
|---|
| 360 | |
|---|
| 361 | /* } */ |
|---|
| 362 | |
|---|
| 363 | /* Inverson method */ |
|---|
| 364 | /* phydbl cdf_min, cdf_max; */ |
|---|
| 365 | /* if((z_min < -10.) && (z_max > +10.)) /\* cdf < 1.E-6, we should be safe. *\/ */ |
|---|
| 366 | /* { */ |
|---|
| 367 | /* z = Rnorm(0.0,1.0); */ |
|---|
| 368 | /* } */ |
|---|
| 369 | /* else */ |
|---|
| 370 | /* { */ |
|---|
| 371 | /* /\* Simple inversion method. Seems to work well. Needs more thorough testing though... *\/ */ |
|---|
| 372 | /* cdf_min = Pnorm(z_min,0.0,1.0); */ |
|---|
| 373 | /* cdf_max = Pnorm(z_max,0.0,1.0); */ |
|---|
| 374 | /* u = cdf_min + (cdf_max-cdf_min) * Uni(); */ |
|---|
| 375 | /* z = PointNormal(u); */ |
|---|
| 376 | /* } */ |
|---|
| 377 | |
|---|
| 378 | |
|---|
| 379 | if((z < z_min-eps) || (z > z_max+eps)) |
|---|
| 380 | { |
|---|
| 381 | *error = YES; |
|---|
| 382 | PhyML_Printf("\n. Numerical precision issue detected in Rnorm_Trunc."); |
|---|
| 383 | PhyML_Printf("\n. z = %f",z); |
|---|
| 384 | PhyML_Printf("\n. mean=%f sd=%f z_min=%f z_max=%f min=%f max=%f",mean,sd,z_min,z_max,min,max); |
|---|
| 385 | ret_val = (max - min)/2.; |
|---|
| 386 | Exit("\n"); |
|---|
| 387 | } |
|---|
| 388 | |
|---|
| 389 | ret_val = z*sd+mean; |
|---|
| 390 | |
|---|
| 391 | return ret_val; |
|---|
| 392 | } |
|---|
| 393 | |
|---|
| 394 | ////////////////////////////////////////////////////////////// |
|---|
| 395 | ////////////////////////////////////////////////////////////// |
|---|
| 396 | |
|---|
| 397 | |
|---|
| 398 | phydbl *Rnorm_Multid_Trunc(phydbl *mean, phydbl *cov, phydbl *min, phydbl *max, int dim) |
|---|
| 399 | { |
|---|
| 400 | int i,j; |
|---|
| 401 | phydbl *L,*x, *u; |
|---|
| 402 | phydbl up, low, rec; |
|---|
| 403 | int err; |
|---|
| 404 | |
|---|
| 405 | u = (phydbl *)mCalloc(dim,sizeof(phydbl)); |
|---|
| 406 | x = (phydbl *)mCalloc(dim,sizeof(phydbl)); |
|---|
| 407 | |
|---|
| 408 | L = Cholesky_Decomp(cov,dim); |
|---|
| 409 | |
|---|
| 410 | low = (min[0]-mean[0])/L[0*dim+0]; |
|---|
| 411 | up = (max[0]-mean[0])/L[0*dim+0]; |
|---|
| 412 | u[0] = Rnorm_Trunc(0.0,1.0,low,up,&err); |
|---|
| 413 | |
|---|
| 414 | for(i=1;i<dim;i++) |
|---|
| 415 | { |
|---|
| 416 | rec = .0; |
|---|
| 417 | For(j,i) rec += L[i*dim+j] * u[j]; |
|---|
| 418 | low = (min[i]-mean[i]-rec)/L[i*dim+i]; |
|---|
| 419 | up = (max[i]-mean[i]-rec)/L[i*dim+i]; |
|---|
| 420 | u[i] = Rnorm_Trunc(0.0,1.0,low,up,&err); |
|---|
| 421 | } |
|---|
| 422 | |
|---|
| 423 | x = Matrix_Mult(L,u,dim,dim,dim,1); |
|---|
| 424 | |
|---|
| 425 | /* PhyML_Printf("\n>>>\n"); */ |
|---|
| 426 | /* For(i,dim) */ |
|---|
| 427 | /* { */ |
|---|
| 428 | /* For(j,dim) */ |
|---|
| 429 | /* { */ |
|---|
| 430 | /* PhyML_Printf("%10lf ",L[i*dim+j]); */ |
|---|
| 431 | /* } */ |
|---|
| 432 | /* PhyML_Printf("\n"); */ |
|---|
| 433 | /* } */ |
|---|
| 434 | /* PhyML_Printf("\n"); */ |
|---|
| 435 | |
|---|
| 436 | /* For(i,dim) PhyML_Printf("%f ",u[i]); */ |
|---|
| 437 | /* PhyML_Printf("\n"); */ |
|---|
| 438 | |
|---|
| 439 | |
|---|
| 440 | /* PhyML_Printf("\n"); */ |
|---|
| 441 | /* For(i,dim) PhyML_Printf("%10lf ",x[i]); */ |
|---|
| 442 | /* PhyML_Printf("\n<<<\n"); */ |
|---|
| 443 | |
|---|
| 444 | For(i,dim) x[i] += mean[i]; |
|---|
| 445 | |
|---|
| 446 | Free(L); |
|---|
| 447 | Free(u); |
|---|
| 448 | |
|---|
| 449 | return x; |
|---|
| 450 | } |
|---|
| 451 | |
|---|
| 452 | ////////////////////////////////////////////////////////////// |
|---|
| 453 | ////////////////////////////////////////////////////////////// |
|---|
| 454 | |
|---|
| 455 | /* DENSITIES / PROBA */ |
|---|
| 456 | ////////////////////////////////////////////////////////////// |
|---|
| 457 | ////////////////////////////////////////////////////////////// |
|---|
| 458 | |
|---|
| 459 | |
|---|
| 460 | phydbl Dnorm_Moments(phydbl x, phydbl mean, phydbl var) |
|---|
| 461 | { |
|---|
| 462 | phydbl dens,sd,pi; |
|---|
| 463 | |
|---|
| 464 | pi = 3.141593; |
|---|
| 465 | sd = SQRT(var); |
|---|
| 466 | |
|---|
| 467 | dens = 1./(SQRT(2*pi)*sd)*EXP(-((x-mean)*(x-mean)/(2.*sd*sd))); |
|---|
| 468 | |
|---|
| 469 | return dens; |
|---|
| 470 | } |
|---|
| 471 | |
|---|
| 472 | ////////////////////////////////////////////////////////////// |
|---|
| 473 | ////////////////////////////////////////////////////////////// |
|---|
| 474 | |
|---|
| 475 | |
|---|
| 476 | phydbl Dnorm(phydbl x, phydbl mean, phydbl sd) |
|---|
| 477 | { |
|---|
| 478 | phydbl dens; |
|---|
| 479 | |
|---|
| 480 | /* dens = -(.5*LOG2PI+LOG(sd)) - .5*POW(x-mean,2)/POW(sd,2); */ |
|---|
| 481 | /* return EXP(dens); */ |
|---|
| 482 | |
|---|
| 483 | x = (x-mean)/sd; |
|---|
| 484 | |
|---|
| 485 | dens = M_1_SQRT_2_PI * EXP(-0.5*x*x); |
|---|
| 486 | |
|---|
| 487 | return dens / sd; |
|---|
| 488 | } |
|---|
| 489 | |
|---|
| 490 | ////////////////////////////////////////////////////////////// |
|---|
| 491 | ////////////////////////////////////////////////////////////// |
|---|
| 492 | |
|---|
| 493 | |
|---|
| 494 | phydbl Log_Dnorm(phydbl x, phydbl mean, phydbl sd, int *err) |
|---|
| 495 | { |
|---|
| 496 | phydbl dens; |
|---|
| 497 | |
|---|
| 498 | *err = NO; |
|---|
| 499 | |
|---|
| 500 | x = (x-mean)/sd; |
|---|
| 501 | |
|---|
| 502 | /* dens = -(phydbl)LOG_SQRT_2_PI - x*x*0.5 - LOG(sd); */ |
|---|
| 503 | dens = -(phydbl)LOG(SQRT(2.*PI)) - x*x*0.5 - LOG(sd); |
|---|
| 504 | |
|---|
| 505 | if(dens < -BIG) |
|---|
| 506 | { |
|---|
| 507 | PhyML_Printf("\n. dens=%f -- x=%f mean=%f sd=%f\n",dens,x,mean,sd); |
|---|
| 508 | *err = 1; |
|---|
| 509 | } |
|---|
| 510 | |
|---|
| 511 | return dens; |
|---|
| 512 | } |
|---|
| 513 | |
|---|
| 514 | ////////////////////////////////////////////////////////////// |
|---|
| 515 | ////////////////////////////////////////////////////////////// |
|---|
| 516 | |
|---|
| 517 | |
|---|
| 518 | phydbl Log_Dnorm_Trunc(phydbl x, phydbl mean, phydbl sd, phydbl lo, phydbl up, int *err) |
|---|
| 519 | { |
|---|
| 520 | phydbl log_dens; |
|---|
| 521 | phydbl cdf_up, cdf_lo; |
|---|
| 522 | |
|---|
| 523 | *err = NO; |
|---|
| 524 | cdf_lo = cdf_up = 0.0; |
|---|
| 525 | |
|---|
| 526 | log_dens = Log_Dnorm(x,mean,sd,err); |
|---|
| 527 | |
|---|
| 528 | if(*err == YES) |
|---|
| 529 | { |
|---|
| 530 | PhyML_Printf("\n== mean=%f sd=%f lo=%f up=%f cdf_lo=%G CDF_up=%G log_dens=%G",mean,sd,lo,up,cdf_lo,cdf_up,log_dens); |
|---|
| 531 | PhyML_Printf("\n== Warning in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 532 | *err = YES; |
|---|
| 533 | } |
|---|
| 534 | |
|---|
| 535 | cdf_up = Pnorm(up,mean,sd); |
|---|
| 536 | cdf_lo = Pnorm(lo,mean,sd); |
|---|
| 537 | |
|---|
| 538 | if(cdf_up - cdf_lo < 1.E-20) |
|---|
| 539 | { |
|---|
| 540 | log_dens = -230.; /* ~LOG(1.E-100) */ |
|---|
| 541 | } |
|---|
| 542 | else |
|---|
| 543 | { |
|---|
| 544 | log_dens -= LOG(cdf_up - cdf_lo); |
|---|
| 545 | } |
|---|
| 546 | |
|---|
| 547 | if(isnan(log_dens) || isinf(FABS(log_dens))) |
|---|
| 548 | { |
|---|
| 549 | PhyML_Printf("\n. x=%f mean=%f sd=%f lo=%f up=%f cdf_lo=%G CDF_up=%G log_dens=%G",x,mean,sd,lo,up,cdf_lo,cdf_up,log_dens); |
|---|
| 550 | PhyML_Printf("\n. Warning in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 551 | *err = YES; |
|---|
| 552 | } |
|---|
| 553 | |
|---|
| 554 | return log_dens; |
|---|
| 555 | } |
|---|
| 556 | |
|---|
| 557 | ////////////////////////////////////////////////////////////// |
|---|
| 558 | ////////////////////////////////////////////////////////////// |
|---|
| 559 | |
|---|
| 560 | |
|---|
| 561 | phydbl Dnorm_Trunc(phydbl x, phydbl mean, phydbl sd, phydbl lo, phydbl up) |
|---|
| 562 | { |
|---|
| 563 | phydbl dens; |
|---|
| 564 | phydbl cdf_up, cdf_lo; |
|---|
| 565 | |
|---|
| 566 | dens = Dnorm(x,mean,sd); |
|---|
| 567 | cdf_up = Pnorm(up,mean,sd); |
|---|
| 568 | cdf_lo = Pnorm(lo,mean,sd); |
|---|
| 569 | |
|---|
| 570 | dens /= (cdf_up - cdf_lo); |
|---|
| 571 | |
|---|
| 572 | if(isnan(dens) || isinf(FABS(dens))) |
|---|
| 573 | { |
|---|
| 574 | PhyML_Printf("\n. mean=%f sd=%f lo=%f up=%f cdf_lo=%G CDF_up=%G",mean,sd,lo,up,cdf_lo,cdf_up); |
|---|
| 575 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 576 | Exit("\n"); |
|---|
| 577 | } |
|---|
| 578 | |
|---|
| 579 | return dens; |
|---|
| 580 | } |
|---|
| 581 | |
|---|
| 582 | ////////////////////////////////////////////////////////////// |
|---|
| 583 | ////////////////////////////////////////////////////////////// |
|---|
| 584 | |
|---|
| 585 | |
|---|
| 586 | phydbl Dnorm_Multi(phydbl *x, phydbl *mu, phydbl *cov, int size, int _log) |
|---|
| 587 | { |
|---|
| 588 | phydbl *xmmu,*invcov; |
|---|
| 589 | phydbl *buff1,*buff2; |
|---|
| 590 | int i; |
|---|
| 591 | phydbl det,density; |
|---|
| 592 | |
|---|
| 593 | xmmu = (phydbl *)mCalloc(size,sizeof(phydbl)); |
|---|
| 594 | invcov = (phydbl *)mCalloc(size*size,sizeof(phydbl)); |
|---|
| 595 | |
|---|
| 596 | For(i,size) xmmu[i] = x[i] - mu[i]; |
|---|
| 597 | For(i,size*size) invcov[i] = cov[i]; |
|---|
| 598 | |
|---|
| 599 | if(!Matinv(invcov,size,size,NO)) |
|---|
| 600 | { |
|---|
| 601 | PhyML_Printf("\n== Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 602 | Exit("\n"); |
|---|
| 603 | } |
|---|
| 604 | |
|---|
| 605 | buff1 = Matrix_Mult(xmmu,invcov,1,size,size,size); |
|---|
| 606 | buff2 = Matrix_Mult(buff1,xmmu,1,size,size,1); |
|---|
| 607 | |
|---|
| 608 | det = Matrix_Det(cov,size,NO); |
|---|
| 609 | /* det_1D(cov,size,&det); */ |
|---|
| 610 | |
|---|
| 611 | density = size * LOG2PI + LOG(det) + buff2[0]; |
|---|
| 612 | density /= -2.; |
|---|
| 613 | |
|---|
| 614 | /* density = (1./(POW(2.*PI,size/2.)*SQRT(FABS(det)))) * EXP(-0.5*buff2[0]); */ |
|---|
| 615 | |
|---|
| 616 | Free(xmmu); |
|---|
| 617 | Free(invcov); |
|---|
| 618 | Free(buff1); |
|---|
| 619 | Free(buff2); |
|---|
| 620 | |
|---|
| 621 | return (_log)?(density):(EXP(density)); |
|---|
| 622 | } |
|---|
| 623 | |
|---|
| 624 | ////////////////////////////////////////////////////////////// |
|---|
| 625 | ////////////////////////////////////////////////////////////// |
|---|
| 626 | |
|---|
| 627 | |
|---|
| 628 | phydbl Dnorm_Multi_Given_InvCov_Det(phydbl *x, phydbl *mu, phydbl *invcov, phydbl log_det, int size, int _log) |
|---|
| 629 | { |
|---|
| 630 | phydbl *xmmu; |
|---|
| 631 | phydbl *buff1,*buff2; |
|---|
| 632 | int i; |
|---|
| 633 | phydbl density; |
|---|
| 634 | |
|---|
| 635 | xmmu = (phydbl *)mCalloc(size,sizeof(phydbl)); |
|---|
| 636 | |
|---|
| 637 | For(i,size) xmmu[i] = x[i] - mu[i]; |
|---|
| 638 | |
|---|
| 639 | buff1 = Matrix_Mult(xmmu,invcov,1,size,size,size); |
|---|
| 640 | buff2 = Matrix_Mult(buff1,xmmu,1,size,size,1); |
|---|
| 641 | |
|---|
| 642 | density = size * LOG2PI + log_det + buff2[0]; |
|---|
| 643 | density /= -2.; |
|---|
| 644 | |
|---|
| 645 | Free(xmmu); |
|---|
| 646 | Free(buff1); |
|---|
| 647 | Free(buff2); |
|---|
| 648 | |
|---|
| 649 | return (_log)?(density):(EXP(density)); |
|---|
| 650 | } |
|---|
| 651 | |
|---|
| 652 | ////////////////////////////////////////////////////////////// |
|---|
| 653 | ////////////////////////////////////////////////////////////// |
|---|
| 654 | |
|---|
| 655 | |
|---|
| 656 | phydbl Pbinom(int N, int ni, phydbl p) |
|---|
| 657 | { |
|---|
| 658 | return Bico(N,ni)*POW(p,ni)*POW(1-p,N-ni); |
|---|
| 659 | } |
|---|
| 660 | |
|---|
| 661 | ////////////////////////////////////////////////////////////// |
|---|
| 662 | ////////////////////////////////////////////////////////////// |
|---|
| 663 | |
|---|
| 664 | |
|---|
| 665 | phydbl Bivariate_Normal_Density(phydbl x, phydbl y, phydbl mux, phydbl muy, phydbl sdx, phydbl sdy, phydbl rho) |
|---|
| 666 | { |
|---|
| 667 | phydbl cx, cy; |
|---|
| 668 | phydbl pi; |
|---|
| 669 | phydbl dens; |
|---|
| 670 | phydbl rho2; |
|---|
| 671 | |
|---|
| 672 | pi = 3.141593; |
|---|
| 673 | |
|---|
| 674 | cx = x - mux; |
|---|
| 675 | cy = y - muy; |
|---|
| 676 | |
|---|
| 677 | rho2 = rho*rho; |
|---|
| 678 | |
|---|
| 679 | dens = 1./(2*pi*sdx*sdy*SQRT(1.-rho2)); |
|---|
| 680 | dens *= EXP((-1./(2.*(1.-rho2)))*(cx*cx/(sdx*sdx)+cy*cy/(sdy*sdy)+2*rho*cx*cy/(sdx*sdy))); |
|---|
| 681 | |
|---|
| 682 | return dens; |
|---|
| 683 | } |
|---|
| 684 | |
|---|
| 685 | ////////////////////////////////////////////////////////////// |
|---|
| 686 | ////////////////////////////////////////////////////////////// |
|---|
| 687 | |
|---|
| 688 | |
|---|
| 689 | phydbl Dgamma_Moments(phydbl x, phydbl mean, phydbl var) |
|---|
| 690 | { |
|---|
| 691 | phydbl shape, scale; |
|---|
| 692 | |
|---|
| 693 | if(var < 1.E-20) |
|---|
| 694 | { |
|---|
| 695 | /* var = 1.E-20; */ |
|---|
| 696 | PhyML_Printf("\n. var=%f mean=%f",var,mean); |
|---|
| 697 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 698 | Exit("\n"); |
|---|
| 699 | } |
|---|
| 700 | |
|---|
| 701 | if(mean < 1.E-20) |
|---|
| 702 | { |
|---|
| 703 | /* mean = 1.E-20; */ |
|---|
| 704 | PhyML_Printf("\n. var=%f mean=%f",var,mean); |
|---|
| 705 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 706 | Exit("\n"); |
|---|
| 707 | } |
|---|
| 708 | |
|---|
| 709 | |
|---|
| 710 | shape = mean * mean / var; |
|---|
| 711 | scale = var / mean; |
|---|
| 712 | |
|---|
| 713 | return(Dgamma(x,shape,scale)); |
|---|
| 714 | } |
|---|
| 715 | |
|---|
| 716 | ////////////////////////////////////////////////////////////// |
|---|
| 717 | ////////////////////////////////////////////////////////////// |
|---|
| 718 | |
|---|
| 719 | |
|---|
| 720 | phydbl Dgamma(phydbl x, phydbl shape, phydbl scale) |
|---|
| 721 | { |
|---|
| 722 | phydbl v; |
|---|
| 723 | |
|---|
| 724 | if(x > INFINITY) |
|---|
| 725 | { |
|---|
| 726 | PhyML_Printf("\n. WARNING: huge value of x -> x = %G",x); |
|---|
| 727 | x = 1.E+10; |
|---|
| 728 | } |
|---|
| 729 | |
|---|
| 730 | if(x < 1.E-20) |
|---|
| 731 | { |
|---|
| 732 | if(x < 0.0) return 0.0; |
|---|
| 733 | else |
|---|
| 734 | { |
|---|
| 735 | PhyML_Printf("\n. WARNING: small value of x -> x = %G",x); |
|---|
| 736 | x = 1.E-20; |
|---|
| 737 | } |
|---|
| 738 | } |
|---|
| 739 | |
|---|
| 740 | |
|---|
| 741 | if(scale < 0.0 || shape < 0.0) |
|---|
| 742 | { |
|---|
| 743 | PhyML_Printf("\n. scale=%f shape=%f",scale,shape); |
|---|
| 744 | Exit("\n"); |
|---|
| 745 | } |
|---|
| 746 | |
|---|
| 747 | |
|---|
| 748 | v = (shape-1.) * LOG(x) - shape * LOG(scale) - x / scale - LnGamma(shape); |
|---|
| 749 | |
|---|
| 750 | |
|---|
| 751 | if(v < 500.) |
|---|
| 752 | { |
|---|
| 753 | v = EXP(v); |
|---|
| 754 | } |
|---|
| 755 | else |
|---|
| 756 | { |
|---|
| 757 | PhyML_Printf("\n. WARNING v=%f x=%f shape=%f scale=%f",v,x,shape,scale); |
|---|
| 758 | PhyML_Printf("\n. LOG(x) = %G LnGamma(shape)=%G",LOG(x),LnGamma(shape)); |
|---|
| 759 | v = EXP(v); |
|---|
| 760 | /* PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); */ |
|---|
| 761 | /* Exit("\n"); */ |
|---|
| 762 | } |
|---|
| 763 | |
|---|
| 764 | |
|---|
| 765 | return v; |
|---|
| 766 | } |
|---|
| 767 | |
|---|
| 768 | ////////////////////////////////////////////////////////////// |
|---|
| 769 | ////////////////////////////////////////////////////////////// |
|---|
| 770 | |
|---|
| 771 | |
|---|
| 772 | phydbl Dexp(phydbl x, phydbl param) |
|---|
| 773 | { |
|---|
| 774 | return param * EXP(-param * x); |
|---|
| 775 | } |
|---|
| 776 | |
|---|
| 777 | ////////////////////////////////////////////////////////////// |
|---|
| 778 | ////////////////////////////////////////////////////////////// |
|---|
| 779 | |
|---|
| 780 | phydbl Dpois(phydbl x, phydbl param) |
|---|
| 781 | { |
|---|
| 782 | phydbl v; |
|---|
| 783 | |
|---|
| 784 | if(x < 0) |
|---|
| 785 | { |
|---|
| 786 | PhyML_Printf("\n. x = %f",x); |
|---|
| 787 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 788 | Warn_And_Exit(""); |
|---|
| 789 | } |
|---|
| 790 | |
|---|
| 791 | v = x * LOG(param) - param - LnGamma(x+1); |
|---|
| 792 | |
|---|
| 793 | if(v < 500) |
|---|
| 794 | { |
|---|
| 795 | v = EXP(v); |
|---|
| 796 | } |
|---|
| 797 | else |
|---|
| 798 | { |
|---|
| 799 | PhyML_Printf("\n. WARNING v=%f x=%f param=%f",v,x,param); |
|---|
| 800 | v = EXP(500); |
|---|
| 801 | } |
|---|
| 802 | |
|---|
| 803 | /* PhyML_Printf("\n. Poi %f %f (x=%f param=%f)", */ |
|---|
| 804 | /* v, */ |
|---|
| 805 | /* POW(param,x) * EXP(-param) / EXP(LnGamma(x+1)), */ |
|---|
| 806 | /* x,param); */ |
|---|
| 807 | /* return POW(param,x) * EXP(-param) / EXP(LnGamma(x+1)); */ |
|---|
| 808 | |
|---|
| 809 | return v; |
|---|
| 810 | } |
|---|
| 811 | |
|---|
| 812 | ////////////////////////////////////////////////////////////// |
|---|
| 813 | ////////////////////////////////////////////////////////////// |
|---|
| 814 | |
|---|
| 815 | |
|---|
| 816 | |
|---|
| 817 | ////////////////////////////////////////////////////////////// |
|---|
| 818 | ////////////////////////////////////////////////////////////// |
|---|
| 819 | |
|---|
| 820 | /* CDFs */ |
|---|
| 821 | ////////////////////////////////////////////////////////////// |
|---|
| 822 | ////////////////////////////////////////////////////////////// |
|---|
| 823 | |
|---|
| 824 | |
|---|
| 825 | phydbl Pnorm(phydbl x, phydbl mean, phydbl sd) |
|---|
| 826 | { |
|---|
| 827 | /* const phydbl b1 = 0.319381530; */ |
|---|
| 828 | /* const phydbl b2 = -0.356563782; */ |
|---|
| 829 | /* const phydbl b3 = 1.781477937; */ |
|---|
| 830 | /* const phydbl b4 = -1.821255978; */ |
|---|
| 831 | /* const phydbl b5 = 1.330274429; */ |
|---|
| 832 | /* const phydbl p = 0.2316419; */ |
|---|
| 833 | /* const phydbl c = 0.39894228; */ |
|---|
| 834 | |
|---|
| 835 | x = (x-mean)/sd; |
|---|
| 836 | |
|---|
| 837 | /* if(x >= 0.0) */ |
|---|
| 838 | /* { */ |
|---|
| 839 | /* phydbl t = 1.0 / ( 1.0 + p * x ); */ |
|---|
| 840 | /* return (1.0 - c * EXP( -x * x / 2.0 ) * t * */ |
|---|
| 841 | /* ( t *( t * ( t * ( t * b5 + b4 ) + b3 ) + b2 ) + b1 )); */ |
|---|
| 842 | /* } */ |
|---|
| 843 | /* else */ |
|---|
| 844 | /* { */ |
|---|
| 845 | /* phydbl t = 1.0 / ( 1.0 - p * x ); */ |
|---|
| 846 | /* return ( c * EXP( -x * x / 2.0 ) * t * */ |
|---|
| 847 | /* ( t *( t * ( t * ( t * b5 + b4 ) + b3 ) + b2 ) + b1 )); */ |
|---|
| 848 | /* } */ |
|---|
| 849 | |
|---|
| 850 | /* i_tail in {0,1,2} means: "lower", "upper", or "both" : |
|---|
| 851 | if(lower) return *cum := P[X <= x] |
|---|
| 852 | if(upper) return *ccum := P[X > x] = 1 - P[X <= x] |
|---|
| 853 | */ |
|---|
| 854 | |
|---|
| 855 | /* return Pnorm_Marsaglia(x); */ |
|---|
| 856 | return Pnorm_Ihaka_Derived_From_Cody(x); |
|---|
| 857 | } |
|---|
| 858 | |
|---|
| 859 | |
|---|
| 860 | /* G. Marsaglia. "Evaluating the Normal distribution". Journal of Statistical Software. 2004. Vol. 11. Issue 4. */ |
|---|
| 861 | phydbl Pnorm_Marsaglia(phydbl x) |
|---|
| 862 | { |
|---|
| 863 | long double s=x,t=0,b=x,q=x*x,i=1; |
|---|
| 864 | while(s!=t) s=(t=s)+(b*=q/(i+=2)); |
|---|
| 865 | return .5+s*exp(-.5*q-.91893853320467274178L); |
|---|
| 866 | |
|---|
| 867 | } |
|---|
| 868 | |
|---|
| 869 | |
|---|
| 870 | |
|---|
| 871 | /* Stolen from R source code */ |
|---|
| 872 | #define SIXTEN 16 |
|---|
| 873 | |
|---|
| 874 | phydbl Pnorm_Ihaka_Derived_From_Cody(phydbl x) |
|---|
| 875 | { |
|---|
| 876 | |
|---|
| 877 | const static double a[5] = { |
|---|
| 878 | 2.2352520354606839287, |
|---|
| 879 | 161.02823106855587881, |
|---|
| 880 | 1067.6894854603709582, |
|---|
| 881 | 18154.981253343561249, |
|---|
| 882 | 0.065682337918207449113 |
|---|
| 883 | }; |
|---|
| 884 | const static double b[4] = { |
|---|
| 885 | 47.20258190468824187, |
|---|
| 886 | 976.09855173777669322, |
|---|
| 887 | 10260.932208618978205, |
|---|
| 888 | 45507.789335026729956 |
|---|
| 889 | }; |
|---|
| 890 | const static double c[9] = { |
|---|
| 891 | 0.39894151208813466764, |
|---|
| 892 | 8.8831497943883759412, |
|---|
| 893 | 93.506656132177855979, |
|---|
| 894 | 597.27027639480026226, |
|---|
| 895 | 2494.5375852903726711, |
|---|
| 896 | 6848.1904505362823326, |
|---|
| 897 | 11602.651437647350124, |
|---|
| 898 | 9842.7148383839780218, |
|---|
| 899 | 1.0765576773720192317e-8 |
|---|
| 900 | }; |
|---|
| 901 | const static double d[8] = { |
|---|
| 902 | 22.266688044328115691, |
|---|
| 903 | 235.38790178262499861, |
|---|
| 904 | 1519.377599407554805, |
|---|
| 905 | 6485.558298266760755, |
|---|
| 906 | 18615.571640885098091, |
|---|
| 907 | 34900.952721145977266, |
|---|
| 908 | 38912.003286093271411, |
|---|
| 909 | 19685.429676859990727 |
|---|
| 910 | }; |
|---|
| 911 | const static double p[6] = { |
|---|
| 912 | 0.21589853405795699, |
|---|
| 913 | 0.1274011611602473639, |
|---|
| 914 | 0.022235277870649807, |
|---|
| 915 | 0.001421619193227893466, |
|---|
| 916 | 2.9112874951168792e-5, |
|---|
| 917 | 0.02307344176494017303 |
|---|
| 918 | }; |
|---|
| 919 | const static double q[5] = { |
|---|
| 920 | 1.28426009614491121, |
|---|
| 921 | 0.468238212480865118, |
|---|
| 922 | 0.0659881378689285515, |
|---|
| 923 | 0.00378239633202758244, |
|---|
| 924 | 7.29751555083966205e-5 |
|---|
| 925 | }; |
|---|
| 926 | |
|---|
| 927 | double xden, xnum, temp, del, eps, xsq, y; |
|---|
| 928 | int i, lower, upper; |
|---|
| 929 | double cum,ccum; |
|---|
| 930 | int i_tail; |
|---|
| 931 | |
|---|
| 932 | i_tail = 0; |
|---|
| 933 | cum = ccum = 0.0; |
|---|
| 934 | |
|---|
| 935 | if(isnan(x)) { cum = ccum = x; return (phydbl)cum; } |
|---|
| 936 | |
|---|
| 937 | /* Consider changing these : */ |
|---|
| 938 | eps = DBL_EPSILON * 0.5; |
|---|
| 939 | |
|---|
| 940 | /* i_tail in {0,1,2} =^= {lower, upper, both} */ |
|---|
| 941 | lower = i_tail != 1; |
|---|
| 942 | upper = i_tail != 0; |
|---|
| 943 | |
|---|
| 944 | y = fabs(x); |
|---|
| 945 | if (y <= 0.67448975) { /* qnorm(3/4) = .6744.... -- earlier had 0.66291 */ |
|---|
| 946 | if (y > eps) { |
|---|
| 947 | xsq = x * x; |
|---|
| 948 | xnum = a[4] * xsq; |
|---|
| 949 | xden = xsq; |
|---|
| 950 | for (i = 0; i < 3; ++i) { |
|---|
| 951 | xnum = (xnum + a[i]) * xsq; |
|---|
| 952 | xden = (xden + b[i]) * xsq; |
|---|
| 953 | } |
|---|
| 954 | } else xnum = xden = 0.0; |
|---|
| 955 | |
|---|
| 956 | temp = x * (xnum + a[3]) / (xden + b[3]); |
|---|
| 957 | if(lower) cum = 0.5 + temp; |
|---|
| 958 | if(upper) ccum = 0.5 - temp; |
|---|
| 959 | } |
|---|
| 960 | else if (y <= M_SQRT_32) { |
|---|
| 961 | |
|---|
| 962 | /* Evaluate pnorm for 0.674.. = qnorm(3/4) < |x| <= SQRT(32) ~= 5.657 */ |
|---|
| 963 | |
|---|
| 964 | xnum = c[8] * y; |
|---|
| 965 | xden = y; |
|---|
| 966 | for (i = 0; i < 7; ++i) { |
|---|
| 967 | xnum = (xnum + c[i]) * y; |
|---|
| 968 | xden = (xden + d[i]) * y; |
|---|
| 969 | } |
|---|
| 970 | temp = (xnum + c[7]) / (xden + d[7]); |
|---|
| 971 | |
|---|
| 972 | #define do_del(X) \ |
|---|
| 973 | xsq = floor(X * SIXTEN) / SIXTEN; \ |
|---|
| 974 | del = (X - xsq) * (X + xsq); \ |
|---|
| 975 | cum = exp(-xsq * xsq * 0.5) * exp(-del * 0.5) * temp; \ |
|---|
| 976 | ccum = 1.0 - cum; \ |
|---|
| 977 | |
|---|
| 978 | #define swap_tail \ |
|---|
| 979 | if (x > 0.) {/* swap ccum <--> cum */ \ |
|---|
| 980 | temp = cum; if(lower) cum = ccum; ccum = temp; \ |
|---|
| 981 | } |
|---|
| 982 | |
|---|
| 983 | do_del(y); |
|---|
| 984 | swap_tail; |
|---|
| 985 | } |
|---|
| 986 | |
|---|
| 987 | /* else |x| > SQRT(32) = 5.657 : |
|---|
| 988 | * the next two case differentiations were really for lower=T, log=F |
|---|
| 989 | * Particularly *not* for log_p ! |
|---|
| 990 | |
|---|
| 991 | * Cody had (-37.5193 < x && x < 8.2924) ; R originally had y < 50 |
|---|
| 992 | * |
|---|
| 993 | * Note that we do want symmetry(0), lower/upper -> hence use y |
|---|
| 994 | */ |
|---|
| 995 | else if((lower && -37.5193 < x && x < 8.2924) || (upper && -8.2924 < x && x < 37.5193)) |
|---|
| 996 | { |
|---|
| 997 | /* Evaluate pnorm for x in (-37.5, -5.657) union (5.657, 37.5) */ |
|---|
| 998 | xsq = 1.0 / (x * x); |
|---|
| 999 | xnum = p[5] * xsq; |
|---|
| 1000 | xden = xsq; |
|---|
| 1001 | for (i = 0; i < 4; ++i) { |
|---|
| 1002 | xnum = (xnum + p[i]) * xsq; |
|---|
| 1003 | xden = (xden + q[i]) * xsq; |
|---|
| 1004 | } |
|---|
| 1005 | temp = xsq * (xnum + p[4]) / (xden + q[4]); |
|---|
| 1006 | temp = (M_1_SQRT_2_PI - temp) / y; |
|---|
| 1007 | |
|---|
| 1008 | do_del(x); |
|---|
| 1009 | swap_tail; |
|---|
| 1010 | } |
|---|
| 1011 | else |
|---|
| 1012 | { /* no log_p , large x such that probs are 0 or 1 */ |
|---|
| 1013 | if(x > 0) { cum = 1.; ccum = 0.; } |
|---|
| 1014 | else { cum = 0.; ccum = 1.; } |
|---|
| 1015 | } |
|---|
| 1016 | |
|---|
| 1017 | return (phydbl)cum; |
|---|
| 1018 | |
|---|
| 1019 | |
|---|
| 1020 | } |
|---|
| 1021 | |
|---|
| 1022 | ////////////////////////////////////////////////////////////// |
|---|
| 1023 | ////////////////////////////////////////////////////////////// |
|---|
| 1024 | |
|---|
| 1025 | |
|---|
| 1026 | phydbl Pgamma(phydbl x, phydbl shape, phydbl scale) |
|---|
| 1027 | { |
|---|
| 1028 | return IncompleteGamma(x/scale,shape,LnGamma(shape)); |
|---|
| 1029 | } |
|---|
| 1030 | |
|---|
| 1031 | ////////////////////////////////////////////////////////////// |
|---|
| 1032 | ////////////////////////////////////////////////////////////// |
|---|
| 1033 | |
|---|
| 1034 | |
|---|
| 1035 | phydbl Ppois(phydbl x, phydbl param) |
|---|
| 1036 | { |
|---|
| 1037 | /* Press et al. (1990) approximation of the CDF for the Poisson distribution */ |
|---|
| 1038 | if(param < SMALL || x < 0.0) |
|---|
| 1039 | { |
|---|
| 1040 | PhyML_Printf("\n. param = %G x=%G",param,x); |
|---|
| 1041 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 1042 | Warn_And_Exit(""); |
|---|
| 1043 | } |
|---|
| 1044 | return IncompleteGamma(x,param,LnGamma(param)); |
|---|
| 1045 | } |
|---|
| 1046 | |
|---|
| 1047 | ////////////////////////////////////////////////////////////// |
|---|
| 1048 | ////////////////////////////////////////////////////////////// |
|---|
| 1049 | |
|---|
| 1050 | |
|---|
| 1051 | ////////////////////////////////////////////////////////////// |
|---|
| 1052 | ////////////////////////////////////////////////////////////// |
|---|
| 1053 | |
|---|
| 1054 | /* Inverse CDFs */ |
|---|
| 1055 | ////////////////////////////////////////////////////////////// |
|---|
| 1056 | ////////////////////////////////////////////////////////////// |
|---|
| 1057 | |
|---|
| 1058 | |
|---|
| 1059 | phydbl PointChi2 (phydbl prob, phydbl v) |
|---|
| 1060 | { |
|---|
| 1061 | /* returns z so that Prob{x<z}=prob where x is Chi2 distributed with df=v |
|---|
| 1062 | returns -1 if in error. 0.000002<prob<0.999998 |
|---|
| 1063 | RATNEST FORTRAN by |
|---|
| 1064 | Best DJ & Roberts DE (1975) The percentage points of the |
|---|
| 1065 | Chi2 distribution. Applied Statistics 24: 385-388. (AS91) |
|---|
| 1066 | Converted into C by Ziheng Yang, Oct. 1993. |
|---|
| 1067 | */ |
|---|
| 1068 | double aa=.6931471805, p=prob, g; |
|---|
| 1069 | double xx, c, ch, a=0,q=0,p1=0,p2=0,t=0,x=0,b=0,s1,s2,s3,s4,s5,s6; |
|---|
| 1070 | double e=.5e-6; |
|---|
| 1071 | |
|---|
| 1072 | if (p<.000002 || p>.999998 || v<=0) return ((phydbl)-1); |
|---|
| 1073 | |
|---|
| 1074 | g = (double)LnGamma(v/2); |
|---|
| 1075 | xx=v/2; c=xx-1; |
|---|
| 1076 | if (v >= -1.24*log(p)) goto l1; |
|---|
| 1077 | |
|---|
| 1078 | ch=pow((p*xx*exp(g+xx*aa)), 1/xx); |
|---|
| 1079 | if (ch-e<0) return (ch); |
|---|
| 1080 | goto l4; |
|---|
| 1081 | l1: |
|---|
| 1082 | if (v>.32) goto l3; |
|---|
| 1083 | ch=0.4; a=log(1-p); |
|---|
| 1084 | l2: |
|---|
| 1085 | q=ch; p1=1+ch*(4.67+ch); p2=ch*(6.73+ch*(6.66+ch)); |
|---|
| 1086 | t=-0.5+(4.67+2*ch)/p1 - (6.73+ch*(13.32+3*ch))/p2; |
|---|
| 1087 | ch-=(1-exp(a+g+.5*ch+c*aa)*p2/p1)/t; |
|---|
| 1088 | if (fabs(q/ch-1)-.01 <= 0) goto l4; |
|---|
| 1089 | else goto l2; |
|---|
| 1090 | |
|---|
| 1091 | l3: |
|---|
| 1092 | x=(double)PointNormal (p); |
|---|
| 1093 | p1=0.222222/v; ch=v*pow((x*sqrt(p1)+1-p1), 3.0); |
|---|
| 1094 | if (ch>2.2*v+6) ch=-2*(log(1-p)-c*log(.5*ch)+g); |
|---|
| 1095 | l4: |
|---|
| 1096 | q=ch; p1=.5*ch; |
|---|
| 1097 | if ((t=(double)IncompleteGamma (p1, xx, g))<0) { |
|---|
| 1098 | PhyML_Printf ("\nerr IncompleteGamma"); |
|---|
| 1099 | return ((phydbl)-1.); |
|---|
| 1100 | } |
|---|
| 1101 | p2=p-t; |
|---|
| 1102 | t=p2*exp(xx*aa+g+p1-c*log(ch)); |
|---|
| 1103 | b=t/ch; a=0.5*t-b*c; |
|---|
| 1104 | |
|---|
| 1105 | s1=(210+a*(140+a*(105+a*(84+a*(70+60*a))))) / 420; |
|---|
| 1106 | s2=(420+a*(735+a*(966+a*(1141+1278*a))))/2520; |
|---|
| 1107 | s3=(210+a*(462+a*(707+932*a)))/2520; |
|---|
| 1108 | s4=(252+a*(672+1182*a)+c*(294+a*(889+1740*a)))/5040; |
|---|
| 1109 | s5=(84+264*a+c*(175+606*a))/2520; |
|---|
| 1110 | s6=(120+c*(346+127*c))/5040; |
|---|
| 1111 | ch+=t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6)))))); |
|---|
| 1112 | if (FABS(q/ch-1) > e) goto l4; |
|---|
| 1113 | |
|---|
| 1114 | return (phydbl)(ch); |
|---|
| 1115 | } |
|---|
| 1116 | |
|---|
| 1117 | ////////////////////////////////////////////////////////////// |
|---|
| 1118 | ////////////////////////////////////////////////////////////// |
|---|
| 1119 | |
|---|
| 1120 | |
|---|
| 1121 | |
|---|
| 1122 | /* |
|---|
| 1123 | The following function was extracted from the source code of R. |
|---|
| 1124 | It implements the methods referenced below. |
|---|
| 1125 | * REFERENCE |
|---|
| 1126 | * |
|---|
| 1127 | * Beasley, J. D. and S. G. Springer (1977). |
|---|
| 1128 | * Algorithm AS 111: The percentage points of the normal distribution, |
|---|
| 1129 | * Applied Statistics, 26, 118-121. |
|---|
| 1130 | * |
|---|
| 1131 | * Wichura, M.J. (1988). |
|---|
| 1132 | * Algorithm AS 241: The Percentage Points of the Normal Distribution. |
|---|
| 1133 | * Applied Statistics, 37, 477-484. |
|---|
| 1134 | */ |
|---|
| 1135 | |
|---|
| 1136 | |
|---|
| 1137 | phydbl PointNormal (phydbl prob) |
|---|
| 1138 | { |
|---|
| 1139 | /* returns z so that Prob{x<z}=prob where x ~ N(0,1) and (1e-12)<prob<1-(1e-12) |
|---|
| 1140 | returns (-9999) if in error |
|---|
| 1141 | Odeh RE & Evans JO (1974) The percentage points of the normal distribution. |
|---|
| 1142 | Applied Statistics 22: 96-97 (AS70) |
|---|
| 1143 | |
|---|
| 1144 | Newer methods: |
|---|
| 1145 | Wichura MJ (1988) Algorithm AS 241: the percentage points of the |
|---|
| 1146 | normal distribution. 37: 477-484. |
|---|
| 1147 | Beasley JD & Springer SG (1977). Algorithm AS 111: the percentage |
|---|
| 1148 | points of the normal distribution. 26: 118-121. |
|---|
| 1149 | */ |
|---|
| 1150 | phydbl a0=-.322232431088, a1=-1, a2=-.342242088547, a3=-.0204231210245; |
|---|
| 1151 | phydbl a4=-.453642210148e-4, b0=.0993484626060, b1=.588581570495; |
|---|
| 1152 | phydbl b2=.531103462366, b3=.103537752850, b4=.0038560700634; |
|---|
| 1153 | phydbl y, z=0, p=prob, p1; |
|---|
| 1154 | |
|---|
| 1155 | p1 = (p<0.5 ? p : 1-p); |
|---|
| 1156 | if (p1<1e-20) z=999; |
|---|
| 1157 | else { |
|---|
| 1158 | y = SQRT (LOG(1/(p1*p1))); |
|---|
| 1159 | z = y + ((((y*a4+a3)*y+a2)*y+a1)*y+a0) / ((((y*b4+b3)*y+b2)*y+b1)*y+b0); |
|---|
| 1160 | } |
|---|
| 1161 | return (p<0.5 ? -z : z); |
|---|
| 1162 | } |
|---|
| 1163 | |
|---|
| 1164 | |
|---|
| 1165 | /* phydbl PointNormal(phydbl p) */ |
|---|
| 1166 | /* { */ |
|---|
| 1167 | /* double p_, q, r, val; */ |
|---|
| 1168 | |
|---|
| 1169 | /* p_ = p; */ |
|---|
| 1170 | /* q = p_ - 0.5; */ |
|---|
| 1171 | |
|---|
| 1172 | /* /\*-- use AS 241 --- *\/ */ |
|---|
| 1173 | /* /\* double ppnd16_(double *p, long *ifault)*\/ */ |
|---|
| 1174 | /* /\* ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 */ |
|---|
| 1175 | |
|---|
| 1176 | /* Produces the normal deviate Z corresponding to a given lower */ |
|---|
| 1177 | /* tail area of P; Z is accurate to about 1 part in 10**16. */ |
|---|
| 1178 | |
|---|
| 1179 | /* (original fortran code used PARAMETER(..) for the coefficients */ |
|---|
| 1180 | /* and provided hash codes for checking them...) */ |
|---|
| 1181 | /* *\/ */ |
|---|
| 1182 | /* if (fabs(q) <= .425) */ |
|---|
| 1183 | /* {/\* 0.075 <= p <= 0.925 *\/ */ |
|---|
| 1184 | /* r = .180625 - q * q; */ |
|---|
| 1185 | /* val = */ |
|---|
| 1186 | /* q * (((((((r * 2509.0809287301226727 + */ |
|---|
| 1187 | /* 33430.575583588128105) * r + 67265.770927008700853) * r + */ |
|---|
| 1188 | /* 45921.953931549871457) * r + 13731.693765509461125) * r + */ |
|---|
| 1189 | /* 1971.5909503065514427) * r + 133.14166789178437745) * r + */ |
|---|
| 1190 | /* 3.387132872796366608) */ |
|---|
| 1191 | /* / (((((((r * 5226.495278852854561 + */ |
|---|
| 1192 | /* 28729.085735721942674) * r + 39307.89580009271061) * r + */ |
|---|
| 1193 | /* 21213.794301586595867) * r + 5394.1960214247511077) * r + */ |
|---|
| 1194 | /* 687.1870074920579083) * r + 42.313330701600911252) * r + 1.); */ |
|---|
| 1195 | /* } */ |
|---|
| 1196 | /* else */ |
|---|
| 1197 | /* { /\* closer than 0.075 from {0,1} boundary *\/ */ |
|---|
| 1198 | |
|---|
| 1199 | /* /\* r = min(p, 1-p) < 0.075 *\/ */ |
|---|
| 1200 | /* if (q > 0) */ |
|---|
| 1201 | /* r = 1-p;/\* 1-p *\/ */ |
|---|
| 1202 | /* else */ |
|---|
| 1203 | /* r = p_;/\* = R_DT_Iv(p) ^= p *\/ */ |
|---|
| 1204 | |
|---|
| 1205 | /* r = sqrt(-log(r)); */ |
|---|
| 1206 | /* /\* r = sqrt(-log(r)) <==> min(p, 1-p) = exp( - r^2 ) *\/ */ |
|---|
| 1207 | |
|---|
| 1208 | /* if (r <= 5.) { /\* <==> min(p,1-p) >= exp(-25) ~= 1.3888e-11 *\/ */ |
|---|
| 1209 | /* r += -1.6; */ |
|---|
| 1210 | /* val = (((((((r * 7.7454501427834140764e-4 + */ |
|---|
| 1211 | /* .0227238449892691845833) * r + .24178072517745061177) * */ |
|---|
| 1212 | /* r + 1.27045825245236838258) * r + */ |
|---|
| 1213 | /* 3.64784832476320460504) * r + 5.7694972214606914055) * */ |
|---|
| 1214 | /* r + 4.6303378461565452959) * r + */ |
|---|
| 1215 | /* 1.42343711074968357734) */ |
|---|
| 1216 | /* / (((((((r * */ |
|---|
| 1217 | /* 1.05075007164441684324e-9 + 5.475938084995344946e-4) * */ |
|---|
| 1218 | /* r + .0151986665636164571966) * r + */ |
|---|
| 1219 | /* .14810397642748007459) * r + .68976733498510000455) * */ |
|---|
| 1220 | /* r + 1.6763848301838038494) * r + */ |
|---|
| 1221 | /* 2.05319162663775882187) * r + 1.); */ |
|---|
| 1222 | /* } */ |
|---|
| 1223 | /* else */ |
|---|
| 1224 | /* { /\* very close to 0 or 1 *\/ */ |
|---|
| 1225 | /* r += -5.; */ |
|---|
| 1226 | /* val = (((((((r * 2.01033439929228813265e-7 + */ |
|---|
| 1227 | /* 2.71155556874348757815e-5) * r + */ |
|---|
| 1228 | /* .0012426609473880784386) * r + .026532189526576123093) * */ |
|---|
| 1229 | /* r + .29656057182850489123) * r + */ |
|---|
| 1230 | /* 1.7848265399172913358) * r + 5.4637849111641143699) * */ |
|---|
| 1231 | /* r + 6.6579046435011037772) */ |
|---|
| 1232 | /* / (((((((r * */ |
|---|
| 1233 | /* 2.04426310338993978564e-15 + 1.4215117583164458887e-7)* */ |
|---|
| 1234 | /* r + 1.8463183175100546818e-5) * r + */ |
|---|
| 1235 | /* 7.868691311456132591e-4) * r + .0148753612908506148525) */ |
|---|
| 1236 | /* * r + .13692988092273580531) * r + */ |
|---|
| 1237 | /* .59983220655588793769) * r + 1.); */ |
|---|
| 1238 | /* } */ |
|---|
| 1239 | |
|---|
| 1240 | /* if(q < 0.0) */ |
|---|
| 1241 | /* val = -val; */ |
|---|
| 1242 | /* /\* return (q >= 0.)? r : -r ;*\/ */ |
|---|
| 1243 | /* } */ |
|---|
| 1244 | /* return (phydbl)val; */ |
|---|
| 1245 | /* } */ |
|---|
| 1246 | |
|---|
| 1247 | ////////////////////////////////////////////////////////////// |
|---|
| 1248 | ////////////////////////////////////////////////////////////// |
|---|
| 1249 | |
|---|
| 1250 | /* MISCs */ |
|---|
| 1251 | ////////////////////////////////////////////////////////////// |
|---|
| 1252 | ////////////////////////////////////////////////////////////// |
|---|
| 1253 | |
|---|
| 1254 | |
|---|
| 1255 | ////////////////////////////////////////////////////////////// |
|---|
| 1256 | ////////////////////////////////////////////////////////////// |
|---|
| 1257 | |
|---|
| 1258 | |
|---|
| 1259 | phydbl Bico(int n, int k) |
|---|
| 1260 | { |
|---|
| 1261 | return FLOOR(0.5+EXP(Factln(n)-Factln(k)-Factln(n-k))); |
|---|
| 1262 | } |
|---|
| 1263 | |
|---|
| 1264 | |
|---|
| 1265 | ////////////////////////////////////////////////////////////// |
|---|
| 1266 | ////////////////////////////////////////////////////////////// |
|---|
| 1267 | |
|---|
| 1268 | |
|---|
| 1269 | phydbl Factln(int n) |
|---|
| 1270 | { |
|---|
| 1271 | static phydbl a[101]; |
|---|
| 1272 | |
|---|
| 1273 | if (n < 0) { Warn_And_Exit("\n== Err: negative factorial in routine FACTLN"); } |
|---|
| 1274 | if (n <= 1) return 0.0; |
|---|
| 1275 | if (n <= 100) return (a[n]>SMALL) ? a[n] : (a[n]=Gammln(n+1.0)); |
|---|
| 1276 | else return Gammln(n+1.0); |
|---|
| 1277 | } |
|---|
| 1278 | |
|---|
| 1279 | ////////////////////////////////////////////////////////////// |
|---|
| 1280 | ////////////////////////////////////////////////////////////// |
|---|
| 1281 | |
|---|
| 1282 | |
|---|
| 1283 | phydbl Gammln(phydbl xx) |
|---|
| 1284 | { |
|---|
| 1285 | double x,tmp,ser; |
|---|
| 1286 | static double cof[6]={76.18009173,-86.50532033,24.01409822, |
|---|
| 1287 | -1.231739516,0.120858003e-2,-0.536382e-5}; |
|---|
| 1288 | int j; |
|---|
| 1289 | |
|---|
| 1290 | x=xx-1.0; |
|---|
| 1291 | tmp=x+5.5; |
|---|
| 1292 | tmp -= (x+0.5)*log(tmp); |
|---|
| 1293 | ser=1.0; |
|---|
| 1294 | for (j=0;j<=5;j++) |
|---|
| 1295 | { |
|---|
| 1296 | x += 1.0; |
|---|
| 1297 | ser += cof[j]/x; |
|---|
| 1298 | } |
|---|
| 1299 | return (phydbl)(-tmp+log(2.50662827465*ser)); |
|---|
| 1300 | } |
|---|
| 1301 | |
|---|
| 1302 | ////////////////////////////////////////////////////////////// |
|---|
| 1303 | ////////////////////////////////////////////////////////////// |
|---|
| 1304 | |
|---|
| 1305 | |
|---|
| 1306 | /* void Plim_Binom(phydbl pH0, int N, phydbl *pinf, phydbl *psup) */ |
|---|
| 1307 | /* { */ |
|---|
| 1308 | /* *pinf = pH0 - 1.64*SQRT(pH0*(1-pH0)/(phydbl)N); */ |
|---|
| 1309 | /* if(*pinf < 0) *pinf = .0; */ |
|---|
| 1310 | /* *psup = pH0 + 1.64*SQRT(pH0*(1-pH0)/(phydbl)N); */ |
|---|
| 1311 | /* } */ |
|---|
| 1312 | |
|---|
| 1313 | ////////////////////////////////////////////////////////////// |
|---|
| 1314 | ////////////////////////////////////////////////////////////// |
|---|
| 1315 | |
|---|
| 1316 | |
|---|
| 1317 | phydbl LnGamma (phydbl alpha) |
|---|
| 1318 | { |
|---|
| 1319 | /* returns ln(gamma(alpha)) for alpha>0, accurate to 10 decimal places. |
|---|
| 1320 | Stirling's formula is used for the central polynomial part of the procedure. |
|---|
| 1321 | Pike MC & Hill ID (1966) Algorithm 291: Logarithm of the gamma function. |
|---|
| 1322 | Communications of the Association for Computing Machinery, 9:684 |
|---|
| 1323 | */ |
|---|
| 1324 | double x=alpha, f=0, z; |
|---|
| 1325 | if (x<7) { |
|---|
| 1326 | f=1; z=x-1; |
|---|
| 1327 | while (++z<7) f*=z; |
|---|
| 1328 | x=z; f=-log(f); |
|---|
| 1329 | } |
|---|
| 1330 | z = 1/(x*x); |
|---|
| 1331 | return (phydbl)(f + (x-0.5)*log(x) - x + .918938533204673 |
|---|
| 1332 | + (((-.000595238095238*z+.000793650793651)*z-.002777777777778)*z |
|---|
| 1333 | +.083333333333333)/x); |
|---|
| 1334 | } |
|---|
| 1335 | |
|---|
| 1336 | ////////////////////////////////////////////////////////////// |
|---|
| 1337 | ////////////////////////////////////////////////////////////// |
|---|
| 1338 | |
|---|
| 1339 | |
|---|
| 1340 | phydbl IncompleteGamma(phydbl x, phydbl alpha, phydbl ln_gamma_alpha) |
|---|
| 1341 | { |
|---|
| 1342 | /* returns the incomplete gamma ratio I(x,alpha) where x is the upper |
|---|
| 1343 | limit of the integration and alpha is the shape parameter. |
|---|
| 1344 | returns (-1) if in error |
|---|
| 1345 | ln_gamma_alpha = ln(Gamma(alpha)), is almost redundant. |
|---|
| 1346 | (1) series expansion if (alpha>x || x<=1) |
|---|
| 1347 | (2) continued fraction otherwise |
|---|
| 1348 | RATNEST FORTRAN by |
|---|
| 1349 | Bhattacharjee GP (1970) The incomplete gamma integral. Applied Statistics, |
|---|
| 1350 | 19: 285-287 (AS32) |
|---|
| 1351 | */ |
|---|
| 1352 | int i; |
|---|
| 1353 | double p=alpha, g=ln_gamma_alpha; |
|---|
| 1354 | double accurate=1e-8, overflow=1e30; |
|---|
| 1355 | double factor, gin=0, rn=0, a=0,b=0,an=0,dif=0, term=0, pn[6]; |
|---|
| 1356 | |
|---|
| 1357 | if (fabs(x) < SMALL) return ((phydbl).0); |
|---|
| 1358 | if (x<0 || p<=0) return ((phydbl)-1); |
|---|
| 1359 | |
|---|
| 1360 | factor=exp(p*log(x)-x-g); |
|---|
| 1361 | if (x>1 && x>=p) goto l30; |
|---|
| 1362 | /* (1) series expansion */ |
|---|
| 1363 | gin=1; term=1; rn=p; |
|---|
| 1364 | l20: |
|---|
| 1365 | rn++; |
|---|
| 1366 | term*=x/rn; gin+=term; |
|---|
| 1367 | |
|---|
| 1368 | if (term > accurate) goto l20; |
|---|
| 1369 | gin*=factor/p; |
|---|
| 1370 | goto l50; |
|---|
| 1371 | l30: |
|---|
| 1372 | /* (2) continued fraction */ |
|---|
| 1373 | a=1-p; b=a+x+1; term=0; |
|---|
| 1374 | pn[0]=1; pn[1]=x; pn[2]=x+1; pn[3]=x*b; |
|---|
| 1375 | gin=pn[2]/pn[3]; |
|---|
| 1376 | l32: |
|---|
| 1377 | a++; b+=2; term++; an=a*term; |
|---|
| 1378 | for (i=0; i<2; i++) pn[i+4]=b*pn[i+2]-an*pn[i]; |
|---|
| 1379 | if (fabs(pn[5]) < .0) goto l35; |
|---|
| 1380 | rn=pn[4]/pn[5]; dif=fabs(gin-rn); |
|---|
| 1381 | if (dif>accurate) goto l34; |
|---|
| 1382 | if (dif<=accurate*rn) goto l42; |
|---|
| 1383 | l34: |
|---|
| 1384 | gin=rn; |
|---|
| 1385 | l35: |
|---|
| 1386 | for (i=0; i<4; i++) pn[i]=pn[i+2]; |
|---|
| 1387 | if (fabs(pn[4]) < overflow) goto l32; |
|---|
| 1388 | for (i=0; i<4; i++) pn[i]/=overflow; |
|---|
| 1389 | goto l32; |
|---|
| 1390 | l42: |
|---|
| 1391 | gin=1-factor*gin; |
|---|
| 1392 | |
|---|
| 1393 | l50: |
|---|
| 1394 | return (phydbl)(gin); |
|---|
| 1395 | } |
|---|
| 1396 | |
|---|
| 1397 | |
|---|
| 1398 | ////////////////////////////////////////////////////////////// |
|---|
| 1399 | ////////////////////////////////////////////////////////////// |
|---|
| 1400 | |
|---|
| 1401 | |
|---|
| 1402 | int DiscreteGamma (phydbl freqK[], phydbl rK[], |
|---|
| 1403 | phydbl alfa, phydbl beta, int K, int median) |
|---|
| 1404 | { |
|---|
| 1405 | /* discretization of gamma distribution with equal proportions in each |
|---|
| 1406 | category |
|---|
| 1407 | */ |
|---|
| 1408 | |
|---|
| 1409 | int i; |
|---|
| 1410 | phydbl gap05=1.0/(2.0*K), t, factor=alfa/beta*K, lnga1; |
|---|
| 1411 | |
|---|
| 1412 | if(K==1) |
|---|
| 1413 | { |
|---|
| 1414 | freqK[0] = 1.0; |
|---|
| 1415 | rK[0] = 1.0; |
|---|
| 1416 | return 0; |
|---|
| 1417 | } |
|---|
| 1418 | |
|---|
| 1419 | if (median) |
|---|
| 1420 | { |
|---|
| 1421 | for (i=0; i<K; i++) rK[i]=PointGamma((i*2.0+1)*gap05, alfa, beta); |
|---|
| 1422 | for (i=0,t=0; i<K; i++) t+=rK[i]; |
|---|
| 1423 | for (i=0; i<K; i++) rK[i]*=factor/t; |
|---|
| 1424 | } |
|---|
| 1425 | else { |
|---|
| 1426 | |
|---|
| 1427 | lnga1=LnGamma(alfa+1); |
|---|
| 1428 | for (i=0; i<K-1; i++) |
|---|
| 1429 | freqK[i]=PointGamma((i+1.0)/K, alfa, beta); |
|---|
| 1430 | for (i=0; i<K-1; i++) |
|---|
| 1431 | freqK[i]=IncompleteGamma(freqK[i]*beta, alfa+1, lnga1); |
|---|
| 1432 | rK[0] = freqK[0]*factor; |
|---|
| 1433 | rK[K-1] = (1-freqK[K-2])*factor; |
|---|
| 1434 | for (i=1; i<K-1; i++) rK[i] = (freqK[i]-freqK[i-1])*factor; |
|---|
| 1435 | } |
|---|
| 1436 | for (i=0; i<K; i++) freqK[i]=1.0/K; |
|---|
| 1437 | return (0); |
|---|
| 1438 | } |
|---|
| 1439 | |
|---|
| 1440 | ////////////////////////////////////////////////////////////// |
|---|
| 1441 | ////////////////////////////////////////////////////////////// |
|---|
| 1442 | |
|---|
| 1443 | |
|---|
| 1444 | /* Return LOG(n!) */ |
|---|
| 1445 | |
|---|
| 1446 | phydbl LnFact(int n) |
|---|
| 1447 | { |
|---|
| 1448 | int i; |
|---|
| 1449 | phydbl res; |
|---|
| 1450 | |
|---|
| 1451 | res = 0; |
|---|
| 1452 | for(i=2;i<=n;i++) res += LOG(i); |
|---|
| 1453 | |
|---|
| 1454 | return(res); |
|---|
| 1455 | } |
|---|
| 1456 | |
|---|
| 1457 | ////////////////////////////////////////////////////////////// |
|---|
| 1458 | ////////////////////////////////////////////////////////////// |
|---|
| 1459 | |
|---|
| 1460 | |
|---|
| 1461 | int Choose(int n, int k) |
|---|
| 1462 | { |
|---|
| 1463 | phydbl accum; |
|---|
| 1464 | int i; |
|---|
| 1465 | |
|---|
| 1466 | if (k > n) return(0); |
|---|
| 1467 | if (k > n/2) k = n-k; |
|---|
| 1468 | if(!k) return(1); |
|---|
| 1469 | |
|---|
| 1470 | accum = 1.; |
|---|
| 1471 | for(i=1;i<k+1;i++) accum = accum * (n-k+i) / i; |
|---|
| 1472 | |
|---|
| 1473 | return((int)accum); |
|---|
| 1474 | } |
|---|
| 1475 | |
|---|
| 1476 | ////////////////////////////////////////////////////////////// |
|---|
| 1477 | ////////////////////////////////////////////////////////////// |
|---|
| 1478 | |
|---|
| 1479 | |
|---|
| 1480 | |
|---|
| 1481 | phydbl *Covariance_Matrix(t_tree *tree) |
|---|
| 1482 | { |
|---|
| 1483 | phydbl *cov, *mean; |
|---|
| 1484 | int *ori_wght,*site_num; |
|---|
| 1485 | int dim,i,j,replicate,n_site,position,sample_size; |
|---|
| 1486 | |
|---|
| 1487 | sample_size = 100; |
|---|
| 1488 | dim = 2*tree->n_otu-3; |
|---|
| 1489 | |
|---|
| 1490 | cov = (phydbl *)mCalloc(dim*dim,sizeof(phydbl)); |
|---|
| 1491 | mean = (phydbl *)mCalloc( dim,sizeof(phydbl)); |
|---|
| 1492 | ori_wght = (int *)mCalloc(tree->data->crunch_len,sizeof(int)); |
|---|
| 1493 | site_num = (int *)mCalloc(tree->data->init_len,sizeof(int)); |
|---|
| 1494 | |
|---|
| 1495 | For(i,tree->data->crunch_len) ori_wght[i] = tree->data->wght[i]; |
|---|
| 1496 | |
|---|
| 1497 | n_site = 0; |
|---|
| 1498 | For(i,tree->data->crunch_len) For(j,tree->data->wght[i]) |
|---|
| 1499 | { |
|---|
| 1500 | site_num[n_site] = i; |
|---|
| 1501 | n_site++; |
|---|
| 1502 | } |
|---|
| 1503 | |
|---|
| 1504 | |
|---|
| 1505 | tree->mod->s_opt->print = 0; |
|---|
| 1506 | For(replicate,sample_size) |
|---|
| 1507 | { |
|---|
| 1508 | For(i,2*tree->n_otu-3) tree->a_edges[i]->l->v = .1; |
|---|
| 1509 | |
|---|
| 1510 | For(i,tree->data->crunch_len) tree->data->wght[i] = 0; |
|---|
| 1511 | |
|---|
| 1512 | For(i,tree->data->init_len) |
|---|
| 1513 | { |
|---|
| 1514 | position = Rand_Int(0,(int)(tree->data->init_len-1.0)); |
|---|
| 1515 | tree->data->wght[site_num[position]] += 1; |
|---|
| 1516 | } |
|---|
| 1517 | |
|---|
| 1518 | Round_Optimize(tree,tree->data,ROUND_MAX); |
|---|
| 1519 | |
|---|
| 1520 | For(i,2*tree->n_otu-3) For(j,2*tree->n_otu-3) cov[i*dim+j] += LOG(tree->a_edges[i]->l->v) * LOG(tree->a_edges[j]->l->v); |
|---|
| 1521 | For(i,2*tree->n_otu-3) mean[i] += LOG(tree->a_edges[i]->l->v); |
|---|
| 1522 | |
|---|
| 1523 | PhyML_Printf("[%3d/%3d]",replicate,sample_size); fflush(NULL); |
|---|
| 1524 | /* PhyML_Printf("\n. %3d %12f %12f %12f ", */ |
|---|
| 1525 | /* replicate, */ |
|---|
| 1526 | /* cov[1*dim+1]/(replicate+1)-mean[1]*mean[1]/POW(replicate+1,2), */ |
|---|
| 1527 | /* tree->a_edges[1]->l->v, */ |
|---|
| 1528 | /* mean[1]/(replicate+1)); */ |
|---|
| 1529 | } |
|---|
| 1530 | |
|---|
| 1531 | For(i,2*tree->n_otu-3) mean[i] /= (phydbl)sample_size; |
|---|
| 1532 | For(i,2*tree->n_otu-3) For(j,2*tree->n_otu-3) cov[i*dim+j] /= (phydbl)sample_size; |
|---|
| 1533 | For(i,2*tree->n_otu-3) For(j,2*tree->n_otu-3) cov[i*dim+j] -= mean[i]*mean[j]; |
|---|
| 1534 | /* For(i,2*tree->n_otu-3) if(cov[i*dim+i] < var_min) cov[i*dim+i] = var_min; */ |
|---|
| 1535 | |
|---|
| 1536 | |
|---|
| 1537 | /* PhyML_Printf("\n"); */ |
|---|
| 1538 | /* For(i,2*tree->n_otu-3) PhyML_Printf("%f %f\n",mean[i],tree->a_edges[i]->l->v); */ |
|---|
| 1539 | /* PhyML_Printf("\n"); */ |
|---|
| 1540 | /* PhyML_Printf("\n"); */ |
|---|
| 1541 | /* For(i,2*tree->n_otu-3) */ |
|---|
| 1542 | /* { */ |
|---|
| 1543 | /* For(j,2*tree->n_otu-3) */ |
|---|
| 1544 | /* { */ |
|---|
| 1545 | /* PhyML_Printf("%G\n",cov[i*dim+j]); */ |
|---|
| 1546 | /* } */ |
|---|
| 1547 | /* PhyML_Printf("\n"); */ |
|---|
| 1548 | /* } */ |
|---|
| 1549 | |
|---|
| 1550 | For(i,tree->data->crunch_len) tree->data->wght[i] = ori_wght[i]; |
|---|
| 1551 | |
|---|
| 1552 | Free(mean); |
|---|
| 1553 | Free(ori_wght); |
|---|
| 1554 | Free(site_num); |
|---|
| 1555 | |
|---|
| 1556 | return cov; |
|---|
| 1557 | } |
|---|
| 1558 | |
|---|
| 1559 | ////////////////////////////////////////////////////////////// |
|---|
| 1560 | ////////////////////////////////////////////////////////////// |
|---|
| 1561 | |
|---|
| 1562 | /* Work out the Hessian for the likelihood function. Only branch lengths are considered as variable. |
|---|
| 1563 | This function is very much inspired from Jeff Thorne's 'hessian' function in his program 'estbranches'. */ |
|---|
| 1564 | phydbl *Hessian(t_tree *tree) |
|---|
| 1565 | { |
|---|
| 1566 | phydbl *hessian; |
|---|
| 1567 | phydbl *plus_plus, *minus_minus, *plus_zero, *minus_zero, *plus_minus, zero_zero; |
|---|
| 1568 | phydbl *ori_bl,*inc,*buff; |
|---|
| 1569 | int *ok_edges,*is_ok; |
|---|
| 1570 | int dim; |
|---|
| 1571 | int n_ok_edges; |
|---|
| 1572 | int i,j; |
|---|
| 1573 | phydbl eps; |
|---|
| 1574 | phydbl lk; |
|---|
| 1575 | phydbl lnL,lnL1,lnL2,ori_lnL; |
|---|
| 1576 | phydbl l_inf; |
|---|
| 1577 | |
|---|
| 1578 | dim = 2*tree->n_otu-3; |
|---|
| 1579 | eps = (tree->mod->log_l == YES)?(0.2):(1E-4); |
|---|
| 1580 | |
|---|
| 1581 | hessian = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 1582 | ori_bl = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 1583 | plus_plus = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 1584 | minus_minus = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 1585 | plus_minus = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 1586 | plus_zero = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 1587 | minus_zero = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 1588 | inc = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 1589 | buff = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 1590 | ok_edges = (int *)mCalloc((int)dim,sizeof(int)); |
|---|
| 1591 | is_ok = (int *)mCalloc((int)dim,sizeof(int)); |
|---|
| 1592 | |
|---|
| 1593 | lnL = lnL1 = lnL2 = UNLIKELY; |
|---|
| 1594 | |
|---|
| 1595 | Set_Both_Sides(YES,tree); |
|---|
| 1596 | Lk(NULL,tree); |
|---|
| 1597 | ori_lnL = tree->c_lnL; |
|---|
| 1598 | |
|---|
| 1599 | |
|---|
| 1600 | For(i,dim) ori_bl[i] = tree->a_edges[i]->l->v; |
|---|
| 1601 | |
|---|
| 1602 | if(tree->mod->log_l == NO) |
|---|
| 1603 | l_inf = MAX(tree->mod->l_min,1./(phydbl)tree->data->init_len); |
|---|
| 1604 | else |
|---|
| 1605 | l_inf = MAX(tree->mod->l_min,-LOG((phydbl)tree->data->init_len)); |
|---|
| 1606 | |
|---|
| 1607 | |
|---|
| 1608 | n_ok_edges = 0; |
|---|
| 1609 | For(i,dim) |
|---|
| 1610 | { |
|---|
| 1611 | if(tree->a_edges[i]->l->v*(1.-eps) > l_inf) |
|---|
| 1612 | { |
|---|
| 1613 | inc[i] = eps * tree->a_edges[i]->l->v; |
|---|
| 1614 | ok_edges[n_ok_edges] = i; |
|---|
| 1615 | n_ok_edges++; |
|---|
| 1616 | is_ok[i] = 1; |
|---|
| 1617 | } |
|---|
| 1618 | else |
|---|
| 1619 | { |
|---|
| 1620 | inc[i] = -1.0; |
|---|
| 1621 | is_ok[i] = 0; |
|---|
| 1622 | } |
|---|
| 1623 | } |
|---|
| 1624 | |
|---|
| 1625 | |
|---|
| 1626 | /* Fine tune the increments */ |
|---|
| 1627 | For(i,dim) |
|---|
| 1628 | { |
|---|
| 1629 | do |
|---|
| 1630 | { |
|---|
| 1631 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 1632 | lnL1 = Lk(tree->a_edges[i],tree); |
|---|
| 1633 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 1634 | inc[i] *= 1.1; |
|---|
| 1635 | }while((FABS(lnL1 - ori_lnL) < 1.E-1) && |
|---|
| 1636 | (tree->a_edges[i]->l->v+inc[i] < tree->mod->l_max)); |
|---|
| 1637 | inc[i] /= 1.1; |
|---|
| 1638 | } |
|---|
| 1639 | |
|---|
| 1640 | |
|---|
| 1641 | |
|---|
| 1642 | /* zero zero */ |
|---|
| 1643 | zero_zero = tree->c_lnL; |
|---|
| 1644 | |
|---|
| 1645 | /* plus zero */ |
|---|
| 1646 | For(i,dim) |
|---|
| 1647 | { |
|---|
| 1648 | if(is_ok[i]) |
|---|
| 1649 | { |
|---|
| 1650 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 1651 | lk = Lk(tree->a_edges[i],tree); |
|---|
| 1652 | plus_zero[i] = lk; |
|---|
| 1653 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 1654 | } |
|---|
| 1655 | } |
|---|
| 1656 | |
|---|
| 1657 | |
|---|
| 1658 | /* minus zero */ |
|---|
| 1659 | For(i,dim) |
|---|
| 1660 | { |
|---|
| 1661 | if(is_ok[i]) |
|---|
| 1662 | { |
|---|
| 1663 | tree->a_edges[i]->l->v -= inc[i]; |
|---|
| 1664 | lk = Lk(tree->a_edges[i],tree); |
|---|
| 1665 | minus_zero[i] = lk; |
|---|
| 1666 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 1667 | } |
|---|
| 1668 | } |
|---|
| 1669 | |
|---|
| 1670 | |
|---|
| 1671 | For(i,dim) Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 1672 | |
|---|
| 1673 | /* plus plus */ |
|---|
| 1674 | For(i,dim) |
|---|
| 1675 | { |
|---|
| 1676 | if(is_ok[i]) |
|---|
| 1677 | { |
|---|
| 1678 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 1679 | Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 1680 | |
|---|
| 1681 | For(j,3) |
|---|
| 1682 | if((!tree->a_edges[i]->left->tax) && (tree->a_edges[i]->left->v[j] != tree->a_edges[i]->rght)) |
|---|
| 1683 | Recurr_Hessian(tree->a_edges[i]->left,tree->a_edges[i]->left->v[j],1,inc,plus_plus+i*dim,is_ok,tree); |
|---|
| 1684 | |
|---|
| 1685 | For(j,3) |
|---|
| 1686 | if((!tree->a_edges[i]->rght->tax) && (tree->a_edges[i]->rght->v[j] != tree->a_edges[i]->left)) |
|---|
| 1687 | Recurr_Hessian(tree->a_edges[i]->rght,tree->a_edges[i]->rght->v[j],1,inc,plus_plus+i*dim,is_ok,tree); |
|---|
| 1688 | |
|---|
| 1689 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 1690 | Lk(NULL,tree); |
|---|
| 1691 | } |
|---|
| 1692 | } |
|---|
| 1693 | |
|---|
| 1694 | |
|---|
| 1695 | /* plus minus */ |
|---|
| 1696 | For(i,dim) |
|---|
| 1697 | { |
|---|
| 1698 | if(is_ok[i]) |
|---|
| 1699 | { |
|---|
| 1700 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 1701 | Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 1702 | |
|---|
| 1703 | For(j,3) |
|---|
| 1704 | if((!tree->a_edges[i]->left->tax) && (tree->a_edges[i]->left->v[j] != tree->a_edges[i]->rght)) |
|---|
| 1705 | Recurr_Hessian(tree->a_edges[i]->left,tree->a_edges[i]->left->v[j],-1,inc,plus_minus+i*dim,is_ok,tree); |
|---|
| 1706 | |
|---|
| 1707 | For(j,3) |
|---|
| 1708 | if((!tree->a_edges[i]->rght->tax) && (tree->a_edges[i]->rght->v[j] != tree->a_edges[i]->left)) |
|---|
| 1709 | Recurr_Hessian(tree->a_edges[i]->rght,tree->a_edges[i]->rght->v[j],-1,inc,plus_minus+i*dim,is_ok,tree); |
|---|
| 1710 | |
|---|
| 1711 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 1712 | Lk(NULL,tree); |
|---|
| 1713 | } |
|---|
| 1714 | } |
|---|
| 1715 | |
|---|
| 1716 | |
|---|
| 1717 | /* minus minus */ |
|---|
| 1718 | For(i,dim) |
|---|
| 1719 | { |
|---|
| 1720 | if(is_ok[i]) |
|---|
| 1721 | { |
|---|
| 1722 | tree->a_edges[i]->l->v -= inc[i]; |
|---|
| 1723 | |
|---|
| 1724 | Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 1725 | |
|---|
| 1726 | For(j,3) |
|---|
| 1727 | if((!tree->a_edges[i]->left->tax) && (tree->a_edges[i]->left->v[j] != tree->a_edges[i]->rght)) |
|---|
| 1728 | Recurr_Hessian(tree->a_edges[i]->left,tree->a_edges[i]->left->v[j],-1,inc,minus_minus+i*dim,is_ok,tree); |
|---|
| 1729 | |
|---|
| 1730 | For(j,3) |
|---|
| 1731 | if((!tree->a_edges[i]->rght->tax) && (tree->a_edges[i]->rght->v[j] != tree->a_edges[i]->left)) |
|---|
| 1732 | Recurr_Hessian(tree->a_edges[i]->rght,tree->a_edges[i]->rght->v[j],-1,inc,minus_minus+i*dim,is_ok,tree); |
|---|
| 1733 | |
|---|
| 1734 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 1735 | Lk(NULL,tree); |
|---|
| 1736 | } |
|---|
| 1737 | } |
|---|
| 1738 | |
|---|
| 1739 | |
|---|
| 1740 | |
|---|
| 1741 | For(i,dim) |
|---|
| 1742 | { |
|---|
| 1743 | if(is_ok[i]) |
|---|
| 1744 | { |
|---|
| 1745 | hessian[i*dim+i] = (plus_zero[i]-2*zero_zero+minus_zero[i])/(POW(inc[i],2)); |
|---|
| 1746 | |
|---|
| 1747 | for(j=i+1;j<dim;j++) |
|---|
| 1748 | { |
|---|
| 1749 | if(is_ok[j]) |
|---|
| 1750 | { |
|---|
| 1751 | hessian[i*dim+j] = |
|---|
| 1752 | (plus_plus[i*dim+j]-plus_minus[i*dim+j]-plus_minus[j*dim+i]+minus_minus[i*dim+j])/ |
|---|
| 1753 | (4*inc[i]*inc[j]); |
|---|
| 1754 | hessian[j*dim+i] = hessian[i*dim+j]; |
|---|
| 1755 | } |
|---|
| 1756 | } |
|---|
| 1757 | } |
|---|
| 1758 | } |
|---|
| 1759 | |
|---|
| 1760 | For(i,n_ok_edges) |
|---|
| 1761 | { |
|---|
| 1762 | For(j,n_ok_edges) |
|---|
| 1763 | { |
|---|
| 1764 | buff[i*n_ok_edges+j] = -1.0*hessian[ok_edges[i]*dim+ok_edges[j]]; |
|---|
| 1765 | } |
|---|
| 1766 | } |
|---|
| 1767 | |
|---|
| 1768 | |
|---|
| 1769 | if(!Matinv(buff,n_ok_edges,n_ok_edges,NO)) |
|---|
| 1770 | { |
|---|
| 1771 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 1772 | Exit("\n"); |
|---|
| 1773 | } |
|---|
| 1774 | |
|---|
| 1775 | For(i,n_ok_edges) |
|---|
| 1776 | { |
|---|
| 1777 | For(j,n_ok_edges) |
|---|
| 1778 | { |
|---|
| 1779 | hessian[ok_edges[i]*dim+ok_edges[j]] = buff[i*n_ok_edges+j]; |
|---|
| 1780 | } |
|---|
| 1781 | } |
|---|
| 1782 | |
|---|
| 1783 | /* eps = 1./(phydbl)tree->data->init_len; */ |
|---|
| 1784 | /* Approximate variance for very short branches */ |
|---|
| 1785 | For(i,dim) |
|---|
| 1786 | if(inc[i] < 0.0 || hessian[i*dim+i] < MIN_VAR_BL) |
|---|
| 1787 | { |
|---|
| 1788 | eps = 0.2 * tree->a_edges[i]->l->v; |
|---|
| 1789 | do |
|---|
| 1790 | { |
|---|
| 1791 | lnL = Lk(tree->a_edges[i],tree); |
|---|
| 1792 | tree->a_edges[i]->l->v += eps; |
|---|
| 1793 | lnL1 = Lk(tree->a_edges[i],tree); |
|---|
| 1794 | tree->a_edges[i]->l->v += eps; |
|---|
| 1795 | lnL2 = Lk(tree->a_edges[i],tree); |
|---|
| 1796 | tree->a_edges[i]->l->v -= 2.*eps; |
|---|
| 1797 | |
|---|
| 1798 | hessian[i*dim+i] = (lnL2 - 2.*lnL1 + lnL) / POW(eps,2); |
|---|
| 1799 | |
|---|
| 1800 | /* printf("\n* l=%G eps=%f lnL=%f lnL1=%f lnL2=%f var=%f",tree->a_edges[i]->l->v,eps,lnL,lnL1,lnL2,hessian[i*dim+i]); */ |
|---|
| 1801 | eps *= 5.; |
|---|
| 1802 | }while(FABS(lnL2 - lnL) < 1.E-3); |
|---|
| 1803 | |
|---|
| 1804 | hessian[i*dim+i] = -1.0 / hessian[i*dim+i]; |
|---|
| 1805 | |
|---|
| 1806 | } |
|---|
| 1807 | |
|---|
| 1808 | |
|---|
| 1809 | /* Fit a straight line to the log-likelihood (i.e., an exponential to the likelihood) */ |
|---|
| 1810 | /* It is only a straight line when considering branch length (rather than log(branch lengths)) */ |
|---|
| 1811 | For(i,dim) |
|---|
| 1812 | if((tree->a_edges[i]->l->v / tree->mod->l_min < 1.1) && |
|---|
| 1813 | (tree->a_edges[i]->l->v / tree->mod->l_min > 0.9)) |
|---|
| 1814 | { |
|---|
| 1815 | phydbl *x,*y,l; |
|---|
| 1816 | phydbl cov,var; |
|---|
| 1817 | |
|---|
| 1818 | x=plus_plus; |
|---|
| 1819 | y=minus_minus; |
|---|
| 1820 | l=(tree->mod->log_l == YES)?(EXP(tree->a_edges[i]->l->v)):(tree->a_edges[i]->l->v); /* Get actual branch length */ |
|---|
| 1821 | |
|---|
| 1822 | For(j,dim) |
|---|
| 1823 | { |
|---|
| 1824 | x[j] = l + (100.*l-l)*((phydbl)j/dim); |
|---|
| 1825 | tree->a_edges[i]->l->v = (tree->mod->log_l)?(LOG(x[j])):(x[j]); /* Transform to log if necessary */ |
|---|
| 1826 | y[j] = Lk(tree->a_edges[i],tree); |
|---|
| 1827 | tree->a_edges[i]->l->v = (tree->mod->log_l)?(LOG(l)):(l); /* Go back to initial edge length */ |
|---|
| 1828 | } |
|---|
| 1829 | |
|---|
| 1830 | cov = Covariance(x,y,dim); |
|---|
| 1831 | var = Covariance(x,x,dim); |
|---|
| 1832 | |
|---|
| 1833 | /* cov/var is minus the parameter of the exponential distribution. |
|---|
| 1834 | The variance is therefore : */ |
|---|
| 1835 | hessian[i*dim+i] = 1.0 / pow(cov/var,2); |
|---|
| 1836 | |
|---|
| 1837 | /* printf("\n. Hessian = %G cov=%G var=%G",hessian[i*dim+i],cov,var); */ |
|---|
| 1838 | } |
|---|
| 1839 | /* } */ |
|---|
| 1840 | |
|---|
| 1841 | |
|---|
| 1842 | For(i,dim) |
|---|
| 1843 | if(hessian[i*dim+i] < 0.0) |
|---|
| 1844 | { |
|---|
| 1845 | PhyML_Printf("\n. l=%G var=%G",tree->a_edges[i]->l->v,hessian[i*dim+i]); |
|---|
| 1846 | /* PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); */ |
|---|
| 1847 | /* Exit("\n"); */ |
|---|
| 1848 | hessian[i*dim+i] = MIN_VAR_BL; |
|---|
| 1849 | } |
|---|
| 1850 | |
|---|
| 1851 | For(i,dim) |
|---|
| 1852 | { |
|---|
| 1853 | if(hessian[i*dim+i] < MIN_VAR_BL) |
|---|
| 1854 | { |
|---|
| 1855 | PhyML_Printf("\n. l=%10G var(l)=%12G. WARNING: numerical precision issues may affect this analysis.", |
|---|
| 1856 | tree->a_edges[i]->l->v,hessian[i*dim+i]); |
|---|
| 1857 | hessian[i*dim+i] = MIN_VAR_BL; |
|---|
| 1858 | } |
|---|
| 1859 | if(hessian[i*dim+i] > MAX_VAR_BL) |
|---|
| 1860 | { |
|---|
| 1861 | PhyML_Printf("\n. l=%10G var(l)=%12G. WARNING: numerical precision issues may affect this analysis.", |
|---|
| 1862 | tree->a_edges[i]->l->v,hessian[i*dim+i]); |
|---|
| 1863 | hessian[i*dim+i] = MAX_VAR_BL; |
|---|
| 1864 | } |
|---|
| 1865 | } |
|---|
| 1866 | |
|---|
| 1867 | Iter_Matinv(hessian,dim,dim,NO); |
|---|
| 1868 | |
|---|
| 1869 | For(i,dim*dim) hessian[i] = -1.0*hessian[i]; |
|---|
| 1870 | |
|---|
| 1871 | For(i,dim) |
|---|
| 1872 | { |
|---|
| 1873 | For(j,dim) |
|---|
| 1874 | { |
|---|
| 1875 | if(FABS(hessian[i*dim+j]-hessian[j*dim+i]) > 1.E-3) |
|---|
| 1876 | { |
|---|
| 1877 | PhyML_Printf("\n. Hessian not symmetrical."); |
|---|
| 1878 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 1879 | Exit("\n"); |
|---|
| 1880 | } |
|---|
| 1881 | hessian[i*dim+j] = (hessian[i*dim+j] + hessian[j*dim+i]) / 2.; |
|---|
| 1882 | hessian[j*dim+i] = hessian[i*dim+j]; |
|---|
| 1883 | } |
|---|
| 1884 | } |
|---|
| 1885 | |
|---|
| 1886 | /* printf("\n"); */ |
|---|
| 1887 | /* printf("HESSIAN\n"); */ |
|---|
| 1888 | /* For(i,dim) */ |
|---|
| 1889 | /* { */ |
|---|
| 1890 | /* PhyML_Printf("[%f] ",tree->a_edges[i]->l->v); */ |
|---|
| 1891 | /* For(j,dim) */ |
|---|
| 1892 | /* { */ |
|---|
| 1893 | /* PhyML_Printf("%12lf ",hessian[i*dim+j]); */ |
|---|
| 1894 | /* } */ |
|---|
| 1895 | /* PhyML_Printf("\n"); */ |
|---|
| 1896 | /* } */ |
|---|
| 1897 | |
|---|
| 1898 | /* Matinv(hessian,dim,dim,NO); */ |
|---|
| 1899 | |
|---|
| 1900 | /* PhyML_Printf("\n"); */ |
|---|
| 1901 | |
|---|
| 1902 | /* For(i,dim) */ |
|---|
| 1903 | /* { */ |
|---|
| 1904 | /* PhyML_Printf("[%f] ",tree->a_edges[i]->l->v); */ |
|---|
| 1905 | /* For(j,dim) */ |
|---|
| 1906 | /* { */ |
|---|
| 1907 | /* PhyML_Printf("%12G ",-hessian[i*dim+j]); */ |
|---|
| 1908 | /* } */ |
|---|
| 1909 | /* PhyML_Printf("\n"); */ |
|---|
| 1910 | /* } */ |
|---|
| 1911 | /* Exit("\n"); */ |
|---|
| 1912 | |
|---|
| 1913 | |
|---|
| 1914 | /* Make sure to update likelihood before bailing out */ |
|---|
| 1915 | Set_Both_Sides(YES,tree); |
|---|
| 1916 | Lk(NULL,tree); |
|---|
| 1917 | |
|---|
| 1918 | Free(ori_bl); |
|---|
| 1919 | Free(plus_plus); |
|---|
| 1920 | Free(minus_minus); |
|---|
| 1921 | Free(plus_zero); |
|---|
| 1922 | Free(minus_zero); |
|---|
| 1923 | Free(plus_minus); |
|---|
| 1924 | Free(inc); |
|---|
| 1925 | Free(buff); |
|---|
| 1926 | Free(ok_edges); |
|---|
| 1927 | Free(is_ok); |
|---|
| 1928 | |
|---|
| 1929 | return hessian; |
|---|
| 1930 | |
|---|
| 1931 | } |
|---|
| 1932 | |
|---|
| 1933 | ////////////////////////////////////////////////////////////// |
|---|
| 1934 | ////////////////////////////////////////////////////////////// |
|---|
| 1935 | |
|---|
| 1936 | |
|---|
| 1937 | /* Work out the gradient for the likelihood function. Only branch lengths are considered as variable. |
|---|
| 1938 | */ |
|---|
| 1939 | phydbl *Gradient(t_tree *tree) |
|---|
| 1940 | { |
|---|
| 1941 | phydbl *gradient; |
|---|
| 1942 | phydbl *plus, *minus; |
|---|
| 1943 | phydbl *ori_bl,*inc; |
|---|
| 1944 | int *is_ok; |
|---|
| 1945 | int dim; |
|---|
| 1946 | int i; |
|---|
| 1947 | phydbl eps; |
|---|
| 1948 | phydbl lk; |
|---|
| 1949 | phydbl lnL,lnL1,lnL2; |
|---|
| 1950 | phydbl l_inf; |
|---|
| 1951 | |
|---|
| 1952 | dim = 2*tree->n_otu-3; |
|---|
| 1953 | eps = (tree->mod->log_l == YES)?(0.2):(1.E-6); |
|---|
| 1954 | |
|---|
| 1955 | gradient = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 1956 | ori_bl = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 1957 | plus = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 1958 | minus = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 1959 | inc = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 1960 | is_ok = (int *)mCalloc((int)dim,sizeof(int)); |
|---|
| 1961 | |
|---|
| 1962 | lnL = lnL1 = lnL2 = UNLIKELY; |
|---|
| 1963 | |
|---|
| 1964 | Set_Both_Sides(YES,tree); |
|---|
| 1965 | Lk(NULL,tree); |
|---|
| 1966 | |
|---|
| 1967 | For(i,dim) ori_bl[i] = tree->a_edges[i]->l->v; |
|---|
| 1968 | |
|---|
| 1969 | if(tree->mod->log_l == NO) |
|---|
| 1970 | l_inf = MAX(tree->mod->l_min,1./(phydbl)tree->data->init_len); |
|---|
| 1971 | else |
|---|
| 1972 | l_inf = MAX(tree->mod->l_min,-LOG((phydbl)tree->data->init_len)); |
|---|
| 1973 | |
|---|
| 1974 | For(i,dim) |
|---|
| 1975 | { |
|---|
| 1976 | if(tree->a_edges[i]->l->v*(1.-eps) > l_inf) |
|---|
| 1977 | { |
|---|
| 1978 | inc[i] = eps * tree->a_edges[i]->l->v; |
|---|
| 1979 | is_ok[i] = YES; |
|---|
| 1980 | } |
|---|
| 1981 | else |
|---|
| 1982 | { |
|---|
| 1983 | inc[i] = -1.0; |
|---|
| 1984 | is_ok[i] = NO; |
|---|
| 1985 | } |
|---|
| 1986 | } |
|---|
| 1987 | |
|---|
| 1988 | /* plus */ |
|---|
| 1989 | For(i,dim) |
|---|
| 1990 | { |
|---|
| 1991 | if(is_ok[i] == YES) |
|---|
| 1992 | { |
|---|
| 1993 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 1994 | lk = Lk(tree->a_edges[i],tree); |
|---|
| 1995 | plus[i] = lk; |
|---|
| 1996 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 1997 | } |
|---|
| 1998 | } |
|---|
| 1999 | |
|---|
| 2000 | |
|---|
| 2001 | /* minus */ |
|---|
| 2002 | For(i,dim) |
|---|
| 2003 | { |
|---|
| 2004 | if(is_ok[i] == YES) |
|---|
| 2005 | { |
|---|
| 2006 | tree->a_edges[i]->l->v -= inc[i]; |
|---|
| 2007 | lk = Lk(tree->a_edges[i],tree); |
|---|
| 2008 | minus[i] = lk; |
|---|
| 2009 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2010 | } |
|---|
| 2011 | } |
|---|
| 2012 | |
|---|
| 2013 | |
|---|
| 2014 | For(i,dim) |
|---|
| 2015 | { |
|---|
| 2016 | if(is_ok[i] == YES) |
|---|
| 2017 | { |
|---|
| 2018 | gradient[i] = (plus[i] - minus[i])/(2.*inc[i]); |
|---|
| 2019 | } |
|---|
| 2020 | } |
|---|
| 2021 | |
|---|
| 2022 | |
|---|
| 2023 | For(i,dim) |
|---|
| 2024 | { |
|---|
| 2025 | if(is_ok[i] == NO) |
|---|
| 2026 | { |
|---|
| 2027 | eps = FABS(0.2 * tree->a_edges[i]->l->v); |
|---|
| 2028 | lnL = Lk(tree->a_edges[i],tree); |
|---|
| 2029 | tree->a_edges[i]->l->v += eps; |
|---|
| 2030 | lnL1 = Lk(tree->a_edges[i],tree); |
|---|
| 2031 | tree->a_edges[i]->l->v += eps; |
|---|
| 2032 | lnL2 = Lk(tree->a_edges[i],tree); |
|---|
| 2033 | tree->a_edges[i]->l->v -= eps; |
|---|
| 2034 | tree->a_edges[i]->l->v -= eps; |
|---|
| 2035 | gradient[i] = (4.*lnL1 - lnL2 - 3.*lnL) / (2.*eps); |
|---|
| 2036 | } |
|---|
| 2037 | } |
|---|
| 2038 | |
|---|
| 2039 | /* Make sure to update likelihood before bailing out */ |
|---|
| 2040 | Set_Both_Sides(YES,tree); |
|---|
| 2041 | Lk(NULL,tree); |
|---|
| 2042 | |
|---|
| 2043 | Free(ori_bl); |
|---|
| 2044 | Free(plus); |
|---|
| 2045 | Free(minus); |
|---|
| 2046 | Free(inc); |
|---|
| 2047 | Free(is_ok); |
|---|
| 2048 | |
|---|
| 2049 | |
|---|
| 2050 | /* printf("\n"); */ |
|---|
| 2051 | /* printf("GRADIENT\n"); */ |
|---|
| 2052 | /* For(i,dim) */ |
|---|
| 2053 | /* { */ |
|---|
| 2054 | /* PhyML_Printf("[%f] ",tree->a_edges[i]->l->v); */ |
|---|
| 2055 | /* For(j,dim) */ |
|---|
| 2056 | /* { */ |
|---|
| 2057 | /* printf("%12lf ",gradient[i]*gradient[j]); */ |
|---|
| 2058 | /* } */ |
|---|
| 2059 | /* printf("\n"); */ |
|---|
| 2060 | /* } */ |
|---|
| 2061 | /* printf("\n"); */ |
|---|
| 2062 | /* For(i,dim) */ |
|---|
| 2063 | /* { */ |
|---|
| 2064 | /* PhyML_Printf("[%f] [%f]\n",tree->a_edges[i]->l->v,gradient[i]); */ |
|---|
| 2065 | /* } */ |
|---|
| 2066 | |
|---|
| 2067 | /* Exit("\n"); */ |
|---|
| 2068 | |
|---|
| 2069 | return gradient; |
|---|
| 2070 | |
|---|
| 2071 | } |
|---|
| 2072 | |
|---|
| 2073 | ////////////////////////////////////////////////////////////// |
|---|
| 2074 | ////////////////////////////////////////////////////////////// |
|---|
| 2075 | |
|---|
| 2076 | |
|---|
| 2077 | /* Work out the Hessian for the likelihood function using the method described by Seo et al., 2004, MBE. |
|---|
| 2078 | Corresponds to the outer product of the scores approach described in Porter, 2002. (matrix J1) |
|---|
| 2079 | */ |
|---|
| 2080 | phydbl *Hessian_Seo(t_tree *tree) |
|---|
| 2081 | { |
|---|
| 2082 | phydbl *hessian,*site_hessian; |
|---|
| 2083 | phydbl *gradient; |
|---|
| 2084 | phydbl *plus, *minus, *plusplus, *zero; |
|---|
| 2085 | phydbl *ori_bl,*inc_plus,*inc_minus,*inc; |
|---|
| 2086 | int *is_ok; |
|---|
| 2087 | int dim; |
|---|
| 2088 | int i,j,k; |
|---|
| 2089 | phydbl eps; |
|---|
| 2090 | phydbl ori_lnL,lnL1,lnL2; |
|---|
| 2091 | phydbl l_inf; |
|---|
| 2092 | int l,n; |
|---|
| 2093 | phydbl small_var; |
|---|
| 2094 | |
|---|
| 2095 | dim = 2*tree->n_otu-3; |
|---|
| 2096 | eps = (tree->mod->log_l == YES)?(0.2):(1.E-4); |
|---|
| 2097 | |
|---|
| 2098 | hessian = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 2099 | site_hessian = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 2100 | gradient = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 2101 | ori_bl = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 2102 | plus = (phydbl *)mCalloc((int)dim*tree->n_pattern,sizeof(phydbl)); |
|---|
| 2103 | plusplus = (phydbl *)mCalloc((int)dim*tree->n_pattern,sizeof(phydbl)); |
|---|
| 2104 | minus = (phydbl *)mCalloc((int)dim*tree->n_pattern,sizeof(phydbl)); |
|---|
| 2105 | zero = (phydbl *)mCalloc((int)dim*tree->n_pattern,sizeof(phydbl)); |
|---|
| 2106 | inc_plus = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 2107 | inc_minus = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 2108 | inc = (phydbl *)mCalloc((int)dim,sizeof(phydbl)); |
|---|
| 2109 | is_ok = (int *)mCalloc((int)dim,sizeof(int)); |
|---|
| 2110 | |
|---|
| 2111 | lnL1 = lnL2 = UNLIKELY; |
|---|
| 2112 | |
|---|
| 2113 | Set_Both_Sides(YES,tree); |
|---|
| 2114 | Lk(NULL,tree); |
|---|
| 2115 | ori_lnL = tree->c_lnL; |
|---|
| 2116 | |
|---|
| 2117 | For(i,dim) ori_bl[i] = tree->a_edges[i]->l->v; |
|---|
| 2118 | |
|---|
| 2119 | if(tree->mod->log_l == NO) |
|---|
| 2120 | l_inf = MAX(tree->mod->l_min,1./(phydbl)tree->data->init_len); |
|---|
| 2121 | else |
|---|
| 2122 | l_inf = MAX(tree->mod->l_min,-LOG((phydbl)tree->data->init_len)); |
|---|
| 2123 | |
|---|
| 2124 | For(i,dim) |
|---|
| 2125 | { |
|---|
| 2126 | if(tree->a_edges[i]->l->v*(1.-eps) > l_inf) |
|---|
| 2127 | { |
|---|
| 2128 | inc_plus[i] = FABS(eps * tree->a_edges[i]->l->v); |
|---|
| 2129 | inc_minus[i] = FABS(eps * tree->a_edges[i]->l->v); |
|---|
| 2130 | is_ok[i] = YES; |
|---|
| 2131 | } |
|---|
| 2132 | else |
|---|
| 2133 | { |
|---|
| 2134 | inc_plus[i] = FABS(0.2 * tree->a_edges[i]->l->v); |
|---|
| 2135 | inc_minus[i] = FABS(0.2 * tree->a_edges[i]->l->v); |
|---|
| 2136 | is_ok[i] = NO; |
|---|
| 2137 | } |
|---|
| 2138 | } |
|---|
| 2139 | |
|---|
| 2140 | |
|---|
| 2141 | /* Fine tune the increments */ |
|---|
| 2142 | For(i,dim) |
|---|
| 2143 | { |
|---|
| 2144 | do |
|---|
| 2145 | { |
|---|
| 2146 | tree->a_edges[i]->l->v += inc_plus[i]; |
|---|
| 2147 | lnL1 = Lk(tree->a_edges[i],tree); |
|---|
| 2148 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2149 | inc_plus[i] *= 1.1; |
|---|
| 2150 | }while((FABS(lnL1 - ori_lnL) < 1.E-1) && |
|---|
| 2151 | (tree->a_edges[i]->l->v+inc_plus[i] < tree->mod->l_max)); |
|---|
| 2152 | inc_plus[i] /= 1.1; |
|---|
| 2153 | } |
|---|
| 2154 | |
|---|
| 2155 | For(i,dim) |
|---|
| 2156 | { |
|---|
| 2157 | do |
|---|
| 2158 | { |
|---|
| 2159 | tree->a_edges[i]->l->v -= inc_minus[i]; |
|---|
| 2160 | lnL1 = Lk(tree->a_edges[i],tree); |
|---|
| 2161 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2162 | inc_minus[i] *= 1.1; |
|---|
| 2163 | }while((FABS(lnL1 - ori_lnL) < 1.E-1) && |
|---|
| 2164 | (tree->a_edges[i]->l->v -inc_minus[i] > tree->mod->l_min)); |
|---|
| 2165 | inc_minus[i] /= 1.1; |
|---|
| 2166 | } |
|---|
| 2167 | |
|---|
| 2168 | For(i,dim) |
|---|
| 2169 | { |
|---|
| 2170 | inc[i] = MIN(inc_plus[i],inc_minus[i]); |
|---|
| 2171 | } |
|---|
| 2172 | |
|---|
| 2173 | /* plus */ |
|---|
| 2174 | For(i,dim) |
|---|
| 2175 | { |
|---|
| 2176 | if(is_ok[i] == YES) |
|---|
| 2177 | { |
|---|
| 2178 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 2179 | Lk(tree->a_edges[i],tree); |
|---|
| 2180 | For(j,tree->n_pattern) plus[i*tree->n_pattern+j] = LOG(tree->cur_site_lk[j]); |
|---|
| 2181 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2182 | } |
|---|
| 2183 | } |
|---|
| 2184 | |
|---|
| 2185 | |
|---|
| 2186 | /* minus */ |
|---|
| 2187 | For(i,dim) |
|---|
| 2188 | { |
|---|
| 2189 | if(is_ok[i] == YES) |
|---|
| 2190 | { |
|---|
| 2191 | tree->a_edges[i]->l->v -= inc[i]; |
|---|
| 2192 | Lk(tree->a_edges[i],tree); |
|---|
| 2193 | For(j,tree->n_pattern) minus[i*tree->n_pattern+j] = LOG(tree->cur_site_lk[j]); |
|---|
| 2194 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2195 | } |
|---|
| 2196 | } |
|---|
| 2197 | |
|---|
| 2198 | |
|---|
| 2199 | For(i,dim) |
|---|
| 2200 | { |
|---|
| 2201 | if(is_ok[i] == NO) |
|---|
| 2202 | { |
|---|
| 2203 | Lk(tree->a_edges[i],tree); |
|---|
| 2204 | For(j,tree->n_pattern) zero[i*tree->n_pattern+j] = LOG(tree->cur_site_lk[j]); |
|---|
| 2205 | |
|---|
| 2206 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 2207 | lnL1 = Lk(tree->a_edges[i],tree); |
|---|
| 2208 | For(j,tree->n_pattern) plus[i*tree->n_pattern+j] = LOG(tree->cur_site_lk[j]); |
|---|
| 2209 | |
|---|
| 2210 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 2211 | lnL2 = Lk(tree->a_edges[i],tree); |
|---|
| 2212 | For(j,tree->n_pattern) plusplus[i*tree->n_pattern+j] = LOG(tree->cur_site_lk[j]); |
|---|
| 2213 | |
|---|
| 2214 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2215 | |
|---|
| 2216 | } |
|---|
| 2217 | } |
|---|
| 2218 | |
|---|
| 2219 | For(i,dim*dim) hessian[i] = 0.0; |
|---|
| 2220 | |
|---|
| 2221 | For(k,tree->n_pattern) |
|---|
| 2222 | { |
|---|
| 2223 | For(i,dim) |
|---|
| 2224 | { |
|---|
| 2225 | if(is_ok[i] == YES) |
|---|
| 2226 | gradient[i] = (plus[i*tree->n_pattern+k] - minus[i*tree->n_pattern+k])/(inc[i] + inc[i]); |
|---|
| 2227 | else |
|---|
| 2228 | gradient[i] = (4.*plus[i*tree->n_pattern+k] - plusplus[i*tree->n_pattern+k] - 3.*zero[i*tree->n_pattern+k])/(inc[i] + inc[i]); |
|---|
| 2229 | |
|---|
| 2230 | /* if(is_ok[i] == NO) */ |
|---|
| 2231 | /* printf("\n. i=%d site=%d l=%G plus=%G plusplus=%G zero=%G num=%f grad=%G", */ |
|---|
| 2232 | /* i,k,tree->a_edges[i]->l->v, */ |
|---|
| 2233 | /* plus[i*tree->n_pattern+k],plusplus[i*tree->n_pattern+k],zero[i*tree->n_pattern+k], */ |
|---|
| 2234 | /* (4.*plus[i*tree->n_pattern+k] - plusplus[i*tree->n_pattern+k] - 3.*zero[i*tree->n_pattern+k]), */ |
|---|
| 2235 | /* gradient[i]); */ |
|---|
| 2236 | } |
|---|
| 2237 | For(i,dim) For(j,dim) site_hessian[i*dim+j] = gradient[i] * gradient[j]; |
|---|
| 2238 | For(i,dim*dim) hessian[i] -= site_hessian[i] * tree->data->wght[k]; |
|---|
| 2239 | } |
|---|
| 2240 | |
|---|
| 2241 | |
|---|
| 2242 | /* Make sure to update likelihood before bailing out */ |
|---|
| 2243 | Set_Both_Sides(YES,tree); |
|---|
| 2244 | Lk(NULL,tree); |
|---|
| 2245 | |
|---|
| 2246 | l = tree->data->init_len; |
|---|
| 2247 | n = tree->mod->ns; |
|---|
| 2248 | /* Delta method for variance. Assume Jukes and Cantor with p=1/n */ |
|---|
| 2249 | small_var = (1./(l*l))*(1.-1./l)*(n-1.)*(n-1.)/(n-1.-n/l); |
|---|
| 2250 | For(i,dim) |
|---|
| 2251 | if(is_ok[i] == NO) |
|---|
| 2252 | { |
|---|
| 2253 | For(j,dim) |
|---|
| 2254 | { |
|---|
| 2255 | hessian[i*dim+j] = 0.; |
|---|
| 2256 | hessian[j*dim+i] = 0.; |
|---|
| 2257 | } |
|---|
| 2258 | hessian[i*dim+i] = -1./small_var; |
|---|
| 2259 | |
|---|
| 2260 | if(tree->mod->log_l == YES) |
|---|
| 2261 | { |
|---|
| 2262 | hessian[i*dim+i] = small_var * POW(EXP(tree->a_edges[i]->l->v),-2); |
|---|
| 2263 | hessian[i*dim+i] = -1./hessian[i*dim+i]; |
|---|
| 2264 | } |
|---|
| 2265 | } |
|---|
| 2266 | |
|---|
| 2267 | For(i,dim) |
|---|
| 2268 | if(is_ok[i] == YES && hessian[i*dim+i] < -1./small_var) |
|---|
| 2269 | { |
|---|
| 2270 | For(j,dim) |
|---|
| 2271 | { |
|---|
| 2272 | hessian[i*dim+j] = 0.; |
|---|
| 2273 | hessian[j*dim+i] = 0.; |
|---|
| 2274 | } |
|---|
| 2275 | hessian[i*dim+i] = -1./small_var; |
|---|
| 2276 | |
|---|
| 2277 | if(tree->mod->log_l == YES) |
|---|
| 2278 | { |
|---|
| 2279 | hessian[i*dim+i] = small_var * POW(EXP(tree->a_edges[i]->l->v),-2); |
|---|
| 2280 | hessian[i*dim+i] = -1./hessian[i*dim+i]; |
|---|
| 2281 | } |
|---|
| 2282 | } |
|---|
| 2283 | |
|---|
| 2284 | |
|---|
| 2285 | For(i,dim) |
|---|
| 2286 | { |
|---|
| 2287 | For(j,dim) |
|---|
| 2288 | { |
|---|
| 2289 | if(FABS(hessian[i*dim+j]-hessian[j*dim+i]) > 1.E-3) |
|---|
| 2290 | { |
|---|
| 2291 | PhyML_Printf("\n== Hessian not symmetrical."); |
|---|
| 2292 | PhyML_Printf("\n== Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 2293 | Exit("\n"); |
|---|
| 2294 | } |
|---|
| 2295 | hessian[i*dim+j] = (hessian[i*dim+j] + hessian[j*dim+i]) / 2.; |
|---|
| 2296 | hessian[j*dim+i] = hessian[i*dim+j]; |
|---|
| 2297 | } |
|---|
| 2298 | } |
|---|
| 2299 | |
|---|
| 2300 | /* printf("\n"); */ |
|---|
| 2301 | /* printf("HESSIAN SEO\n"); */ |
|---|
| 2302 | /* For(i,dim) */ |
|---|
| 2303 | /* { */ |
|---|
| 2304 | /* PhyML_Printf("[%f] ",tree->a_edges[i]->l->v); */ |
|---|
| 2305 | /* For(j,dim) */ |
|---|
| 2306 | /* { */ |
|---|
| 2307 | /* PhyML_Printf("%12lf ",hessian[i*dim+j]); */ |
|---|
| 2308 | /* } */ |
|---|
| 2309 | /* PhyML_Printf("\n"); */ |
|---|
| 2310 | /* } */ |
|---|
| 2311 | |
|---|
| 2312 | Free(site_hessian); |
|---|
| 2313 | Free(ori_bl); |
|---|
| 2314 | Free(plus); |
|---|
| 2315 | Free(minus); |
|---|
| 2316 | Free(plusplus); |
|---|
| 2317 | Free(zero); |
|---|
| 2318 | Free(inc); |
|---|
| 2319 | Free(inc_plus); |
|---|
| 2320 | Free(inc_minus); |
|---|
| 2321 | Free(is_ok); |
|---|
| 2322 | Free(gradient); |
|---|
| 2323 | |
|---|
| 2324 | return hessian; |
|---|
| 2325 | |
|---|
| 2326 | } |
|---|
| 2327 | |
|---|
| 2328 | ////////////////////////////////////////////////////////////// |
|---|
| 2329 | ////////////////////////////////////////////////////////////// |
|---|
| 2330 | |
|---|
| 2331 | |
|---|
| 2332 | void Recurr_Hessian(t_node *a, t_node *d, int plus_minus, phydbl *inc, phydbl *res, int *is_ok, t_tree *tree) |
|---|
| 2333 | { |
|---|
| 2334 | int i; |
|---|
| 2335 | phydbl ori_l; |
|---|
| 2336 | |
|---|
| 2337 | For(i,3) |
|---|
| 2338 | if(a->v[i] == d) |
|---|
| 2339 | { |
|---|
| 2340 | Update_P_Lk(tree,a->b[i],a); |
|---|
| 2341 | |
|---|
| 2342 | ori_l = a->b[i]->l->v; |
|---|
| 2343 | if(is_ok[a->b[i]->num]) |
|---|
| 2344 | { |
|---|
| 2345 | if(plus_minus > 0) a->b[i]->l->v += inc[a->b[i]->num]; |
|---|
| 2346 | else a->b[i]->l->v -= inc[a->b[i]->num]; |
|---|
| 2347 | res[a->b[i]->num] = Lk(a->b[i],tree); |
|---|
| 2348 | a->b[i]->l->v = ori_l; |
|---|
| 2349 | Update_PMat_At_Given_Edge(a->b[i],tree); |
|---|
| 2350 | } |
|---|
| 2351 | break; |
|---|
| 2352 | } |
|---|
| 2353 | |
|---|
| 2354 | if(d->tax) return; |
|---|
| 2355 | else |
|---|
| 2356 | For(i,3) |
|---|
| 2357 | if(d->v[i] != a) |
|---|
| 2358 | Recurr_Hessian(d,d->v[i],plus_minus,inc,res,is_ok,tree); |
|---|
| 2359 | } |
|---|
| 2360 | |
|---|
| 2361 | ////////////////////////////////////////////////////////////// |
|---|
| 2362 | ////////////////////////////////////////////////////////////// |
|---|
| 2363 | |
|---|
| 2364 | |
|---|
| 2365 | /* Work out the Hessian for the likelihood function. Only LOGARITHM of branch lengths are considered as variable. |
|---|
| 2366 | This function is very much inspired from Jeff Thorne's 'hessian' function in his program 'estbranches'. */ |
|---|
| 2367 | phydbl *Hessian_Log(t_tree *tree) |
|---|
| 2368 | { |
|---|
| 2369 | phydbl *hessian; |
|---|
| 2370 | phydbl *plus_plus, *minus_minus, *plus_zero, *minus_zero, *plus_minus, *zero_zero; |
|---|
| 2371 | phydbl *ori_bl,*inc,*buff; |
|---|
| 2372 | int *ok_edges,*is_ok; |
|---|
| 2373 | int dim; |
|---|
| 2374 | int n_ok_edges; |
|---|
| 2375 | int i,j; |
|---|
| 2376 | phydbl eps; |
|---|
| 2377 | phydbl lk; |
|---|
| 2378 | |
|---|
| 2379 | dim = 2*tree->n_otu-3; |
|---|
| 2380 | eps = 1.E-4; |
|---|
| 2381 | |
|---|
| 2382 | hessian = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 2383 | ori_bl = (phydbl *)mCalloc((int)dim, sizeof(phydbl)); |
|---|
| 2384 | plus_plus = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 2385 | minus_minus = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 2386 | plus_minus = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 2387 | plus_zero = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 2388 | minus_zero = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 2389 | zero_zero = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 2390 | inc = (phydbl *)mCalloc((int)dim ,sizeof(phydbl)); |
|---|
| 2391 | buff = (phydbl *)mCalloc((int)dim*dim,sizeof(phydbl)); |
|---|
| 2392 | ok_edges = (int *)mCalloc((int)dim, sizeof(int)); |
|---|
| 2393 | is_ok = (int *)mCalloc((int)dim, sizeof(int)); |
|---|
| 2394 | |
|---|
| 2395 | Set_Both_Sides(YES,tree); |
|---|
| 2396 | Lk(NULL,tree); |
|---|
| 2397 | |
|---|
| 2398 | For(i,dim) ori_bl[i] = tree->a_edges[i]->l->v; |
|---|
| 2399 | |
|---|
| 2400 | n_ok_edges = 0; |
|---|
| 2401 | For(i,dim) |
|---|
| 2402 | { |
|---|
| 2403 | if(tree->a_edges[i]->l->v > 3.0/(phydbl)tree->data->init_len) |
|---|
| 2404 | { |
|---|
| 2405 | inc[i] = FABS(eps * tree->a_edges[i]->l->v); |
|---|
| 2406 | ok_edges[n_ok_edges] = i; |
|---|
| 2407 | n_ok_edges++; |
|---|
| 2408 | is_ok[i] = 1; |
|---|
| 2409 | } |
|---|
| 2410 | else is_ok[i] = 0; |
|---|
| 2411 | } |
|---|
| 2412 | |
|---|
| 2413 | /* zero zero */ |
|---|
| 2414 | lk = Log_Det(is_ok,tree); |
|---|
| 2415 | For(i,dim) if(is_ok[i]) zero_zero[i] = tree->c_lnL+lk; |
|---|
| 2416 | |
|---|
| 2417 | /* plus zero */ |
|---|
| 2418 | For(i,dim) |
|---|
| 2419 | { |
|---|
| 2420 | if(is_ok[i]) |
|---|
| 2421 | { |
|---|
| 2422 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 2423 | lk = Lk(tree->a_edges[i],tree); |
|---|
| 2424 | plus_zero[i] = lk+Log_Det(is_ok,tree); |
|---|
| 2425 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2426 | } |
|---|
| 2427 | } |
|---|
| 2428 | |
|---|
| 2429 | |
|---|
| 2430 | /* minus zero */ |
|---|
| 2431 | For(i,dim) |
|---|
| 2432 | { |
|---|
| 2433 | if(is_ok[i]) |
|---|
| 2434 | { |
|---|
| 2435 | tree->a_edges[i]->l->v -= inc[i]; |
|---|
| 2436 | lk = Lk(tree->a_edges[i],tree); |
|---|
| 2437 | minus_zero[i] = lk+Log_Det(is_ok,tree); |
|---|
| 2438 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2439 | } |
|---|
| 2440 | } |
|---|
| 2441 | |
|---|
| 2442 | For(i,dim) Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 2443 | |
|---|
| 2444 | /* plus plus */ |
|---|
| 2445 | For(i,dim) |
|---|
| 2446 | { |
|---|
| 2447 | if(is_ok[i]) |
|---|
| 2448 | { |
|---|
| 2449 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 2450 | Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 2451 | |
|---|
| 2452 | For(j,3) |
|---|
| 2453 | if((!tree->a_edges[i]->left->tax) && (tree->a_edges[i]->left->v[j] != tree->a_edges[i]->rght)) |
|---|
| 2454 | Recurr_Hessian_Log(tree->a_edges[i]->left,tree->a_edges[i]->left->v[j],1,inc,plus_plus+i*dim,is_ok,tree); |
|---|
| 2455 | |
|---|
| 2456 | For(j,3) |
|---|
| 2457 | if((!tree->a_edges[i]->rght->tax) && (tree->a_edges[i]->rght->v[j] != tree->a_edges[i]->left)) |
|---|
| 2458 | Recurr_Hessian_Log(tree->a_edges[i]->rght,tree->a_edges[i]->rght->v[j],1,inc,plus_plus+i*dim,is_ok,tree); |
|---|
| 2459 | |
|---|
| 2460 | /* For(j,dim) */ |
|---|
| 2461 | /* if(j != i) */ |
|---|
| 2462 | /* { */ |
|---|
| 2463 | /* if(inc[j] > 0.0) */ |
|---|
| 2464 | /* { */ |
|---|
| 2465 | /* tree->a_edges[j]->l->v += inc[j]; */ |
|---|
| 2466 | /* Lk(tree); */ |
|---|
| 2467 | /* plus_plus[i*dim+j]=tree->c_lnL; */ |
|---|
| 2468 | /* tree->a_edges[j]->l->v = ori_bl[j]; */ |
|---|
| 2469 | /* } */ |
|---|
| 2470 | /* } */ |
|---|
| 2471 | |
|---|
| 2472 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2473 | Lk(NULL,tree); |
|---|
| 2474 | } |
|---|
| 2475 | } |
|---|
| 2476 | |
|---|
| 2477 | /* plus minus */ |
|---|
| 2478 | For(i,dim) |
|---|
| 2479 | { |
|---|
| 2480 | if(is_ok[i]) |
|---|
| 2481 | { |
|---|
| 2482 | tree->a_edges[i]->l->v += inc[i]; |
|---|
| 2483 | Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 2484 | |
|---|
| 2485 | For(j,3) |
|---|
| 2486 | if((!tree->a_edges[i]->left->tax) && (tree->a_edges[i]->left->v[j] != tree->a_edges[i]->rght)) |
|---|
| 2487 | Recurr_Hessian_Log(tree->a_edges[i]->left,tree->a_edges[i]->left->v[j],-1,inc,plus_minus+i*dim,is_ok,tree); |
|---|
| 2488 | |
|---|
| 2489 | For(j,3) |
|---|
| 2490 | if((!tree->a_edges[i]->rght->tax) && (tree->a_edges[i]->rght->v[j] != tree->a_edges[i]->left)) |
|---|
| 2491 | Recurr_Hessian_Log(tree->a_edges[i]->rght,tree->a_edges[i]->rght->v[j],-1,inc,plus_minus+i*dim,is_ok,tree); |
|---|
| 2492 | |
|---|
| 2493 | /* For(j,dim) */ |
|---|
| 2494 | /* if(j != i) */ |
|---|
| 2495 | /* { */ |
|---|
| 2496 | /* if(inc[j] > 0.0) */ |
|---|
| 2497 | /* { */ |
|---|
| 2498 | /* tree->a_edges[j]->l->v -= inc[j]; */ |
|---|
| 2499 | /* Lk(tree); */ |
|---|
| 2500 | /* plus_minus[i*dim+j] = tree->c_lnL; */ |
|---|
| 2501 | /* tree->a_edges[j]->l->v = ori_bl[j]; */ |
|---|
| 2502 | /* } */ |
|---|
| 2503 | /* } */ |
|---|
| 2504 | |
|---|
| 2505 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2506 | Lk(NULL,tree); |
|---|
| 2507 | } |
|---|
| 2508 | } |
|---|
| 2509 | |
|---|
| 2510 | |
|---|
| 2511 | /* minus minus */ |
|---|
| 2512 | For(i,dim) |
|---|
| 2513 | { |
|---|
| 2514 | if(is_ok[i]) |
|---|
| 2515 | { |
|---|
| 2516 | tree->a_edges[i]->l->v -= inc[i]; |
|---|
| 2517 | |
|---|
| 2518 | Update_PMat_At_Given_Edge(tree->a_edges[i],tree); |
|---|
| 2519 | |
|---|
| 2520 | For(j,3) |
|---|
| 2521 | if((!tree->a_edges[i]->left->tax) && (tree->a_edges[i]->left->v[j] != tree->a_edges[i]->rght)) |
|---|
| 2522 | Recurr_Hessian_Log(tree->a_edges[i]->left,tree->a_edges[i]->left->v[j],-1,inc,minus_minus+i*dim,is_ok,tree); |
|---|
| 2523 | |
|---|
| 2524 | For(j,3) |
|---|
| 2525 | if((!tree->a_edges[i]->rght->tax) && (tree->a_edges[i]->rght->v[j] != tree->a_edges[i]->left)) |
|---|
| 2526 | Recurr_Hessian_Log(tree->a_edges[i]->rght,tree->a_edges[i]->rght->v[j],-1,inc,minus_minus+i*dim,is_ok,tree); |
|---|
| 2527 | |
|---|
| 2528 | /* For(j,dim) */ |
|---|
| 2529 | /* if(j != i) */ |
|---|
| 2530 | /* { */ |
|---|
| 2531 | /* if(inc[j] > 0.0) */ |
|---|
| 2532 | /* { */ |
|---|
| 2533 | /* tree->a_edges[j]->l->v -= inc[j]; */ |
|---|
| 2534 | /* Lk(tree); */ |
|---|
| 2535 | /* minus_minus[i*dim+j] = tree->c_lnL; */ |
|---|
| 2536 | /* tree->a_edges[j]->l->v = ori_bl[j]; */ |
|---|
| 2537 | /* } */ |
|---|
| 2538 | /* } */ |
|---|
| 2539 | |
|---|
| 2540 | tree->a_edges[i]->l->v = ori_bl[i]; |
|---|
| 2541 | Lk(NULL,tree); |
|---|
| 2542 | } |
|---|
| 2543 | } |
|---|
| 2544 | |
|---|
| 2545 | /* For(i,dim) if(is_ok[i]) inc[i] = POW(tree->a_edges[i]->l->v+inc[i],2)-POW(tree->a_edges[i]->l->v,2); */ |
|---|
| 2546 | For(i,dim) if(is_ok[i]) inc[i] = LOG(tree->a_edges[i]->l->v+inc[i])-LOG(tree->a_edges[i]->l->v); |
|---|
| 2547 | /* For(i,dim) inc[i] = 2.*inc[i]; */ |
|---|
| 2548 | /* For(i,dim) if(is_ok[i]) inc[i] = SQRT(tree->a_edges[i]->l->v+inc[i])-SQRT(tree->a_edges[i]->l->v); */ |
|---|
| 2549 | |
|---|
| 2550 | For(i,dim) |
|---|
| 2551 | { |
|---|
| 2552 | if(is_ok[i]) |
|---|
| 2553 | { |
|---|
| 2554 | hessian[i*dim+i] = (plus_zero[i]-2*zero_zero[i]+minus_zero[i])/(POW(inc[i],2)); |
|---|
| 2555 | |
|---|
| 2556 | for(j=i+1;j<dim;j++) |
|---|
| 2557 | { |
|---|
| 2558 | if(is_ok[j]) |
|---|
| 2559 | { |
|---|
| 2560 | hessian[i*dim+j] = |
|---|
| 2561 | (plus_plus[i*dim+j]-plus_minus[i*dim+j]-plus_minus[j*dim+i]+minus_minus[i*dim+j])/ |
|---|
| 2562 | (4*inc[i]*inc[i]); |
|---|
| 2563 | hessian[j*dim+i] = hessian[i*dim+j]; |
|---|
| 2564 | } |
|---|
| 2565 | } |
|---|
| 2566 | } |
|---|
| 2567 | } |
|---|
| 2568 | |
|---|
| 2569 | |
|---|
| 2570 | For(i,n_ok_edges) |
|---|
| 2571 | { |
|---|
| 2572 | For(j,n_ok_edges) |
|---|
| 2573 | { |
|---|
| 2574 | buff[i*n_ok_edges+j] = -hessian[ok_edges[i]*dim+ok_edges[j]]; |
|---|
| 2575 | } |
|---|
| 2576 | } |
|---|
| 2577 | |
|---|
| 2578 | if(!Matinv(buff,n_ok_edges,n_ok_edges,NO)) |
|---|
| 2579 | { |
|---|
| 2580 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 2581 | Exit("\n"); |
|---|
| 2582 | } |
|---|
| 2583 | |
|---|
| 2584 | For(i,n_ok_edges) |
|---|
| 2585 | { |
|---|
| 2586 | For(j,n_ok_edges) |
|---|
| 2587 | { |
|---|
| 2588 | hessian[ok_edges[i]*dim+ok_edges[j]] = buff[i*n_ok_edges+j]; |
|---|
| 2589 | } |
|---|
| 2590 | } |
|---|
| 2591 | |
|---|
| 2592 | /* Approximate variance for very short branches */ |
|---|
| 2593 | For(i,dim) |
|---|
| 2594 | if(!is_ok[i]) |
|---|
| 2595 | { |
|---|
| 2596 | hessian[i*dim+i] = 1./POW(tree->data->init_len,2); |
|---|
| 2597 | } |
|---|
| 2598 | |
|---|
| 2599 | if(!Matinv(hessian,dim,dim,NO)) |
|---|
| 2600 | { |
|---|
| 2601 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 2602 | Exit("\n"); |
|---|
| 2603 | } |
|---|
| 2604 | |
|---|
| 2605 | For(i,dim*dim) hessian[i] = -1.0*hessian[i]; |
|---|
| 2606 | |
|---|
| 2607 | /* For(i,dim) */ |
|---|
| 2608 | /* { */ |
|---|
| 2609 | /* PhyML_Printf("[%f] ",tree->a_edges[i]->l->v); */ |
|---|
| 2610 | /* For(j,i+1) */ |
|---|
| 2611 | /* { */ |
|---|
| 2612 | /* PhyML_Printf("%12lf ",hessian[i*dim+j]); */ |
|---|
| 2613 | /* } */ |
|---|
| 2614 | /* PhyML_Printf("\n"); */ |
|---|
| 2615 | /* } */ |
|---|
| 2616 | |
|---|
| 2617 | /* Matinv(hessian,dim,dim); */ |
|---|
| 2618 | |
|---|
| 2619 | /* PhyML_Printf("\n"); */ |
|---|
| 2620 | |
|---|
| 2621 | For(i,dim) |
|---|
| 2622 | { |
|---|
| 2623 | PhyML_Printf("[%f] ",tree->a_edges[i]->l->v); |
|---|
| 2624 | For(j,i+1) |
|---|
| 2625 | { |
|---|
| 2626 | PhyML_Printf("%12lf ",hessian[i*dim+j]); |
|---|
| 2627 | } |
|---|
| 2628 | PhyML_Printf("\n"); |
|---|
| 2629 | } |
|---|
| 2630 | /* Exit("\n"); */ |
|---|
| 2631 | |
|---|
| 2632 | |
|---|
| 2633 | Free(ori_bl); |
|---|
| 2634 | Free(plus_plus); |
|---|
| 2635 | Free(minus_minus); |
|---|
| 2636 | Free(plus_zero); |
|---|
| 2637 | Free(minus_zero); |
|---|
| 2638 | Free(plus_minus); |
|---|
| 2639 | Free(zero_zero); |
|---|
| 2640 | Free(inc); |
|---|
| 2641 | Free(buff); |
|---|
| 2642 | Free(ok_edges); |
|---|
| 2643 | Free(is_ok); |
|---|
| 2644 | |
|---|
| 2645 | return hessian; |
|---|
| 2646 | |
|---|
| 2647 | } |
|---|
| 2648 | |
|---|
| 2649 | ////////////////////////////////////////////////////////////// |
|---|
| 2650 | ////////////////////////////////////////////////////////////// |
|---|
| 2651 | |
|---|
| 2652 | |
|---|
| 2653 | void Recurr_Hessian_Log(t_node *a, t_node *d, int plus_minus, phydbl *inc, phydbl *res, int *is_ok, t_tree *tree) |
|---|
| 2654 | { |
|---|
| 2655 | int i; |
|---|
| 2656 | phydbl ori_l; |
|---|
| 2657 | |
|---|
| 2658 | For(i,3) |
|---|
| 2659 | if(a->v[i] == d) |
|---|
| 2660 | { |
|---|
| 2661 | Update_P_Lk(tree,a->b[i],a); |
|---|
| 2662 | |
|---|
| 2663 | ori_l = a->b[i]->l->v; |
|---|
| 2664 | if(is_ok[a->b[i]->num]) |
|---|
| 2665 | { |
|---|
| 2666 | if(plus_minus > 0) a->b[i]->l->v += inc[a->b[i]->num]; |
|---|
| 2667 | else a->b[i]->l->v -= inc[a->b[i]->num]; |
|---|
| 2668 | res[a->b[i]->num] = Lk(a->b[i],tree); |
|---|
| 2669 | res[a->b[i]->num] += Log_Det(is_ok,tree); |
|---|
| 2670 | a->b[i]->l->v = ori_l; |
|---|
| 2671 | Update_PMat_At_Given_Edge(a->b[i],tree); |
|---|
| 2672 | } |
|---|
| 2673 | break; |
|---|
| 2674 | } |
|---|
| 2675 | |
|---|
| 2676 | if(d->tax) return; |
|---|
| 2677 | else |
|---|
| 2678 | For(i,3) |
|---|
| 2679 | if(d->v[i] != a) |
|---|
| 2680 | Recurr_Hessian_Log(d,d->v[i],plus_minus,inc,res,is_ok,tree); |
|---|
| 2681 | } |
|---|
| 2682 | |
|---|
| 2683 | ////////////////////////////////////////////////////////////// |
|---|
| 2684 | ////////////////////////////////////////////////////////////// |
|---|
| 2685 | |
|---|
| 2686 | |
|---|
| 2687 | phydbl Log_Det(int *is_ok, t_tree *tree) |
|---|
| 2688 | { |
|---|
| 2689 | int i; |
|---|
| 2690 | phydbl ldet; |
|---|
| 2691 | |
|---|
| 2692 | ldet = 0.0; |
|---|
| 2693 | /* For(i,2*tree->n_otu-3) if(is_ok[i]) ldet += LOG(2.*SQRT(tree->a_edges[i]->l->v)); */ |
|---|
| 2694 | For(i,2*tree->n_otu-3) if(is_ok[i]) ldet += LOG(tree->a_edges[i]->l->v); |
|---|
| 2695 | /* For(i,2*tree->n_otu-3) if(is_ok[i]) ldet -= LOG(2*tree->a_edges[i]->l->v); */ |
|---|
| 2696 | |
|---|
| 2697 | return ldet; |
|---|
| 2698 | |
|---|
| 2699 | } |
|---|
| 2700 | |
|---|
| 2701 | ////////////////////////////////////////////////////////////// |
|---|
| 2702 | ////////////////////////////////////////////////////////////// |
|---|
| 2703 | |
|---|
| 2704 | |
|---|
| 2705 | phydbl Normal_Trunc_Mean(phydbl mu, phydbl sd, phydbl min, phydbl max) |
|---|
| 2706 | { |
|---|
| 2707 | phydbl mean; |
|---|
| 2708 | |
|---|
| 2709 | mean = mu + sd * |
|---|
| 2710 | (Dnorm((min-mu)/sd,0.,1.)-Dnorm((max-mu)/sd,0.,1.))/ |
|---|
| 2711 | (Pnorm((max-mu)/sd,0.,1.)-Pnorm((min-mu)/sd,0.,1.)); |
|---|
| 2712 | return mean; |
|---|
| 2713 | } |
|---|
| 2714 | |
|---|
| 2715 | ////////////////////////////////////////////////////////////// |
|---|
| 2716 | ////////////////////////////////////////////////////////////// |
|---|
| 2717 | |
|---|
| 2718 | |
|---|
| 2719 | phydbl Constraint_Normal_Trunc_Mean(phydbl wanted_mu, phydbl sd, phydbl min, phydbl max) |
|---|
| 2720 | { |
|---|
| 2721 | int j; |
|---|
| 2722 | phydbl dx,f,fmid,xmid,rtb; |
|---|
| 2723 | phydbl x1, x2; |
|---|
| 2724 | |
|---|
| 2725 | x1 = min; |
|---|
| 2726 | x2 = max; |
|---|
| 2727 | |
|---|
| 2728 | f = Normal_Trunc_Mean(x1,sd,min,max) - wanted_mu; |
|---|
| 2729 | fmid = Normal_Trunc_Mean(x2,sd,min,max) - wanted_mu; |
|---|
| 2730 | |
|---|
| 2731 | if(f*fmid >= 0.0) |
|---|
| 2732 | { |
|---|
| 2733 | PhyML_Printf("\n. Root must be bracketed for bisection!"); |
|---|
| 2734 | PhyML_Printf("\n. f=%f fmid=%f",f,fmid); |
|---|
| 2735 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 2736 | Exit("\n"); |
|---|
| 2737 | } |
|---|
| 2738 | |
|---|
| 2739 | rtb = f < 0.0 ? (dx=x2-x1,x1) : (dx=x1-x2,x2); |
|---|
| 2740 | |
|---|
| 2741 | For(j,100) |
|---|
| 2742 | { |
|---|
| 2743 | xmid=rtb+(dx *= 0.5); |
|---|
| 2744 | fmid=Normal_Trunc_Mean(xmid,sd,min,max)-wanted_mu; |
|---|
| 2745 | if(fmid <= 0.0) rtb=xmid; |
|---|
| 2746 | if(fmid > -1.E-10 && fmid < 1.E-10) return rtb; |
|---|
| 2747 | } |
|---|
| 2748 | |
|---|
| 2749 | Exit("Too many bisections in RTBIS"); |
|---|
| 2750 | return(-1.); |
|---|
| 2751 | } |
|---|
| 2752 | |
|---|
| 2753 | ////////////////////////////////////////////////////////////// |
|---|
| 2754 | ////////////////////////////////////////////////////////////// |
|---|
| 2755 | |
|---|
| 2756 | |
|---|
| 2757 | int Matinv(phydbl *x, int n, int m, int verbose) |
|---|
| 2758 | { |
|---|
| 2759 | |
|---|
| 2760 | /* x[n*m] ... m>=n |
|---|
| 2761 | */ |
|---|
| 2762 | |
|---|
| 2763 | int i,j,k; |
|---|
| 2764 | int *irow; |
|---|
| 2765 | phydbl ee, t,t1,xmax; |
|---|
| 2766 | phydbl det; |
|---|
| 2767 | |
|---|
| 2768 | ee = 1.0E-10; |
|---|
| 2769 | det = 1.0; |
|---|
| 2770 | |
|---|
| 2771 | irow = (int *)mCalloc(n,sizeof(int)); |
|---|
| 2772 | |
|---|
| 2773 | For (i,n) |
|---|
| 2774 | { |
|---|
| 2775 | xmax = 0.; |
|---|
| 2776 | for (j=i; j<n; j++) |
|---|
| 2777 | if (xmax < FABS(x[j*m+i])) |
|---|
| 2778 | { |
|---|
| 2779 | xmax = FABS(x[j*m+i]); |
|---|
| 2780 | irow[i]=j; |
|---|
| 2781 | } |
|---|
| 2782 | |
|---|
| 2783 | det *= xmax; |
|---|
| 2784 | if (xmax < ee) |
|---|
| 2785 | { |
|---|
| 2786 | Free(irow); |
|---|
| 2787 | if(verbose) |
|---|
| 2788 | { |
|---|
| 2789 | PhyML_Printf("\n== Determinant becomes zero at %3d!\t", i+1); |
|---|
| 2790 | PhyML_Printf("\n== Failed to invert the matrix."); |
|---|
| 2791 | } |
|---|
| 2792 | return(0); |
|---|
| 2793 | } |
|---|
| 2794 | if (irow[i] != i) |
|---|
| 2795 | { |
|---|
| 2796 | For (j,m) |
|---|
| 2797 | { |
|---|
| 2798 | t = x[i*m+j]; |
|---|
| 2799 | x[i*m+j] = x[irow[i]*m+j]; |
|---|
| 2800 | x[irow[i]*m+j] = t; |
|---|
| 2801 | } |
|---|
| 2802 | } |
|---|
| 2803 | t = 1./x[i*m+i]; |
|---|
| 2804 | For (j,n) |
|---|
| 2805 | { |
|---|
| 2806 | if (j == i) continue; |
|---|
| 2807 | t1 = t*x[j*m+i]; |
|---|
| 2808 | For(k,m) x[j*m+k] -= t1*x[i*m+k]; |
|---|
| 2809 | x[j*m+i] = -t1; |
|---|
| 2810 | } |
|---|
| 2811 | For(j,m) x[i*m+j] *= t; |
|---|
| 2812 | x[i*m+i] = t; |
|---|
| 2813 | } /* i */ |
|---|
| 2814 | for (i=n-1; i>=0; i--) |
|---|
| 2815 | { |
|---|
| 2816 | if (irow[i] == i) continue; |
|---|
| 2817 | For(j,n) |
|---|
| 2818 | { |
|---|
| 2819 | t = x[j*m+i]; |
|---|
| 2820 | x[j*m+i] = x[j*m + irow[i]]; |
|---|
| 2821 | x[j*m + irow[i]] = t; |
|---|
| 2822 | } |
|---|
| 2823 | } |
|---|
| 2824 | |
|---|
| 2825 | Free(irow); |
|---|
| 2826 | return (1); |
|---|
| 2827 | |
|---|
| 2828 | /* int i, j, k, lower, upper; */ |
|---|
| 2829 | /* phydbl temp; */ |
|---|
| 2830 | /* phydbl *a; */ |
|---|
| 2831 | /* int nsize; */ |
|---|
| 2832 | |
|---|
| 2833 | /* nsize = n; */ |
|---|
| 2834 | /* a = x; */ |
|---|
| 2835 | |
|---|
| 2836 | /* /\*Gauss-Jordan reduction -- invert matrix a in place, */ |
|---|
| 2837 | /* overwriting previous contents of a. On exit, matrix a */ |
|---|
| 2838 | /* contains the inverse.*\/ */ |
|---|
| 2839 | /* lower = 0; */ |
|---|
| 2840 | /* upper = nsize-1; */ |
|---|
| 2841 | /* for(i = lower; i <= upper; i++) */ |
|---|
| 2842 | /* { */ |
|---|
| 2843 | /* temp = 1.0 / a[i*n+i]; */ |
|---|
| 2844 | /* a[i*n+i] = 1.0; */ |
|---|
| 2845 | /* for (j = lower; j <= upper; j++) */ |
|---|
| 2846 | /* { */ |
|---|
| 2847 | /* a[i*n+j] *= temp; */ |
|---|
| 2848 | /* } */ |
|---|
| 2849 | /* for (j = lower; j <= upper; j++) */ |
|---|
| 2850 | /* { */ |
|---|
| 2851 | /* if (j != i) */ |
|---|
| 2852 | /* { */ |
|---|
| 2853 | /* temp = a[j*n+i]; */ |
|---|
| 2854 | /* a[j*n+i] = 0.0; */ |
|---|
| 2855 | /* for (k = lower; k <= upper; k++) */ |
|---|
| 2856 | /* { */ |
|---|
| 2857 | /* a[j*n+k] -= temp * a[i*n+k]; */ |
|---|
| 2858 | /* } */ |
|---|
| 2859 | /* } */ |
|---|
| 2860 | /* } */ |
|---|
| 2861 | /* } */ |
|---|
| 2862 | |
|---|
| 2863 | return(1); |
|---|
| 2864 | |
|---|
| 2865 | } |
|---|
| 2866 | |
|---|
| 2867 | ////////////////////////////////////////////////////////////// |
|---|
| 2868 | ////////////////////////////////////////////////////////////// |
|---|
| 2869 | |
|---|
| 2870 | |
|---|
| 2871 | int Iter_Matinv(phydbl *x, int n, int m, int verbose) |
|---|
| 2872 | { |
|---|
| 2873 | phydbl *buff; |
|---|
| 2874 | int i,iter; |
|---|
| 2875 | phydbl scaler; |
|---|
| 2876 | int pb; |
|---|
| 2877 | |
|---|
| 2878 | buff = (phydbl *)mCalloc(n*m,sizeof(phydbl)); |
|---|
| 2879 | |
|---|
| 2880 | pb = NO; |
|---|
| 2881 | iter = 0; |
|---|
| 2882 | scaler = 1.; |
|---|
| 2883 | For(i,n*m) buff[i] = x[i]; |
|---|
| 2884 | while(!Matinv(buff,n,m,verbose)) |
|---|
| 2885 | { |
|---|
| 2886 | pb = YES; |
|---|
| 2887 | For(i,n*m) buff[i] = x[i]; |
|---|
| 2888 | scaler *= 10.; |
|---|
| 2889 | For(i,n*m) buff[i] *= scaler; |
|---|
| 2890 | iter++; |
|---|
| 2891 | |
|---|
| 2892 | if(iter > 100) |
|---|
| 2893 | { |
|---|
| 2894 | PhyML_Printf("\n== Err in file %s at line %d.",__FILE__,__LINE__); |
|---|
| 2895 | return 0; |
|---|
| 2896 | } |
|---|
| 2897 | } |
|---|
| 2898 | if(pb) PhyML_Printf("\n== Managed to fix the problem by rescaling the matrix."); |
|---|
| 2899 | For(i,n*m) x[i] = buff[i]*scaler; |
|---|
| 2900 | Free(buff); |
|---|
| 2901 | return 1; |
|---|
| 2902 | } |
|---|
| 2903 | |
|---|
| 2904 | |
|---|
| 2905 | ////////////////////////////////////////////////////////////// |
|---|
| 2906 | ////////////////////////////////////////////////////////////// |
|---|
| 2907 | |
|---|
| 2908 | |
|---|
| 2909 | phydbl *Matrix_Mult(phydbl *A, phydbl *B, int nra, int nca, int nrb, int ncb) |
|---|
| 2910 | { |
|---|
| 2911 | int i,j,k; |
|---|
| 2912 | phydbl *C; |
|---|
| 2913 | |
|---|
| 2914 | C = (phydbl *)mCalloc(nra*ncb,sizeof(phydbl)); |
|---|
| 2915 | |
|---|
| 2916 | if(nca != nrb) |
|---|
| 2917 | { |
|---|
| 2918 | PhyML_Printf("\n. Matrices dimensions don't match."); |
|---|
| 2919 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 2920 | Exit("\n"); |
|---|
| 2921 | } |
|---|
| 2922 | |
|---|
| 2923 | For(i,nra) |
|---|
| 2924 | For(j,ncb) |
|---|
| 2925 | For(k,nca) |
|---|
| 2926 | C[i*ncb+j] += A[i*nca+k] * B[k*ncb+j]; |
|---|
| 2927 | |
|---|
| 2928 | return C; |
|---|
| 2929 | } |
|---|
| 2930 | |
|---|
| 2931 | ////////////////////////////////////////////////////////////// |
|---|
| 2932 | ////////////////////////////////////////////////////////////// |
|---|
| 2933 | |
|---|
| 2934 | |
|---|
| 2935 | phydbl *Matrix_Transpose(phydbl *A, int dim) |
|---|
| 2936 | { |
|---|
| 2937 | phydbl *tA,buff; |
|---|
| 2938 | int i,j; |
|---|
| 2939 | |
|---|
| 2940 | tA = (phydbl *)mCalloc(dim*dim,sizeof(phydbl)); |
|---|
| 2941 | |
|---|
| 2942 | For(i,dim*dim) tA[i]=A[i]; |
|---|
| 2943 | |
|---|
| 2944 | For(i,dim) for(j=i+1;j<dim;j++) |
|---|
| 2945 | { |
|---|
| 2946 | buff = tA[i*dim+j]; |
|---|
| 2947 | tA[i*dim+j] = tA[j*dim+i]; |
|---|
| 2948 | tA[j*dim+i] = buff; |
|---|
| 2949 | } |
|---|
| 2950 | |
|---|
| 2951 | return tA; |
|---|
| 2952 | } |
|---|
| 2953 | |
|---|
| 2954 | ////////////////////////////////////////////////////////////// |
|---|
| 2955 | ////////////////////////////////////////////////////////////// |
|---|
| 2956 | |
|---|
| 2957 | |
|---|
| 2958 | phydbl Matrix_Det(phydbl *A, int size, int _log) |
|---|
| 2959 | { |
|---|
| 2960 | phydbl *triA; |
|---|
| 2961 | int i; |
|---|
| 2962 | phydbl det; |
|---|
| 2963 | |
|---|
| 2964 | triA = Cholesky_Decomp(A,size); |
|---|
| 2965 | det = 0.0; |
|---|
| 2966 | For(i,size) det += LOG(triA[i*size+i]); |
|---|
| 2967 | Free(triA); |
|---|
| 2968 | |
|---|
| 2969 | if(_log == NO) |
|---|
| 2970 | { |
|---|
| 2971 | det = EXP(det); |
|---|
| 2972 | return det*det; |
|---|
| 2973 | } |
|---|
| 2974 | else |
|---|
| 2975 | { |
|---|
| 2976 | return 2.*det; |
|---|
| 2977 | } |
|---|
| 2978 | } |
|---|
| 2979 | |
|---|
| 2980 | ////////////////////////////////////////////////////////////// |
|---|
| 2981 | ////////////////////////////////////////////////////////////// |
|---|
| 2982 | |
|---|
| 2983 | |
|---|
| 2984 | /* http://en.wikipedia.org/wiki/Multivariate_normal_distribution (Conditional distributions) */ |
|---|
| 2985 | void Normal_Conditional(phydbl *mu, phydbl *cov, phydbl *a, int n, short int *is_1, int n1, phydbl *cond_mu, phydbl *cond_cov) |
|---|
| 2986 | { |
|---|
| 2987 | phydbl *mu1,*mu2; |
|---|
| 2988 | phydbl *sig11,*sig12,*sig21,*sig22,*sig12_invsig22,*buff; |
|---|
| 2989 | phydbl *ctrd_a; |
|---|
| 2990 | phydbl *cond_cov_norder,*cond_mu_norder; |
|---|
| 2991 | int n2; |
|---|
| 2992 | int i,j,nr,nc; |
|---|
| 2993 | phydbl *buff_mat; |
|---|
| 2994 | |
|---|
| 2995 | n2 = n-n1; |
|---|
| 2996 | |
|---|
| 2997 | mu1 = (phydbl *)mCalloc(n1, sizeof(phydbl)); |
|---|
| 2998 | mu2 = (phydbl *)mCalloc(n2, sizeof(phydbl)); |
|---|
| 2999 | sig11 = (phydbl *)mCalloc(n1*n1,sizeof(phydbl)); |
|---|
| 3000 | sig12 = (phydbl *)mCalloc(n1*n2,sizeof(phydbl)); |
|---|
| 3001 | sig21 = (phydbl *)mCalloc(n2*n1,sizeof(phydbl)); |
|---|
| 3002 | sig22 = (phydbl *)mCalloc(n2*n2,sizeof(phydbl)); |
|---|
| 3003 | ctrd_a = (phydbl *)mCalloc(n2, sizeof(phydbl)); |
|---|
| 3004 | cond_cov_norder = (phydbl *)mCalloc(n1*n1,sizeof(phydbl)); |
|---|
| 3005 | cond_mu_norder = (phydbl *)mCalloc(n1*n1,sizeof(phydbl)); |
|---|
| 3006 | buff_mat = (phydbl *)mCalloc(n2*n2,sizeof(phydbl)); |
|---|
| 3007 | |
|---|
| 3008 | nr=0; |
|---|
| 3009 | For(i,n) { if(!is_1[i]) { ctrd_a[nr] = a[i]-mu[i]; nr++; } } |
|---|
| 3010 | |
|---|
| 3011 | nr=0; |
|---|
| 3012 | For(i,n) { if( is_1[i]) { mu1[nr] = mu[i]; nr++; } } |
|---|
| 3013 | |
|---|
| 3014 | nr=0; |
|---|
| 3015 | For(i,n) { if(!is_1[i]) { mu2[nr] = mu[i]; nr++; } } |
|---|
| 3016 | |
|---|
| 3017 | nr=0; nc=0; |
|---|
| 3018 | For(i,n) |
|---|
| 3019 | { |
|---|
| 3020 | if(is_1[i]) |
|---|
| 3021 | { |
|---|
| 3022 | nc = nr; |
|---|
| 3023 | for(j=i;j<n;j++) |
|---|
| 3024 | /* nc = 0; */ |
|---|
| 3025 | /* For(j,n) */ |
|---|
| 3026 | { |
|---|
| 3027 | if(is_1[j]) |
|---|
| 3028 | { |
|---|
| 3029 | sig11[nr*n1+nc] = cov[i*n+j]; |
|---|
| 3030 | sig11[nc*n1+nr] = cov[i*n+j]; |
|---|
| 3031 | nc++; |
|---|
| 3032 | } |
|---|
| 3033 | } |
|---|
| 3034 | nr++; |
|---|
| 3035 | } |
|---|
| 3036 | } |
|---|
| 3037 | |
|---|
| 3038 | |
|---|
| 3039 | nr=0; nc=0; |
|---|
| 3040 | For(i,n) |
|---|
| 3041 | { |
|---|
| 3042 | if(is_1[i]) |
|---|
| 3043 | { |
|---|
| 3044 | /* nc = nr; */ |
|---|
| 3045 | /* for(j=i;j<n;j++) */ |
|---|
| 3046 | nc = 0; |
|---|
| 3047 | For(j,n) |
|---|
| 3048 | { |
|---|
| 3049 | if(!is_1[j]) |
|---|
| 3050 | { |
|---|
| 3051 | sig12[nr*n2+nc] = cov[i*n+j]; |
|---|
| 3052 | /* sig12[nc*n2+nr] = cov[i*n+j]; */ |
|---|
| 3053 | nc++; |
|---|
| 3054 | } |
|---|
| 3055 | } |
|---|
| 3056 | nr++; |
|---|
| 3057 | } |
|---|
| 3058 | } |
|---|
| 3059 | |
|---|
| 3060 | nr=0; nc=0; |
|---|
| 3061 | For(i,n) |
|---|
| 3062 | { |
|---|
| 3063 | if(!is_1[i]) |
|---|
| 3064 | { |
|---|
| 3065 | /* nc = nr; */ |
|---|
| 3066 | /* for(j=i;j<n;j++) */ |
|---|
| 3067 | nc = 0; |
|---|
| 3068 | For(j,n) |
|---|
| 3069 | { |
|---|
| 3070 | if(is_1[j]) |
|---|
| 3071 | { |
|---|
| 3072 | sig21[nr*n1+nc] = cov[i*n+j]; |
|---|
| 3073 | /* sig21[nc*n1+nr] = cov[i*n+j]; */ |
|---|
| 3074 | nc++; |
|---|
| 3075 | } |
|---|
| 3076 | } |
|---|
| 3077 | nr++; |
|---|
| 3078 | } |
|---|
| 3079 | } |
|---|
| 3080 | |
|---|
| 3081 | |
|---|
| 3082 | nr=0; nc=0; |
|---|
| 3083 | For(i,n) |
|---|
| 3084 | { |
|---|
| 3085 | if(!is_1[i]) |
|---|
| 3086 | { |
|---|
| 3087 | nc = nr; |
|---|
| 3088 | for(j=i;j<n;j++) |
|---|
| 3089 | /* nc = 0; */ |
|---|
| 3090 | /* For(j,n) */ |
|---|
| 3091 | { |
|---|
| 3092 | if(!is_1[j]) |
|---|
| 3093 | { |
|---|
| 3094 | sig22[nr*n2+nc] = cov[i*n+j]; |
|---|
| 3095 | sig22[nc*n2+nr] = cov[i*n+j]; |
|---|
| 3096 | nc++; |
|---|
| 3097 | } |
|---|
| 3098 | } |
|---|
| 3099 | nr++; |
|---|
| 3100 | } |
|---|
| 3101 | } |
|---|
| 3102 | |
|---|
| 3103 | Iter_Matinv(sig22,n2,n2,NO); |
|---|
| 3104 | |
|---|
| 3105 | sig12_invsig22 = Matrix_Mult(sig12,sig22,n1,n2,n2,n2); |
|---|
| 3106 | |
|---|
| 3107 | buff = Matrix_Mult(sig12_invsig22,ctrd_a,n1,n2,n2,1); |
|---|
| 3108 | For(i,n1) cond_mu_norder[i] = mu1[i]+buff[i]; |
|---|
| 3109 | Free(buff); |
|---|
| 3110 | |
|---|
| 3111 | buff = Matrix_Mult(sig12_invsig22,sig21,n1,n2,n2,n1); |
|---|
| 3112 | For(i,n1) For(j,n1) cond_cov_norder[i*n1+j] = sig11[i*n1+j] - buff[i*n1+j]; |
|---|
| 3113 | Free(buff); |
|---|
| 3114 | |
|---|
| 3115 | nr = 0; |
|---|
| 3116 | For(i,n) if(is_1[i]) { cond_mu[i] = cond_mu_norder[nr]; nr++; } |
|---|
| 3117 | |
|---|
| 3118 | nr = nc = 0; |
|---|
| 3119 | For(i,n) |
|---|
| 3120 | { |
|---|
| 3121 | if(is_1[i]) |
|---|
| 3122 | { |
|---|
| 3123 | nc = 0; |
|---|
| 3124 | For(j,n) |
|---|
| 3125 | { |
|---|
| 3126 | if(is_1[j]) |
|---|
| 3127 | { |
|---|
| 3128 | cond_cov[i*n+j] = cond_cov_norder[nr*n1+nc]; |
|---|
| 3129 | nc++; |
|---|
| 3130 | } |
|---|
| 3131 | } |
|---|
| 3132 | nr++; |
|---|
| 3133 | } |
|---|
| 3134 | } |
|---|
| 3135 | |
|---|
| 3136 | /* For(i,n1) */ |
|---|
| 3137 | /* { */ |
|---|
| 3138 | /* for(j=i;j<n1;j++) */ |
|---|
| 3139 | /* if(FABS(cond_cov_norder[i*n1+j] - cond_cov_norder[j*n1+i]) > 1.E-3) */ |
|---|
| 3140 | /* { */ |
|---|
| 3141 | /* PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); */ |
|---|
| 3142 | /* Warn_And_Exit(""); */ |
|---|
| 3143 | /* } */ |
|---|
| 3144 | /* } */ |
|---|
| 3145 | |
|---|
| 3146 | |
|---|
| 3147 | For(i,n) |
|---|
| 3148 | { |
|---|
| 3149 | for(j=i+1;j<n;j++) |
|---|
| 3150 | if(FABS(cond_cov[i*n+j] - cond_cov[j*n+i]) > 1.E-3) |
|---|
| 3151 | { |
|---|
| 3152 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3153 | Warn_And_Exit(""); |
|---|
| 3154 | } |
|---|
| 3155 | } |
|---|
| 3156 | |
|---|
| 3157 | Free(mu1); |
|---|
| 3158 | Free(mu2); |
|---|
| 3159 | Free(sig11); |
|---|
| 3160 | Free(sig12); |
|---|
| 3161 | Free(sig21); |
|---|
| 3162 | Free(sig22); |
|---|
| 3163 | Free(ctrd_a); |
|---|
| 3164 | Free(cond_cov_norder); |
|---|
| 3165 | Free(cond_mu_norder); |
|---|
| 3166 | Free(sig12_invsig22); |
|---|
| 3167 | Free(buff_mat); |
|---|
| 3168 | } |
|---|
| 3169 | |
|---|
| 3170 | |
|---|
| 3171 | ////////////////////////////////////////////////////////////// |
|---|
| 3172 | ////////////////////////////////////////////////////////////// |
|---|
| 3173 | |
|---|
| 3174 | |
|---|
| 3175 | /* http://en.wikipedia.org/wiki/Multivariate_normal_distribution (Conditional distributions) */ |
|---|
| 3176 | void Normal_Conditional_Unsorted(phydbl *mu, phydbl *cov, phydbl *a, int n, short int *is_1, int n1, phydbl *cond_mu, phydbl *cond_cov) |
|---|
| 3177 | { |
|---|
| 3178 | phydbl *mu1,*mu2; |
|---|
| 3179 | phydbl *sig11,*sig12,*sig21,*sig22,*sig12_invsig22,*buff; |
|---|
| 3180 | phydbl *ctrd_a; |
|---|
| 3181 | int n2; |
|---|
| 3182 | int i,j,nr,nc; |
|---|
| 3183 | |
|---|
| 3184 | n2 = n-n1; |
|---|
| 3185 | |
|---|
| 3186 | mu1 = (phydbl *)mCalloc(n1, sizeof(phydbl)); |
|---|
| 3187 | mu2 = (phydbl *)mCalloc(n2, sizeof(phydbl)); |
|---|
| 3188 | sig11 = (phydbl *)mCalloc(n1*n1,sizeof(phydbl)); |
|---|
| 3189 | sig12 = (phydbl *)mCalloc(n1*n2,sizeof(phydbl)); |
|---|
| 3190 | sig21 = (phydbl *)mCalloc(n2*n1,sizeof(phydbl)); |
|---|
| 3191 | sig22 = (phydbl *)mCalloc(n2*n2,sizeof(phydbl)); |
|---|
| 3192 | ctrd_a = (phydbl *)mCalloc(n2, sizeof(phydbl)); |
|---|
| 3193 | |
|---|
| 3194 | nr=0; |
|---|
| 3195 | For(i,n) { if(!is_1[i]) { ctrd_a[nr] = a[i]-mu[i]; nr++; } } |
|---|
| 3196 | |
|---|
| 3197 | nr=0; |
|---|
| 3198 | For(i,n) { if( is_1[i]) { mu1[nr] = mu[i]; nr++; } } |
|---|
| 3199 | |
|---|
| 3200 | nr=0; |
|---|
| 3201 | For(i,n) { if(!is_1[i]) { mu2[nr] = mu[i]; nr++; } } |
|---|
| 3202 | |
|---|
| 3203 | nr=0; nc=0; |
|---|
| 3204 | For(i,n) |
|---|
| 3205 | { |
|---|
| 3206 | if(is_1[i]) |
|---|
| 3207 | { |
|---|
| 3208 | nc = nr; |
|---|
| 3209 | for(j=i;j<n;j++) |
|---|
| 3210 | /* nc = 0; */ |
|---|
| 3211 | /* For(j,n) */ |
|---|
| 3212 | { |
|---|
| 3213 | if(is_1[j]) |
|---|
| 3214 | { |
|---|
| 3215 | sig11[nr*n1+nc] = cov[i*n+j]; |
|---|
| 3216 | sig11[nc*n1+nr] = cov[i*n+j]; |
|---|
| 3217 | nc++; |
|---|
| 3218 | } |
|---|
| 3219 | } |
|---|
| 3220 | nr++; |
|---|
| 3221 | } |
|---|
| 3222 | } |
|---|
| 3223 | |
|---|
| 3224 | |
|---|
| 3225 | nr=0; nc=0; |
|---|
| 3226 | For(i,n) |
|---|
| 3227 | { |
|---|
| 3228 | if(is_1[i]) |
|---|
| 3229 | { |
|---|
| 3230 | /* nc = nr; */ |
|---|
| 3231 | /* for(j=i;j<n;j++) */ |
|---|
| 3232 | nc = 0; |
|---|
| 3233 | For(j,n) |
|---|
| 3234 | { |
|---|
| 3235 | if(!is_1[j]) |
|---|
| 3236 | { |
|---|
| 3237 | sig12[nr*n2+nc] = cov[i*n+j]; |
|---|
| 3238 | /* sig12[nc*n2+nr] = cov[i*n+j]; */ |
|---|
| 3239 | nc++; |
|---|
| 3240 | } |
|---|
| 3241 | } |
|---|
| 3242 | nr++; |
|---|
| 3243 | } |
|---|
| 3244 | } |
|---|
| 3245 | |
|---|
| 3246 | nr=0; nc=0; |
|---|
| 3247 | For(i,n) |
|---|
| 3248 | { |
|---|
| 3249 | if(!is_1[i]) |
|---|
| 3250 | { |
|---|
| 3251 | /* nc = nr; */ |
|---|
| 3252 | /* for(j=i;j<n;j++) */ |
|---|
| 3253 | nc = 0; |
|---|
| 3254 | For(j,n) |
|---|
| 3255 | { |
|---|
| 3256 | if(is_1[j]) |
|---|
| 3257 | { |
|---|
| 3258 | sig21[nr*n1+nc] = cov[i*n+j]; |
|---|
| 3259 | /* sig21[nc*n1+nr] = cov[i*n+j]; */ |
|---|
| 3260 | nc++; |
|---|
| 3261 | } |
|---|
| 3262 | } |
|---|
| 3263 | nr++; |
|---|
| 3264 | } |
|---|
| 3265 | } |
|---|
| 3266 | |
|---|
| 3267 | |
|---|
| 3268 | nr=0; nc=0; |
|---|
| 3269 | For(i,n) |
|---|
| 3270 | { |
|---|
| 3271 | if(!is_1[i]) |
|---|
| 3272 | { |
|---|
| 3273 | nc = nr; |
|---|
| 3274 | for(j=i;j<n;j++) |
|---|
| 3275 | /* nc = 0; */ |
|---|
| 3276 | /* For(j,n) */ |
|---|
| 3277 | { |
|---|
| 3278 | if(!is_1[j]) |
|---|
| 3279 | { |
|---|
| 3280 | sig22[nr*n2+nc] = cov[i*n+j]; |
|---|
| 3281 | sig22[nc*n2+nr] = cov[i*n+j]; |
|---|
| 3282 | nc++; |
|---|
| 3283 | } |
|---|
| 3284 | } |
|---|
| 3285 | nr++; |
|---|
| 3286 | } |
|---|
| 3287 | } |
|---|
| 3288 | |
|---|
| 3289 | if(!Matinv(sig22,n2,n2,NO)) |
|---|
| 3290 | { |
|---|
| 3291 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3292 | Exit("\n"); |
|---|
| 3293 | } |
|---|
| 3294 | sig12_invsig22 = Matrix_Mult(sig12,sig22,n1,n2,n2,n2); |
|---|
| 3295 | |
|---|
| 3296 | buff = Matrix_Mult(sig12_invsig22,ctrd_a,n1,n2,n2,1); |
|---|
| 3297 | For(i,n1) cond_mu[i] = mu1[i]+buff[i]; |
|---|
| 3298 | Free(buff); |
|---|
| 3299 | |
|---|
| 3300 | buff = Matrix_Mult(sig12_invsig22,sig21,n1,n2,n2,n1); |
|---|
| 3301 | For(i,n1) For(j,n1) cond_cov[i*n1+j] = sig11[i*n1+j] - buff[i*n1+j]; |
|---|
| 3302 | |
|---|
| 3303 | |
|---|
| 3304 | Free(mu1); |
|---|
| 3305 | Free(mu2); |
|---|
| 3306 | Free(sig11); |
|---|
| 3307 | Free(sig12); |
|---|
| 3308 | Free(sig21); |
|---|
| 3309 | Free(sig22); |
|---|
| 3310 | Free(ctrd_a); |
|---|
| 3311 | Free(sig12_invsig22); |
|---|
| 3312 | } |
|---|
| 3313 | |
|---|
| 3314 | |
|---|
| 3315 | ////////////////////////////////////////////////////////////// |
|---|
| 3316 | ////////////////////////////////////////////////////////////// |
|---|
| 3317 | |
|---|
| 3318 | |
|---|
| 3319 | /* http://en.wikipedia.org/wiki/Multivariate_normal_distribution (Conditional distributions) */ |
|---|
| 3320 | void Get_Reg_Coeff(phydbl *mu, phydbl *cov, phydbl *a, int n, short int *is_1, int n1, phydbl *reg_coeff) |
|---|
| 3321 | { |
|---|
| 3322 | phydbl *sig12,*sig22,*sig12_invsig22; |
|---|
| 3323 | int n2; |
|---|
| 3324 | int i,j,nr,nc; |
|---|
| 3325 | |
|---|
| 3326 | n2 = n-n1; |
|---|
| 3327 | |
|---|
| 3328 | sig12 = (phydbl *)mCalloc(n1*n2,sizeof(phydbl)); |
|---|
| 3329 | sig22 = (phydbl *)mCalloc(n2*n2,sizeof(phydbl)); |
|---|
| 3330 | |
|---|
| 3331 | nr=0; nc=0; |
|---|
| 3332 | For(i,n) |
|---|
| 3333 | { |
|---|
| 3334 | if(is_1[i]) |
|---|
| 3335 | { |
|---|
| 3336 | nc = 0; |
|---|
| 3337 | For(j,n) |
|---|
| 3338 | { |
|---|
| 3339 | if(!is_1[j]) |
|---|
| 3340 | { |
|---|
| 3341 | sig12[nr*n2+nc] = cov[i*n+j]; |
|---|
| 3342 | nc++; |
|---|
| 3343 | } |
|---|
| 3344 | } |
|---|
| 3345 | nr++; |
|---|
| 3346 | } |
|---|
| 3347 | } |
|---|
| 3348 | |
|---|
| 3349 | |
|---|
| 3350 | nr=0; nc=0; |
|---|
| 3351 | For(i,n) |
|---|
| 3352 | { |
|---|
| 3353 | if(!is_1[i]) |
|---|
| 3354 | { |
|---|
| 3355 | nc = nr; |
|---|
| 3356 | for(j=i;j<n;j++) |
|---|
| 3357 | { |
|---|
| 3358 | if(!is_1[j]) |
|---|
| 3359 | { |
|---|
| 3360 | sig22[nr*n2+nc] = cov[i*n+j]; |
|---|
| 3361 | sig22[nc*n2+nr] = cov[i*n+j]; |
|---|
| 3362 | nc++; |
|---|
| 3363 | } |
|---|
| 3364 | } |
|---|
| 3365 | nr++; |
|---|
| 3366 | } |
|---|
| 3367 | } |
|---|
| 3368 | |
|---|
| 3369 | |
|---|
| 3370 | if(!Matinv(sig22,n2,n2,NO)) |
|---|
| 3371 | { |
|---|
| 3372 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3373 | Exit("\n"); |
|---|
| 3374 | } |
|---|
| 3375 | sig12_invsig22 = Matrix_Mult(sig12,sig22,n1,n2,n2,n2); |
|---|
| 3376 | |
|---|
| 3377 | |
|---|
| 3378 | For(i,n) reg_coeff[i] = 0.0; |
|---|
| 3379 | |
|---|
| 3380 | /* nr = 0; */ |
|---|
| 3381 | /* For(i,n) if(!is_1[i]) { reg_coeff[i] = sig12_invsig22[nr]; nr++; } */ |
|---|
| 3382 | |
|---|
| 3383 | nc = 0; |
|---|
| 3384 | nr = 0; |
|---|
| 3385 | For(i,n1) |
|---|
| 3386 | { |
|---|
| 3387 | nc = 0; |
|---|
| 3388 | For(j,n) |
|---|
| 3389 | if(!is_1[j]) |
|---|
| 3390 | { |
|---|
| 3391 | reg_coeff[i*n+j] = sig12_invsig22[nr*n2+nc]; |
|---|
| 3392 | nc++; |
|---|
| 3393 | } |
|---|
| 3394 | nr++; |
|---|
| 3395 | } |
|---|
| 3396 | |
|---|
| 3397 | |
|---|
| 3398 | if(nc != n2 || nr != n1) |
|---|
| 3399 | { |
|---|
| 3400 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3401 | Exit("\n"); |
|---|
| 3402 | } |
|---|
| 3403 | |
|---|
| 3404 | |
|---|
| 3405 | Free(sig12); |
|---|
| 3406 | Free(sig22); |
|---|
| 3407 | Free(sig12_invsig22); |
|---|
| 3408 | } |
|---|
| 3409 | |
|---|
| 3410 | |
|---|
| 3411 | ////////////////////////////////////////////////////////////// |
|---|
| 3412 | ////////////////////////////////////////////////////////////// |
|---|
| 3413 | |
|---|
| 3414 | |
|---|
| 3415 | phydbl Norm_Trunc_Sd(phydbl mu, phydbl sd, phydbl a, phydbl b) |
|---|
| 3416 | { |
|---|
| 3417 | phydbl pdfa, pdfb; |
|---|
| 3418 | phydbl cdfa, cdfb; |
|---|
| 3419 | phydbl ctra, ctrb; |
|---|
| 3420 | phydbl cond_var; |
|---|
| 3421 | phydbl cdfbmcdfa; |
|---|
| 3422 | |
|---|
| 3423 | ctra = (a - mu)/sd; |
|---|
| 3424 | ctrb = (b - mu)/sd; |
|---|
| 3425 | |
|---|
| 3426 | pdfa = Dnorm(ctra,0.0,1.0); |
|---|
| 3427 | pdfb = Dnorm(ctrb,0.0,1.0); |
|---|
| 3428 | |
|---|
| 3429 | cdfa = Pnorm(ctra,0.0,1.0); |
|---|
| 3430 | cdfb = Pnorm(ctrb,0.0,1.0); |
|---|
| 3431 | |
|---|
| 3432 | cdfbmcdfa = cdfb - cdfa; |
|---|
| 3433 | |
|---|
| 3434 | if(cdfbmcdfa < SMALL) |
|---|
| 3435 | { |
|---|
| 3436 | cdfbmcdfa = SMALL; |
|---|
| 3437 | PhyML_Printf("\n. mu=%G sd=%G a=%G b=%G",mu,sd,a,b); |
|---|
| 3438 | PhyML_Printf("\n. Numerical precision issue detected."); |
|---|
| 3439 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3440 | } |
|---|
| 3441 | |
|---|
| 3442 | cond_var = sd*sd*(1. + (ctra*pdfa - ctrb*pdfb)/cdfbmcdfa - POW((pdfa - pdfb)/cdfbmcdfa,2)); |
|---|
| 3443 | |
|---|
| 3444 | return SQRT(cond_var); |
|---|
| 3445 | } |
|---|
| 3446 | |
|---|
| 3447 | ////////////////////////////////////////////////////////////// |
|---|
| 3448 | ////////////////////////////////////////////////////////////// |
|---|
| 3449 | |
|---|
| 3450 | |
|---|
| 3451 | phydbl Norm_Trunc_Mean(phydbl mu, phydbl sd, phydbl a, phydbl b) |
|---|
| 3452 | { |
|---|
| 3453 | phydbl pdfa, pdfb; |
|---|
| 3454 | phydbl cdfa, cdfb; |
|---|
| 3455 | phydbl ctra, ctrb; |
|---|
| 3456 | phydbl cond_mu; |
|---|
| 3457 | phydbl cdfbmcdfa; |
|---|
| 3458 | |
|---|
| 3459 | ctra = (a - mu)/sd; |
|---|
| 3460 | ctrb = (b - mu)/sd; |
|---|
| 3461 | |
|---|
| 3462 | pdfa = Dnorm(ctra,0.0,1.0); |
|---|
| 3463 | pdfb = Dnorm(ctrb,0.0,1.0); |
|---|
| 3464 | |
|---|
| 3465 | cdfa = Pnorm(ctra,0.0,1.0); |
|---|
| 3466 | cdfb = Pnorm(ctrb,0.0,1.0); |
|---|
| 3467 | |
|---|
| 3468 | cdfbmcdfa = cdfb - cdfa; |
|---|
| 3469 | |
|---|
| 3470 | if(cdfbmcdfa < SMALL) |
|---|
| 3471 | { |
|---|
| 3472 | cdfbmcdfa = SMALL; |
|---|
| 3473 | PhyML_Printf("\n. mu=%G sd=%G a=%G b=%G",mu,sd,a,b); |
|---|
| 3474 | PhyML_Printf("\n. Numerical precision issue detected."); |
|---|
| 3475 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3476 | } |
|---|
| 3477 | |
|---|
| 3478 | cond_mu = mu + sd*(pdfa - pdfb)/cdfbmcdfa; |
|---|
| 3479 | |
|---|
| 3480 | return cond_mu; |
|---|
| 3481 | } |
|---|
| 3482 | |
|---|
| 3483 | ////////////////////////////////////////////////////////////// |
|---|
| 3484 | ////////////////////////////////////////////////////////////// |
|---|
| 3485 | |
|---|
| 3486 | |
|---|
| 3487 | int Norm_Trunc_Mean_Sd(phydbl mu, phydbl sd, phydbl a, phydbl b, phydbl *trunc_mu, phydbl *trunc_sd) |
|---|
| 3488 | { |
|---|
| 3489 | |
|---|
| 3490 | phydbl pdfa, pdfb; |
|---|
| 3491 | phydbl cdfa, cdfb; |
|---|
| 3492 | phydbl ctra, ctrb; |
|---|
| 3493 | phydbl cdfbmcdfa; |
|---|
| 3494 | |
|---|
| 3495 | ctra = (a - mu)/sd; |
|---|
| 3496 | ctrb = (b - mu)/sd; |
|---|
| 3497 | |
|---|
| 3498 | pdfa = Dnorm(ctra,0.0,1.0); |
|---|
| 3499 | pdfb = Dnorm(ctrb,0.0,1.0); |
|---|
| 3500 | |
|---|
| 3501 | cdfa = Pnorm(ctra,0.0,1.0); |
|---|
| 3502 | cdfb = Pnorm(ctrb,0.0,1.0); |
|---|
| 3503 | |
|---|
| 3504 | cdfbmcdfa = cdfb - cdfa; |
|---|
| 3505 | |
|---|
| 3506 | if(cdfbmcdfa < SMALL) |
|---|
| 3507 | { |
|---|
| 3508 | cdfbmcdfa = SMALL; |
|---|
| 3509 | PhyML_Printf("\n. mu=%G sd=%G a=%G b=%G",mu,sd,a,b); |
|---|
| 3510 | PhyML_Printf("\n. cdfa=%G cdfb=%G",cdfa,cdfb); |
|---|
| 3511 | PhyML_Printf("\n. Numerical precision issue detected."); |
|---|
| 3512 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3513 | return 0; |
|---|
| 3514 | } |
|---|
| 3515 | |
|---|
| 3516 | *trunc_mu = mu + sd*(pdfa - pdfb)/cdfbmcdfa; |
|---|
| 3517 | *trunc_sd = sd*sd*(1. + (ctra*pdfa - ctrb*pdfb)/cdfbmcdfa - POW((pdfa - pdfb)/cdfbmcdfa,2)); |
|---|
| 3518 | *trunc_sd = SQRT(*trunc_sd); |
|---|
| 3519 | return 1; |
|---|
| 3520 | } |
|---|
| 3521 | |
|---|
| 3522 | ////////////////////////////////////////////////////////////// |
|---|
| 3523 | ////////////////////////////////////////////////////////////// |
|---|
| 3524 | |
|---|
| 3525 | |
|---|
| 3526 | void VarCov_Approx_Likelihood(t_tree *tree) |
|---|
| 3527 | { |
|---|
| 3528 | int i,j; |
|---|
| 3529 | phydbl *cov; |
|---|
| 3530 | phydbl *mean; |
|---|
| 3531 | int dim; |
|---|
| 3532 | int iter; |
|---|
| 3533 | phydbl cur_mean,new_mean,diff_mean,max_diff_mean; |
|---|
| 3534 | phydbl cur_cov,new_cov,diff_cov,max_diff_cov; |
|---|
| 3535 | FILE *fp; |
|---|
| 3536 | |
|---|
| 3537 | |
|---|
| 3538 | cov = tree->rates->cov_l; |
|---|
| 3539 | mean = tree->rates->mean_l; |
|---|
| 3540 | dim = 2*tree->n_otu-3; |
|---|
| 3541 | |
|---|
| 3542 | fp = fopen("covariance","w"); |
|---|
| 3543 | fprintf(fp,"\n"); |
|---|
| 3544 | fprintf(fp,"Run\t"); |
|---|
| 3545 | fprintf(fp,"lnL\t"); |
|---|
| 3546 | For(i,dim) fprintf(fp,"Edge%d[%f]\t",i,tree->rates->u_ml_l[i]); |
|---|
| 3547 | |
|---|
| 3548 | |
|---|
| 3549 | For(i,dim) mean[i] = .0; |
|---|
| 3550 | For(i,dim*dim) cov[i] = .0; |
|---|
| 3551 | |
|---|
| 3552 | MCMC_Randomize_Branch_Lengths(tree); |
|---|
| 3553 | |
|---|
| 3554 | /* For(i,2*tree->n_otu-3) tree->a_edges[i]->l->v *= Rgamma(5.,1./5.); */ |
|---|
| 3555 | |
|---|
| 3556 | Set_Both_Sides(YES,tree); |
|---|
| 3557 | Lk(NULL,tree); |
|---|
| 3558 | |
|---|
| 3559 | iter = 0; |
|---|
| 3560 | do |
|---|
| 3561 | { |
|---|
| 3562 | /* tree->both_sides = YES; */ |
|---|
| 3563 | /* Lk(tree); */ |
|---|
| 3564 | MCMC_Br_Lens(tree); |
|---|
| 3565 | /* MCMC_Scale_Br_Lens(tree); */ |
|---|
| 3566 | |
|---|
| 3567 | |
|---|
| 3568 | max_diff_mean = 0.0; |
|---|
| 3569 | For(i,dim) |
|---|
| 3570 | { |
|---|
| 3571 | cur_mean = mean[i]; |
|---|
| 3572 | |
|---|
| 3573 | mean[i] *= (phydbl)iter; |
|---|
| 3574 | mean[i] += tree->a_edges[i]->l->v; |
|---|
| 3575 | mean[i] /= (phydbl)(iter+1); |
|---|
| 3576 | |
|---|
| 3577 | new_mean = mean[i]; |
|---|
| 3578 | diff_mean = MAX(cur_mean,new_mean)/MIN(cur_mean,new_mean); |
|---|
| 3579 | if(diff_mean > max_diff_mean) max_diff_mean = diff_mean; |
|---|
| 3580 | /* printf("\n. %d diff_mean = %f %f %f %f",i,diff_mean,cur_mean,new_mean,tree->a_edges[i]->l->v); */ |
|---|
| 3581 | } |
|---|
| 3582 | |
|---|
| 3583 | max_diff_cov = 0.0; |
|---|
| 3584 | For(i,dim) |
|---|
| 3585 | { |
|---|
| 3586 | For(j,dim) |
|---|
| 3587 | { |
|---|
| 3588 | cur_cov = cov[i*dim+j]; |
|---|
| 3589 | |
|---|
| 3590 | cov[i*dim+j] *= (phydbl)iter; |
|---|
| 3591 | cov[i*dim+j] += tree->a_edges[i]->l->v * tree->a_edges[j]->l->v; |
|---|
| 3592 | cov[i*dim+j] /= (phydbl)(iter+1); |
|---|
| 3593 | |
|---|
| 3594 | new_cov = cov[i*dim+j]; |
|---|
| 3595 | diff_cov = MAX(cur_cov,new_cov)/MIN(cur_cov,new_cov); |
|---|
| 3596 | if(diff_cov > max_diff_cov) max_diff_cov = diff_cov; |
|---|
| 3597 | } |
|---|
| 3598 | } |
|---|
| 3599 | iter++; |
|---|
| 3600 | |
|---|
| 3601 | /* if(!(iter%10)) */ |
|---|
| 3602 | /* printf("\n. iter=%d max_diff_mean=%f max_diff_cov=%f",iter,max_diff_mean,max_diff_cov); */ |
|---|
| 3603 | |
|---|
| 3604 | /* if(iter && max_diff_mean < 1.01 && max_diff_cov < 1.01) break; */ |
|---|
| 3605 | |
|---|
| 3606 | if(!(iter%20)) |
|---|
| 3607 | { |
|---|
| 3608 | fprintf(fp,"\n"); |
|---|
| 3609 | fprintf(fp,"%d\t",iter); |
|---|
| 3610 | fprintf(fp,"%f\t",tree->c_lnL); |
|---|
| 3611 | For(i,dim) fprintf(fp,"%f\t",tree->a_edges[i]->l->v); |
|---|
| 3612 | fflush(NULL); |
|---|
| 3613 | } |
|---|
| 3614 | |
|---|
| 3615 | }while(iter < 5000); |
|---|
| 3616 | |
|---|
| 3617 | |
|---|
| 3618 | For(i,dim) |
|---|
| 3619 | { |
|---|
| 3620 | For(j,dim) |
|---|
| 3621 | { |
|---|
| 3622 | cov[i*dim+j] = cov[i*dim+j] - mean[i]*mean[j]; |
|---|
| 3623 | if(i == j && cov[i*dim+j] < MIN_VAR_BL) cov[i*dim+j] = MIN_VAR_BL; |
|---|
| 3624 | } |
|---|
| 3625 | } |
|---|
| 3626 | |
|---|
| 3627 | fclose(fp); |
|---|
| 3628 | } |
|---|
| 3629 | |
|---|
| 3630 | ////////////////////////////////////////////////////////////// |
|---|
| 3631 | ////////////////////////////////////////////////////////////// |
|---|
| 3632 | |
|---|
| 3633 | |
|---|
| 3634 | /* Order statistic. x_is are uniformily distributed in [min,max] */ |
|---|
| 3635 | phydbl Dorder_Unif(phydbl x, int r, int n, phydbl min, phydbl max) |
|---|
| 3636 | { |
|---|
| 3637 | phydbl cons; |
|---|
| 3638 | phydbl Fx; |
|---|
| 3639 | phydbl dens; |
|---|
| 3640 | |
|---|
| 3641 | if(x < min || x > max || min > max) |
|---|
| 3642 | { |
|---|
| 3643 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3644 | Exit("\n"); |
|---|
| 3645 | } |
|---|
| 3646 | |
|---|
| 3647 | cons = LnGamma(n+1) - LnGamma(r) - LnGamma(n-r+1); |
|---|
| 3648 | cons = EXP(cons); |
|---|
| 3649 | cons = ROUND(cons); |
|---|
| 3650 | |
|---|
| 3651 | Fx = (x-min)/(max-min); |
|---|
| 3652 | |
|---|
| 3653 | dens = cons * pow(Fx,r-1) * pow(1.-Fx,n-r) * (1./(max-min)); |
|---|
| 3654 | |
|---|
| 3655 | /* printf("\n. x=%f r=%d n=%d min=%f max=%f dens=%f",x,r,n,min,max,dens); */ |
|---|
| 3656 | /* Exit("\n"); */ |
|---|
| 3657 | |
|---|
| 3658 | return(dens); |
|---|
| 3659 | } |
|---|
| 3660 | |
|---|
| 3661 | ////////////////////////////////////////////////////////////// |
|---|
| 3662 | ////////////////////////////////////////////////////////////// |
|---|
| 3663 | |
|---|
| 3664 | |
|---|
| 3665 | phydbl Covariance(phydbl *x, phydbl *y, int n) |
|---|
| 3666 | { |
|---|
| 3667 | int i; |
|---|
| 3668 | phydbl mean_x,mean_y,mean_xy; |
|---|
| 3669 | |
|---|
| 3670 | mean_x = .0; |
|---|
| 3671 | For(i,n) mean_x += x[i]; |
|---|
| 3672 | mean_x /= (phydbl)n; |
|---|
| 3673 | |
|---|
| 3674 | mean_y = .0; |
|---|
| 3675 | For(i,n) mean_y += y[i]; |
|---|
| 3676 | mean_y /= (phydbl)n; |
|---|
| 3677 | |
|---|
| 3678 | mean_xy = .0; |
|---|
| 3679 | For(i,n) mean_xy += x[i]*y[i]; |
|---|
| 3680 | mean_xy /= (phydbl)n; |
|---|
| 3681 | |
|---|
| 3682 | return (mean_xy - mean_x*mean_y); |
|---|
| 3683 | } |
|---|
| 3684 | |
|---|
| 3685 | ////////////////////////////////////////////////////////////// |
|---|
| 3686 | ////////////////////////////////////////////////////////////// |
|---|
| 3687 | |
|---|
| 3688 | /* Sample X from a multivariate normal with mean mu and covariance cov, within |
|---|
| 3689 | the interval [min,max], under the linear constraint X.lambda=k |
|---|
| 3690 | */ |
|---|
| 3691 | |
|---|
| 3692 | phydbl *Rnorm_Multid_Trunc_Constraint(phydbl *mu, phydbl *cov, phydbl *min, phydbl *max, phydbl *lambda, phydbl k, phydbl *res, int len) |
|---|
| 3693 | { |
|---|
| 3694 | |
|---|
| 3695 | phydbl *loc_res; |
|---|
| 3696 | int i,j,cond,iter; |
|---|
| 3697 | phydbl *x; |
|---|
| 3698 | phydbl cond_mean,cond_var; |
|---|
| 3699 | phydbl cov_zic,cov_zii,cov_zcc; |
|---|
| 3700 | phydbl mean_zi, mean_zc; |
|---|
| 3701 | phydbl alpha; |
|---|
| 3702 | phydbl sum; |
|---|
| 3703 | int err; |
|---|
| 3704 | phydbl zi; |
|---|
| 3705 | |
|---|
| 3706 | |
|---|
| 3707 | cond = 0; |
|---|
| 3708 | |
|---|
| 3709 | loc_res = NULL; |
|---|
| 3710 | if(!res) |
|---|
| 3711 | { |
|---|
| 3712 | loc_res = (phydbl *)mCalloc(len,sizeof(phydbl)); |
|---|
| 3713 | x = loc_res; |
|---|
| 3714 | } |
|---|
| 3715 | else x = res; |
|---|
| 3716 | |
|---|
| 3717 | |
|---|
| 3718 | |
|---|
| 3719 | /* zi = x[i] . lambda[i] */ |
|---|
| 3720 | |
|---|
| 3721 | iter = 0; |
|---|
| 3722 | do |
|---|
| 3723 | { |
|---|
| 3724 | sum = 0.0; |
|---|
| 3725 | For(i,len) |
|---|
| 3726 | { |
|---|
| 3727 | if(i != cond) |
|---|
| 3728 | { |
|---|
| 3729 | cov_zic = lambda[i] * lambda[cond] * cov[i*len+cond]; |
|---|
| 3730 | cov_zii = lambda[i] * lambda[i] * cov[i*len+i]; |
|---|
| 3731 | cov_zcc = lambda[cond] * lambda[cond] * cov[cond*len+cond]; |
|---|
| 3732 | |
|---|
| 3733 | mean_zi = lambda[i]; |
|---|
| 3734 | mean_zc = lambda[cond]; |
|---|
| 3735 | |
|---|
| 3736 | /* alpha = k - \sum_{j != cond, j !=i} z_j */ |
|---|
| 3737 | alpha = k; |
|---|
| 3738 | For(j,len) if(j != cond && j != i) alpha -= lambda[j] * x[j]; |
|---|
| 3739 | |
|---|
| 3740 | cond_mean = mean_zi + (cov_zii + cov_zic) / (cov_zii + 2.*cov_zic + cov_zcc) * (alpha - mean_zi - mean_zc); |
|---|
| 3741 | cond_var = cov_zii - POW(cov_zii + cov_zic,2)/(cov_zii + 2.*cov_zic + cov_zcc); |
|---|
| 3742 | |
|---|
| 3743 | if(lambda[i]*min[i] > alpha - lambda[cond]*min[i]) |
|---|
| 3744 | { |
|---|
| 3745 | PhyML_Printf("\n. Cannot satisfy the constraint.\n"); |
|---|
| 3746 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3747 | Exit("\n"); |
|---|
| 3748 | } |
|---|
| 3749 | |
|---|
| 3750 | err = NO; |
|---|
| 3751 | zi = Rnorm_Trunc(cond_mean,SQRT(cond_var), |
|---|
| 3752 | MAX(lambda[i]*min[i],alpha-lambda[cond]*max[cond]), |
|---|
| 3753 | MIN(lambda[i]*max[i],alpha-lambda[cond]*min[cond]),&err); |
|---|
| 3754 | if(err == YES) |
|---|
| 3755 | { |
|---|
| 3756 | PhyML_Printf("\n. Err in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 3757 | Exit("\n"); |
|---|
| 3758 | } |
|---|
| 3759 | sum += zi; |
|---|
| 3760 | x[i] = zi / lambda[i]; |
|---|
| 3761 | } |
|---|
| 3762 | } |
|---|
| 3763 | |
|---|
| 3764 | x[cond] = (k - sum)/lambda[cond]; |
|---|
| 3765 | |
|---|
| 3766 | }while(iter++ < 10); |
|---|
| 3767 | |
|---|
| 3768 | return(loc_res); |
|---|
| 3769 | |
|---|
| 3770 | } |
|---|
| 3771 | |
|---|
| 3772 | ////////////////////////////////////////////////////////////// |
|---|
| 3773 | ////////////////////////////////////////////////////////////// |
|---|
| 3774 | |
|---|
| 3775 | |
|---|
| 3776 | void PMat_MGF_Gamma(phydbl *Pij, phydbl shape, phydbl scale, phydbl scaling_fact, t_mod *mod) |
|---|
| 3777 | { |
|---|
| 3778 | int dim; |
|---|
| 3779 | int i,j,k; |
|---|
| 3780 | phydbl *uexpt,*imbd; |
|---|
| 3781 | |
|---|
| 3782 | dim = mod->eigen->size; |
|---|
| 3783 | uexpt = mod->eigen->r_e_vect_im; |
|---|
| 3784 | imbd = mod->eigen->e_val_im; |
|---|
| 3785 | |
|---|
| 3786 | /* Get the eigenvalues of Q (not the exponentials) */ |
|---|
| 3787 | For(i,dim) imbd[i] = LOG(mod->eigen->e_val[i]); |
|---|
| 3788 | |
|---|
| 3789 | /* Multiply them by the scaling factor */ |
|---|
| 3790 | For(i,dim) imbd[i] *= scaling_fact; |
|---|
| 3791 | |
|---|
| 3792 | For(i,dim) imbd[i] *= -scale; |
|---|
| 3793 | For(i,dim) imbd[i] += 1.0; |
|---|
| 3794 | For(i,dim) imbd[i] = POW(imbd[i],-shape); |
|---|
| 3795 | |
|---|
| 3796 | For(i,dim) For(k,dim) uexpt[i*dim+k] = mod->eigen->r_e_vect[i*dim+k] * imbd[k]; |
|---|
| 3797 | |
|---|
| 3798 | For(i,dim) For(k,dim) Pij[dim*i+k] = .0; |
|---|
| 3799 | |
|---|
| 3800 | For(i,dim) |
|---|
| 3801 | { |
|---|
| 3802 | For(j,dim) |
|---|
| 3803 | { |
|---|
| 3804 | For(k,dim) |
|---|
| 3805 | { |
|---|
| 3806 | Pij[dim*i+j] += (uexpt[i*dim+k] * mod->eigen->l_e_vect[k*dim+j]); |
|---|
| 3807 | } |
|---|
| 3808 | if(Pij[dim*i+j] < SMALL_PIJ) Pij[dim*i+j] = SMALL_PIJ; |
|---|
| 3809 | } |
|---|
| 3810 | } |
|---|
| 3811 | |
|---|
| 3812 | /* printf("\n. shape = %f scale = %f",shape,scale); */ |
|---|
| 3813 | /* printf("\n. Qmat"); */ |
|---|
| 3814 | /* For(i,dim) */ |
|---|
| 3815 | /* { */ |
|---|
| 3816 | /* printf("\n"); */ |
|---|
| 3817 | /* For(j,dim) */ |
|---|
| 3818 | /* { */ |
|---|
| 3819 | /* printf("%12f ",mod->qmat[i*dim+j]); */ |
|---|
| 3820 | /* } */ |
|---|
| 3821 | /* } */ |
|---|
| 3822 | |
|---|
| 3823 | /* printf("\n. Pmat"); */ |
|---|
| 3824 | /* For(i,dim) */ |
|---|
| 3825 | /* { */ |
|---|
| 3826 | /* printf("\n"); */ |
|---|
| 3827 | /* For(j,dim) */ |
|---|
| 3828 | /* { */ |
|---|
| 3829 | /* printf("%12f ",Pij[i*dim+j]); */ |
|---|
| 3830 | /* } */ |
|---|
| 3831 | /* } */ |
|---|
| 3832 | /* Exit("\n"); */ |
|---|
| 3833 | } |
|---|
| 3834 | |
|---|
| 3835 | ////////////////////////////////////////////////////////////// |
|---|
| 3836 | ////////////////////////////////////////////////////////////// |
|---|
| 3837 | |
|---|
| 3838 | |
|---|
| 3839 | void Integrated_Brownian_Bridge_Moments(phydbl x_beg, phydbl x_end, |
|---|
| 3840 | phydbl y_beg, phydbl y_end, |
|---|
| 3841 | phydbl brownian_var, phydbl *mean, phydbl *var) |
|---|
| 3842 | { |
|---|
| 3843 | /* phydbl *y; */ |
|---|
| 3844 | /* phydbl *y_mean; */ |
|---|
| 3845 | /* int n_rep; */ |
|---|
| 3846 | int n_breaks; |
|---|
| 3847 | int i; |
|---|
| 3848 | /* int j; */ |
|---|
| 3849 | /* phydbl traj_mean, traj_sd; */ |
|---|
| 3850 | /* phydbl x_prev, x_curr; */ |
|---|
| 3851 | phydbl x; |
|---|
| 3852 | phydbl x_step; |
|---|
| 3853 | phydbl sum; |
|---|
| 3854 | /* phydbl sumsum; */ |
|---|
| 3855 | phydbl scaled_var; |
|---|
| 3856 | |
|---|
| 3857 | scaled_var = brownian_var/FABS(x_end - x_beg); |
|---|
| 3858 | |
|---|
| 3859 | n_breaks = 100; |
|---|
| 3860 | |
|---|
| 3861 | |
|---|
| 3862 | /* n_rep = 500; */ |
|---|
| 3863 | |
|---|
| 3864 | /* x_step = (x_end - x_beg)/(n_breaks+1); */ |
|---|
| 3865 | |
|---|
| 3866 | /* y = (phydbl *)mCalloc(n_breaks+2,sizeof(phydbl)); */ |
|---|
| 3867 | /* y_mean = (phydbl *)mCalloc(n_rep,sizeof(phydbl)); */ |
|---|
| 3868 | |
|---|
| 3869 | /* y[0] = y_beg; */ |
|---|
| 3870 | /* y[n_breaks+1] = y_end; */ |
|---|
| 3871 | |
|---|
| 3872 | /* For(i,n_rep) */ |
|---|
| 3873 | /* { */ |
|---|
| 3874 | /* for(j=1;j<n_breaks+1;j++) */ |
|---|
| 3875 | /* { */ |
|---|
| 3876 | /* x_prev = x_beg + (j-1)*x_step; */ |
|---|
| 3877 | /* x_curr = x_prev + x_step; */ |
|---|
| 3878 | |
|---|
| 3879 | /* traj_mean = y[j-1] + (y_end - y[j-1])*(x_curr - x_prev)/(x_end - x_prev); */ |
|---|
| 3880 | /* traj_sd = SQRT(scaled_var*(x_curr - x_prev)*(x_end - x_curr)/(x_end - x_prev)); */ |
|---|
| 3881 | |
|---|
| 3882 | /* if(isnan(traj_mean) || isnan(traj_sd)) */ |
|---|
| 3883 | /* { */ |
|---|
| 3884 | /* PhyML_Printf("\n. traj_mean=%f traj_sd=%f x_end=%f x_prev=%f x_step=%f [%f %f %f %f %f %f %f] j=%d n_breaks=%d", */ |
|---|
| 3885 | /* traj_mean,traj_sd,x_end,x_prev,x_step, */ |
|---|
| 3886 | /* y[j-1],y_end,y[j-1],x_curr,x_prev,x_end,x_prev,j,n_breaks); */ |
|---|
| 3887 | /* Exit("\n"); */ |
|---|
| 3888 | /* } */ |
|---|
| 3889 | |
|---|
| 3890 | /* y[j] = Rnorm(traj_mean,traj_sd); */ |
|---|
| 3891 | |
|---|
| 3892 | /* if(isnan(y[j]) || isinf(y[j])) */ |
|---|
| 3893 | /* { */ |
|---|
| 3894 | /* printf("\n. mean=%f sd=%f %f j=%d y[j]=%f",traj_sd,traj_mean,Rnorm(traj_mean,traj_sd),j,y[j]); */ |
|---|
| 3895 | /* Exit("\n"); */ |
|---|
| 3896 | /* } */ |
|---|
| 3897 | |
|---|
| 3898 | /* } */ |
|---|
| 3899 | |
|---|
| 3900 | /* sum = 0.0; */ |
|---|
| 3901 | /* For(j,n_breaks+2) sum += FABS(y[j]); */ |
|---|
| 3902 | /* y_mean[i] = sum/(n_breaks+2); */ |
|---|
| 3903 | /* } */ |
|---|
| 3904 | |
|---|
| 3905 | /* sum = sumsum = 0.0; */ |
|---|
| 3906 | /* For(i,n_rep) */ |
|---|
| 3907 | /* { */ |
|---|
| 3908 | /* sum += y_mean[i]; */ |
|---|
| 3909 | /* sumsum += y_mean[i] * y_mean[i]; */ |
|---|
| 3910 | /* } */ |
|---|
| 3911 | |
|---|
| 3912 | /* *mean = sum/n_rep; */ |
|---|
| 3913 | /* *var = sumsum/n_rep - (*mean) * (*mean); */ |
|---|
| 3914 | |
|---|
| 3915 | /* if(isnan(*mean) || isnan(*var)) */ |
|---|
| 3916 | /* { */ |
|---|
| 3917 | /* PhyML_Printf("\n. sum=%f sumsum=%f n_rep=%d",sum,sumsum,n_rep); */ |
|---|
| 3918 | /* Exit("\n"); */ |
|---|
| 3919 | /* } */ |
|---|
| 3920 | |
|---|
| 3921 | /* Free(y); */ |
|---|
| 3922 | /* Free(y_mean); */ |
|---|
| 3923 | |
|---|
| 3924 | /* /\* printf("\n. [%f %f]",*mean,*var); *\/ */ |
|---|
| 3925 | |
|---|
| 3926 | phydbl mux,six; |
|---|
| 3927 | |
|---|
| 3928 | x_step = (x_end - x_beg)/(n_breaks+1); |
|---|
| 3929 | sum = y_beg; |
|---|
| 3930 | for(i=1;i<n_breaks+1;i++) |
|---|
| 3931 | { |
|---|
| 3932 | x = x_beg + i*x_step; |
|---|
| 3933 | |
|---|
| 3934 | mux = y_beg + (y_end - y_beg)*(x - x_beg)/(x_end - x_beg); |
|---|
| 3935 | six = SQRT(scaled_var*(x - x_beg)*(x_end - x)/(x_end - x_beg)); |
|---|
| 3936 | |
|---|
| 3937 | sum += |
|---|
| 3938 | (2.*six)/SQRT(2.*PI)*EXP(-POW(mux,2)/(2.*POW(six,2))) + |
|---|
| 3939 | 2.*mux*Pnorm(mux/six,.0,1.) - mux; |
|---|
| 3940 | } |
|---|
| 3941 | sum += y_end; |
|---|
| 3942 | |
|---|
| 3943 | (*mean) = sum / (n_breaks+2.); |
|---|
| 3944 | (*var) = (1./12.)*scaled_var*(x_end - x_beg); |
|---|
| 3945 | |
|---|
| 3946 | /* printf(" [%f %f] -- x_beg=%f x_end=%f y_beg=%f y_end=%f sd=%f", */ |
|---|
| 3947 | /* (*mean),(*var),x_beg,x_end,y_beg,y_end,brownian_var); */ |
|---|
| 3948 | } |
|---|
| 3949 | |
|---|
| 3950 | |
|---|
| 3951 | ////////////////////////////////////////////////////////////// |
|---|
| 3952 | ////////////////////////////////////////////////////////////// |
|---|
| 3953 | |
|---|
| 3954 | ////////////////////////////////////////////////////////////// |
|---|
| 3955 | ////////////////////////////////////////////////////////////// |
|---|
| 3956 | |
|---|
| 3957 | ////////////////////////////////////////////////////////////// |
|---|
| 3958 | ////////////////////////////////////////////////////////////// |
|---|
| 3959 | |
|---|
| 3960 | |
|---|
| 3961 | /* Let X'(t) = A + (B-A)t/T + X(t) and X(t) = W(t) + t/T * W(T), |
|---|
| 3962 | i.e., X(t) is a Brownian bridge starting at 0 at t=0 and stopping |
|---|
| 3963 | at 0 at t=T. X'(t) starts at X'(t)=A at t=0 and stops at X'(t)=B at |
|---|
| 3964 | t=T. This function calculates the mean and variance of |
|---|
| 3965 | Z(T) = 1/T \int_0^T exp(X'(t)) dt. It uses a 10th order approximation |
|---|
| 3966 | to exp(X) = 1 + X + (1/2!)X^2 + ... (1/10!)X^10 |
|---|
| 3967 | */ |
|---|
| 3968 | |
|---|
| 3969 | void Integrated_Geometric_Brownian_Bridge_Moments(phydbl T, phydbl A, phydbl B, phydbl u, phydbl *mean, phydbl *var) |
|---|
| 3970 | { |
|---|
| 3971 | Integrated_Geometric_Brownian_Bridge_Mean(T,A,B,u,mean); |
|---|
| 3972 | Integrated_Geometric_Brownian_Bridge_Var(T,A,B,u,var); |
|---|
| 3973 | } |
|---|
| 3974 | |
|---|
| 3975 | ////////////////////////////////////////////////////////////// |
|---|
| 3976 | ////////////////////////////////////////////////////////////// |
|---|
| 3977 | |
|---|
| 3978 | /* |
|---|
| 3979 | with(CodeGeneration); C(exp(A)*(int(sum(((B-A)*s/t+(1/2)*u*(t-s)*s/t)^k/factorial(k), k = 0 .. 13), s = 0 .. t))/t, optimize) |
|---|
| 3980 | */ |
|---|
| 3981 | |
|---|
| 3982 | void Integrated_Geometric_Brownian_Bridge_Mean(phydbl T, phydbl A, phydbl B, phydbl u, phydbl *mean) |
|---|
| 3983 | { |
|---|
| 3984 | phydbl t1 = exp(A); |
|---|
| 3985 | phydbl t2 = A * A; |
|---|
| 3986 | phydbl t3 = t2 * t2; |
|---|
| 3987 | phydbl t4 = t3 * t3; |
|---|
| 3988 | phydbl t5 = t4 * t2; |
|---|
| 3989 | phydbl t6 = B * B; |
|---|
| 3990 | phydbl t7 = t6 * B; |
|---|
| 3991 | phydbl t10 = t4 * A; |
|---|
| 3992 | phydbl t11 = t6 * t6; |
|---|
| 3993 | phydbl t14 = t2 * A; |
|---|
| 3994 | phydbl t15 = t4 * t14; |
|---|
| 3995 | phydbl t18 = t11 * B; |
|---|
| 3996 | phydbl t21 = t4 * t3; |
|---|
| 3997 | phydbl t24 = t11 * t11; |
|---|
| 3998 | phydbl t25 = t24 * t7; |
|---|
| 3999 | phydbl t26 = t25 * A; |
|---|
| 4000 | phydbl t28 = t14 * t7; |
|---|
| 4001 | phydbl t30 = t6 * A; |
|---|
| 4002 | phydbl t32 = B * t2; |
|---|
| 4003 | phydbl t34 = t7 * A; |
|---|
| 4004 | phydbl t36 = B * t14; |
|---|
| 4005 | phydbl t38 = t7 * t2; |
|---|
| 4006 | phydbl t40 = t11 * t4; |
|---|
| 4007 | phydbl t42 = B * t10; |
|---|
| 4008 | phydbl t44 = t7 * t10; |
|---|
| 4009 | phydbl t46 = t6 * t5; |
|---|
| 4010 | phydbl t48 = B * t15; |
|---|
| 4011 | phydbl t50 = -0.46994831769600e14 * t5 * t7 + 0.117487079424000e15 * t10 * t11 + 0.12816772300800e14 * t15 * t6 - 0.211476742963200e15 * t4 * t18 - 0.2136128716800e13 * t21 * B + 0.27605355724800e14 * t26 + 0.56844948508508160000e20 * t28 + 0.1790615878018007040000e22 * t30 - 0.1790615878018007040000e22 * t32 + 0.477497567471468544000e21 * t34 + 0.477497567471468544000e21 * t36 - 0.198957319779778560000e21 * t38 - 0.1138720923648000e16 * t40 + 0.3588696244224000e16 * t42 + 0.506098188288000e15 * t44 - 0.151829456486400e15 * t46 + 0.27605355724800e14 * t48; |
|---|
| 4012 | phydbl t51 = u * u; |
|---|
| 4013 | phydbl t52 = t51 * t51; |
|---|
| 4014 | phydbl t53 = t52 * t52; |
|---|
| 4015 | phydbl t54 = t53 * t52; |
|---|
| 4016 | phydbl t55 = T * T; |
|---|
| 4017 | phydbl t56 = t55 * t55; |
|---|
| 4018 | phydbl t57 = t56 * t56; |
|---|
| 4019 | phydbl t58 = t57 * t56; |
|---|
| 4020 | phydbl t61 = t3 * t14; |
|---|
| 4021 | phydbl t62 = t11 * t61; |
|---|
| 4022 | phydbl t64 = t53 * t51; |
|---|
| 4023 | phydbl t65 = t57 * t55; |
|---|
| 4024 | phydbl t66 = t64 * t65; |
|---|
| 4025 | phydbl t68 = t24 * B; |
|---|
| 4026 | phydbl t69 = t68 * A; |
|---|
| 4027 | phydbl t70 = t51 * u; |
|---|
| 4028 | phydbl t71 = t55 * T; |
|---|
| 4029 | phydbl t72 = t70 * t71; |
|---|
| 4030 | phydbl t75 = t24 * t6; |
|---|
| 4031 | phydbl t76 = t75 * A; |
|---|
| 4032 | phydbl t77 = t51 * t55; |
|---|
| 4033 | phydbl t80 = u * T; |
|---|
| 4034 | phydbl t83 = t24 * t3; |
|---|
| 4035 | phydbl t86 = t3 * t2; |
|---|
| 4036 | phydbl t87 = B * t86; |
|---|
| 4037 | phydbl t88 = t52 * t51; |
|---|
| 4038 | phydbl t89 = t56 * t55; |
|---|
| 4039 | phydbl t90 = t88 * t89; |
|---|
| 4040 | phydbl t93 = t11 * t86; |
|---|
| 4041 | phydbl t96 = t7 * t86; |
|---|
| 4042 | phydbl t97 = t52 * t56; |
|---|
| 4043 | phydbl t100 = t18 * t86; |
|---|
| 4044 | phydbl t103 = t6 * t86; |
|---|
| 4045 | phydbl t104 = t52 * u; |
|---|
| 4046 | phydbl t105 = t56 * T; |
|---|
| 4047 | phydbl t106 = t104 * t105; |
|---|
| 4048 | phydbl t109 = t4 * t6; |
|---|
| 4049 | phydbl t112 = t5 * B; |
|---|
| 4050 | phydbl t117 = B * t61; |
|---|
| 4051 | phydbl t122 = t11 * t6; |
|---|
| 4052 | phydbl t123 = t122 * A; |
|---|
| 4053 | phydbl t126 = -0.108e3 * t54 * t58 + 0.9868914671616000e16 * t62 - 0.993600e6 * t66 + 0.86387558400e11 * t69 * t72 + 0.293717698560e12 * t76 * t77 + 0.854451486720e12 * t26 * t80 - 0.35246123827200e14 * t83 * t80 - 0.795674880e9 * t87 * t90 - 0.1814138726400e13 * t93 * t72 - 0.201570969600e12 * t96 * t97 - 0.12336143339520e14 * t100 * t77 - 0.15913497600e11 * t103 * t106 - 0.388744012800e12 * t109 * t72 - 0.293717698560e12 * t112 * t77 + 0.86387558400e11 * t42 * t72 + 0.4546713600e10 * t117 * t106 + 0.854451486720e12 * t48 * t80 + 0.103520083968000e15 * t72 * t123; |
|---|
| 4054 | phydbl t128 = t6 * t3; |
|---|
| 4055 | phydbl t131 = t18 * t14; |
|---|
| 4056 | phydbl t134 = t11 * t3; |
|---|
| 4057 | phydbl t137 = t18 * A; |
|---|
| 4058 | phydbl t140 = t11 * t7; |
|---|
| 4059 | phydbl t141 = t140 * A; |
|---|
| 4060 | phydbl t146 = B * A; |
|---|
| 4061 | phydbl t151 = t24 * t14; |
|---|
| 4062 | phydbl t154 = t24 * t2; |
|---|
| 4063 | phydbl t159 = t24 * A; |
|---|
| 4064 | phydbl t162 = t140 * t3; |
|---|
| 4065 | phydbl t165 = t6 * t2; |
|---|
| 4066 | phydbl t170 = t6 * t14; |
|---|
| 4067 | phydbl t173 = B * t3; |
|---|
| 4068 | phydbl t176 = -0.51760041984000e14 * t97 * t128 + 0.2898562351104000e16 * t77 * t131 - 0.3623202938880000e16 * t77 * t134 + 0.20704016793600e14 * t97 * t137 + 0.414080335872000e15 * t77 * t141 - 0.177640464089088000e18 * t32 * t72 + 0.16149133099008000e17 * t146 * t97 + 0.1184269760593920000e19 * t36 * t77 + 0.162674417664000e15 * t151 * t80 - 0.16267441766400e14 * t154 * t77 - 0.10658427845345280000e20 * t38 * t80 + 0.1016715110400e13 * t159 * t72 - 0.325348835328000e15 * t162 * t80 - 0.1776404640890880000e19 * t165 * t77 + 0.177640464089088000e18 * t30 * t72 + 0.10658427845345280000e20 * t170 * t80 - 0.5329213922672640000e19 * t173 * t80; |
|---|
| 4069 | phydbl t177 = t11 * A; |
|---|
| 4070 | phydbl t184 = t3 * A; |
|---|
| 4071 | phydbl t185 = t122 * t184; |
|---|
| 4072 | phydbl t188 = t140 * t14; |
|---|
| 4073 | phydbl t191 = t140 * t2; |
|---|
| 4074 | phydbl t196 = t6 * t184; |
|---|
| 4075 | phydbl t199 = t52 * t70; |
|---|
| 4076 | phydbl t200 = t56 * t71; |
|---|
| 4077 | phydbl t201 = t199 * t200; |
|---|
| 4078 | phydbl t208 = B * t184; |
|---|
| 4079 | phydbl t213 = t7 * t184; |
|---|
| 4080 | phydbl t224 = 0.5329213922672640000e19 * t177 * t80 + 0.1184269760593920000e19 * t34 * t77 + 0.239227084800e12 * t141 * t97 + 0.455488369459200e15 * t185 * t80 + 0.43379844710400e14 * t188 * t77 - 0.4066860441600e13 * t191 * t72 + 0.116290944000e12 * t90 * t170 + 0.7117005772800e13 * t97 * t196 - 0.9180864000e10 * t201 * t165 + 0.6120576000e10 * t201 * t34 + 0.40668604416000e14 * t77 * t159 + 0.828988832415744000e18 * t208 * t80 - 0.4710163820544000e16 * t32 * t97 + 0.75914728243200e14 * t72 * t213 + 0.4710163820544000e16 * t30 * t97 + 0.75914728243200e14 * t72 * t131 - 0.1046618496000e13 * t106 * t128 + 0.2372335257600e13 * t97 * t123; |
|---|
| 4081 | phydbl t227 = t7 * t3; |
|---|
| 4082 | phydbl t234 = t122 * t3; |
|---|
| 4083 | phydbl t237 = t122 * t14; |
|---|
| 4084 | phydbl t242 = t11 * t2; |
|---|
| 4085 | phydbl t245 = t7 * t61; |
|---|
| 4086 | phydbl t260 = t18 * t184; |
|---|
| 4087 | phydbl t267 = -0.11861676288000e14 * t97 * t227 - 0.116290944000e12 * t90 * t38 + 0.1395491328000e13 * t106 * t28 - 0.75914728243200e14 * t234 * t77 + 0.9489341030400e13 * t237 * t72 - 0.414494416207872000e18 * t38 * t77 - 0.2072472081039360000e19 * t242 * t80 + 0.1518294564864000e16 * t80 * t245 + 0.10844961177600e14 * t72 * t141 + 0.418647398400e12 * t106 * t137 + 0.414494416207872000e18 * t170 * t77 - 0.94893410304000e14 * t72 * t134 - 0.2657015488512000e16 * t80 * t93 + 0.2763296108052480000e19 * t28 * t80 + 0.3188418586214400e16 * t80 * t260 + 0.37681310564352000e17 * t34 * t72 + 0.126524547072000e15 * t80 * t69; |
|---|
| 4088 | phydbl t268 = t122 * t2; |
|---|
| 4089 | phydbl t285 = t24 * t11; |
|---|
| 4090 | phydbl t297 = B * t52; |
|---|
| 4091 | phydbl t300 = t7 * t51; |
|---|
| 4092 | phydbl t303 = t6 * u; |
|---|
| 4093 | phydbl t309 = -0.837294796800e12 * t268 * t97 + 0.46516377600e11 * t123 * t106 + 0.1518294564864000e16 * t80 * t188 - 0.569360461824000e15 * t80 * t154 - 0.2657015488512000e16 * t80 * t234 + 0.207247208103936000e18 * t177 * t77 + 0.828988832415744000e18 * t137 * t80 - 0.2072472081039360000e19 * t128 * t80 + 0.2136128716800e13 * t285 * A - 0.119374391867867136000e21 * t11 - 0.2387487837357342720000e22 * t6 + 0.596871959339335680000e21 * t14 - 0.296067440148480000e18 * t2 * t70 * t71 + 0.1776404640890880000e19 * t14 * t51 * t55 - 0.29606744014848000e17 * t297 * t56 - 0.1776404640890880000e19 * t300 * t55 - 0.179061587801800704000e21 * t303 * T + 0.596871959339335680000e21 * A * u * T; |
|---|
| 4094 | phydbl t311 = B * u; |
|---|
| 4095 | phydbl t332 = B * t88; |
|---|
| 4096 | phydbl t341 = t7 * t52; |
|---|
| 4097 | phydbl t347 = t6 * t104; |
|---|
| 4098 | phydbl t362 = -0.596871959339335680000e21 * t311 * T + 0.29606744014848000e17 * A * t52 * t56 - 0.7105618563563520000e19 * t3 * u * T + 0.41449441620787200e17 * t184 * t51 * t55 - 0.181160146944000e15 * t2 * t104 * t105 + 0.1570054606848000e16 * t14 * t52 * t56 - 0.138164805402624000e18 * t86 * u * T - 0.12940010496000e14 * t332 * t89 - 0.138164805402624000e18 * t122 * u * T - 0.9420327641088000e16 * t11 * t70 * t71 - 0.1570054606848000e16 * t341 * t56 - 0.41449441620787200e17 * t18 * t51 * t55 - 0.181160146944000e15 * t347 * t105 + 0.1065842784534528000e19 * t184 * u * T - 0.8074566549504000e16 * t2 * t52 * t56 + 0.672880545792000e15 * A * t104 * t105 - 0.296067440148480000e18 * t3 * t51 * t55; |
|---|
| 4099 | phydbl t366 = B * t104; |
|---|
| 4100 | phydbl t372 = t6 * t52; |
|---|
| 4101 | phydbl t375 = t7 * t70; |
|---|
| 4102 | phydbl t381 = t6 * t51; |
|---|
| 4103 | phydbl t388 = t4 * B; |
|---|
| 4104 | phydbl t391 = t61 * t6; |
|---|
| 4105 | phydbl t394 = t4 * t7; |
|---|
| 4106 | phydbl t399 = t10 * t6; |
|---|
| 4107 | phydbl t406 = 0.59213488029696000e17 * t14 * t70 * t71 - 0.672880545792000e15 * t366 * t105 - 0.296067440148480000e18 * t11 * t51 * t55 - 0.8074566549504000e16 * t372 * t56 - 0.59213488029696000e17 * t375 * t71 - 0.1065842784534528000e19 * t18 * u * T - 0.8526742276276224000e19 * t381 * t55 - 0.7162463512072028160000e22 * B + 0.7162463512072028160000e22 * A - 0.596871959339335680000e21 * t7 - 0.2387487837357342720000e22 * t2 - 0.21596889600e11 * t388 * t97 + 0.86387558400e11 * t391 * t97 - 0.4405765478400e13 * t394 * t77 - 0.35246123827200e14 * t40 * t80 + 0.1468588492800e13 * t399 * t77 + 0.15664943923200e14 * t44 * t80 + 0.1036650700800e13 * t245 * t72; |
|---|
| 4108 | phydbl t412 = t18 * t61; |
|---|
| 4109 | phydbl t429 = t184 * t70; |
|---|
| 4110 | phydbl t449 = t2 * t88; |
|---|
| 4111 | phydbl t453 = t53 * u; |
|---|
| 4112 | phydbl t455 = t57 * T; |
|---|
| 4113 | phydbl t467 = t3 * t52; |
|---|
| 4114 | phydbl t475 = 0.8811530956800e13 * t62 * t77 + 0.56393798123520e14 * t412 * t80 - 0.4699483176960e13 * t46 * t80 + 0.113667840e9 * t184 * t199 * t200 * B + 0.302356454400e12 * t184 * t52 * t56 * t11 + 0.31826995200e11 * t184 * t104 * t105 * t7 + 0.2176966471680e13 * t429 * t71 * t18 + 0.2387024640e10 * t184 * t88 * t89 * t6 - 0.70200e5 * t2 * t64 * t65 * B - 0.284169600e9 * t2 * t199 * t200 * t11 - 0.25833600e8 * t2 * t53 * t57 * t7 - 0.2387024640e10 * t449 * t89 * t18 - 0.1684800e7 * t2 * t453 * t455 * t6 - 0.284169600e9 * t3 * t199 * t200 * t6 + 0.1123200e7 * t14 * t453 * t455 * B - 0.302356454400e12 * t467 * t56 * t18 - 0.12916800e8 * t3 * t53 * t57 * B; |
|---|
| 4115 | phydbl t496 = t14 * t104; |
|---|
| 4116 | phydbl t500 = t53 * t70; |
|---|
| 4117 | phydbl t502 = t57 * t71; |
|---|
| 4118 | phydbl t510 = A * t453; |
|---|
| 4119 | phydbl t514 = A * t199; |
|---|
| 4120 | phydbl t522 = t105 * t3; |
|---|
| 4121 | phydbl t527 = t184 * t11; |
|---|
| 4122 | phydbl t536 = t11 * t14; |
|---|
| 4123 | phydbl t539 = 0.25833600e8 * t14 * t53 * t57 * t6 - 0.3978374400e10 * t3 * t88 * t89 * t7 - 0.39783744000e11 * t3 * t104 * t105 * t11 + 0.378892800e9 * t14 * t199 * t200 * t7 + 0.3978374400e10 * t14 * t88 * t89 * t11 + 0.31826995200e11 * t496 * t105 * t18 + 0.2808e4 * A * t500 * t502 * B + 0.12916800e8 * A * t53 * t57 * t11 + 0.1123200e7 * t510 * t455 * t7 + 0.113667840e9 * t514 * t200 * t18 + 0.70200e5 * A * t64 * t65 * t6 - 0.3235002624000e13 * t366 * t522 - 0.162674417664000e15 * t77 * t191 + 0.14234011545600e14 * t527 * t72 - 0.2093236992000e13 * t134 * t97 + 0.325348835328000e15 * t62 * t80 - 0.75914728243200e14 * t93 * t77 + 0.232581888000e12 * t536 * t106; |
|---|
| 4124 | phydbl t547 = t7 * u; |
|---|
| 4125 | phydbl t548 = T * t4; |
|---|
| 4126 | phydbl t561 = B * t199; |
|---|
| 4127 | phydbl t562 = t200 * t2; |
|---|
| 4128 | phydbl t565 = B * t51; |
|---|
| 4129 | phydbl t566 = t55 * t61; |
|---|
| 4130 | phydbl t571 = t18 * t2; |
|---|
| 4131 | phydbl t582 = -0.18361728000e11 * t242 * t90 + 0.30145048451481600e17 * t208 * t77 + 0.918086400e9 * t177 * t201 - 0.162674417664000e15 * t547 * t548 + 0.966187450368000e15 * t36 * t97 - 0.103520083968000e15 * t32 * t106 - 0.110531844322099200e18 * t87 * t80 + 0.6901338931200e13 * t146 * t90 - 0.12560436854784000e17 * t38 * t72 - 0.31715712000e11 * t561 * t562 + 0.414080335872000e15 * t565 * t566 + 0.100483494838272000e18 * t28 * t77 - 0.331595532966297600e18 * t571 * t80 - 0.75362621128704000e17 * t242 * t77 + 0.966187450368000e15 * t34 * t97 - 0.1449281175552000e16 * t165 * t97 + 0.331595532966297600e18 * t196 * t80; |
|---|
| 4132 | phydbl t601 = t56 * t184; |
|---|
| 4133 | phydbl t604 = B * t53; |
|---|
| 4134 | phydbl t605 = t57 * A; |
|---|
| 4135 | phydbl t610 = t7 * t104; |
|---|
| 4136 | phydbl t615 = t71 * t86; |
|---|
| 4137 | phydbl t621 = 0.103520083968000e15 * t30 * t106 + 0.12560436854784000e17 * t170 * t72 - 0.75362621128704000e17 * t128 * t77 - 0.6280218427392000e16 * t173 * t72 + 0.30145048451481600e17 * t137 * t77 + 0.6280218427392000e16 * t177 * t72 + 0.552659221610496000e18 * t536 * t80 - 0.552659221610496000e18 * t227 * t80 + 0.110531844322099200e18 * t123 * t80 + 0.20704016793600e14 * t297 * t601 + 0.1669248000e10 * t604 * t605 + 0.1674589593600e13 * t341 * t601 - 0.232581888000e12 * t610 * t522 + 0.43379844710400e14 * t300 * t566 - 0.9489341030400e13 * t375 * t615 - 0.3947565868646400e16 * t68 + 0.3947565868646400e16 * t10 - 0.1345761091584000e16 * t106; |
|---|
| 4138 | phydbl t643 = B * t70; |
|---|
| 4139 | phydbl t649 = t6 * t70; |
|---|
| 4140 | phydbl t660 = t53 * t57; |
|---|
| 4141 | phydbl t665 = 0.39791463955955712000e20 * t14 * u * T + 0.1065842784534528000e19 * A * t70 * t71 - 0.8526742276276224000e19 * t2 * t51 * t55 - 0.179061587801800704000e21 * t2 * u * T - 0.29843597966966784000e20 * t565 * t55 + 0.29843597966966784000e20 * A * t51 * t55 - 0.39791463955955712000e20 * t547 * T - 0.1065842784534528000e19 * t643 * t71 - 0.7105618563563520000e19 * t11 * u * T - 0.296067440148480000e18 * t649 * t71 - 0.2842247425425408000e19 * t86 - 0.2842247425425408000e19 * t122 + 0.11861676288000e14 * t97 * t536 - 0.1046618496000e13 * t106 * t242 - 0.56521965846528000e17 * t165 * t72 + 0.459043200e9 * t660 * t30 - 0.37957364121600e14 * t72 * t103; |
|---|
| 4142 | phydbl t696 = t68 * t2; |
|---|
| 4143 | phydbl t703 = 0.6470005248000e13 * t106 * t170 - 0.570882816000e12 * t90 * t165 - 0.207247208103936000e18 * t173 * t77 + 0.37681310564352000e17 * t36 * t72 + 0.362320293888000e15 * t146 * t106 + 0.310560251904000e15 * t72 * t196 + 0.1345761091584000e16 * t80 * t159 + 0.358123175603601408000e21 * t146 * t80 + 0.10844961177600e14 * t76 * t80 + 0.119374391867867136000e21 * t30 * t80 + 0.17053484552552448000e20 * t146 * t77 - 0.119374391867867136000e21 * t32 * t80 + 0.380588544000e12 * t90 * t34 + 0.2898562351104000e16 * t77 * t213 + 0.28422474254254080000e20 * t36 * t80 - 0.54224805888000e14 * t696 * t80 + 0.592134880296960000e18 * t146 * t72 + 0.69013389312000e14 * t97 * t28; |
|---|
| 4144 | phydbl t740 = -0.14324927024144056320000e23 - 0.5329213922672640000e19 * t32 * t77 - 0.6470005248000e13 * t106 * t38 - 0.517600419840000e15 * t72 * t227 + 0.3614987059200e13 * t69 * t77 - 0.42633711381381120000e20 * t165 * t80 + 0.5329213922672640000e19 * t30 * t77 + 0.28422474254254080000e20 * t34 * t80 + 0.355280928178176000e18 * t61 - 0.39475658686464000e17 * t24 - 0.39475658686464000e17 * t4 - 0.1404e4 * t6 * t500 * t502 - 0.2583360e7 * t18 * t53 * t57 - 0.280800e6 * t11 * t453 * t455 - 0.23400e5 * t7 * t64 * t65 - 0.54e2 * B * t54 * t58 - 0.21859200e8 * t11 * t53 * t57; |
|---|
| 4145 | phydbl t765 = t453 * t455; |
|---|
| 4146 | phydbl t772 = t500 * t502; |
|---|
| 4147 | phydbl t783 = -0.1987200e7 * t7 * t453 * t455 - 0.129600e6 * t6 * t64 * t65 - 0.5400e4 * B * t500 * t502 + 0.985905561600e12 * t15 * u * T - 0.361498705920e12 * t77 * t5 + 0.112968345600e12 * t72 * t10 - 0.29903385600e11 * t97 * t4 - 0.1224115200e10 * t90 * t86 + 0.183617280e9 * t201 * t184 + 0.6645196800e10 * t106 * t61 + 0.1987200e7 * t765 * t14 - 0.129600e6 * t66 * t2 - 0.21859200e8 * t660 * t3 + 0.5400e4 * t772 * A + 0.6120576000e10 * t201 * t36 - 0.2372335257600e13 * t97 * t87 + 0.418647398400e12 * t106 * t208 + 0.10844961177600e14 * t72 * t117; |
|---|
| 4148 | phydbl t794 = t18 * t3; |
|---|
| 4149 | phydbl t823 = -0.459043200e9 * t660 * t32 - 0.58145472000e11 * t90 * t173 + 0.162674417664000e15 * t77 * t391 - 0.569360461824000e15 * t77 * t794 - 0.40668604416000e14 * t77 * t388 - 0.569360461824000e15 * t80 * t109 + 0.126524547072000e15 * t80 * t42 + 0.21859200e8 * t765 * t146 - 0.379573641216000e15 * t77 * t96 - 0.455488369459200e15 * t100 * t80 + 0.91097673891840e14 * t260 * t77 - 0.14234011545600e14 * t794 * t72 + 0.1674589593600e13 * t131 * t97 - 0.139549132800e12 * t571 * t106 + 0.7344691200e10 * t137 * t90 + 0.379573641216000e15 * t77 * t237 + 0.569360461824000e15 * t77 * t527; |
|---|
| 4150 | phydbl t826 = t89 * t14; |
|---|
| 4151 | phydbl t835 = t122 * t86; |
|---|
| 4152 | phydbl t850 = t140 * t184; |
|---|
| 4153 | phydbl t859 = t75 * t2; |
|---|
| 4154 | phydbl t864 = -0.103520083968000e15 * t643 * t615 + 0.380588544000e12 * t332 * t826 + 0.12336143339520e14 * t185 * t77 - 0.15913497600e11 * t268 * t106 + 0.201570969600e12 * t237 * t97 - 0.65792764477440e14 * t835 * t80 - 0.388744012800e12 * t154 * t72 + 0.795674880e9 * t123 * t90 - 0.1814138726400e13 * t234 * t72 - 0.8811530956800e13 * t162 * t77 + 0.1036650700800e13 * t188 * t72 + 0.4546713600e10 * t141 * t106 + 0.56393798123520e14 * t850 * t80 - 0.86387558400e11 * t191 * t97 + 0.21596889600e11 * t159 * t97 - 0.1468588492800e13 * t696 * t77 - 0.4699483176960e13 * t859 * t80 + 0.4405765478400e13 * t151 * t77; |
|---|
| 4155 | phydbl t866 = t68 * t14; |
|---|
| 4156 | phydbl t905 = 0.15664943923200e14 * t866 * t80 - 0.1345761091584000e16 * t311 * t548 + 0.24482304000e11 * t7 * t88 * t826 - 0.1836172800e10 * t7 * t199 * t562 + 0.87436800e8 * t7 * t53 * t605 + 0.54224805888000e14 * t303 * T * t10 - 0.18840655282176000e17 * t80 * t794 + 0.5383044366336000e16 * t80 * t391 - 0.113043931693056000e18 * t80 * t134 + 0.12919306479206400e17 * t80 * t117 - 0.45217572677222400e17 * t80 * t103 + 0.90435145354444800e17 * t80 * t131 + 0.90435145354444800e17 * t80 * t213 - 0.45217572677222400e17 * t80 * t268 + 0.20704016793600e14 * t106 * t34 - 0.2173921763328000e16 * t72 * t242 - 0.11304393169305600e17 * t77 * t571; |
|---|
| 4157 | phydbl t938 = t6 * t88; |
|---|
| 4158 | phydbl t949 = 0.2898562351104000e16 * t72 * t28 - 0.310560251904000e15 * t97 * t38 + 0.114176563200e12 * t201 * t146 - 0.3768131056435200e16 * t77 * t87 - 0.1941001574400e13 * t90 * t32 + 0.20704016793600e14 * t106 * t36 + 0.869568705331200e15 * t72 * t208 + 0.12919306479206400e17 * t80 * t141 + 0.58145472000e11 * t90 * t177 + 0.1941001574400e13 * t90 * t30 + 0.11304393169305600e17 * t77 * t196 - 0.31056025190400e14 * t106 * t165 - 0.16267441766400e14 * t381 * t55 * t4 + 0.4066860441600e13 * t649 * t71 * t61 + 0.310560251904000e15 * t97 * t170 - 0.18361728000e11 * t938 * t89 * t3 + 0.1836172800e10 * t6 * t199 * t200 * t14 - 0.837294796800e12 * t372 * t56 * t86; |
|---|
| 4159 | phydbl t979 = 0.139549132800e12 * t347 * t105 * t184 - 0.2173921763328000e16 * t72 * t128 - 0.131155200e9 * t6 * t53 * t57 * t2 + 0.5961600e7 * t30 * t765 - 0.155280125952000e15 * t97 * t173 + 0.869568705331200e15 * t72 * t137 - 0.29905802035200e14 * t25 - 0.2300446310400e13 * t285 - 0.12816772300800e14 * t25 * t2 - 0.355280928178176000e18 * t140 - 0.2131685569069056000e19 * t72 - 0.716246351207202816000e21 * t165 - 0.10800e5 * t772 - 0.59687195933933568000e20 * t77 + 0.4774975674714685440000e22 * t146 + 0.99478659889889280000e20 * t177 - 0.99478659889889280000e20 * t173; |
|---|
| 4160 | phydbl t998 = -0.59213488029696000e17 * t97 - 0.151829456486400e15 * t859 + 0.198957319779778560000e21 * t170 + 0.17053484552552448000e20 * t137 - 0.42633711381381120000e20 * t242 + 0.17053484552552448000e20 * t208 - 0.42633711381381120000e20 * t128 - 0.12434832486236160000e20 * t227 + 0.12434832486236160000e20 * t536 + 0.7460899491741696000e19 * t196 - 0.7460899491741696000e19 * t571 + 0.2486966497247232000e19 * t123 - 0.2486966497247232000e19 * t87 - 0.25880020992000e14 * t90 - 0.431333683200e12 * t201 + 0.315805269491712000e18 * t117 + 0.43064354930688000e17 * t245 - 0.75362621128704000e17 * t234; |
|---|
| 4161 | phydbl t1017 = -0.1138720923648000e16 * t83 - 0.2763296108052480000e19 * t134 - 0.16149133099008000e17 * t154 + 0.43064354930688000e17 * t188 - 0.1105318443220992000e19 * t268 + 0.2210636886441984000e19 * t131 + 0.3588696244224000e16 * t69 + 0.90435145354444800e17 * t260 - 0.75362621128704000e17 * t93 - 0.1105318443220992000e19 * t103 - 0.6343142400e10 * t660 + 0.1821953477836800e16 * t850 - 0.83462400e8 * t765 - 0.2125612390809600e16 * t835 - 0.1193743918678671360000e22 * t80 + 0.1821953477836800e16 * t412 + 0.315805269491712000e18 * t141; |
|---|
| 4162 | phydbl t1038 = 0.2210636886441984000e19 * t213 - 0.331595532966297600e18 * t96 - t53 * t104 * t57 * t105 + 0.506098188288000e15 * t866 - 0.16149133099008000e17 * t109 - 0.497393299449446400e18 * t794 + 0.35528092817817600e17 * t159 - 0.142112371271270400e18 * t191 + 0.331595532966297600e18 * t237 + 0.497393299449446400e18 * t527 + 0.142112371271270400e18 * t391 - 0.35528092817817600e17 * t388 - 0.4934457335808000e16 * t394 + 0.1644819111936000e16 * t399 - 0.328963822387200e15 * t112 - 0.9868914671616000e16 * t162 + 0.328963822387200e15 * t76 - 0.1644819111936000e16 * t696; |
|---|
| 4163 | phydbl t1070 = 0.4934457335808000e16 * t151 + 0.13816480540262400e17 * t185 - 0.13816480540262400e17 * t100 + 0.281968990617600e15 * t122 * t61 - 0.117487079424000e15 * t68 * t3 + 0.46994831769600e14 * t75 * t14 + 0.211476742963200e15 * t24 * t184 - 0.281968990617600e15 * t140 * t86 - 0.358869624422400e15 * t75 - 0.358869624422400e15 * t5 + 0.29905802035200e14 * t15 + 0.155280125952000e15 * t97 * t177 - 0.18840655282176000e17 * t77 * t227 + 0.18840655282176000e17 * t77 * t536 + 0.3768131056435200e16 * t77 * t123 - 0.12560436854784000e17 * t80 * t96 + 0.12560436854784000e17 * t80 * t237; |
|---|
| 4164 | phydbl t1093 = B * t453; |
|---|
| 4165 | phydbl t1119 = -0.10844961177600e14 * t311 * T * t5 + 0.3614987059200e13 * t565 * t55 * t10 - 0.1016715110400e13 * t643 * t71 * t4 + 0.239227084800e12 * t297 * t56 * t61 - 0.46516377600e11 * t366 * t105 * t86 + 0.7344691200e10 * t332 * t89 * t184 + 0.18840655282176000e17 * t80 * t527 - 0.5383044366336000e16 * t80 * t191 - 0.5961600e7 * t1093 * t455 * t2 + 0.259200e6 * B * t64 * t65 * A - 0.918086400e9 * t561 * t200 * t3 + 0.87436800e8 * t604 * t57 * t14 + 0.3235002624000e13 * t106 * t177 - 0.310560251904000e15 * t72 * t571 - 0.1449281175552000e16 * t77 * t268 + 0.517600419840000e15 * t72 * t536 - 0.51760041984000e14 * t97 * t242 + 0.31715712000e11 * t201 * t30; |
|---|
| 4166 | phydbl t1160 = -0.1449281175552000e16 * t77 * t103 - 0.7117005772800e13 * t97 * t571 - 0.37957364121600e14 * t72 * t268 - 0.164317593600e12 * t24 * t18 + 0.164317593600e12 * t4 * t184 + 0.215666841600e12 * t514 * t200 + 0.1256043685478400e16 * t429 * t71 - 0.3450669465600e13 * t449 * t89 + 0.15790263474585600e17 * t61 * u * T - 0.241546862592000e15 * t467 * t56 + 0.34506694656000e14 * t496 * t105 - 0.5024174741913600e16 * t86 * t51 * t55 - 0.215666841600e12 * t561 * t200 - 0.34506694656000e14 * t610 * t105 - 0.5024174741913600e16 * t122 * t51 * t55 - 0.241546862592000e15 * t11 * t52 * t56 - 0.1256043685478400e16 * t18 * t70 * t71; |
|---|
| 4167 | phydbl t1200 = -0.15790263474585600e17 * t140 * u * T - 0.3450669465600e13 * t938 * t89 + 0.12940010496000e14 * A * t88 * t89 - 0.9420327641088000e16 * t3 * t70 * t71 - 0.57088281600e11 * t201 * t6 - 0.538304436633600e15 * t77 * t140 - 0.31056025190400e14 * t97 * t18 - 0.5176004198400e13 * t106 * t11 - 0.144928117555200e15 * t72 * t122 - 0.647000524800e12 * t90 * t7 - 0.3171571200e10 * t660 * B - 0.144928117555200e15 * t72 * t86 + 0.647000524800e12 * t90 * t14 - 0.5176004198400e13 * t106 * t3 + 0.538304436633600e15 * t77 * t61 - 0.57088281600e11 * t201 * t2 + 0.31056025190400e14 * t97 * t184 + 0.3171571200e10 * t660 * A; |
|---|
| 4168 | phydbl t1239 = -0.1614913309900800e16 * t80 * t4 - 0.1614913309900800e16 * t80 * t24 - 0.985905561600e12 * t25 * u * T - 0.361498705920e12 * t75 * t51 * t55 - 0.112968345600e12 * t68 * t70 * t71 - 0.29903385600e11 * t24 * t52 * t56 - 0.6645196800e10 * t140 * t104 * t105 - 0.12652454707200e14 * t80 * t5 - 0.1355620147200e13 * t72 * t24 - 0.12652454707200e14 * t80 * t75 - 0.1224115200e10 * t122 * t88 * t89 - 0.1530144000e10 * t201 * t11 - 0.119374391867867136000e21 * t3 - 0.19895731977977856000e20 * t18 + 0.19895731977977856000e20 * t184 - 0.2300446310400e13 * t21 - 0.338905036800e12 * t97 * t140; |
|---|
| 4169 | phydbl t1277 = -0.153014400e9 * t660 * t7 - 0.69774566400e11 * t106 * t122 + 0.11629094400e11 * t90 * t184 - 0.1530144000e10 * t201 * t3 + 0.153014400e9 * t660 * t14 - 0.1355620147200e13 * t72 * t4 - 0.4518733824000e13 * t77 * t68 - 0.69774566400e11 * t106 * t86 - 0.11629094400e11 * t90 * t18 - 0.10929600e8 * t765 * t6 - 0.10929600e8 * t765 * t2 + 0.496800e6 * t66 * A + 0.338905036800e12 * t97 * t61 - 0.496800e6 * t66 * B + 0.4518733824000e13 * t77 * t10 - 0.51760041984000e14 * t77 * t24 - 0.10571904000e11 * t201 * t7 - 0.183617280e9 * t18 * t199 * t200; |
|---|
| 4170 | phydbl t1314 = -0.3450669465600e13 * t97 * t122 - 0.95147136000e11 * t90 * t11 - 0.14788583424000e14 * t72 * t140 - 0.647000524800e12 * t106 * t18 - 0.834624000e9 * t660 * t6 - 0.149529010176000e15 * t80 * t68 - 0.3450669465600e13 * t97 * t86 + 0.10571904000e11 * t201 * t14 - 0.51760041984000e14 * t77 * t4 + 0.647000524800e12 * t106 * t184 - 0.95147136000e11 * t90 * t3 + 0.14788583424000e14 * t72 * t61 - 0.41731200e8 * t1093 * t455 - 0.834624000e9 * t660 * t2 + 0.41731200e8 * t510 * t455 + 0.149529010176000e15 * t80 * t10 - 0.113667840e9 * t140 * t88 * t89; |
|---|
| 4171 | phydbl t1369 = -0.71204290560e11 * t285 * u * T - 0.8638755840e10 * t75 * t70 * t71 - 0.2399654400e10 * t68 * t52 * t56 - 0.26701608960e11 * t25 * t51 * t55 - 0.568339200e9 * t24 * t104 * t105 - 0.18944640e8 * t122 * t199 * t200 + 0.26701608960e11 * t15 * t51 * t55 - 0.568339200e9 * t4 * t104 * t105 + 0.2399654400e10 * t10 * t52 * t56 - 0.71204290560e11 * t21 * u * T + 0.113667840e9 * t61 * t88 * t89 - 0.8638755840e10 * t5 * t70 * t71 - 0.18944640e8 * t86 * t199 * t200 + 0.2583360e7 * t184 * t53 * t57 - 0.280800e6 * t3 * t453 * t455 + 0.23400e5 * t14 * t64 * t65 - 0.1404e4 * t2 * t500 * t502 + 0.54e2 * A * t54 * t58; |
|---|
| 4172 | *mean = -t1 * (t126 + t1160 + t823 + t665 + t621 + t1369 + t267 + t1070 + t1314 + t475 + t783 + t1200 + t703 + t1119 + t740 + t582 + t406 + t1239 + t1017 + t979 + t539 + t309 + t224 + t50 + t1277 + t905 + t864 + t998 + t949 + t1038 + t362 + t176) / 0.14324927024144056320000e23; |
|---|
| 4173 | |
|---|
| 4174 | |
|---|
| 4175 | /* printf("\n. Taylor: %f",*mean); */ |
|---|
| 4176 | |
|---|
| 4177 | /* /\* C(int(exp((B-A)*s/T+(1/2)*u*(T-s)*s/T), s = 0 .. T)) *\/ */ |
|---|
| 4178 | /* /\* Correct but numerically unstable dur to EXP(TOO BIG)*\/ */ |
|---|
| 4179 | |
|---|
| 4180 | /* *mean = */ |
|---|
| 4181 | /* SQRT(0.2e1) * */ |
|---|
| 4182 | /* SQRT(0.3141592654e1) * */ |
|---|
| 4183 | /* EXP((double) ((4 * B * B - 8 * B * A + 4 * B * u * T + 4 * A * A - 4 * A * u * T + u * u * T * T) / u / T) / 0.8e1) * */ |
|---|
| 4184 | /* (-erf(SQRT(0.2e1) * (double) (-2 * B + 2 * A - u * T) / (double) T * pow((double) (u / T), -0.1e1 / 0.2e1) / 0.4e1) */ |
|---|
| 4185 | /* +erf(SQRT(0.2e1) * (double) (u * T - 2 * B + 2 * A) / (double) T * pow((double) (u / T), -0.1e1 / 0.2e1) / 0.4e1))* */ |
|---|
| 4186 | /* pow((double) (u / T), -0.1e1 / 0.2e1) / 0.2e1; */ |
|---|
| 4187 | |
|---|
| 4188 | /* *mean /= T; */ |
|---|
| 4189 | /* *mean *= EXP(A); */ |
|---|
| 4190 | |
|---|
| 4191 | /* printf("\nErf: %f [%f %f %f]", */ |
|---|
| 4192 | /* *mean, */ |
|---|
| 4193 | /* EXP((double) ((4 * B * B - 8 * B * A + 4 * B * u * T + 4 * A * A - 4 * A * u * T + u * u * T * T) / u / T) / 0.8e1), */ |
|---|
| 4194 | /* (double) ((4 * B * B - 8 * B * A + 4 * B * u * T + 4 * A * A - 4 * A * u * T + u * u * T * T) / u / T) / 0.8e1, */ |
|---|
| 4195 | /* (-erf(SQRT(0.2e1) * (double) (-2 * B + 2 * A - u * T) / (double) T * pow((double) (u / T), -0.1e1 / 0.2e1) / 0.4e1) + erf(SQRT(0.2e1) * (double) (u * T - 2 * B + 2 * A) / (double) T * pow((double) (u / T), -0.1e1 / 0.2e1) / 0.4e1)) * pow((double) (u / T), -0.1e1 / 0.2e1) / 0.2e1); */ |
|---|
| 4196 | |
|---|
| 4197 | } |
|---|
| 4198 | |
|---|
| 4199 | ////////////////////////////////////////////////////////////// |
|---|
| 4200 | ////////////////////////////////////////////////////////////// |
|---|
| 4201 | |
|---|
| 4202 | void Integrated_Geometric_Brownian_Bridge_Var(phydbl T, phydbl A, phydbl B, phydbl u, phydbl *var) |
|---|
| 4203 | { |
|---|
| 4204 | phydbl t2 = exp(0.2e1 * A); |
|---|
| 4205 | phydbl t3 = A * A; |
|---|
| 4206 | phydbl t7 = u * u; |
|---|
| 4207 | phydbl t8 = B * t7; |
|---|
| 4208 | phydbl t9 = T * T; |
|---|
| 4209 | phydbl t12 = B * B; |
|---|
| 4210 | phydbl t13 = t7 * u; |
|---|
| 4211 | phydbl t14 = t7 * t7; |
|---|
| 4212 | phydbl t15 = t14 * t14; |
|---|
| 4213 | phydbl t16 = t15 * t13; |
|---|
| 4214 | phydbl t18 = t9 * T; |
|---|
| 4215 | phydbl t19 = t9 * t9; |
|---|
| 4216 | phydbl t20 = t19 * t19; |
|---|
| 4217 | phydbl t21 = t20 * t18; |
|---|
| 4218 | phydbl t24 = t12 * t12; |
|---|
| 4219 | phydbl t25 = t24 * B; |
|---|
| 4220 | phydbl t29 = t15 * u; |
|---|
| 4221 | phydbl t31 = t20 * T; |
|---|
| 4222 | phydbl t34 = t12 * B; |
|---|
| 4223 | phydbl t35 = t15 * t7; |
|---|
| 4224 | phydbl t37 = t20 * t9; |
|---|
| 4225 | phydbl t40 = t15 * t14; |
|---|
| 4226 | phydbl t42 = t20 * t19; |
|---|
| 4227 | phydbl t57 = t3 * A; |
|---|
| 4228 | phydbl t58 = t3 * t3; |
|---|
| 4229 | phydbl t59 = t58 * t58; |
|---|
| 4230 | phydbl t60 = t59 * t57; |
|---|
| 4231 | phydbl t64 = t7 * t9; |
|---|
| 4232 | phydbl t65 = t59 * t3; |
|---|
| 4233 | phydbl t68 = t13 * t18; |
|---|
| 4234 | phydbl t69 = t59 * A; |
|---|
| 4235 | phydbl t72 = t14 * t19; |
|---|
| 4236 | phydbl t75 = t14 * t7; |
|---|
| 4237 | phydbl t76 = t19 * t9; |
|---|
| 4238 | phydbl t77 = t75 * t76; |
|---|
| 4239 | phydbl t78 = t58 * t3; |
|---|
| 4240 | phydbl t81 = -0.4722222240e18 * t3 * u * T - 0.2222222160e18 * t8 * t9 - 0.2370000e7 * t12 * t16 * t21 - 0.745270000e9 * t25 * t15 * t20 - 0.143603000e9 * t24 * t29 * t31 - 0.13704400e8 * t34 * t35 * t37 + 0.220000e6 * B * t40 * t42 - 0.3230000000e10 * t24 * t15 * t20 - 0.565000000e9 * t34 * t29 * t31 - 0.100000000e9 * t12 * t35 * t37 - 0.85000e5 * B * t16 * t21 + 0.6891165130e12 * t60 * u * T - 0.8770304000e12 * t64 * t65 + 0.6541049000e12 * t68 * t69 - 0.3577430000e12 * t72 * t59 - 0.5328000000e11 * t77 * t78; |
|---|
| 4241 | phydbl t82 = t14 * t13; |
|---|
| 4242 | phydbl t83 = t19 * t18; |
|---|
| 4243 | phydbl t84 = t82 * t83; |
|---|
| 4244 | phydbl t85 = t58 * A; |
|---|
| 4245 | phydbl t88 = t14 * u; |
|---|
| 4246 | phydbl t89 = t19 * T; |
|---|
| 4247 | phydbl t90 = t88 * t89; |
|---|
| 4248 | phydbl t91 = t58 * t57; |
|---|
| 4249 | phydbl t94 = t29 * t31; |
|---|
| 4250 | phydbl t97 = t35 * t37; |
|---|
| 4251 | phydbl t100 = t15 * t20; |
|---|
| 4252 | phydbl t103 = t16 * t21; |
|---|
| 4253 | phydbl t106 = t34 * t88; |
|---|
| 4254 | phydbl t107 = t89 * t58; |
|---|
| 4255 | phydbl t110 = t34 * t7; |
|---|
| 4256 | phydbl t111 = t9 * t91; |
|---|
| 4257 | phydbl t114 = t34 * t13; |
|---|
| 4258 | phydbl t115 = t18 * t78; |
|---|
| 4259 | phydbl t118 = B * u; |
|---|
| 4260 | phydbl t119 = T * t59; |
|---|
| 4261 | phydbl t123 = t76 * t57; |
|---|
| 4262 | phydbl t127 = t83 * t3; |
|---|
| 4263 | phydbl t131 = t20 * A; |
|---|
| 4264 | phydbl t134 = t12 * u; |
|---|
| 4265 | phydbl t138 = u * T; |
|---|
| 4266 | phydbl t139 = t25 * t58; |
|---|
| 4267 | phydbl t142 = t91 * t12; |
|---|
| 4268 | phydbl t145 = t24 * t58; |
|---|
| 4269 | phydbl t148 = 0.1479000000e11 * t84 * t85 + 0.1539200000e12 * t90 * t91 + 0.587000000e9 * t94 * t57 - 0.92460000e8 * t97 * t3 - 0.3259400000e10 * t100 * t58 + 0.10000000e8 * t103 * A - 0.5386900000e13 * t106 * t107 + 0.1052436300e15 * t110 * t111 - 0.5494474000e14 * t114 * t115 - 0.2664291708e15 * t118 * t119 + 0.1065273000e13 * t34 * t75 * t123 - 0.1479180000e12 * t34 * t82 * t127 + 0.1338774000e11 * t34 * t15 * t131 + 0.3790140862e14 * t134 * T * t69 - 0.3730008441e16 * t138 * t139 + 0.1065716712e16 * t138 * t142 - 0.1197449022e17 * t138 * t145; |
|---|
| 4270 | phydbl t150 = B * t91; |
|---|
| 4271 | phydbl t153 = t12 * t78; |
|---|
| 4272 | phydbl t156 = t25 * t57; |
|---|
| 4273 | phydbl t159 = t34 * t85; |
|---|
| 4274 | phydbl t162 = t24 * t12; |
|---|
| 4275 | phydbl t163 = t162 * t3; |
|---|
| 4276 | phydbl t166 = t34 * A; |
|---|
| 4277 | phydbl t169 = t24 * t3; |
|---|
| 4278 | phydbl t172 = t25 * t3; |
|---|
| 4279 | phydbl t175 = t34 * t57; |
|---|
| 4280 | phydbl t178 = t34 * t3; |
|---|
| 4281 | phydbl t181 = B * A; |
|---|
| 4282 | phydbl t184 = B * t78; |
|---|
| 4283 | phydbl t187 = B * t3; |
|---|
| 4284 | phydbl t190 = B * t57; |
|---|
| 4285 | phydbl t193 = B * t85; |
|---|
| 4286 | phydbl t196 = t24 * t34; |
|---|
| 4287 | phydbl t197 = t196 * A; |
|---|
| 4288 | phydbl t200 = t24 * A; |
|---|
| 4289 | phydbl t203 = 0.1368513200e16 * t138 * t150 - 0.4789796130e16 * t138 * t153 + 0.9579592368e16 * t138 * t156 + 0.9579592019e16 * t138 * t159 - 0.4789796148e16 * t138 * t163 + 0.6456120000e14 * t90 * t166 - 0.1780077270e16 * t68 * t169 - 0.4005331107e16 * t64 * t172 + 0.2373436550e16 * t68 * t175 - 0.5114963006e15 * t72 * t178 + 0.1197000000e13 * t84 * t181 - 0.1335110261e16 * t64 * t184 - 0.1115603000e14 * t77 * t187 + 0.6455912700e14 * t90 * t190 + 0.7120309141e15 * t68 * t193 + 0.1368513201e16 * t138 * t197 + 0.1291400000e13 * t77 * t200; |
|---|
| 4290 | phydbl t204 = t12 * A; |
|---|
| 4291 | phydbl t207 = t12 * t85; |
|---|
| 4292 | phydbl t210 = t12 * t3; |
|---|
| 4293 | phydbl t213 = t12 * t7; |
|---|
| 4294 | phydbl t217 = t12 * t13; |
|---|
| 4295 | phydbl t221 = t12 * t57; |
|---|
| 4296 | phydbl t224 = t12 * t75; |
|---|
| 4297 | phydbl t232 = t12 * t14; |
|---|
| 4298 | phydbl t236 = t12 * t88; |
|---|
| 4299 | phydbl t240 = t12 * t58; |
|---|
| 4300 | phydbl t249 = B * t58; |
|---|
| 4301 | phydbl t252 = t25 * A; |
|---|
| 4302 | phydbl t257 = t34 * t58; |
|---|
| 4303 | phydbl t260 = 0.1115831100e14 * t77 * t204 + 0.4005330927e16 * t64 * t207 - 0.9683950000e14 * t90 * t210 - 0.3946635700e14 * t213 * t9 * t59 + 0.2354776600e14 * t217 * t18 * t91 + 0.5114971000e15 * t72 * t221 - 0.7991390000e12 * t224 * t76 * t58 + 0.1481000000e12 * t12 * t82 * t83 * t57 - 0.1001680000e14 * t232 * t19 * t78 + 0.3232259000e13 * t236 * t89 * t85 - 0.1780077100e16 * t68 * t240 - 0.1933540000e11 * t12 * t15 * t20 * t3 + 0.1300000000e10 * t204 * t94 - 0.2557472700e15 * t72 * t249 + 0.7120305100e15 * t68 * t252 + 0.2557476700e15 * t72 * t200 - 0.6675552600e16 * t64 * t257; |
|---|
| 4304 | phydbl t263 = t24 * t57; |
|---|
| 4305 | phydbl t266 = t162 * A; |
|---|
| 4306 | phydbl t269 = t34 * t78; |
|---|
| 4307 | phydbl t272 = t162 * t57; |
|---|
| 4308 | phydbl t281 = B * t13; |
|---|
| 4309 | phydbl t285 = B * t14; |
|---|
| 4310 | phydbl t289 = B * t88; |
|---|
| 4311 | phydbl t293 = B * t75; |
|---|
| 4312 | phydbl t297 = t85 * t24; |
|---|
| 4313 | phydbl t300 = t196 * t3; |
|---|
| 4314 | phydbl t303 = B * t29; |
|---|
| 4315 | phydbl t311 = B * t82; |
|---|
| 4316 | phydbl t315 = B * t15; |
|---|
| 4317 | phydbl t321 = 0.6675550630e16 * t64 * t263 + 0.1335110310e16 * t64 * t266 - 0.2486672290e16 * t138 * t269 + 0.2486672264e16 * t138 * t272 - 0.7580281740e13 * t118 * T * t65 + 0.8770300400e13 * t8 * t9 * t69 - 0.5886921000e13 * t281 * t18 * t59 + 0.2861957000e13 * t285 * t19 * t91 - 0.1077430000e13 * t289 * t89 * t78 + 0.3195000000e12 * t293 * t76 * t85 + 0.3730008390e16 * t138 * t297 - 0.1065716699e16 * t138 * t300 - 0.1395750000e10 * t303 * t31 * t3 + 0.152478000e9 * B * t35 * t37 * A - 0.7417900000e11 * t311 * t83 * t58 + 0.1310000000e11 * t315 * t20 * t57 + 0.1971235000e14 * t90 * t200; |
|---|
| 4318 | phydbl t354 = -0.4879631000e15 * t68 * t172 - 0.9734606000e15 * t64 * t163 + 0.8132711424e15 * t68 * t263 - 0.1652248000e15 * t72 * t169 + 0.6575580000e12 * t84 * t204 - 0.9734607070e15 * t64 * t153 - 0.3000000000e10 * t12 + 0.1000000000e10 * t57 + 0.7331618000e14 * t72 * t263 - 0.1244100000e14 * t90 * t169 - 0.1253983358e17 * t210 * t68 + 0.3439800000e11 * t100 * t204 - 0.1144586120e15 * t68 * t153 + 0.3942690000e14 * t90 * t221 - 0.6457200000e13 * t77 * t210 - 0.2050264784e17 * t249 * t64 + 0.8359887000e16 * t190 * t68; |
|---|
| 4319 | phydbl t360 = t24 * t24; |
|---|
| 4320 | phydbl t361 = t360 * A; |
|---|
| 4321 | phydbl t366 = t360 * t12; |
|---|
| 4322 | phydbl t367 = t366 * A; |
|---|
| 4323 | phydbl t374 = t360 * B; |
|---|
| 4324 | phydbl t381 = t34 * u; |
|---|
| 4325 | phydbl t397 = 0.2929910910e15 * t181 * t90 + 0.4879629976e15 * t68 * t207 + 0.2664291701e15 * t138 * t361 + 0.9444444500e18 * t181 * t138 + 0.7580281461e13 * t367 * t138 + 0.5833333338e18 * t204 * t138 + 0.2460317400e18 * t181 * t64 + 0.200000e6 * t374 - 0.200000e6 * t69 + 0.100000000e9 * t24 + 0.2222222150e18 * A * t7 * t9 - 0.1944444438e18 * t381 * T - 0.3224206410e17 * t281 * t18 - 0.6398809530e17 * t24 * u * T - 0.1755952430e17 * t217 * t18 - 0.1230158726e18 * t3 * t7 * t9 + 0.3224206250e17 * A * t13 * t18; |
|---|
| 4326 | phydbl t444 = 0.1944444429e18 * t57 * u * T - 0.1755952280e17 * t3 * t13 * t18 + 0.4894179970e17 * t57 * t7 * t9 - 0.3339945030e16 * t285 * t19 - 0.4894180056e17 * t110 * t9 - 0.4722222240e18 * t134 * T + 0.8333333350e18 * A * u * T - 0.8333333400e18 * t118 * T + 0.3339946425e16 * A * t14 * t19 - 0.6398809540e17 * t58 * u * T + 0.4100529100e16 * t85 * t7 * t9 - 0.1464959090e15 * t3 * t88 * t89 + 0.6839256369e15 * t57 * t14 * t19 - 0.4238315719e16 * t78 * u * T - 0.1897556340e14 * t293 * t76 - 0.4238315750e16 * t162 * u * T - 0.2089971880e16 * t24 * t13 * t18; |
|---|
| 4327 | phydbl t448 = t34 * t14; |
|---|
| 4328 | phydbl t478 = t360 * t3; |
|---|
| 4329 | phydbl t481 = t162 * t58; |
|---|
| 4330 | phydbl t490 = -0.6839241185e15 * t448 * t19 - 0.4100529178e16 * t25 * t7 * t9 - 0.1464966800e15 * t236 * t89 + 0.1769179920e17 * t85 * u * T - 0.1797238280e16 * t3 * t14 * t19 + 0.2747601900e15 * A * t88 * t89 - 0.1547619080e17 * t58 * t7 * t9 + 0.6812170220e16 * t57 * t13 * t18 - 0.2747571750e15 * t289 * t89 - 0.1547619200e17 * t24 * t7 * t9 - 0.20000000e8 * t25 - 0.30000000e8 * t85 - 0.2114391104e15 * t138 * t478 - 0.9867158400e15 * t138 * t481 + 0.2050264696e17 * t200 * t64 + 0.2542989412e17 * t252 * t138 - 0.6357473500e17 * t240 * t138; |
|---|
| 4331 | phydbl t507 = t59 * B; |
|---|
| 4332 | phydbl t510 = t12 * t59; |
|---|
| 4333 | phydbl t513 = B * t69; |
|---|
| 4334 | phydbl t520 = t25 * t78; |
|---|
| 4335 | phydbl t523 = t25 * t85; |
|---|
| 4336 | phydbl t530 = 0.2508160000e12 * t84 * t190 - 0.1466339000e14 * t72 * t184 + 0.4976610000e13 * t90 * t193 + 0.3270245000e14 * t68 * t150 - 0.3450000000e11 * t100 * t187 - 0.1291300000e13 * t77 * t249 + 0.2074777207e15 * t64 * t142 - 0.7261721108e15 * t64 * t139 - 0.5186943795e14 * t64 * t507 - 0.2114391078e15 * t138 * t510 + 0.4698646924e14 * t138 * t513 + 0.3070300000e10 * t94 * t181 - 0.4841145120e15 * t64 * t269 - 0.3183718246e15 * t520 * t138 + 0.2210116600e15 * t523 * t64 - 0.8241728800e14 * t139 * t68 + 0.2003340000e14 * t156 * t72; |
|---|
| 4337 | phydbl t553 = t19 * t85; |
|---|
| 4338 | phydbl t559 = -0.3232400000e13 * t172 * t90 + 0.3196000000e12 * t252 * t77 + 0.4841147005e15 * t64 * t272 + 0.7261720740e15 * t64 * t297 - 0.1626544080e15 * t281 * t115 + 0.4303517000e13 * t293 * t123 - 0.3000000e7 * t360 - 0.3000000e7 * t59 - 0.17000000e8 * t196 - 0.4399012000e14 * t72 * t172 - 0.1144586200e15 * t68 * t163 - 0.48000e5 * t366 - 0.20000e5 * t65 + 0.2003375000e14 * t448 * t553 - 0.10000000e8 * t78 - 0.50000000e8 * t162 + 0.8000000e7 * t91; |
|---|
| 4339 | phydbl t561 = t59 * t58; |
|---|
| 4340 | phydbl t574 = A * t82; |
|---|
| 4341 | phydbl t577 = t85 * t13; |
|---|
| 4342 | phydbl t580 = t3 * t75; |
|---|
| 4343 | phydbl t586 = t58 * t14; |
|---|
| 4344 | phydbl t589 = t57 * t88; |
|---|
| 4345 | phydbl t602 = -0.100000e6 * t367 - 0.1420e4 * t561 - 0.4325330800e13 * t510 * t68 - 0.1797236000e16 * t232 * t19 - 0.6812172380e16 * t114 * t18 - 0.1769179896e17 * t25 * u * T - 0.1230158720e18 * t213 * t9 + 0.1136992000e13 * t574 * t83 + 0.5357388956e15 * t577 * t18 - 0.1004312000e14 * t580 * t76 + 0.8983686054e15 * t91 * u * T - 0.2049036000e15 * t586 * t19 + 0.5490979267e14 * t589 * t89 - 0.9402891770e15 * t78 * t7 * t9 - 0.1136811000e13 * t311 * t83 - 0.5490960000e14 * t106 * t89 - 0.9402891530e15 * t162 * t7 * t9; |
|---|
| 4346 | phydbl t644 = -0.2049024100e15 * t24 * t14 * t19 - 0.5357393770e15 * t25 * t13 * t18 - 0.8983686060e15 * t196 * u * T - 0.1004260240e14 * t224 * t76 + 0.1897544000e14 * A * t75 * t76 - 0.2089971420e16 * t58 * t13 * t18 - 0.5984000000e12 * t84 * t12 - 0.1907300810e15 * t64 * t196 - 0.5114985270e14 * t72 * t25 - 0.1614025000e14 * t90 * t24 - 0.1186717058e15 * t68 * t162 - 0.3719300000e13 * t77 * t34 - 0.6049800000e11 * t100 * B - 0.1186716997e15 * t68 * t78 + 0.3719150000e13 * t77 * t57 - 0.1614009620e14 * t90 * t58 + 0.1907300700e15 * t64 * t91; |
|---|
| 4347 | phydbl t655 = t360 * t34; |
|---|
| 4348 | phydbl t686 = -0.5983807300e12 * t84 * t3 + 0.5114970240e14 * t72 * t85 + 0.6059000000e11 * t100 * A - 0.1710641462e15 * t138 * t59 - 0.1710641438e15 * t138 * t360 - 0.6891165120e12 * t655 * u * T - 0.8770302200e12 * t366 * t7 * t9 - 0.6541040000e12 * t374 * t13 * t18 - 0.3577404000e12 * t360 * t14 * t19 - 0.1539200000e12 * t196 * t88 * t89 - 0.4698646953e13 * t138 * t65 - 0.4087803000e13 * t68 * t360 - 0.4698647004e13 * t138 * t366 - 0.5328500000e11 * t162 * t75 * t76 - 0.6280000000e11 * t84 * t24 - 0.2094778000e13 * t72 * t196 - 0.1159280000e11 * t100 * t34; |
|---|
| 4349 | phydbl t723 = -0.8294300000e12 * t90 * t162 + 0.2583700000e12 * t77 * t85 - 0.6265560000e11 * t84 * t58 + 0.1149330000e11 * t100 * t57 - 0.4087804000e13 * t68 * t59 - 0.5763269898e13 * t64 * t374 - 0.8293904000e12 * t90 * t78 - 0.2582655100e12 * t77 * t25 - 0.1521060000e10 * t94 * t12 - 0.1510800000e10 * t94 * t3 + 0.85420000e8 * t97 * A + 0.2094757500e13 * t72 * t91 - 0.78510000e8 * t97 * B + 0.5763268400e13 * t64 * t69 - 0.3476645600e14 * t64 * t360 - 0.2192000000e12 * t84 * t34 - 0.1481620000e11 * t25 * t82 * t83; |
|---|
| 4350 | phydbl t752 = A * t29; |
|---|
| 4351 | phydbl t760 = -0.1101512460e14 * t72 * t162 - 0.1076151000e13 * t77 * t24 - 0.2323633800e14 * t68 * t196 - 0.3942769100e13 * t90 * t25 - 0.3179650000e11 * t100 * t12 - 0.2960324185e14 * t138 * t374 - 0.1101515600e14 * t72 * t78 + 0.2192784000e12 * t84 * t57 - 0.3476645322e14 * t64 * t59 + 0.3942680000e13 * t90 * t85 - 0.1076127000e13 * t77 * t58 + 0.2323633627e14 * t68 * t91 - 0.2880000000e10 * t303 * t31 - 0.3137962000e11 * t100 * t3 + 0.2840510000e10 * t752 * t31 + 0.2960324165e14 * t138 * t69 - 0.9682000000e10 * t196 * t75 * t76; |
|---|
| 4352 | phydbl t765 = t360 * t24; |
|---|
| 4353 | phydbl t814 = -0.9396930200e11 * t765 * u * T - 0.9611875000e11 * t366 * t13 * t18 - 0.5556330000e11 * t374 * t14 * t19 - 0.1234481500e12 * t655 * t7 * t9 - 0.2563440000e11 * t360 * t88 * t89 - 0.2994200000e10 * t162 * t82 * t83 + 0.1234481600e12 * t60 * t7 * t9 - 0.2563300000e11 * t59 * t88 * t89 + 0.5556248000e11 * t69 * t14 * t19 - 0.9396930200e11 * t561 * u * T + 0.9689500000e10 * t91 * t75 * t76 - 0.9611880000e11 * t65 * t13 * t18 - 0.3021580000e10 * t78 * t82 * t83 + 0.763720000e9 * t85 * t15 * t20 - 0.129241000e9 * t58 * t29 * t31 + 0.7383500e7 * t57 * t35 * t37; |
|---|
| 4354 | phydbl t829 = t374 * t3; |
|---|
| 4355 | phydbl t842 = t374 * A; |
|---|
| 4356 | phydbl t853 = -0.5600000e7 * t3 * t16 * t21 - 0.3213600e7 * A * t40 * t42 - 0.5833333350e18 * t187 * t138 + 0.4304200000e13 * t77 * t166 + 0.1946921629e16 * t64 * t159 + 0.2559523820e18 * t190 * t138 - 0.3790140882e14 * t829 * t138 + 0.3511906000e17 * t181 * t68 + 0.2202988200e15 * t72 * t175 - 0.1468254070e18 * t187 * t64 - 0.3942732000e14 * t90 * t178 - 0.8132711000e15 * t68 * t257 + 0.8770302700e13 * t842 * t64 - 0.3839285591e18 * t210 * t138 + 0.1468253985e18 * t204 * t64 + 0.2559523810e18 * t166 * t138 + 0.1626542320e15 * t68 * t266; |
|---|
| 4357 | phydbl t871 = t360 * t57; |
|---|
| 4358 | phydbl t880 = t196 * t58; |
|---|
| 4359 | phydbl t891 = -0.1652248000e15 * t72 * t240 + 0.1946921488e16 * t64 * t156 - 0.2433651484e16 * t64 * t145 + 0.6609041000e14 * t72 * t252 + 0.2781316600e15 * t64 * t197 - 0.2043651325e17 * t187 * t68 + 0.3594474817e16 * t181 * t72 + 0.6190476200e17 * t190 * t64 + 0.1137042247e15 * t871 * t138 - 0.3946636500e14 * t478 * t64 - 0.1769179894e18 * t178 * t138 + 0.5886927000e13 * t361 * t68 - 0.2274084525e15 * t880 * t138 - 0.9285714360e17 * t210 * t64 + 0.2043651805e17 * t204 * t68 + 0.1769179900e18 * t221 * t138 - 0.8845899000e17 * t249 * t138; |
|---|
| 4360 | phydbl t898 = t162 * t85; |
|---|
| 4361 | phydbl t901 = t196 * t57; |
|---|
| 4362 | phydbl t928 = 0.8845899300e17 * t200 * t138 + 0.6190475974e17 * t166 * t64 + 0.2861967000e13 * t197 * t72 + 0.3183718369e15 * t898 * t138 + 0.1052436420e15 * t901 * t64 - 0.2354776200e14 * t300 * t68 + 0.2583300000e13 * t77 * t221 + 0.4399010000e14 * t72 * t207 - 0.3755200000e12 * t84 * t210 + 0.2509100000e12 * t84 * t166 + 0.5186945270e14 * t64 * t361 + 0.2542989379e17 * t193 * t138 - 0.2051769370e16 * t187 * t72 + 0.2289169200e15 * t68 * t159 + 0.2051768000e16 * t204 * t72 + 0.2289167900e15 * t68 * t156 - 0.1244097000e14 * t90 * t240; |
|---|
| 4363 | phydbl t947 = t34 * t91; |
|---|
| 4364 | phydbl t958 = t24 * t78; |
|---|
| 4365 | phydbl t967 = 0.1466349000e14 * t72 * t266 - 0.7331650000e14 * t72 * t257 - 0.2583029000e13 * t77 * t178 + 0.1658907000e14 * t90 * t175 - 0.1841763540e15 * t481 * t64 + 0.5494474200e14 * t272 * t68 - 0.4100529010e17 * t178 * t64 - 0.6357473383e17 * t169 * t138 + 0.5638376416e15 * t138 * t947 + 0.3270242900e14 * t68 * t197 + 0.4976387700e13 * t90 * t252 + 0.4100529000e17 * t221 * t64 - 0.2861462400e15 * t68 * t145 - 0.9867158433e15 * t138 * t958 + 0.8476631585e17 * t175 * t138 + 0.1184059034e16 * t138 * t523 + 0.8359888510e16 * t166 * t68; |
|---|
| 4366 | phydbl t978 = t65 * B; |
|---|
| 4367 | phydbl t985 = B * t60; |
|---|
| 4368 | phydbl t992 = t59 * t34; |
|---|
| 4369 | phydbl t995 = t24 * t59; |
|---|
| 4370 | phydbl t998 = t69 * t12; |
|---|
| 4371 | phydbl t1001 = t34 * t69; |
|---|
| 4372 | phydbl t1006 = 0.4698646863e14 * t138 * t842 - 0.1001659000e14 * t163 * t72 + 0.1077350000e13 * t266 * t90 + 0.5638376400e15 * t138 * t901 - 0.360000e6 * t880 + 0.10000e5 * t60 - 0.1357930100e13 * t978 * t64 + 0.9611860000e12 * t513 * t68 + 0.2050665000e12 * t150 * t90 + 0.1127631630e13 * t985 * t138 - 0.5000541000e12 * t507 * t72 + 0.2000230000e13 * t142 * t72 - 0.2036894700e14 * t992 * t64 - 0.4651480740e14 * t995 * t138 + 0.6789651000e13 * t998 * t64 + 0.2067324610e14 * t1001 * t138 + 0.1153425500e14 * t947 * t68; |
|---|
| 4373 | phydbl t1008 = t91 * t24; |
|---|
| 4374 | phydbl t1011 = t25 * t91; |
|---|
| 4375 | phydbl t1014 = t12 * t65; |
|---|
| 4376 | phydbl t1070 = 0.4073788600e14 * t1008 * t64 + 0.7442369200e14 * t1011 * t138 - 0.6201974310e13 * t1014 * t138 + 0.1809000000e11 * t85 * t82 * t83 * B + 0.7000817000e13 * t85 * t14 * t19 * t24 + 0.1435633000e13 * t85 * t88 * t89 * t34 + 0.2422191000e14 * t577 * t18 * t25 + 0.2034000000e12 * t85 * t75 * t76 * t12 - 0.54366000e8 * t3 * t35 * t37 * B - 0.4510900000e11 * t3 * t82 * t83 * t24 - 0.7466500000e10 * t3 * t15 * t20 * t34 - 0.2035185700e12 * t580 * t76 * t25 - 0.1040000000e10 * t3 * t29 * t31 * t12 - 0.4514750000e11 * t58 * t82 * t83 * t12 + 0.612330000e9 * t57 * t29 * t31 * B - 0.7000850000e13 * t586 * t19 * t25 - 0.3850000000e10 * t58 * t15 * t20 * B; |
|---|
| 4377 | phydbl t1124 = 0.7537400000e10 * t57 * t15 * t20 * t12 - 0.3386100000e12 * t58 * t75 * t76 * t34 - 0.1794360000e13 * t58 * t88 * t89 * t24 + 0.5995720000e11 * t57 * t82 * t83 * t34 + 0.3388054000e12 * t57 * t75 * t76 * t24 + 0.1435490000e13 * t589 * t89 * t25 + 0.16000000e8 * A * t16 * t21 * B + 0.3773240000e10 * A * t15 * t20 * t24 + 0.692700000e9 * t752 * t31 * t34 + 0.1795620000e11 * t574 * t83 * t25 + 0.79693000e8 * A * t35 * t37 * t12 - 0.1971335000e14 * t289 * t107 - 0.2074777361e15 * t64 * t300 + 0.8241726800e14 * t297 * t68 - 0.2504208000e14 * t145 * t72 + 0.2274084510e15 * t1008 * t138 - 0.1841763400e15 * t958 * t64; |
|---|
| 4378 | phydbl t1162 = 0.5386800000e13 * t263 * t90 - 0.7989000000e12 * t169 * t77 + 0.5641734828e16 * t193 * t64 + 0.7417430000e11 * t200 * t84 - 0.1137042238e15 * t381 * t119 + 0.8196118110e15 * t190 * t72 - 0.1647262473e15 * t187 * t90 - 0.6288580100e16 * t184 * t138 + 0.2008619000e14 * t181 * t77 - 0.5357392640e16 * t178 * t68 - 0.6579000000e12 * t311 * t127 + 0.2781316526e15 * t8 * t111 + 0.1880578242e17 * t175 * t64 - 0.1886574102e17 * t172 * t138 - 0.1410433708e17 * t169 * t64 + 0.8196108200e15 * t166 * t72 - 0.1229418200e16 * t210 * t72; |
|---|
| 4379 | phydbl t1194 = 0.1886574129e17 * t207 * t138 + 0.1647291050e15 * t204 * t90 + 0.5357390500e16 * t221 * t68 - 0.1410433708e17 * t240 * t64 - 0.2678697000e16 * t249 * t68 + 0.5641735040e16 * t252 * t64 + 0.2678700000e16 * t200 * t68 + 0.3144290150e17 * t263 * t138 - 0.3144290124e17 * t257 * t138 + 0.6288580291e16 * t266 * t138 + 0.6609036000e14 * t285 * t553 + 0.6340000000e11 * t315 * t131 + 0.1000000e7 * t871 + 0.2300000e7 * t898 - 0.4000000e7 * t520 + 0.220000e6 * t162 * t91 - 0.140000e6 * t374 * t58; |
|---|
| 4380 | phydbl t1224 = -0.40000e5 * t366 * t57 - 0.180000e6 * t360 * t85 + 0.1000e4 * t655 * t3 + 0.990e3 * t765 * A - 0.211100e6 * t196 * t78 - 0.30000e5 * t65 * t34 + 0.133900e6 * t69 * t24 + 0.20860e5 * t60 * t12 + 0.254000e6 * t59 * t25 - 0.1020e4 * t561 * B + 0.600000e6 * t995 - 0.20000e5 * t513 - 0.200000e6 * t1001 + 0.117000e6 * t1014 - 0.22790e5 * t985 - 0.28500e5 * t40 * t42 - 0.114000000e9 * t97; |
|---|
| 4381 | phydbl t1235 = t162 * t78; |
|---|
| 4382 | phydbl t1250 = t196 * t85; |
|---|
| 4383 | phydbl t1259 = t366 * t3; |
|---|
| 4384 | phydbl t1262 = -0.101e3 * t360 * t25 + 0.76e2 * t59 * t85 + 0.5703305000e14 * t898 * t64 - 0.7175350000e12 * t163 * t90 + 0.4667200000e13 * t272 * t72 - 0.8682763800e14 * t1235 * t138 - 0.4325349000e13 * t478 * t68 + 0.6776140000e11 * t266 * t77 - 0.2018495000e14 * t481 * t68 - 0.4073788100e14 * t880 * t64 + 0.1153425000e14 * t901 * t68 + 0.2050823000e12 * t197 * t90 + 0.7442369200e14 * t1250 * t138 - 0.2000230000e13 * t300 * t72 + 0.5000544000e12 * t361 * t72 - 0.6789650400e13 * t829 * t64 - 0.6201974000e13 * t1259 * t138; |
|---|
| 4385 | phydbl t1277 = t360 * t58; |
|---|
| 4386 | phydbl t1296 = 0.2036894600e14 * t871 * t64 + 0.2067324700e14 * t374 * t57 * t138 + 0.9611900000e12 * t842 * t68 + 0.1357930000e13 * t367 * t64 + 0.1127631640e13 * t655 * A * t138 - 0.4651480610e14 * t1277 * t138 - 0.6775000000e11 * t184 * t77 - 0.2018493300e14 * t958 * t68 - 0.4667170000e13 * t269 * t72 - 0.5703305700e14 * t520 * t64 - 0.7176804000e12 * t153 * t90 + 0.300000e6 * t978 - 0.10000e5 * t655 - 0.1900e4 * t765 - 0.170000e6 * t829 - 0.2747570000e15 * t90 - 0.3224206200e17 * t68; |
|---|
| 4387 | phydbl t1314 = 0.1000000000e10 * t210 - 0.5246000e7 * t103 - 0.2222222269e18 * t64 - 0.100000000e9 * t200 + 0.400000000e9 * t249 - 0.3339948000e16 * t72 - 0.30000e5 * t1259 + 0.1000000000e10 * t221 - 0.200000000e9 * t252 - 0.200000000e9 * t169 - 0.100000000e9 * t193 + 0.270000000e9 * t240 + 0.100000000e9 * t257 - 0.100000000e9 * t263 - 0.210000000e9 * t207 + 0.40000000e8 * t172 + 0.20000000e8 * t266; |
|---|
| 4388 | phydbl t1333 = 0.30000000e8 * t184 - 0.1897466160e14 * t77 - 0.1137580000e13 * t84 + 0.5000000e7 * t150 - 0.1000000e7 * t947 - 0.25000000e8 * t481 + 0.510000e6 * t1277 - 0.20000000e8 * t145 - 0.200000e6 * t478 + 0.1000000e7 * t901 + 0.20000000e8 * t163 - 0.130000000e9 * t156 - 0.700000e6 * t842 - 0.25000000e8 * t523 + 0.31000000e8 * t958 + 0.20000000e8 * t153 - 0.6034000000e11 * t100; |
|---|
| 4389 | phydbl t1354 = 0.1000000e7 * t1250 - 0.2889000000e10 * t94 - 0.600000e6 * t1235 - 0.8333333300e18 * t138 + 0.700000e6 * t1011 - 0.351766e6 * t15 * t88 * t20 * t89 + 0.29000000e8 * t139 - 0.1000000e7 * t361 - 0.2000000e7 * t300 + 0.20000000e8 * t272 - 0.70000000e8 * t297 + 0.21000000e8 * t142 - 0.1000000e7 * t507 - 0.994000e6 * t992 - 0.130000e6 * t998 - 0.1000000000e10 * t34 - 0.3000000000e10 * t3; |
|---|
| 4390 | *var = -0.1000000000e-18 * t2 * (t891 + t853 + t1296 + t81 + t1070 + t928 + t1314 + t148 + t760 + t203 + t814 + t1224 + t686 + t1354 + t1162 + t321 + t1006 + t559 + t530 + t967 + t260 + t397 + t1262 + t644 + t1333 + t1194 + t354 + t602 + t1124 + t723 + t490 + t444); |
|---|
| 4391 | |
|---|
| 4392 | } |
|---|
| 4393 | |
|---|
| 4394 | ////////////////////////////////////////////////////////////// |
|---|
| 4395 | ////////////////////////////////////////////////////////////// |
|---|
| 4396 | |
|---|
| 4397 | int Sample_i_With_Proba_pi(phydbl *pi, int len) |
|---|
| 4398 | { |
|---|
| 4399 | phydbl *cum_pi; |
|---|
| 4400 | int i; |
|---|
| 4401 | phydbl u; |
|---|
| 4402 | |
|---|
| 4403 | cum_pi = (phydbl *)mCalloc(len,sizeof(phydbl)); |
|---|
| 4404 | |
|---|
| 4405 | For(i,len) cum_pi[i] = pi[i]; |
|---|
| 4406 | for(i=1;i<len;i++) cum_pi[i] += cum_pi[i-1]; |
|---|
| 4407 | |
|---|
| 4408 | if((cum_pi[i-1] > 1. + 1.E-10) || (cum_pi[i-1] < 1. - 1.E-10)) |
|---|
| 4409 | { |
|---|
| 4410 | PhyML_Printf("\n== Sum of probabilities is different from 1.0."); |
|---|
| 4411 | PhyML_Printf("\n== Err. in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 4412 | Exit("\n"); |
|---|
| 4413 | } |
|---|
| 4414 | |
|---|
| 4415 | i = 0; |
|---|
| 4416 | u = Uni(); |
|---|
| 4417 | For(i,len) if(cum_pi[i] > u) break; |
|---|
| 4418 | |
|---|
| 4419 | if(i == len) |
|---|
| 4420 | { |
|---|
| 4421 | PhyML_Printf("\n== Len = %d",len); |
|---|
| 4422 | PhyML_Printf("\n== Err. in file %s at line %d\n",__FILE__,__LINE__); |
|---|
| 4423 | Exit("\n"); |
|---|
| 4424 | } |
|---|
| 4425 | Free(cum_pi); |
|---|
| 4426 | |
|---|
| 4427 | return(i); |
|---|
| 4428 | } |
|---|
| 4429 | |
|---|
| 4430 | ////////////////////////////////////////////////////////////// |
|---|
| 4431 | ////////////////////////////////////////////////////////////// |
|---|
| 4432 | |
|---|
| 4433 | // Return the value y such that Prob(x<y) = p |
|---|
| 4434 | phydbl Quantile(phydbl *x, int len, phydbl p) |
|---|
| 4435 | { |
|---|
| 4436 | phydbl *y,q; |
|---|
| 4437 | int i; |
|---|
| 4438 | int swap; |
|---|
| 4439 | phydbl buff; |
|---|
| 4440 | |
|---|
| 4441 | y = (phydbl *)mCalloc(len,sizeof(phydbl)); |
|---|
| 4442 | For(i,len) y[i] = x[i]; |
|---|
| 4443 | |
|---|
| 4444 | do |
|---|
| 4445 | { |
|---|
| 4446 | swap = NO; |
|---|
| 4447 | For(i,len-1) |
|---|
| 4448 | { |
|---|
| 4449 | if(y[i+1] < y[i]) |
|---|
| 4450 | { |
|---|
| 4451 | swap = YES; |
|---|
| 4452 | |
|---|
| 4453 | buff = y[i+1]; |
|---|
| 4454 | y[i+1] = y[i]; |
|---|
| 4455 | y[i] = buff; |
|---|
| 4456 | } |
|---|
| 4457 | } |
|---|
| 4458 | } |
|---|
| 4459 | while(swap == YES); |
|---|
| 4460 | |
|---|
| 4461 | q = y[(int)((len-1)*p)]; |
|---|
| 4462 | |
|---|
| 4463 | Free(y); |
|---|
| 4464 | |
|---|
| 4465 | return(q); |
|---|
| 4466 | |
|---|
| 4467 | } |
|---|
| 4468 | |
|---|
| 4469 | |
|---|
| 4470 | ////////////////////////////////////////////////////////////// |
|---|
| 4471 | ////////////////////////////////////////////////////////////// |
|---|
| 4472 | |
|---|
| 4473 | // Return p such that Prob(x<z) = p |
|---|
| 4474 | phydbl Prob(phydbl *x, int len, phydbl z) |
|---|
| 4475 | { |
|---|
| 4476 | int i; |
|---|
| 4477 | phydbl hit; |
|---|
| 4478 | |
|---|
| 4479 | hit = 0.; |
|---|
| 4480 | For(i,len) if(x[i] < z) hit+=1.; |
|---|
| 4481 | |
|---|
| 4482 | return(hit/(phydbl)len); |
|---|
| 4483 | |
|---|
| 4484 | } |
|---|
| 4485 | |
|---|
| 4486 | ////////////////////////////////////////////////////////////// |
|---|
| 4487 | ////////////////////////////////////////////////////////////// |
|---|
| 4488 | |
|---|
| 4489 | // Return x where mu is the first moment of the normal density |
|---|
| 4490 | // and x is the value such that f(x;mu,sigma)=y |
|---|
| 4491 | |
|---|
| 4492 | phydbl Inverse_Truncated_Normal(phydbl y, phydbl mu, phydbl sigma, phydbl lim_inf, phydbl lim_sup) |
|---|
| 4493 | { |
|---|
| 4494 | phydbl p_inf, p_sup; |
|---|
| 4495 | |
|---|
| 4496 | p_inf = Pnorm(lim_inf,mu,sigma); |
|---|
| 4497 | p_sup = Pnorm(lim_sup,mu,sigma); |
|---|
| 4498 | |
|---|
| 4499 | /* return(mu + sigma * SQRT(-LOG( y * y * (p_sup - p_inf) * (p_sup - p_inf) * 2 * PI * sigma * sigma))); */ |
|---|
| 4500 | return(mu + sigma * SQRT(-LOG( y * y * (p_sup - p_inf) * (p_sup - p_inf) * 2. * PI * sigma * sigma))); |
|---|
| 4501 | } |
|---|
| 4502 | |
|---|
| 4503 | ////////////////////////////////////////////////////////////// |
|---|
| 4504 | ////////////////////////////////////////////////////////////// |
|---|
| 4505 | // Returns a vector with a permutation of all the integer from 0 |
|---|
| 4506 | // to len-1. |
|---|
| 4507 | |
|---|
| 4508 | int *Permutate(int len) |
|---|
| 4509 | { |
|---|
| 4510 | int i,pos,tmp; |
|---|
| 4511 | int *x; |
|---|
| 4512 | |
|---|
| 4513 | x = (int *)mCalloc(len,sizeof(int)); |
|---|
| 4514 | |
|---|
| 4515 | For(i,len) x[i] = i; |
|---|
| 4516 | |
|---|
| 4517 | For(i,len) |
|---|
| 4518 | { |
|---|
| 4519 | pos = Rand_Int(0,len-1); |
|---|
| 4520 | |
|---|
| 4521 | tmp = x[i]; |
|---|
| 4522 | x[i] = x[pos]; |
|---|
| 4523 | x[pos] = tmp; |
|---|
| 4524 | } |
|---|
| 4525 | |
|---|
| 4526 | return(x); |
|---|
| 4527 | } |
|---|
| 4528 | |
|---|
| 4529 | ////////////////////////////////////////////////////////////// |
|---|
| 4530 | ////////////////////////////////////////////////////////////// |
|---|
| 4531 | // Returns the p-value for the Mantel test of correlation between |
|---|
| 4532 | // matrices x and y. |
|---|
| 4533 | |
|---|
| 4534 | phydbl Mantel(phydbl *x, phydbl *y, int nrow, int ncol) |
|---|
| 4535 | { |
|---|
| 4536 | |
|---|
| 4537 | phydbl obs_stat; // Value of the statistic on the observed data |
|---|
| 4538 | phydbl mc_stat; // Value of the statistics on the Monte Carlo generated data |
|---|
| 4539 | int N; |
|---|
| 4540 | phydbl sumx, sumy, sumxy, sumxx, sumyy; |
|---|
| 4541 | int i,j,k; |
|---|
| 4542 | int npermut; |
|---|
| 4543 | int *permut; |
|---|
| 4544 | phydbl p_val; |
|---|
| 4545 | |
|---|
| 4546 | N = nrow*ncol; |
|---|
| 4547 | |
|---|
| 4548 | sumx = .0; |
|---|
| 4549 | For(i,N) sumx += x[i]; |
|---|
| 4550 | |
|---|
| 4551 | sumy = .0; |
|---|
| 4552 | For(i,N) sumy += y[i]; |
|---|
| 4553 | |
|---|
| 4554 | sumxx = .0; |
|---|
| 4555 | For(i,N) sumxx += x[i]*x[i]; |
|---|
| 4556 | |
|---|
| 4557 | sumyy = .0; |
|---|
| 4558 | For(i,N) sumyy += y[i]*y[i]; |
|---|
| 4559 | |
|---|
| 4560 | sumxy = .0; |
|---|
| 4561 | For(i,N) sumxy += x[i]*y[i]; |
|---|
| 4562 | |
|---|
| 4563 | obs_stat = (N * sumxy - sumx * sumy) / (SQRT((N-1)*sumxx - (sumx/N)*(sumx/N)) * SQRT((N-1)*sumyy - (sumy/N)*(sumy/N))); |
|---|
| 4564 | |
|---|
| 4565 | npermut = 1000; |
|---|
| 4566 | p_val = 0.0; |
|---|
| 4567 | For(k,npermut) |
|---|
| 4568 | { |
|---|
| 4569 | permut = Permutate(nrow); |
|---|
| 4570 | |
|---|
| 4571 | sumxy = .0; |
|---|
| 4572 | For(i,nrow) |
|---|
| 4573 | { |
|---|
| 4574 | For(j,ncol) |
|---|
| 4575 | { |
|---|
| 4576 | sumxy += x[i*ncol+j] * y[permut[i]*ncol+permut[j]]; |
|---|
| 4577 | } |
|---|
| 4578 | } |
|---|
| 4579 | |
|---|
| 4580 | mc_stat = (N * sumxy - sumx * sumy) / (SQRT((N-1)*sumxx - (sumx/N)*(sumx/N)) * SQRT((N-1)*sumyy - (sumy/N)*(sumy/N))); |
|---|
| 4581 | |
|---|
| 4582 | Free(permut); |
|---|
| 4583 | |
|---|
| 4584 | if(mc_stat > obs_stat) p_val += 1.; |
|---|
| 4585 | } |
|---|
| 4586 | |
|---|
| 4587 | return(p_val / (phydbl)npermut); |
|---|
| 4588 | |
|---|
| 4589 | } |
|---|
| 4590 | |
|---|
| 4591 | ////////////////////////////////////////////////////////////// |
|---|
| 4592 | ////////////////////////////////////////////////////////////// |
|---|
| 4593 | |
|---|
| 4594 | phydbl Weighted_Mean(phydbl *x, phydbl *w, int l) |
|---|
| 4595 | { |
|---|
| 4596 | int i; |
|---|
| 4597 | phydbl wm; |
|---|
| 4598 | wm = .0; |
|---|
| 4599 | For(i,l) wm += x[i]*w[i]; |
|---|
| 4600 | return(wm); |
|---|
| 4601 | } |
|---|
| 4602 | |
|---|
| 4603 | |
|---|
| 4604 | |
|---|
| 4605 | |
|---|
| 4606 | |
|---|
| 4607 | |
|---|
| 4608 | |
|---|
| 4609 | |
|---|
| 4610 | |
|---|
| 4611 | |
|---|
| 4612 | |
|---|
| 4613 | |
|---|
| 4614 | |
|---|
| 4615 | |
|---|
| 4616 | |
|---|
| 4617 | |
|---|
| 4618 | |
|---|
| 4619 | |
|---|
| 4620 | |
|---|