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 | |
---|