imach/src/imach.c - view

File: [Local Repository] / imach / src / imach.c
Revision 1.196: download - view: text, annotated - select for diffs
Tue Aug 18 23:17:52 2015 UTC (8 years, 10 months ago) by brouard
Branches: MAIN
CVS tags: HEAD

Summary: 0.98q5

1: /* $Id: imach.c,v 1.196 2015/08/18 23:17:52 brouard Exp $ 2: $State: Exp $ 3: $Log: imach.c,v $ 4: Revision 1.196 2015/08/18 23:17:52 brouard 5: Summary: 0.98q5 6: 7: Revision 1.195 2015/08/18 16:28:39 brouard 8: Summary: Adding a hack for testing purpose 9: 10: After reading the title, ftol and model lines, if the comment line has 11: a q, starting with #q, the answer at the end of the run is quit. It 12: permits to run test files in batch with ctest. The former workaround was 13: $ echo q | imach foo.imach 14: 15: Revision 1.194 2015/08/18 13:32:00 brouard 16: Summary: Adding error when the covariance matrix doesn't contain the exact number of lines required by the model line. 17: 18: Revision 1.193 2015/08/04 07:17:42 brouard 19: Summary: 0.98q4 20: 21: Revision 1.192 2015/07/16 16:49:02 brouard 22: Summary: Fixing some outputs 23: 24: Revision 1.191 2015/07/14 10:00:33 brouard 25: Summary: Some fixes 26: 27: Revision 1.190 2015/05/05 08:51:13 brouard 28: Summary: Adding digits in output parameters (7 digits instead of 6) 29: 30: Fix 1+age+. 31: 32: Revision 1.189 2015/04/30 14:45:16 brouard 33: Summary: 0.98q2 34: 35: Revision 1.188 2015/04/30 08:27:53 brouard 36: *** empty log message *** 37: 38: Revision 1.187 2015/04/29 09:11:15 brouard 39: *** empty log message *** 40: 41: Revision 1.186 2015/04/23 12:01:52 brouard 42: Summary: V1*age is working now, version 0.98q1 43: 44: Some codes had been disabled in order to simplify and Vn*age was 45: working in the optimization phase, ie, giving correct MLE parameters, 46: but, as usual, outputs were not correct and program core dumped. 47: 48: Revision 1.185 2015/03/11 13:26:42 brouard 49: Summary: Inclusion of compile and links command line for Intel Compiler 50: 51: Revision 1.184 2015/03/11 11:52:39 brouard 52: Summary: Back from Windows 8. Intel Compiler 53: 54: Revision 1.183 2015/03/10 20:34:32 brouard 55: Summary: 0.98q0, trying with directest, mnbrak fixed 56: 57: We use directest instead of original Powell test; probably no 58: incidence on the results, but better justifications; 59: We fixed Numerical Recipes mnbrak routine which was wrong and gave 60: wrong results. 61: 62: Revision 1.182 2015/02/12 08:19:57 brouard 63: Summary: Trying to keep directest which seems simpler and more general 64: Author: Nicolas Brouard 65: 66: Revision 1.181 2015/02/11 23:22:24 brouard 67: Summary: Comments on Powell added 68: 69: Author: 70: 71: Revision 1.180 2015/02/11 17:33:45 brouard 72: Summary: Finishing move from main to function (hpijx and prevalence_limit) 73: 74: Revision 1.179 2015/01/04 09:57:06 brouard 75: Summary: back to OS/X 76: 77: Revision 1.178 2015/01/04 09:35:48 brouard 78: *** empty log message *** 79: 80: Revision 1.177 2015/01/03 18:40:56 brouard 81: Summary: Still testing ilc32 on OSX 82: 83: Revision 1.176 2015/01/03 16:45:04 brouard 84: *** empty log message *** 85: 86: Revision 1.175 2015/01/03 16:33:42 brouard 87: *** empty log message *** 88: 89: Revision 1.174 2015/01/03 16:15:49 brouard 90: Summary: Still in cross-compilation 91: 92: Revision 1.173 2015/01/03 12:06:26 brouard 93: Summary: trying to detect cross-compilation 94: 95: Revision 1.172 2014/12/27 12:07:47 brouard 96: Summary: Back from Visual Studio and Intel, options for compiling for Windows XP 97: 98: Revision 1.171 2014/12/23 13:26:59 brouard 99: Summary: Back from Visual C 100: 101: Still problem with utsname.h on Windows 102: 103: Revision 1.170 2014/12/23 11:17:12 brouard 104: Summary: Cleaning some \%% back to %% 105: 106: The escape was mandatory for a specific compiler (which one?), but too many warnings. 107: 108: Revision 1.169 2014/12/22 23:08:31 brouard 109: Summary: 0.98p 110: 111: Outputs some informations on compiler used, OS etc. Testing on different platforms. 112: 113: Revision 1.168 2014/12/22 15:17:42 brouard 114: Summary: update 115: 116: Revision 1.167 2014/12/22 13:50:56 brouard 117: Summary: Testing uname and compiler version and if compiled 32 or 64 118: 119: Testing on Linux 64 120: 121: Revision 1.166 2014/12/22 11:40:47 brouard 122: *** empty log message *** 123: 124: Revision 1.165 2014/12/16 11:20:36 brouard 125: Summary: After compiling on Visual C 126: 127: * imach.c (Module): Merging 1.61 to 1.162 128: 129: Revision 1.164 2014/12/16 10:52:11 brouard 130: Summary: Merging with Visual C after suppressing some warnings for unused variables. Also fixing Saito's bug 0.98Xn 131: 132: * imach.c (Module): Merging 1.61 to 1.162 133: 134: Revision 1.163 2014/12/16 10:30:11 brouard 135: * imach.c (Module): Merging 1.61 to 1.162 136: 137: Revision 1.162 2014/09/25 11:43:39 brouard 138: Summary: temporary backup 0.99! 139: 140: Revision 1.1 2014/09/16 11:06:58 brouard 141: Summary: With some code (wrong) for nlopt 142: 143: Author: 144: 145: Revision 1.161 2014/09/15 20:41:41 brouard 146: Summary: Problem with macro SQR on Intel compiler 147: 148: Revision 1.160 2014/09/02 09:24:05 brouard 149: *** empty log message *** 150: 151: Revision 1.159 2014/09/01 10:34:10 brouard 152: Summary: WIN32 153: Author: Brouard 154: 155: Revision 1.158 2014/08/27 17:11:51 brouard 156: *** empty log message *** 157: 158: Revision 1.157 2014/08/27 16:26:55 brouard 159: Summary: Preparing windows Visual studio version 160: Author: Brouard 161: 162: In order to compile on Visual studio, time.h is now correct and time_t 163: and tm struct should be used. difftime should be used but sometimes I 164: just make the differences in raw time format (time(&now). 165: Trying to suppress #ifdef LINUX 166: Add xdg-open for __linux in order to open default browser. 167: 168: Revision 1.156 2014/08/25 20:10:10 brouard 169: *** empty log message *** 170: 171: Revision 1.155 2014/08/25 18:32:34 brouard 172: Summary: New compile, minor changes 173: Author: Brouard 174: 175: Revision 1.154 2014/06/20 17:32:08 brouard 176: Summary: Outputs now all graphs of convergence to period prevalence 177: 178: Revision 1.153 2014/06/20 16:45:46 brouard 179: Summary: If 3 live state, convergence to period prevalence on same graph 180: Author: Brouard 181: 182: Revision 1.152 2014/06/18 17:54:09 brouard 183: Summary: open browser, use gnuplot on same dir than imach if not found in the path 184: 185: Revision 1.151 2014/06/18 16:43:30 brouard 186: *** empty log message *** 187: 188: Revision 1.150 2014/06/18 16:42:35 brouard 189: Summary: If gnuplot is not in the path try on same directory than imach binary (OSX) 190: Author: brouard 191: 192: Revision 1.149 2014/06/18 15:51:14 brouard 193: Summary: Some fixes in parameter files errors 194: Author: Nicolas Brouard 195: 196: Revision 1.148 2014/06/17 17:38:48 brouard 197: Summary: Nothing new 198: Author: Brouard 199: 200: Just a new packaging for OS/X version 0.98nS 201: 202: Revision 1.147 2014/06/16 10:33:11 brouard 203: *** empty log message *** 204: 205: Revision 1.146 2014/06/16 10:20:28 brouard 206: Summary: Merge 207: Author: Brouard 208: 209: Merge, before building revised version. 210: 211: Revision 1.145 2014/06/10 21:23:15 brouard 212: Summary: Debugging with valgrind 213: Author: Nicolas Brouard 214: 215: Lot of changes in order to output the results with some covariates 216: After the Edimburgh REVES conference 2014, it seems mandatory to 217: improve the code. 218: No more memory valgrind error but a lot has to be done in order to 219: continue the work of splitting the code into subroutines. 220: Also, decodemodel has been improved. Tricode is still not 221: optimal. nbcode should be improved. Documentation has been added in 222: the source code. 223: 224: Revision 1.143 2014/01/26 09:45:38 brouard 225: Summary: Version 0.98nR (to be improved, but gives same optimization results as 0.98k. Nice, promising 226: 227: * imach.c (Module): Trying to merge old staffs together while being at Tokyo. Not tested... 228: (Module): Version 0.98nR Running ok, but output format still only works for three covariates. 229: 230: Revision 1.142 2014/01/26 03:57:36 brouard 231: Summary: gnuplot changed plot w l 1 has to be changed to plot w l lt 2 232: 233: * imach.c (Module): Trying to merge old staffs together while being at Tokyo. Not tested... 234: 235: Revision 1.141 2014/01/26 02:42:01 brouard 236: * imach.c (Module): Trying to merge old staffs together while being at Tokyo. Not tested... 237: 238: Revision 1.140 2011/09/02 10:37:54 brouard 239: Summary: times.h is ok with mingw32 now. 240: 241: Revision 1.139 2010/06/14 07:50:17 brouard 242: After the theft of my laptop, I probably lost some lines of codes which were not uploaded to the CVS tree. 243: I remember having already fixed agemin agemax which are pointers now but not cvs saved. 244: 245: Revision 1.138 2010/04/30 18:19:40 brouard 246: *** empty log message *** 247: 248: Revision 1.137 2010/04/29 18:11:38 brouard 249: (Module): Checking covariates for more complex models 250: than V1+V2. A lot of change to be done. Unstable. 251: 252: Revision 1.136 2010/04/26 20:30:53 brouard 253: (Module): merging some libgsl code. Fixing computation 254: of likelione (using inter/intrapolation if mle = 0) in order to 255: get same likelihood as if mle=1. 256: Some cleaning of code and comments added. 257: 258: Revision 1.135 2009/10/29 15:33:14 brouard 259: (Module): Now imach stops if date of birth, at least year of birth, is not given. Some cleaning of the code. 260: 261: Revision 1.134 2009/10/29 13:18:53 brouard 262: (Module): Now imach stops if date of birth, at least year of birth, is not given. Some cleaning of the code. 263: 264: Revision 1.133 2009/07/06 10:21:25 brouard 265: just nforces 266: 267: Revision 1.132 2009/07/06 08:22:05 brouard 268: Many tings 269: 270: Revision 1.131 2009/06/20 16:22:47 brouard 271: Some dimensions resccaled 272: 273: Revision 1.130 2009/05/26 06:44:34 brouard 274: (Module): Max Covariate is now set to 20 instead of 8. A 275: lot of cleaning with variables initialized to 0. Trying to make 276: V2+V3*age+V1+V4 strb=V3*age+V1+V4 working better. 277: 278: Revision 1.129 2007/08/31 13:49:27 lievre 279: Modification of the way of exiting when the covariate is not binary in order to see on the window the error message before exiting 280: 281: Revision 1.128 2006/06/30 13:02:05 brouard 282: (Module): Clarifications on computing e.j 283: 284: Revision 1.127 2006/04/28 18:11:50 brouard 285: (Module): Yes the sum of survivors was wrong since 286: imach-114 because nhstepm was no more computed in the age 287: loop. Now we define nhstepma in the age loop. 288: (Module): In order to speed up (in case of numerous covariates) we 289: compute health expectancies (without variances) in a first step 290: and then all the health expectancies with variances or standard 291: deviation (needs data from the Hessian matrices) which slows the 292: computation. 293: In the future we should be able to stop the program is only health 294: expectancies and graph are needed without standard deviations. 295: 296: Revision 1.126 2006/04/28 17:23:28 brouard 297: (Module): Yes the sum of survivors was wrong since 298: imach-114 because nhstepm was no more computed in the age 299: loop. Now we define nhstepma in the age loop. 300: Version 0.98h 301: 302: Revision 1.125 2006/04/04 15:20:31 lievre 303: Errors in calculation of health expectancies. Age was not initialized. 304: Forecasting file added. 305: 306: Revision 1.124 2006/03/22 17:13:53 lievre 307: Parameters are printed with %lf instead of %f (more numbers after the comma). 308: The log-likelihood is printed in the log file 309: 310: Revision 1.123 2006/03/20 10:52:43 brouard 311: * imach.c (Module): <title> changed, corresponds to .htm file 312: name. <head> headers where missing. 313: 314: * imach.c (Module): Weights can have a decimal point as for 315: English (a comma might work with a correct LC_NUMERIC environment, 316: otherwise the weight is truncated). 317: Modification of warning when the covariates values are not 0 or 318: 1. 319: Version 0.98g 320: 321: Revision 1.122 2006/03/20 09:45:41 brouard 322: (Module): Weights can have a decimal point as for 323: English (a comma might work with a correct LC_NUMERIC environment, 324: otherwise the weight is truncated). 325: Modification of warning when the covariates values are not 0 or 326: 1. 327: Version 0.98g 328: 329: Revision 1.121 2006/03/16 17:45:01 lievre 330: * imach.c (Module): Comments concerning covariates added 331: 332: * imach.c (Module): refinements in the computation of lli if 333: status=-2 in order to have more reliable computation if stepm is 334: not 1 month. Version 0.98f 335: 336: Revision 1.120 2006/03/16 15:10:38 lievre 337: (Module): refinements in the computation of lli if 338: status=-2 in order to have more reliable computation if stepm is 339: not 1 month. Version 0.98f 340: 341: Revision 1.119 2006/03/15 17:42:26 brouard 342: (Module): Bug if status = -2, the loglikelihood was 343: computed as likelihood omitting the logarithm. Version O.98e 344: 345: Revision 1.118 2006/03/14 18:20:07 brouard 346: (Module): varevsij Comments added explaining the second 347: table of variances if popbased=1 . 348: (Module): Covariances of eij, ekl added, graphs fixed, new html link. 349: (Module): Function pstamp added 350: (Module): Version 0.98d 351: 352: Revision 1.117 2006/03/14 17:16:22 brouard 353: (Module): varevsij Comments added explaining the second 354: table of variances if popbased=1 . 355: (Module): Covariances of eij, ekl added, graphs fixed, new html link. 356: (Module): Function pstamp added 357: (Module): Version 0.98d 358: 359: Revision 1.116 2006/03/06 10:29:27 brouard 360: (Module): Variance-covariance wrong links and 361: varian-covariance of ej. is needed (Saito). 362: 363: Revision 1.115 2006/02/27 12:17:45 brouard 364: (Module): One freematrix added in mlikeli! 0.98c 365: 366: Revision 1.114 2006/02/26 12:57:58 brouard 367: (Module): Some improvements in processing parameter 368: filename with strsep. 369: 370: Revision 1.113 2006/02/24 14:20:24 brouard 371: (Module): Memory leaks checks with valgrind and: 372: datafile was not closed, some imatrix were not freed and on matrix 373: allocation too. 374: 375: Revision 1.112 2006/01/30 09:55:26 brouard 376: (Module): Back to gnuplot.exe instead of wgnuplot.exe 377: 378: Revision 1.111 2006/01/25 20:38:18 brouard 379: (Module): Lots of cleaning and bugs added (Gompertz) 380: (Module): Comments can be added in data file. Missing date values 381: can be a simple dot '.'. 382: 383: Revision 1.110 2006/01/25 00:51:50 brouard 384: (Module): Lots of cleaning and bugs added (Gompertz) 385: 386: Revision 1.109 2006/01/24 19:37:15 brouard 387: (Module): Comments (lines starting with a #) are allowed in data. 388: 389: Revision 1.108 2006/01/19 18:05:42 lievre 390: Gnuplot problem appeared... 391: To be fixed 392: 393: Revision 1.107 2006/01/19 16:20:37 brouard 394: Test existence of gnuplot in imach path 395: 396: Revision 1.106 2006/01/19 13:24:36 brouard 397: Some cleaning and links added in html output 398: 399: Revision 1.105 2006/01/05 20:23:19 lievre 400: *** empty log message *** 401: 402: Revision 1.104 2005/09/30 16:11:43 lievre 403: (Module): sump fixed, loop imx fixed, and simplifications. 404: (Module): If the status is missing at the last wave but we know 405: that the person is alive, then we can code his/her status as -2 406: (instead of missing=-1 in earlier versions) and his/her 407: contributions to the likelihood is 1 - Prob of dying from last 408: health status (= 1-p13= p11+p12 in the easiest case of somebody in 409: the healthy state at last known wave). Version is 0.98 410: 411: Revision 1.103 2005/09/30 15:54:49 lievre 412: (Module): sump fixed, loop imx fixed, and simplifications. 413: 414: Revision 1.102 2004/09/15 17:31:30 brouard 415: Add the possibility to read data file including tab characters. 416: 417: Revision 1.101 2004/09/15 10:38:38 brouard 418: Fix on curr_time 419: 420: Revision 1.100 2004/07/12 18:29:06 brouard 421: Add version for Mac OS X. Just define UNIX in Makefile 422: 423: Revision 1.99 2004/06/05 08:57:40 brouard 424: *** empty log message *** 425: 426: Revision 1.98 2004/05/16 15:05:56 brouard 427: New version 0.97 . First attempt to estimate force of mortality 428: directly from the data i.e. without the need of knowing the health 429: state at each age, but using a Gompertz model: log u =a + b*age . 430: This is the basic analysis of mortality and should be done before any 431: other analysis, in order to test if the mortality estimated from the 432: cross-longitudinal survey is different from the mortality estimated 433: from other sources like vital statistic data. 434: 435: The same imach parameter file can be used but the option for mle should be -3. 436: 437: Agnès, who wrote this part of the code, tried to keep most of the 438: former routines in order to include the new code within the former code. 439: 440: The output is very simple: only an estimate of the intercept and of 441: the slope with 95% confident intervals. 442: 443: Current limitations: 444: A) Even if you enter covariates, i.e. with the 445: model= V1+V2 equation for example, the programm does only estimate a unique global model without covariates. 446: B) There is no computation of Life Expectancy nor Life Table. 447: 448: Revision 1.97 2004/02/20 13:25:42 lievre 449: Version 0.96d. Population forecasting command line is (temporarily) 450: suppressed. 451: 452: Revision 1.96 2003/07/15 15:38:55 brouard 453: * imach.c (Repository): Errors in subdirf, 2, 3 while printing tmpout is 454: rewritten within the same printf. Workaround: many printfs. 455: 456: Revision 1.95 2003/07/08 07:54:34 brouard 457: * imach.c (Repository): 458: (Repository): Using imachwizard code to output a more meaningful covariance 459: matrix (cov(a12,c31) instead of numbers. 460: 461: Revision 1.94 2003/06/27 13:00:02 brouard 462: Just cleaning 463: 464: Revision 1.93 2003/06/25 16:33:55 brouard 465: (Module): On windows (cygwin) function asctime_r doesn't 466: exist so I changed back to asctime which exists. 467: (Module): Version 0.96b 468: 469: Revision 1.92 2003/06/25 16:30:45 brouard 470: (Module): On windows (cygwin) function asctime_r doesn't 471: exist so I changed back to asctime which exists. 472: 473: Revision 1.91 2003/06/25 15:30:29 brouard 474: * imach.c (Repository): Duplicated warning errors corrected. 475: (Repository): Elapsed time after each iteration is now output. It 476: helps to forecast when convergence will be reached. Elapsed time 477: is stamped in powell. We created a new html file for the graphs 478: concerning matrix of covariance. It has extension -cov.htm. 479: 480: Revision 1.90 2003/06/24 12:34:15 brouard 481: (Module): Some bugs corrected for windows. Also, when 482: mle=-1 a template is output in file "or"mypar.txt with the design 483: of the covariance matrix to be input. 484: 485: Revision 1.89 2003/06/24 12:30:52 brouard 486: (Module): Some bugs corrected for windows. Also, when 487: mle=-1 a template is output in file "or"mypar.txt with the design 488: of the covariance matrix to be input. 489: 490: Revision 1.88 2003/06/23 17:54:56 brouard 491: * imach.c (Repository): Create a sub-directory where all the secondary files are. Only imach, htm, gp and r(imach) are on the main directory. Correct time and other things. 492: 493: Revision 1.87 2003/06/18 12:26:01 brouard 494: Version 0.96 495: 496: Revision 1.86 2003/06/17 20:04:08 brouard 497: (Module): Change position of html and gnuplot routines and added 498: routine fileappend. 499: 500: Revision 1.85 2003/06/17 13:12:43 brouard 501: * imach.c (Repository): Check when date of death was earlier that 502: current date of interview. It may happen when the death was just 503: prior to the death. In this case, dh was negative and likelihood 504: was wrong (infinity). We still send an "Error" but patch by 505: assuming that the date of death was just one stepm after the 506: interview. 507: (Repository): Because some people have very long ID (first column) 508: we changed int to long in num[] and we added a new lvector for 509: memory allocation. But we also truncated to 8 characters (left 510: truncation) 511: (Repository): No more line truncation errors. 512: 513: Revision 1.84 2003/06/13 21:44:43 brouard 514: * imach.c (Repository): Replace "freqsummary" at a correct 515: place. It differs from routine "prevalence" which may be called 516: many times. Probs is memory consuming and must be used with 517: parcimony. 518: Version 0.95a3 (should output exactly the same maximization than 0.8a2) 519: 520: Revision 1.83 2003/06/10 13:39:11 lievre 521: *** empty log message *** 522: 523: Revision 1.82 2003/06/05 15:57:20 brouard 524: Add log in imach.c and fullversion number is now printed. 525: 526: */ 527: /* 528: Interpolated Markov Chain 529: 530: Short summary of the programme: 531: 532: This program computes Healthy Life Expectancies from 533: cross-longitudinal data. Cross-longitudinal data consist in: -1- a 534: first survey ("cross") where individuals from different ages are 535: interviewed on their health status or degree of disability (in the 536: case of a health survey which is our main interest) -2- at least a 537: second wave of interviews ("longitudinal") which measure each change 538: (if any) in individual health status. Health expectancies are 539: computed from the time spent in each health state according to a 540: model. More health states you consider, more time is necessary to reach the 541: Maximum Likelihood of the parameters involved in the model. The 542: simplest model is the multinomial logistic model where pij is the 543: probability to be observed in state j at the second wave 544: conditional to be observed in state i at the first wave. Therefore 545: the model is: log(pij/pii)= aij + bij*age+ cij*sex + etc , where 546: 'age' is age and 'sex' is a covariate. If you want to have a more 547: complex model than "constant and age", you should modify the program 548: where the markup *Covariates have to be included here again* invites 549: you to do it. More covariates you add, slower the 550: convergence. 551: 552: The advantage of this computer programme, compared to a simple 553: multinomial logistic model, is clear when the delay between waves is not 554: identical for each individual. Also, if a individual missed an 555: intermediate interview, the information is lost, but taken into 556: account using an interpolation or extrapolation. 557: 558: hPijx is the probability to be observed in state i at age x+h 559: conditional to the observed state i at age x. The delay 'h' can be 560: split into an exact number (nh*stepm) of unobserved intermediate 561: states. This elementary transition (by month, quarter, 562: semester or year) is modelled as a multinomial logistic. The hPx 563: matrix is simply the matrix product of nh*stepm elementary matrices 564: and the contribution of each individual to the likelihood is simply 565: hPijx. 566: 567: Also this programme outputs the covariance matrix of the parameters but also 568: of the life expectancies. It also computes the period (stable) prevalence. 569: 570: Authors: Nicolas Brouard (brouard@ined.fr) and Agnès Lièvre (lievre@ined.fr). 571: Institut national d'études démographiques, Paris. 572: This software have been partly granted by Euro-REVES, a concerted action 573: from the European Union. 574: It is copyrighted identically to a GNU software product, ie programme and 575: software can be distributed freely for non commercial use. Latest version 576: can be accessed at http://euroreves.ined.fr/imach . 577: 578: Help to debug: LD_PRELOAD=/usr/local/lib/libnjamd.so ./imach foo.imach 579: or better on gdb : set env LD_PRELOAD=/usr/local/lib/libnjamd.so 580: 581: **********************************************************************/ 582: /* 583: main 584: read parameterfile 585: read datafile 586: concatwav 587: freqsummary 588: if (mle >= 1) 589: mlikeli 590: print results files 591: if mle==1 592: computes hessian 593: read end of parameter file: agemin, agemax, bage, fage, estepm 594: begin-prev-date,... 595: open gnuplot file 596: open html file 597: period (stable) prevalence | pl_nom 1-1 2-2 etc by covariate 598: for age prevalim() | #****** V1=0 V2=1 V3=1 V4=0 ****** 599: | 65 1 0 2 1 3 1 4 0 0.96326 0.03674 600: freexexit2 possible for memory heap. 601: 602: h Pij x | pij_nom ficrestpij 603: # Cov Agex agex+h hpijx with i,j= 1-1 1-2 1-3 2-1 2-2 2-3 604: 1 85 85 1.00000 0.00000 0.00000 0.00000 1.00000 0.00000 605: 1 85 86 0.68299 0.22291 0.09410 0.71093 0.00000 0.28907 606: 607: 1 65 99 0.00364 0.00322 0.99314 0.00350 0.00310 0.99340 608: 1 65 100 0.00214 0.00204 0.99581 0.00206 0.00196 0.99597 609: variance of p one-step probabilities varprob | prob_nom ficresprob #One-step probabilities and stand. devi in () 610: Standard deviation of one-step probabilities | probcor_nom ficresprobcor #One-step probabilities and correlation matrix 611: Matrix of variance covariance of one-step probabilities | probcov_nom ficresprobcov #One-step probabilities and covariance matrix 612: 613: forecasting if prevfcast==1 prevforecast call prevalence() 614: health expectancies 615: Variance-covariance of DFLE 616: prevalence() 617: movingaverage() 618: varevsij() 619: if popbased==1 varevsij(,popbased) 620: total life expectancies 621: Variance of period (stable) prevalence 622: end 623: */ 624: 625: /* #define DEBUG */ 626: /* #define DEBUGBRENT */ 627: #define POWELL /* Instead of NLOPT */ 628: #define POWELLF1F3 /* Skip test */ 629: /* #define POWELLORIGINAL /\* Don't use Directest to decide new direction but original Powell test *\/ */ 630: /* #define MNBRAKORIGINAL /\* Don't use mnbrak fix *\/ */ 631: 632: #include <math.h> 633: #include <stdio.h> 634: #include <stdlib.h> 635: #include <string.h> 636: 637: #ifdef _WIN32 638: #include <io.h> 639: #include <windows.h> 640: #include <tchar.h> 641: #else 642: #include <unistd.h> 643: #endif 644: 645: #include <limits.h> 646: #include <sys/types.h> 647: 648: #if defined(__GNUC__) 649: #include <sys/utsname.h> /* Doesn't work on Windows */ 650: #endif 651: 652: #include <sys/stat.h> 653: #include <errno.h> 654: /* extern int errno; */ 655: 656: /* #ifdef LINUX */ 657: /* #include <time.h> */ 658: /* #include "timeval.h" */ 659: /* #else */ 660: /* #include <sys/time.h> */ 661: /* #endif */ 662: 663: #include <time.h> 664: 665: #ifdef GSL 666: #include <gsl/gsl_errno.h> 667: #include <gsl/gsl_multimin.h> 668: #endif 669: 670: 671: #ifdef NLOPT 672: #include <nlopt.h> 673: typedef struct { 674: double (* function)(double [] ); 675: } myfunc_data ; 676: #endif 677: 678: /* #include <libintl.h> */ 679: /* #define _(String) gettext (String) */ 680: 681: #define MAXLINE 1024 /* Was 256. Overflow with 312 with 2 states and 4 covariates. Should be ok */ 682: 683: #define GNUPLOTPROGRAM "gnuplot" 684: /*#define GNUPLOTPROGRAM "..\\gp37mgw\\wgnuplot"*/ 685: #define FILENAMELENGTH 132 686: 687: #define GLOCK_ERROR_NOPATH -1 /* empty path */ 688: #define GLOCK_ERROR_GETCWD -2 /* cannot get cwd */ 689: 690: #define MAXPARM 128 /**< Maximum number of parameters for the optimization */ 691: #define NPARMAX 64 /**< (nlstate+ndeath-1)*nlstate*ncovmodel */ 692: 693: #define NINTERVMAX 8 694: #define NLSTATEMAX 8 /**< Maximum number of live states (for func) */ 695: #define NDEATHMAX 8 /**< Maximum number of dead states (for func) */ 696: #define NCOVMAX 20 /**< Maximum number of covariates, including generated covariates V1*V2 */ 697: #define codtabm(h,k) 1 & (h-1) >> (k-1) ; 698: #define MAXN 20000 699: #define YEARM 12. /**< Number of months per year */ 700: #define AGESUP 130 701: #define AGEBASE 40 702: #define AGEOVERFLOW 1.e20 703: #define AGEGOMP 10 /**< Minimal age for Gompertz adjustment */ 704: #ifdef _WIN32 705: #define DIRSEPARATOR '\\' 706: #define CHARSEPARATOR "\\" 707: #define ODIRSEPARATOR '/' 708: #else 709: #define DIRSEPARATOR '/' 710: #define CHARSEPARATOR "/" 711: #define ODIRSEPARATOR '\\' 712: #endif 713: 714: /* $Id: imach.c,v 1.196 2015/08/18 23:17:52 brouard Exp $ */ 715: /* $State: Exp $ */ 716: #include "version.h" 717: char version[]=__IMACH_VERSION__; 718: char copyright[]="August 2015,INED-EUROREVES-Institut de longevite-Japan Society for the Promotion of Science (Grant-in-Aid for Scientific Research 25293121), Intel Software 2015"; 719: char fullversion[]="$Revision: 1.196 $ $Date: 2015/08/18 23:17:52 $"; 720: char strstart[80]; 721: char optionfilext[10], optionfilefiname[FILENAMELENGTH]; 722: int erreur=0, nberr=0, nbwarn=0; /* Error number, number of errors number of warnings */ 723: int nagesqr=0, nforce=0; /* nagesqr=1 if model is including age*age, number of forces */ 724: /* Number of covariates model=V2+V1+ V3*age+V2*V4 */ 725: int cptcovn=0; /**< cptcovn number of covariates added in the model (excepting constant and age and age*product) */ 726: int cptcovt=0; /**< cptcovt number of covariates added in the model (excepting constant and age) */ 727: int cptcovs=0; /**< cptcovs number of simple covariates V2+V1 =2 */ 728: int cptcovage=0; /**< Number of covariates with age: V3*age only =1 */ 729: int cptcovprodnoage=0; /**< Number of covariate products without age */ 730: int cptcoveff=0; /* Total number of covariates to vary for printing results */ 731: int cptcov=0; /* Working variable */ 732: int npar=NPARMAX; 733: int nlstate=2; /* Number of live states */ 734: int ndeath=1; /* Number of dead states */ 735: int ncovmodel=0, ncovcol=0; /* Total number of covariables including constant a12*1 +b12*x ncovmodel=2 */ 736: int popbased=0; 737: 738: int *wav; /* Number of waves for this individuual 0 is possible */ 739: int maxwav=0; /* Maxim number of waves */ 740: int jmin=0, jmax=0; /* min, max spacing between 2 waves */ 741: int ijmin=0, ijmax=0; /* Individuals having jmin and jmax */ 742: int gipmx=0, gsw=0; /* Global variables on the number of contributions 743: to the likelihood and the sum of weights (done by funcone)*/ 744: int mle=1, weightopt=0; 745: int **mw; /* mw[mi][i] is number of the mi wave for this individual */ 746: int **dh; /* dh[mi][i] is number of steps between mi,mi+1 for this individual */ 747: int **bh; /* bh[mi][i] is the bias (+ or -) for this individual if the delay between 748: * wave mi and wave mi+1 is not an exact multiple of stepm. */ 749: int countcallfunc=0; /* Count the number of calls to func */ 750: double jmean=1; /* Mean space between 2 waves */ 751: double **matprod2(); /* test */ 752: double **oldm, **newm, **savm; /* Working pointers to matrices */ 753: double **oldms, **newms, **savms; /* Fixed working pointers to matrices */ 754: /*FILE *fic ; */ /* Used in readdata only */ 755: FILE *ficpar, *ficparo,*ficres, *ficresp, *ficrespl, *ficrespij, *ficrest,*ficresf,*ficrespop; 756: FILE *ficlog, *ficrespow; 757: int globpr=0; /* Global variable for printing or not */ 758: double fretone; /* Only one call to likelihood */ 759: long ipmx=0; /* Number of contributions */ 760: double sw; /* Sum of weights */ 761: char filerespow[FILENAMELENGTH]; 762: char fileresilk[FILENAMELENGTH]; /* File of individual contributions to the likelihood */ 763: FILE *ficresilk; 764: FILE *ficgp,*ficresprob,*ficpop, *ficresprobcov, *ficresprobcor; 765: FILE *ficresprobmorprev; 766: FILE *fichtm, *fichtmcov; /* Html File */ 767: FILE *ficreseij; 768: char filerese[FILENAMELENGTH]; 769: FILE *ficresstdeij; 770: char fileresstde[FILENAMELENGTH]; 771: FILE *ficrescveij; 772: char filerescve[FILENAMELENGTH]; 773: FILE *ficresvij; 774: char fileresv[FILENAMELENGTH]; 775: FILE *ficresvpl; 776: char fileresvpl[FILENAMELENGTH]; 777: char title[MAXLINE]; 778: char optionfile[FILENAMELENGTH], datafile[FILENAMELENGTH], filerespl[FILENAMELENGTH]; 779: char plotcmd[FILENAMELENGTH], pplotcmd[FILENAMELENGTH]; 780: char tmpout[FILENAMELENGTH], tmpout2[FILENAMELENGTH]; 781: char command[FILENAMELENGTH]; 782: int outcmd=0; 783: 784: char fileres[FILENAMELENGTH], filerespij[FILENAMELENGTH], filereso[FILENAMELENGTH], rfileres[FILENAMELENGTH]; 785: 786: char filelog[FILENAMELENGTH]; /* Log file */ 787: char filerest[FILENAMELENGTH]; 788: char fileregp[FILENAMELENGTH]; 789: char popfile[FILENAMELENGTH]; 790: 791: char optionfilegnuplot[FILENAMELENGTH], optionfilehtm[FILENAMELENGTH], optionfilehtmcov[FILENAMELENGTH] ; 792: 793: /* struct timeval start_time, end_time, curr_time, last_time, forecast_time; */ 794: /* struct timezone tzp; */ 795: /* extern int gettimeofday(); */ 796: struct tm tml, *gmtime(), *localtime(); 797: 798: extern time_t time(); 799: 800: struct tm start_time, end_time, curr_time, last_time, forecast_time; 801: time_t rstart_time, rend_time, rcurr_time, rlast_time, rforecast_time; /* raw time */ 802: struct tm tm; 803: 804: char strcurr[80], strfor[80]; 805: 806: char *endptr; 807: long lval; 808: double dval; 809: 810: #define NR_END 1 811: #define FREE_ARG char* 812: #define FTOL 1.0e-10 813: 814: #define NRANSI 815: #define ITMAX 200 816: 817: #define TOL 2.0e-4 818: 819: #define CGOLD 0.3819660 820: #define ZEPS 1.0e-10 821: #define SHFT(a,b,c,d) (a)=(b);(b)=(c);(c)=(d); 822: 823: #define GOLD 1.618034 824: #define GLIMIT 100.0 825: #define TINY 1.0e-20 826: 827: static double maxarg1,maxarg2; 828: #define FMAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1)>(maxarg2)? (maxarg1):(maxarg2)) 829: #define FMIN(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1)<(maxarg2)? (maxarg1):(maxarg2)) 830: 831: #define SIGN(a,b) ((b)>0.0 ? fabs(a) : -fabs(a)) 832: #define rint(a) floor(a+0.5) 833: /* http://www.thphys.uni-heidelberg.de/~robbers/cmbeasy/doc/html/myutils_8h-source.html */ 834: #define mytinydouble 1.0e-16 835: /* #define DEQUAL(a,b) (fabs((a)-(b))<mytinydouble) */ 836: /* http://www.thphys.uni-heidelberg.de/~robbers/cmbeasy/doc/html/mynrutils_8h-source.html */ 837: /* static double dsqrarg; */ 838: /* #define DSQR(a) (DEQUAL((dsqrarg=(a)),0.0) ? 0.0 : dsqrarg*dsqrarg) */ 839: static double sqrarg; 840: #define SQR(a) ((sqrarg=(a)) == 0.0 ? 0.0 :sqrarg*sqrarg) 841: #define SWAP(a,b) {temp=(a);(a)=(b);(b)=temp;} 842: int agegomp= AGEGOMP; 843: 844: int imx; 845: int stepm=1; 846: /* Stepm, step in month: minimum step interpolation*/ 847: 848: int estepm; 849: /* Estepm, step in month to interpolate survival function in order to approximate Life Expectancy*/ 850: 851: int m,nb; 852: long *num; 853: int firstpass=0, lastpass=4,*cod, *Tage,*cens; 854: int *ncodemax; /* ncodemax[j]= Number of modalities of the j th 855: covariate for which somebody answered excluding 856: undefined. Usually 2: 0 and 1. */ 857: int *ncodemaxwundef; /* ncodemax[j]= Number of modalities of the j th 858: covariate for which somebody answered including 859: undefined. Usually 3: -1, 0 and 1. */ 860: double **agev,*moisnais, *annais, *moisdc, *andc,**mint, **anint; 861: double **pmmij, ***probs; 862: double *ageexmed,*agecens; 863: double dateintmean=0; 864: 865: double *weight; 866: int **s; /* Status */ 867: double *agedc; 868: double **covar; /**< covar[j,i], value of jth covariate for individual i, 869: * covar=matrix(0,NCOVMAX,1,n); 870: * cov[Tage[kk]+2]=covar[Tvar[Tage[kk]]][i]*age; */ 871: double idx; 872: int **nbcode, *Tvar; /**< model=V2 => Tvar[1]= 2 */ 873: int *Ndum; /** Freq of modality (tricode */ 874: int **codtab; /**< codtab=imatrix(1,100,1,10); */ 875: int **Tvard, *Tprod, cptcovprod, *Tvaraff; 876: double *lsurv, *lpop, *tpop; 877: 878: double ftol=FTOL; /**< Tolerance for computing Max Likelihood */ 879: double ftolhess; /**< Tolerance for computing hessian */ 880: 881: /**************** split *************************/ 882: static int split( char *path, char *dirc, char *name, char *ext, char *finame ) 883: { 884: /* From a file name with (full) path (either Unix or Windows) we extract the directory (dirc) 885: the name of the file (name), its extension only (ext) and its first part of the name (finame) 886: */ 887: char *ss; /* pointer */ 888: int l1=0, l2=0; /* length counters */ 889: 890: l1 = strlen(path ); /* length of path */ 891: if ( l1 == 0 ) return( GLOCK_ERROR_NOPATH ); 892: ss= strrchr( path, DIRSEPARATOR ); /* find last / */ 893: if ( ss == NULL ) { /* no directory, so determine current directory */ 894: strcpy( name, path ); /* we got the fullname name because no directory */ 895: /*if(strrchr(path, ODIRSEPARATOR )==NULL) 896: printf("Warning you should use %s as a separator\n",DIRSEPARATOR);*/ 897: /* get current working directory */ 898: /* extern char* getcwd ( char *buf , int len);*/ 899: #ifdef WIN32 900: if (_getcwd( dirc, FILENAME_MAX ) == NULL ) { 901: #else 902: if (getcwd(dirc, FILENAME_MAX) == NULL) { 903: #endif 904: return( GLOCK_ERROR_GETCWD ); 905: } 906: /* got dirc from getcwd*/ 907: printf(" DIRC = %s \n",dirc); 908: } else { /* strip direcotry from path */ 909: ss++; /* after this, the filename */ 910: l2 = strlen( ss ); /* length of filename */ 911: if ( l2 == 0 ) return( GLOCK_ERROR_NOPATH ); 912: strcpy( name, ss ); /* save file name */ 913: strncpy( dirc, path, l1 - l2 ); /* now the directory */ 914: dirc[l1-l2] = '\0'; /* add zero */ 915: printf(" DIRC2 = %s \n",dirc); 916: } 917: /* We add a separator at the end of dirc if not exists */ 918: l1 = strlen( dirc ); /* length of directory */ 919: if( dirc[l1-1] != DIRSEPARATOR ){ 920: dirc[l1] = DIRSEPARATOR; 921: dirc[l1+1] = 0; 922: printf(" DIRC3 = %s \n",dirc); 923: } 924: ss = strrchr( name, '.' ); /* find last / */ 925: if (ss >0){ 926: ss++; 927: strcpy(ext,ss); /* save extension */ 928: l1= strlen( name); 929: l2= strlen(ss)+1; 930: strncpy( finame, name, l1-l2); 931: finame[l1-l2]= 0; 932: } 933: 934: return( 0 ); /* we're done */ 935: } 936: 937: 938: /******************************************/ 939: 940: void replace_back_to_slash(char *s, char*t) 941: { 942: int i; 943: int lg=0; 944: i=0; 945: lg=strlen(t); 946: for(i=0; i<= lg; i++) { 947: (s[i] = t[i]); 948: if (t[i]== '\\') s[i]='/'; 949: } 950: } 951: 952: char *trimbb(char *out, char *in) 953: { /* Trim multiple blanks in line but keeps first blanks if line starts with blanks */ 954: char *s; 955: s=out; 956: while (*in != '\0'){ 957: while( *in == ' ' && *(in+1) == ' '){ /* && *(in+1) != '\0'){*/ 958: in++; 959: } 960: *out++ = *in++; 961: } 962: *out='\0'; 963: return s; 964: } 965: 966: /* char *substrchaine(char *out, char *in, char *chain) */ 967: /* { */ 968: /* /\* Substract chain 'chain' from 'in', return and output 'out' *\/ */ 969: /* char *s, *t; */ 970: /* t=in;s=out; */ 971: /* while ((*in != *chain) && (*in != '\0')){ */ 972: /* *out++ = *in++; */ 973: /* } */ 974: 975: /* /\* *in matches *chain *\/ */ 976: /* while ((*in++ == *chain++) && (*in != '\0')){ */ 977: /* printf("*in = %c, *out= %c *chain= %c \n", *in, *out, *chain); */ 978: /* } */ 979: /* in--; chain--; */ 980: /* while ( (*in != '\0')){ */ 981: /* printf("Bef *in = %c, *out= %c *chain= %c \n", *in, *out, *chain); */ 982: /* *out++ = *in++; */ 983: /* printf("Aft *in = %c, *out= %c *chain= %c \n", *in, *out, *chain); */ 984: /* } */ 985: /* *out='\0'; */ 986: /* out=s; */ 987: /* return out; */ 988: /* } */ 989: char *substrchaine(char *out, char *in, char *chain) 990: { 991: /* Substract chain 'chain' from 'in', return and output 'out' */ 992: /* in="V1+V1*age+age*age+V2", chain="age*age" */ 993: 994: char *strloc; 995: 996: strcpy (out, in); 997: strloc = strstr(out, chain); /* strloc points to out at age*age+V2 */ 998: printf("Bef strloc=%s chain=%s out=%s \n", strloc, chain, out); 999: if(strloc != NULL){ 1000: /* will affect out */ /* strloc+strlenc(chain)=+V2 */ /* Will also work in Unicode */ 1001: memmove(strloc,strloc+strlen(chain), strlen(strloc+strlen(chain))+1); 1002: /* strcpy (strloc, strloc +strlen(chain));*/ 1003: } 1004: printf("Aft strloc=%s chain=%s in=%s out=%s \n", strloc, chain, in, out); 1005: return out; 1006: } 1007: 1008: 1009: char *cutl(char *blocc, char *alocc, char *in, char occ) 1010: { 1011: /* cuts string in into blocc and alocc where blocc ends before FIRST occurence of char 'occ' 1012: and alocc starts after first occurence of char 'occ' : ex cutv(blocc,alocc,"abcdef2ghi2j",'2') 1013: gives blocc="abcdef" and alocc="ghi2j". 1014: If occ is not found blocc is null and alocc is equal to in. Returns blocc 1015: */ 1016: char *s, *t; 1017: t=in;s=in; 1018: while ((*in != occ) && (*in != '\0')){ 1019: *alocc++ = *in++; 1020: } 1021: if( *in == occ){ 1022: *(alocc)='\0'; 1023: s=++in; 1024: } 1025: 1026: if (s == t) {/* occ not found */ 1027: *(alocc-(in-s))='\0'; 1028: in=s; 1029: } 1030: while ( *in != '\0'){ 1031: *blocc++ = *in++; 1032: } 1033: 1034: *blocc='\0'; 1035: return t; 1036: } 1037: char *cutv(char *blocc, char *alocc, char *in, char occ) 1038: { 1039: /* cuts string in into blocc and alocc where blocc ends before LAST occurence of char 'occ' 1040: and alocc starts after last occurence of char 'occ' : ex cutv(blocc,alocc,"abcdef2ghi2j",'2') 1041: gives blocc="abcdef2ghi" and alocc="j". 1042: If occ is not found blocc is null and alocc is equal to in. Returns alocc 1043: */ 1044: char *s, *t; 1045: t=in;s=in; 1046: while (*in != '\0'){ 1047: while( *in == occ){ 1048: *blocc++ = *in++; 1049: s=in; 1050: } 1051: *blocc++ = *in++; 1052: } 1053: if (s == t) /* occ not found */ 1054: *(blocc-(in-s))='\0'; 1055: else 1056: *(blocc-(in-s)-1)='\0'; 1057: in=s; 1058: while ( *in != '\0'){ 1059: *alocc++ = *in++; 1060: } 1061: 1062: *alocc='\0'; 1063: return s; 1064: } 1065: 1066: int nbocc(char *s, char occ) 1067: { 1068: int i,j=0; 1069: int lg=20; 1070: i=0; 1071: lg=strlen(s); 1072: for(i=0; i<= lg; i++) { 1073: if (s[i] == occ ) j++; 1074: } 1075: return j; 1076: } 1077: 1078: /* void cutv(char *u,char *v, char*t, char occ) */ 1079: /* { */ 1080: /* /\* cuts string t into u and v where u ends before last occurence of char 'occ' */ 1081: /* and v starts after last occurence of char 'occ' : ex cutv(u,v,"abcdef2ghi2j",'2') */ 1082: /* gives u="abcdef2ghi" and v="j" *\/ */ 1083: /* int i,lg,j,p=0; */ 1084: /* i=0; */ 1085: /* lg=strlen(t); */ 1086: /* for(j=0; j<=lg-1; j++) { */ 1087: /* if((t[j]!= occ) && (t[j+1]== occ)) p=j+1; */ 1088: /* } */ 1089: 1090: /* for(j=0; j<p; j++) { */ 1091: /* (u[j] = t[j]); */ 1092: /* } */ 1093: /* u[p]='\0'; */ 1094: 1095: /* for(j=0; j<= lg; j++) { */ 1096: /* if (j>=(p+1))(v[j-p-1] = t[j]); */ 1097: /* } */ 1098: /* } */ 1099: 1100: #ifdef _WIN32 1101: char * strsep(char **pp, const char *delim) 1102: { 1103: char *p, *q; 1104: 1105: if ((p = *pp) == NULL) 1106: return 0; 1107: if ((q = strpbrk (p, delim)) != NULL) 1108: { 1109: *pp = q + 1; 1110: *q = '\0'; 1111: } 1112: else 1113: *pp = 0; 1114: return p; 1115: } 1116: #endif 1117: 1118: /********************** nrerror ********************/ 1119: 1120: void nrerror(char error_text[]) 1121: { 1122: fprintf(stderr,"ERREUR ...\n"); 1123: fprintf(stderr,"%s\n",error_text); 1124: exit(EXIT_FAILURE); 1125: } 1126: /*********************** vector *******************/ 1127: double *vector(int nl, int nh) 1128: { 1129: double *v; 1130: v=(double *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(double))); 1131: if (!v) nrerror("allocation failure in vector"); 1132: return v-nl+NR_END; 1133: } 1134: 1135: /************************ free vector ******************/ 1136: void free_vector(double*v, int nl, int nh) 1137: { 1138: free((FREE_ARG)(v+nl-NR_END)); 1139: } 1140: 1141: /************************ivector *******************************/ 1142: int *ivector(long nl,long nh) 1143: { 1144: int *v; 1145: v=(int *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(int))); 1146: if (!v) nrerror("allocation failure in ivector"); 1147: return v-nl+NR_END; 1148: } 1149: 1150: /******************free ivector **************************/ 1151: void free_ivector(int *v, long nl, long nh) 1152: { 1153: free((FREE_ARG)(v+nl-NR_END)); 1154: } 1155: 1156: /************************lvector *******************************/ 1157: long *lvector(long nl,long nh) 1158: { 1159: long *v; 1160: v=(long *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(long))); 1161: if (!v) nrerror("allocation failure in ivector"); 1162: return v-nl+NR_END; 1163: } 1164: 1165: /******************free lvector **************************/ 1166: void free_lvector(long *v, long nl, long nh) 1167: { 1168: free((FREE_ARG)(v+nl-NR_END)); 1169: } 1170: 1171: /******************* imatrix *******************************/ 1172: int **imatrix(long nrl, long nrh, long ncl, long nch) 1173: /* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */ 1174: { 1175: long i, nrow=nrh-nrl+1,ncol=nch-ncl+1; 1176: int **m; 1177: 1178: /* allocate pointers to rows */ 1179: m=(int **) malloc((size_t)((nrow+NR_END)*sizeof(int*))); 1180: if (!m) nrerror("allocation failure 1 in matrix()"); 1181: m += NR_END; 1182: m -= nrl; 1183: 1184: 1185: /* allocate rows and set pointers to them */ 1186: m[nrl]=(int *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(int))); 1187: if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); 1188: m[nrl] += NR_END; 1189: m[nrl] -= ncl; 1190: 1191: for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol; 1192: 1193: /* return pointer to array of pointers to rows */ 1194: return m; 1195: } 1196: 1197: /****************** free_imatrix *************************/ 1198: void free_imatrix(m,nrl,nrh,ncl,nch) 1199: int **m; 1200: long nch,ncl,nrh,nrl; 1201: /* free an int matrix allocated by imatrix() */ 1202: { 1203: free((FREE_ARG) (m[nrl]+ncl-NR_END)); 1204: free((FREE_ARG) (m+nrl-NR_END)); 1205: } 1206: 1207: /******************* matrix *******************************/ 1208: double **matrix(long nrl, long nrh, long ncl, long nch) 1209: { 1210: long i, nrow=nrh-nrl+1, ncol=nch-ncl+1; 1211: double **m; 1212: 1213: m=(double **) malloc((size_t)((nrow+NR_END)*sizeof(double*))); 1214: if (!m) nrerror("allocation failure 1 in matrix()"); 1215: m += NR_END; 1216: m -= nrl; 1217: 1218: m[nrl]=(double *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double))); 1219: if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); 1220: m[nrl] += NR_END; 1221: m[nrl] -= ncl; 1222: 1223: for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol; 1224: return m; 1225: /* print *(*(m+1)+70) or print m[1][70]; print m+1 or print &(m[1]) or &(m[1][0]) 1226: m[i] = address of ith row of the table. &(m[i]) is its value which is another adress 1227: that of m[i][0]. In order to get the value p m[i][0] but it is unitialized. 1228: */ 1229: } 1230: 1231: /*************************free matrix ************************/ 1232: void free_matrix(double **m, long nrl, long nrh, long ncl, long nch) 1233: { 1234: free((FREE_ARG)(m[nrl]+ncl-NR_END)); 1235: free((FREE_ARG)(m+nrl-NR_END)); 1236: } 1237: 1238: /******************* ma3x *******************************/ 1239: double ***ma3x(long nrl, long nrh, long ncl, long nch, long nll, long nlh) 1240: { 1241: long i, j, nrow=nrh-nrl+1, ncol=nch-ncl+1, nlay=nlh-nll+1; 1242: double ***m; 1243: 1244: m=(double ***) malloc((size_t)((nrow+NR_END)*sizeof(double*))); 1245: if (!m) nrerror("allocation failure 1 in matrix()"); 1246: m += NR_END; 1247: m -= nrl; 1248: 1249: m[nrl]=(double **) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double))); 1250: if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); 1251: m[nrl] += NR_END; 1252: m[nrl] -= ncl; 1253: 1254: for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol; 1255: 1256: m[nrl][ncl]=(double *) malloc((size_t)((nrow*ncol*nlay+NR_END)*sizeof(double))); 1257: if (!m[nrl][ncl]) nrerror("allocation failure 3 in matrix()"); 1258: m[nrl][ncl] += NR_END; 1259: m[nrl][ncl] -= nll; 1260: for (j=ncl+1; j<=nch; j++) 1261: m[nrl][j]=m[nrl][j-1]+nlay; 1262: 1263: for (i=nrl+1; i<=nrh; i++) { 1264: m[i][ncl]=m[i-1l][ncl]+ncol*nlay; 1265: for (j=ncl+1; j<=nch; j++) 1266: m[i][j]=m[i][j-1]+nlay; 1267: } 1268: return m; 1269: /* gdb: p *(m+1) <=> p m[1] and p (m+1) <=> p (m+1) <=> p &(m[1]) 1270: &(m[i][j][k]) <=> *((*(m+i) + j)+k) 1271: */ 1272: } 1273: 1274: /*************************free ma3x ************************/ 1275: void free_ma3x(double ***m, long nrl, long nrh, long ncl, long nch,long nll, long nlh) 1276: { 1277: free((FREE_ARG)(m[nrl][ncl]+ nll-NR_END)); 1278: free((FREE_ARG)(m[nrl]+ncl-NR_END)); 1279: free((FREE_ARG)(m+nrl-NR_END)); 1280: } 1281: 1282: /*************** function subdirf ***********/ 1283: char *subdirf(char fileres[]) 1284: { 1285: /* Caution optionfilefiname is hidden */ 1286: strcpy(tmpout,optionfilefiname); 1287: strcat(tmpout,"/"); /* Add to the right */ 1288: strcat(tmpout,fileres); 1289: return tmpout; 1290: } 1291: 1292: /*************** function subdirf2 ***********/ 1293: char *subdirf2(char fileres[], char *preop) 1294: { 1295: 1296: /* Caution optionfilefiname is hidden */ 1297: strcpy(tmpout,optionfilefiname); 1298: strcat(tmpout,"/"); 1299: strcat(tmpout,preop); 1300: strcat(tmpout,fileres); 1301: return tmpout; 1302: } 1303: 1304: /*************** function subdirf3 ***********/ 1305: char *subdirf3(char fileres[], char *preop, char *preop2) 1306: { 1307: 1308: /* Caution optionfilefiname is hidden */ 1309: strcpy(tmpout,optionfilefiname); 1310: strcat(tmpout,"/"); 1311: strcat(tmpout,preop); 1312: strcat(tmpout,preop2); 1313: strcat(tmpout,fileres); 1314: return tmpout; 1315: } 1316: 1317: char *asc_diff_time(long time_sec, char ascdiff[]) 1318: { 1319: long sec_left, days, hours, minutes; 1320: days = (time_sec) / (60*60*24); 1321: sec_left = (time_sec) % (60*60*24); 1322: hours = (sec_left) / (60*60) ; 1323: sec_left = (sec_left) %(60*60); 1324: minutes = (sec_left) /60; 1325: sec_left = (sec_left) % (60); 1326: sprintf(ascdiff,"%ld day(s) %ld hour(s) %ld minute(s) %ld second(s)",days, hours, minutes, sec_left); 1327: return ascdiff; 1328: } 1329: 1330: /***************** f1dim *************************/ 1331: extern int ncom; 1332: extern double *pcom,*xicom; 1333: extern double (*nrfunc)(double []); 1334: 1335: double f1dim(double x) 1336: { 1337: int j; 1338: double f; 1339: double *xt; 1340: 1341: xt=vector(1,ncom); 1342: for (j=1;j<=ncom;j++) xt[j]=pcom[j]+x*xicom[j]; 1343: f=(*nrfunc)(xt); 1344: free_vector(xt,1,ncom); 1345: return f; 1346: } 1347: 1348: /*****************brent *************************/ 1349: double brent(double ax, double bx, double cx, double (*f)(double), double tol, double *xmin) 1350: { 1351: /* Given a function f, and given a bracketing triplet of abscissas ax, bx, cx (such that bx is 1352: * between ax and cx, and f(bx) is less than both f(ax) and f(cx) ), this routine isolates 1353: * the minimum to a fractional precision of about tol using Brent’s method. The abscissa of 1354: * the minimum is returned as xmin, and the minimum function value is returned as brent , the 1355: * returned function value. 1356: */ 1357: int iter; 1358: double a,b,d,etemp; 1359: double fu=0,fv,fw,fx; 1360: double ftemp=0.; 1361: double p,q,r,tol1,tol2,u,v,w,x,xm; 1362: double e=0.0; 1363: 1364: a=(ax < cx ? ax : cx); 1365: b=(ax > cx ? ax : cx); 1366: x=w=v=bx; 1367: fw=fv=fx=(*f)(x); 1368: for (iter=1;iter<=ITMAX;iter++) { 1369: xm=0.5*(a+b); 1370: tol2=2.0*(tol1=tol*fabs(x)+ZEPS); 1371: /* if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret)))*/ 1372: printf(".");fflush(stdout); 1373: fprintf(ficlog,".");fflush(ficlog); 1374: #ifdef DEBUGBRENT 1375: printf("br %d,x=%.10e xm=%.10e b=%.10e a=%.10e tol=%.10e tol1=%.10e tol2=%.10e x-xm=%.10e fx=%.12e fu=%.12e,fw=%.12e,ftemp=%.12e,ftol=%.12e\n",iter,x,xm,b,a,tol,tol1,tol2,(x-xm),fx,fu,fw,ftemp,ftol); 1376: fprintf(ficlog,"br %d,x=%.10e xm=%.10e b=%.10e a=%.10e tol=%.10e tol1=%.10e tol2=%.10e x-xm=%.10e fx=%.12e fu=%.12e,fw=%.12e,ftemp=%.12e,ftol=%.12e\n",iter,x,xm,b,a,tol,tol1,tol2,(x-xm),fx,fu,fw,ftemp,ftol); 1377: /* if ((fabs(x-xm) <= (tol2-0.5*(b-a)))||(2.0*fabs(fu-ftemp) <= ftol*1.e-2*(fabs(fu)+fabs(ftemp)))) { */ 1378: #endif 1379: if (fabs(x-xm) <= (tol2-0.5*(b-a))){ 1380: *xmin=x; 1381: return fx; 1382: } 1383: ftemp=fu; 1384: if (fabs(e) > tol1) { 1385: r=(x-w)*(fx-fv); 1386: q=(x-v)*(fx-fw); 1387: p=(x-v)*q-(x-w)*r; 1388: q=2.0*(q-r); 1389: if (q > 0.0) p = -p; 1390: q=fabs(q); 1391: etemp=e; 1392: e=d; 1393: if (fabs(p) >= fabs(0.5*q*etemp) || p <= q*(a-x) || p >= q*(b-x)) 1394: d=CGOLD*(e=(x >= xm ? a-x : b-x)); 1395: else { 1396: d=p/q; 1397: u=x+d; 1398: if (u-a < tol2 || b-u < tol2) 1399: d=SIGN(tol1,xm-x); 1400: } 1401: } else { 1402: d=CGOLD*(e=(x >= xm ? a-x : b-x)); 1403: } 1404: u=(fabs(d) >= tol1 ? x+d : x+SIGN(tol1,d)); 1405: fu=(*f)(u); 1406: if (fu <= fx) { 1407: if (u >= x) a=x; else b=x; 1408: SHFT(v,w,x,u) 1409: SHFT(fv,fw,fx,fu) 1410: } else { 1411: if (u < x) a=u; else b=u; 1412: if (fu <= fw || w == x) { 1413: v=w; 1414: w=u; 1415: fv=fw; 1416: fw=fu; 1417: } else if (fu <= fv || v == x || v == w) { 1418: v=u; 1419: fv=fu; 1420: } 1421: } 1422: } 1423: nrerror("Too many iterations in brent"); 1424: *xmin=x; 1425: return fx; 1426: } 1427: 1428: /****************** mnbrak ***********************/ 1429: 1430: void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, double *fc, 1431: double (*func)(double)) 1432: { /* Given a function func , and given distinct initial points ax and bx , this routine searches in 1433: the downhill direction (defined by the function as evaluated at the initial points) and returns 1434: new points ax , bx , cx that bracket a minimum of the function. Also returned are the function 1435: values at the three points, fa, fb , and fc such that fa > fb and fb < fc. 1436: */ 1437: double ulim,u,r,q, dum; 1438: double fu; 1439: 1440: double scale=10.; 1441: int iterscale=0; 1442: 1443: *fa=(*func)(*ax); /* xta[j]=pcom[j]+(*ax)*xicom[j]; fa=f(xta[j])*/ 1444: *fb=(*func)(*bx); /* xtb[j]=pcom[j]+(*bx)*xicom[j]; fb=f(xtb[j]) */ 1445: 1446: 1447: /* while(*fb != *fb){ /\* *ax should be ok, reducing distance to *ax *\/ */ 1448: /* printf("Warning mnbrak *fb = %lf, *bx=%lf *ax=%lf *fa==%lf iter=%d\n",*fb, *bx, *ax, *fa, iterscale++); */ 1449: /* *bx = *ax - (*ax - *bx)/scale; */ 1450: /* *fb=(*func)(*bx); /\* xtb[j]=pcom[j]+(*bx)*xicom[j]; fb=f(xtb[j]) *\/ */ 1451: /* } */ 1452: 1453: if (*fb > *fa) { 1454: SHFT(dum,*ax,*bx,dum) 1455: SHFT(dum,*fb,*fa,dum) 1456: } 1457: *cx=(*bx)+GOLD*(*bx-*ax); 1458: *fc=(*func)(*cx); 1459: #ifdef DEBUG 1460: printf("mnbrak0 *fb=%.12e *fc=%.12e\n",*fb,*fc); 1461: fprintf(ficlog,"mnbrak0 *fb=%.12e *fc=%.12e\n",*fb,*fc); 1462: #endif 1463: while (*fb > *fc) { /* Declining a,b,c with fa> fb > fc */ 1464: r=(*bx-*ax)*(*fb-*fc); 1465: q=(*bx-*cx)*(*fb-*fa); 1466: u=(*bx)-((*bx-*cx)*q-(*bx-*ax)*r)/ 1467: (2.0*SIGN(FMAX(fabs(q-r),TINY),q-r)); /* Minimum abscissa of a parabolic estimated from (a,fa), (b,fb) and (c,fc). */ 1468: ulim=(*bx)+GLIMIT*(*cx-*bx); /* Maximum abscissa where function should be evaluated */ 1469: if ((*bx-u)*(u-*cx) > 0.0) { /* if u_p is between b and c */ 1470: fu=(*func)(u); 1471: #ifdef DEBUG 1472: /* f(x)=A(x-u)**2+f(u) */ 1473: double A, fparabu; 1474: A= (*fb - *fa)/(*bx-*ax)/(*bx+*ax-2*u); 1475: fparabu= *fa - A*(*ax-u)*(*ax-u); 1476: printf("mnbrak (*ax=%.12f, *fa=%.12lf), (*bx=%.12f, *fb=%.12lf), (*cx=%.12f, *fc=%.12lf), (*u=%.12f, fu=%.12lf, fparabu=%.12f)\n",*ax,*fa,*bx,*fb,*cx,*fc,u,fu, fparabu); 1477: fprintf(ficlog, "mnbrak (*ax=%.12f, *fa=%.12lf), (*bx=%.12f, *fb=%.12lf), (*cx=%.12f, *fc=%.12lf), (*u=%.12f, fu=%.12lf, fparabu=%.12f)\n",*ax,*fa,*bx,*fb,*cx,*fc,u,fu, fparabu); 1478: /* And thus,it can be that fu > *fc even if fparabu < *fc */ 1479: /* mnbrak (*ax=7.666299858533, *fa=299039.693133272231), (*bx=8.595447774979, *fb=298976.598289369489), 1480: (*cx=10.098840694817, *fc=298946.631474258087), (*u=9.852501168332, fu=298948.773013752128, fparabu=298945.434711494134) */ 1481: /* In that case, there is no bracket in the output! Routine is wrong with many consequences.*/ 1482: #endif 1483: #ifdef MNBRAKORIGINAL 1484: #else 1485: /* if (fu > *fc) { */ 1486: /* #ifdef DEBUG */ 1487: /* printf("mnbrak4 fu > fc \n"); */ 1488: /* fprintf(ficlog, "mnbrak4 fu > fc\n"); */ 1489: /* #endif */ 1490: /* /\* SHFT(u,*cx,*cx,u) /\\* ie a=c, c=u and u=c; in that case, next SHFT(a,b,c,u) will give a=b=b, b=c=u, c=u=c and *\\/ *\/ */ 1491: /* /\* SHFT(*fa,*fc,fu,*fc) /\\* (b, u, c) is a bracket while test fb > fc will be fu > fc will exit *\\/ *\/ */ 1492: /* dum=u; /\* Shifting c and u *\/ */ 1493: /* u = *cx; */ 1494: /* *cx = dum; */ 1495: /* dum = fu; */ 1496: /* fu = *fc; */ 1497: /* *fc =dum; */ 1498: /* } else { /\* end *\/ */ 1499: /* #ifdef DEBUG */ 1500: /* printf("mnbrak3 fu < fc \n"); */ 1501: /* fprintf(ficlog, "mnbrak3 fu < fc\n"); */ 1502: /* #endif */ 1503: /* dum=u; /\* Shifting c and u *\/ */ 1504: /* u = *cx; */ 1505: /* *cx = dum; */ 1506: /* dum = fu; */ 1507: /* fu = *fc; */ 1508: /* *fc =dum; */ 1509: /* } */ 1510: #ifdef DEBUG 1511: printf("mnbrak34 fu < or >= fc \n"); 1512: fprintf(ficlog, "mnbrak34 fu < fc\n"); 1513: #endif 1514: dum=u; /* Shifting c and u */ 1515: u = *cx; 1516: *cx = dum; 1517: dum = fu; 1518: fu = *fc; 1519: *fc =dum; 1520: #endif 1521: } else if ((*cx-u)*(u-ulim) > 0.0) { /* u is after c but before ulim */ 1522: #ifdef DEBUG 1523: printf("mnbrak2 u after c but before ulim\n"); 1524: fprintf(ficlog, "mnbrak2 u after c but before ulim\n"); 1525: #endif 1526: fu=(*func)(u); 1527: if (fu < *fc) { 1528: #ifdef DEBUG 1529: printf("mnbrak2 u after c but before ulim AND fu < fc\n"); 1530: fprintf(ficlog, "mnbrak2 u after c but before ulim AND fu <fc \n"); 1531: #endif 1532: SHFT(*bx,*cx,u,*cx+GOLD*(*cx-*bx)) 1533: SHFT(*fb,*fc,fu,(*func)(u)) 1534: } 1535: } else if ((u-ulim)*(ulim-*cx) >= 0.0) { /* u outside ulim (verifying that ulim is beyond c) */ 1536: #ifdef DEBUG 1537: printf("mnbrak2 u outside ulim (verifying that ulim is beyond c)\n"); 1538: fprintf(ficlog, "mnbrak2 u outside ulim (verifying that ulim is beyond c)\n"); 1539: #endif 1540: u=ulim; 1541: fu=(*func)(u); 1542: } else { /* u could be left to b (if r > q parabola has a maximum) */ 1543: #ifdef DEBUG 1544: printf("mnbrak2 u could be left to b (if r > q parabola has a maximum)\n"); 1545: fprintf(ficlog, "mnbrak2 u could be left to b (if r > q parabola has a maximum)\n"); 1546: #endif 1547: u=(*cx)+GOLD*(*cx-*bx); 1548: fu=(*func)(u); 1549: } /* end tests */ 1550: SHFT(*ax,*bx,*cx,u) 1551: SHFT(*fa,*fb,*fc,fu) 1552: #ifdef DEBUG 1553: printf("mnbrak2 (*ax=%.12f, *fa=%.12lf), (*bx=%.12f, *fb=%.12lf), (*cx=%.12f, *fc=%.12lf), (*u=%.12f, fu=%.12lf)\n",*ax,*fa,*bx,*fb,*cx,*fc,u,fu); 1554: fprintf(ficlog, "mnbrak2 (*ax=%.12f, *fa=%.12lf), (*bx=%.12f, *fb=%.12lf), (*cx=%.12f, *fc=%.12lf), (*u=%.12f, fu=%.12lf)\n",*ax,*fa,*bx,*fb,*cx,*fc,u,fu); 1555: #endif 1556: } /* end while; ie return (a, b, c, fa, fb, fc) such that a f(b) and fb < f(c) */ 1557: } 1558: 1559: /*************** linmin ************************/ 1560: /* Given an n -dimensional point p[1..n] and an n -dimensional direction xi[1..n] , moves and 1561: resets p to where the function func(p) takes on a minimum along the direction xi from p , 1562: and replaces xi by the actual vector displacement that p was moved. Also returns as fret 1563: the value of func at the returned location p . This is actually all accomplished by calling the 1564: routines mnbrak and brent .*/ 1565: int ncom; 1566: double *pcom,*xicom; 1567: double (*nrfunc)(double []); 1568: 1569: void linmin(double p[], double xi[], int n, double *fret,double (*func)(double [])) 1570: { 1571: double brent(double ax, double bx, double cx, 1572: double (*f)(double), double tol, double *xmin); 1573: double f1dim(double x); 1574: void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, 1575: double *fc, double (*func)(double)); 1576: int j; 1577: double xx,xmin,bx,ax; 1578: double fx,fb,fa; 1579: 1580: double scale=10., axs, xxs, xxss; /* Scale added for infinity */ 1581: 1582: ncom=n; 1583: pcom=vector(1,n); 1584: xicom=vector(1,n); 1585: nrfunc=func; 1586: for (j=1;j<=n;j++) { 1587: pcom[j]=p[j]; 1588: xicom[j]=xi[j]; 1589: } 1590: 1591: /* axs=0.0; */ 1592: /* xxss=1; /\* 1 and using scale *\/ */ 1593: xxs=1; 1594: /* do{ */ 1595: ax=0.; 1596: xx= xxs; 1597: mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,f1dim); /* Outputs: xtx[j]=pcom[j]+(*xx)*xicom[j]; fx=f(xtx[j]) */ 1598: /* brackets with inputs ax=0 and xx=1, but points, pcom=p, and directions values, xicom=xi, are sent via f1dim(x) */ 1599: /* xt[x,j]=pcom[j]+x*xicom[j] f(ax) = f(xt(a,j=1,n)) = f(p(j) + 0 * xi(j)) and f(xx) = f(xt(x, j=1,n)) = f(p(j) + 1 * xi(j)) */ 1600: /* Outputs: fa=f(p(j)) and fx=f(p(j) + xxs * xi(j) ) and f(bx)= f(p(j)+ bx* xi(j)) */ 1601: /* Given input ax=axs and xx=xxs, xx might be too far from ax to get a finite f(xx) */ 1602: /* Searches on line, outputs (ax, xx, bx) such that fx < min(fa and fb) */ 1603: /* Find a bracket a,x,b in direction n=xi ie xicom, order may change. Scale is [0:xxs*xi[j]] et non plus [0:xi[j]]*/ 1604: /* if (fx != fx){ */ 1605: /* xxs=xxs/scale; /\* Trying a smaller xx, closer to initial ax=0 *\/ */ 1606: /* printf("\nLinmin NAN : input [axs=%lf:xxs=%lf], mnbrak outputs fx=%lf <(fb=%lf and fa=%lf) with xx=%lf in [ax=%lf:bx=%lf] \n", axs, xxs, fx,fb, fa, xx, ax, bx); */ 1607: /* } */ 1608: /* }while(fx != fx); */ 1609: 1610: #ifdef DEBUGLINMIN 1611: printf("\nLinmin after mnbrak: ax=%12.7f xx=%12.7f bx=%12.7f fa=%12.2f fx=%12.2f fb=%12.2f\n", ax,xx,bx,fa,fx,fb); 1612: #endif 1613: *fret=brent(ax,xx,bx,f1dim,TOL,&xmin); /* Giving a bracketting triplet (ax, xx, bx), find a minimum, xmin, according to f1dim, *fret(xmin),*/ 1614: /* fa = f(p[j] + ax * xi[j]), fx = f(p[j] + xx * xi[j]), fb = f(p[j] + bx * xi[j]) */ 1615: /* fmin = f(p[j] + xmin * xi[j]) */ 1616: /* P+lambda n in that direction (lambdamin), with TOL between abscisses */ 1617: /* f1dim(xmin): for (j=1;j<=ncom;j++) xt[j]=pcom[j]+xmin*xicom[j]; */ 1618: #ifdef DEBUG 1619: printf("retour brent fret=%.12e xmin=%.12e\n",*fret,xmin); 1620: fprintf(ficlog,"retour brent fret=%.12e xmin=%.12e\n",*fret,xmin); 1621: #endif 1622: #ifdef DEBUGLINMIN 1623: printf("linmin end "); 1624: #endif 1625: for (j=1;j<=n;j++) { 1626: /* printf(" before xi[%d]=%12.8f", j,xi[j]); */ 1627: xi[j] *= xmin; /* xi rescaled by xmin: if xmin=-1.237 and xi=(1,0,...,0) xi=(-1.237,0,...,0) */ 1628: /* if(xxs <1.0) */ 1629: /* printf(" after xi[%d]=%12.8f, xmin=%12.8f, ax=%12.8f, xx=%12.8f, bx=%12.8f, xxs=%12.8f", j,xi[j], xmin, ax, xx, bx,xxs ); */ 1630: p[j] += xi[j]; /* Parameters values are updated accordingly */ 1631: } 1632: /* printf("\n"); */ 1633: #ifdef DEBUGLINMIN 1634: printf("Comparing last *frec(xmin=%12.8f)=%12.8f from Brent and frec(0.)=%12.8f \n", xmin, *fret, (*func)(p)); 1635: for (j=1;j<=n;j++) { 1636: printf(" xi[%d]= %12.7f p[%d]= %12.7f",j,xi[j],j,p[j]); 1637: if(j % ncovmodel == 0) 1638: printf("\n"); 1639: } 1640: #endif 1641: free_vector(xicom,1,n); 1642: free_vector(pcom,1,n); 1643: } 1644: 1645: 1646: /*************** powell ************************/ 1647: /* 1648: Minimization of a function func of n variables. Input consists of an initial starting point 1649: p[1..n] ; an initial matrix xi[1..n][1..n] , whose columns contain the initial set of di- 1650: rections (usually the n unit vectors); and ftol , the fractional tolerance in the function value 1651: such that failure to decrease by more than this amount on one iteration signals doneness. On 1652: output, p is set to the best point found, xi is the then-current direction set, fret is the returned 1653: function value at p , and iter is the number of iterations taken. The routine linmin is used. 1654: */ 1655: void powell(double p[], double **xi, int n, double ftol, int *iter, double *fret, 1656: double (*func)(double [])) 1657: { 1658: void linmin(double p[], double xi[], int n, double *fret, 1659: double (*func)(double [])); 1660: int i,ibig,j; 1661: double del,t,*pt,*ptt,*xit; 1662: double directest; 1663: double fp,fptt; 1664: double *xits; 1665: int niterf, itmp; 1666: 1667: pt=vector(1,n); 1668: ptt=vector(1,n); 1669: xit=vector(1,n); 1670: xits=vector(1,n); 1671: *fret=(*func)(p); 1672: for (j=1;j<=n;j++) pt[j]=p[j]; 1673: rcurr_time = time(NULL); 1674: for (*iter=1;;++(*iter)) { 1675: fp=(*fret); /* From former iteration or initial value */ 1676: ibig=0; 1677: del=0.0; 1678: rlast_time=rcurr_time; 1679: /* (void) gettimeofday(&curr_time,&tzp); */ 1680: rcurr_time = time(NULL); 1681: curr_time = *localtime(&rcurr_time); 1682: printf("\nPowell iter=%d -2*LL=%.12f %ld sec. %ld sec.",*iter,*fret, rcurr_time-rlast_time, rcurr_time-rstart_time);fflush(stdout); 1683: fprintf(ficlog,"\nPowell iter=%d -2*LL=%.12f %ld sec. %ld sec.",*iter,*fret,rcurr_time-rlast_time, rcurr_time-rstart_time); fflush(ficlog); 1684: /* fprintf(ficrespow,"%d %.12f %ld",*iter,*fret,curr_time.tm_sec-start_time.tm_sec); */ 1685: for (i=1;i<=n;i++) { 1686: printf(" %d %.12f",i, p[i]); 1687: fprintf(ficlog," %d %.12lf",i, p[i]); 1688: fprintf(ficrespow," %.12lf", p[i]); 1689: } 1690: printf("\n"); 1691: fprintf(ficlog,"\n"); 1692: fprintf(ficrespow,"\n");fflush(ficrespow); 1693: if(*iter <=3){ 1694: tml = *localtime(&rcurr_time); 1695: strcpy(strcurr,asctime(&tml)); 1696: rforecast_time=rcurr_time; 1697: itmp = strlen(strcurr); 1698: if(strcurr[itmp-1]=='\n') /* Windows outputs with a new line */ 1699: strcurr[itmp-1]='\0'; 1700: printf("\nConsidering the time needed for the last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time); 1701: fprintf(ficlog,"\nConsidering the time needed for this last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time); 1702: for(niterf=10;niterf<=30;niterf+=10){ 1703: rforecast_time=rcurr_time+(niterf-*iter)*(rcurr_time-rlast_time); 1704: forecast_time = *localtime(&rforecast_time); 1705: strcpy(strfor,asctime(&forecast_time)); 1706: itmp = strlen(strfor); 1707: if(strfor[itmp-1]=='\n') 1708: strfor[itmp-1]='\0'; 1709: printf(" - if your program needs %d iterations to converge, convergence will be \n reached in %s i.e.\n on %s (current time is %s);\n",niterf, asc_diff_time(rforecast_time-rcurr_time,tmpout),strfor,strcurr); 1710: fprintf(ficlog," - if your program needs %d iterations to converge, convergence will be \n reached in %s i.e.\n on %s (current time is %s);\n",niterf, asc_diff_time(rforecast_time-rcurr_time,tmpout),strfor,strcurr); 1711: } 1712: } 1713: for (i=1;i<=n;i++) { /* For each direction i */ 1714: for (j=1;j<=n;j++) xit[j]=xi[j][i]; /* Directions stored from previous iteration with previous scales */ 1715: fptt=(*fret); 1716: #ifdef DEBUG 1717: printf("fret=%lf, %lf, %lf \n", *fret, *fret, *fret); 1718: fprintf(ficlog, "fret=%lf, %lf, %lf \n", *fret, *fret, *fret); 1719: #endif 1720: printf("%d",i);fflush(stdout); /* print direction (parameter) i */ 1721: fprintf(ficlog,"%d",i);fflush(ficlog); 1722: linmin(p,xit,n,fret,func); /* Point p[n]. xit[n] has been loaded for direction i as input.*/ 1723: /* Outputs are fret(new point p) p is updated and xit rescaled */ 1724: if (fabs(fptt-(*fret)) > del) { /* We are keeping the max gain on each of the n directions */ 1725: /* because that direction will be replaced unless the gain del is small */ 1726: /* in comparison with the 'probable' gain, mu^2, with the last average direction. */ 1727: /* Unless the n directions are conjugate some gain in the determinant may be obtained */ 1728: /* with the new direction. */ 1729: del=fabs(fptt-(*fret)); 1730: ibig=i; 1731: } 1732: #ifdef DEBUG 1733: printf("%d %.12e",i,(*fret)); 1734: fprintf(ficlog,"%d %.12e",i,(*fret)); 1735: for (j=1;j<=n;j++) { 1736: xits[j]=FMAX(fabs(p[j]-pt[j]),1.e-5); 1737: printf(" x(%d)=%.12e",j,xit[j]); 1738: fprintf(ficlog," x(%d)=%.12e",j,xit[j]); 1739: } 1740: for(j=1;j<=n;j++) { 1741: printf(" p(%d)=%.12e",j,p[j]); 1742: fprintf(ficlog," p(%d)=%.12e",j,p[j]); 1743: } 1744: printf("\n"); 1745: fprintf(ficlog,"\n"); 1746: #endif 1747: } /* end loop on each direction i */ 1748: /* Convergence test will use last linmin estimation (fret) and compare former iteration (fp) */ 1749: /* But p and xit have been updated at the end of linmin, *fret corresponds to new p, xit */ 1750: /* New value of last point Pn is not computed, P(n-1) */ 1751: if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret))) { /* Did we reach enough precision? */ 1752: /* We could compare with a chi^2. chisquare(0.95,ddl=1)=3.84 */ 1753: /* By adding age*age in a model, the new -2LL should be lower and the difference follows a */ 1754: /* a chisquare statistics with 1 degree. To be significant at the 95% level, it should have */ 1755: /* decreased of more than 3.84 */ 1756: /* By adding age*age and V1*age the gain (-2LL) should be more than 5.99 (ddl=2) */ 1757: /* By using V1+V2+V3, the gain should be 7.82, compared with basic 1+age. */ 1758: /* By adding 10 parameters more the gain should be 18.31 */ 1759: 1760: /* Starting the program with initial values given by a former maximization will simply change */ 1761: /* the scales of the directions and the directions, because the are reset to canonical directions */ 1762: /* Thus the first calls to linmin will give new points and better maximizations until fp-(*fret) is */ 1763: /* under the tolerance value. If the tolerance is very small 1.e-9, it could last long. */ 1764: #ifdef DEBUG 1765: int k[2],l; 1766: k[0]=1; 1767: k[1]=-1; 1768: printf("Max: %.12e",(*func)(p)); 1769: fprintf(ficlog,"Max: %.12e",(*func)(p)); 1770: for (j=1;j<=n;j++) { 1771: printf(" %.12e",p[j]); 1772: fprintf(ficlog," %.12e",p[j]); 1773: } 1774: printf("\n"); 1775: fprintf(ficlog,"\n"); 1776: for(l=0;l<=1;l++) { 1777: for (j=1;j<=n;j++) { 1778: ptt[j]=p[j]+(p[j]-pt[j])*k[l]; 1779: printf("l=%d j=%d ptt=%.12e, xits=%.12e, p=%.12e, xit=%.12e", l,j,ptt[j],xits[j],p[j],xit[j]); 1780: fprintf(ficlog,"l=%d j=%d ptt=%.12e, xits=%.12e, p=%.12e, xit=%.12e", l,j,ptt[j],xits[j],p[j],xit[j]); 1781: } 1782: printf("func(ptt)=%.12e, deriv=%.12e\n",(*func)(ptt),(ptt[j]-p[j])/((*func)(ptt)-(*func)(p))); 1783: fprintf(ficlog,"func(ptt)=%.12e, deriv=%.12e\n",(*func)(ptt),(ptt[j]-p[j])/((*func)(ptt)-(*func)(p))); 1784: } 1785: #endif 1786: 1787: 1788: free_vector(xit,1,n); 1789: free_vector(xits,1,n); 1790: free_vector(ptt,1,n); 1791: free_vector(pt,1,n); 1792: return; 1793: } /* enough precision */ 1794: if (*iter == ITMAX) nrerror("powell exceeding maximum iterations."); 1795: for (j=1;j<=n;j++) { /* Computes the extrapolated point P_0 + 2 (P_n-P_0) */ 1796: ptt[j]=2.0*p[j]-pt[j]; 1797: xit[j]=p[j]-pt[j]; 1798: pt[j]=p[j]; 1799: } 1800: fptt=(*func)(ptt); /* f_3 */ 1801: #ifdef POWELLF1F3 1802: #else 1803: if (fptt < fp) { /* If extrapolated point is better, decide if we keep that new direction or not */ 1804: #endif 1805: /* (x1 f1=fp), (x2 f2=*fret), (x3 f3=fptt), (xm fm) */ 1806: /* From x1 (P0) distance of x2 is at h and x3 is 2h */ 1807: /* Let f"(x2) be the 2nd derivative equal everywhere. */ 1808: /* Then the parabolic through (x1,f1), (x2,f2) and (x3,f3) */ 1809: /* will reach at f3 = fm + h^2/2 f"m ; f" = (f1 -2f2 +f3 ) / h**2 */ 1810: /* Conditional for using this new direction is that mu^2 = (f1-2f2+f3)^2 /2 < del */ 1811: /* t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)-del*SQR(fp-fptt); */ 1812: #ifdef NRCORIGINAL 1813: t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)- del*SQR(fp-fptt); /* Original Numerical Recipes in C*/ 1814: #else 1815: t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del); /* Intel compiler doesn't work on one line; bug reported */ 1816: t= t- del*SQR(fp-fptt); 1817: #endif 1818: directest = fp-2.0*(*fret)+fptt - 2.0 * del; /* If del was big enough we change it for a new direction */ 1819: #ifdef DEBUG 1820: printf("t1= %.12lf, t2= %.12lf, t=%.12lf directest=%.12lf\n", 2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del),del*SQR(fp-fptt),t,directest); 1821: fprintf(ficlog,"t1= %.12lf, t2= %.12lf, t=%.12lf directest=%.12lf\n", 2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del),del*SQR(fp-fptt),t,directest); 1822: printf("t3= %.12lf, t4= %.12lf, t3*= %.12lf, t4*= %.12lf\n",SQR(fp-(*fret)-del),SQR(fp-fptt), 1823: (fp-(*fret)-del)*(fp-(*fret)-del),(fp-fptt)*(fp-fptt)); 1824: fprintf(ficlog,"t3= %.12lf, t4= %.12lf, t3*= %.12lf, t4*= %.12lf\n",SQR(fp-(*fret)-del),SQR(fp-fptt), 1825: (fp-(*fret)-del)*(fp-(*fret)-del),(fp-fptt)*(fp-fptt)); 1826: printf("tt= %.12lf, t=%.12lf\n",2.0*(fp-2.0*(*fret)+fptt)*(fp-(*fret)-del)*(fp-(*fret)-del)-del*(fp-fptt)*(fp-fptt),t); 1827: fprintf(ficlog, "tt= %.12lf, t=%.12lf\n",2.0*(fp-2.0*(*fret)+fptt)*(fp-(*fret)-del)*(fp-(*fret)-del)-del*(fp-fptt)*(fp-fptt),t); 1828: #endif 1829: #ifdef POWELLORIGINAL 1830: if (t < 0.0) { /* Then we use it for new direction */ 1831: #else 1832: if (directest*t < 0.0) { /* Contradiction between both tests */ 1833: printf("directest= %.12lf, t= %.12lf, f1= %.12lf,f2= %.12lf,f3= %.12lf, del= %.12lf\n",directest, t, fp,(*fret),fptt,del); 1834: printf("f1-2f2+f3= %.12lf, f1-f2-del= %.12lf, f1-f3= %.12lf\n",fp-2.0*(*fret)+fptt, fp -(*fret) -del, fp-fptt); 1835: fprintf(ficlog,"directest= %.12lf, t= %.12lf, f1= %.12lf,f2= %.12lf,f3= %.12lf, del= %.12lf\n",directest, t, fp,(*fret),fptt, del); 1836: fprintf(ficlog,"f1-2f2+f3= %.12lf, f1-f2-del= %.12lf, f1-f3= %.12lf\n",fp-2.0*(*fret)+fptt, fp -(*fret) -del, fp-fptt); 1837: } 1838: if (directest < 0.0) { /* Then we use it for new direction */ 1839: #endif 1840: #ifdef DEBUGLINMIN 1841: printf("Before linmin in direction P%d-P0\n",n); 1842: for (j=1;j<=n;j++) { 1843: printf("Before xit[%d]= %12.7f p[%d]= %12.7f",j,xit[j],j,p[j]); 1844: if(j % ncovmodel == 0) 1845: printf("\n"); 1846: } 1847: #endif 1848: linmin(p,xit,n,fret,func); /* computes minimum on the extrapolated direction: changes p and rescales xit.*/ 1849: #ifdef DEBUGLINMIN 1850: for (j=1;j<=n;j++) { 1851: printf("After xit[%d]= %12.7f p[%d]= %12.7f",j,xit[j],j,p[j]); 1852: if(j % ncovmodel == 0) 1853: printf("\n"); 1854: } 1855: #endif 1856: for (j=1;j<=n;j++) { 1857: xi[j][ibig]=xi[j][n]; /* Replace direction with biggest decrease by last direction n */ 1858: xi[j][n]=xit[j]; /* and this nth direction by the by the average p_0 p_n */ 1859: } 1860: printf("Gaining to use new average direction of P0 P%d instead of biggest increase direction %d :\n",n,ibig); 1861: fprintf(ficlog,"Gaining to use new average direction of P0 P%d instead of biggest increase direction %d :\n",n,ibig); 1862: 1863: #ifdef DEBUG 1864: printf("Direction changed last moved %d in place of ibig=%d, new last is the average:\n",n,ibig); 1865: fprintf(ficlog,"Direction changed last moved %d in place of ibig=%d, new last is the average:\n",n,ibig); 1866: for(j=1;j<=n;j++){ 1867: printf(" %.12e",xit[j]); 1868: fprintf(ficlog," %.12e",xit[j]); 1869: } 1870: printf("\n"); 1871: fprintf(ficlog,"\n"); 1872: #endif 1873: } /* end of t or directest negative */ 1874: #ifdef POWELLF1F3 1875: #else 1876: } /* end if (fptt < fp) */ 1877: #endif 1878: } /* loop iteration */ 1879: } 1880: 1881: /**** Prevalence limit (stable or period prevalence) ****************/ 1882: 1883: double **prevalim(double **prlim, int nlstate, double x[], double age, double **oldm, double **savm, double ftolpl, int ij) 1884: { 1885: /* Computes the prevalence limit in each live state at age x by left multiplying the unit 1886: matrix by transitions matrix until convergence is reached */ 1887: 1888: int i, ii,j,k; 1889: double min, max, maxmin, maxmax,sumnew=0.; 1890: /* double **matprod2(); */ /* test */ 1891: double **out, cov[NCOVMAX+1], **pmij(); 1892: double **newm; 1893: double agefin, delaymax=50 ; /* Max number of years to converge */ 1894: 1895: for (ii=1;ii<=nlstate+ndeath;ii++) 1896: for (j=1;j<=nlstate+ndeath;j++){ 1897: oldm[ii][j]=(ii==j ? 1.0 : 0.0); 1898: } 1899: 1900: cov[1]=1.; 1901: 1902: /* Even if hstepm = 1, at least one multiplication by the unit matrix */ 1903: for(agefin=age-stepm/YEARM; agefin>=age-delaymax; agefin=agefin-stepm/YEARM){ 1904: newm=savm; 1905: /* Covariates have to be included here again */ 1906: cov[2]=agefin; 1907: if(nagesqr==1) 1908: cov[3]= agefin*agefin;; 1909: for (k=1; k<=cptcovn;k++) { 1910: cov[2+nagesqr+k]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]]; 1911: /*printf("prevalim ij=%d k=%d Tvar[%d]=%d nbcode=%d cov=%lf codtab[%d][Tvar[%d]]=%d \n",ij,k, k, Tvar[k],nbcode[Tvar[k]][codtab[ij][Tvar[k]]],cov[2+k], ij, k, codtab[ij][Tvar[k]]);*/ 1912: } 1913: /*wrong? for (k=1; k<=cptcovage;k++) cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2]; */ 1914: for (k=1; k<=cptcovage;k++) cov[2+nagesqr+Tage[k]]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]]*cov[2]; 1915: for (k=1; k<=cptcovprod;k++) /* Useless */ 1916: cov[2+nagesqr+Tprod[k]]=nbcode[Tvard[k][1]][codtab[ij][Tvard[k][1]]] * nbcode[Tvard[k][2]][codtab[ij][Tvard[k][2]]]; 1917: 1918: /*printf("ij=%d cptcovprod=%d tvar=%d ", ij, cptcovprod, Tvar[1]);*/ 1919: /*printf("ij=%d cov[3]=%lf cov[4]=%lf \n",ij, cov[3],cov[4]);*/ 1920: /*printf("ij=%d cov[3]=%lf \n",ij, cov[3]);*/ 1921: /* savm=pmij(pmmij,cov,ncovmodel,x,nlstate); */ 1922: /* out=matprod2(newm, pmij(pmmij,cov,ncovmodel,x,nlstate),1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, oldm); /\* Bug Valgrind *\/ */ 1923: out=matprod2(newm, pmij(pmmij,cov,ncovmodel,x,nlstate),1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, oldm); /* Bug Valgrind */ 1924: 1925: savm=oldm; 1926: oldm=newm; 1927: maxmax=0.; 1928: for(j=1;j<=nlstate;j++){ 1929: min=1.; 1930: max=0.; 1931: for(i=1; i<=nlstate; i++) { 1932: sumnew=0; 1933: for(k=1; k<=ndeath; k++) sumnew+=newm[i][nlstate+k]; 1934: prlim[i][j]= newm[i][j]/(1-sumnew); 1935: /*printf(" prevalim i=%d, j=%d, prmlim[%d][%d]=%f, agefin=%d \n", i, j, i, j, prlim[i][j],(int)agefin);*/ 1936: max=FMAX(max,prlim[i][j]); 1937: min=FMIN(min,prlim[i][j]); 1938: } 1939: maxmin=max-min; 1940: maxmax=FMAX(maxmax,maxmin); 1941: } /* j loop */ 1942: if(maxmax < ftolpl){ 1943: return prlim; 1944: } 1945: } /* age loop */ 1946: return prlim; /* should not reach here */ 1947: } 1948: 1949: /*************** transition probabilities ***************/ 1950: 1951: double **pmij(double **ps, double *cov, int ncovmodel, double *x, int nlstate ) 1952: { 1953: /* According to parameters values stored in x and the covariate's values stored in cov, 1954: computes the probability to be observed in state j being in state i by appying the 1955: model to the ncovmodel covariates (including constant and age). 1956: lnpijopii=ln(pij/pii)= aij+bij*age+cij*v1+dij*v2+... = sum_nc=1^ncovmodel xij(nc)*cov[nc] 1957: and, according on how parameters are entered, the position of the coefficient xij(nc) of the 1958: ncth covariate in the global vector x is given by the formula: 1959: j=i nc + ((i-1)*(nlstate+ndeath-1)+(j-2))*ncovmodel 1961: Computes ln(pij/pii) (lnpijopii), deduces pij/pii by exponentiation, 1962: sums on j different of i to get 1-pii/pii, deduces pii, and then all pij. 1963: Outputs ps[i][j] the probability to be observed in j being in j according to 1964: the values of the covariates cov[nc] and corresponding parameter values x[nc+shiftij] 1965: */ 1966: double s1, lnpijopii; 1967: /*double t34;*/ 1968: int i,j, nc, ii, jj; 1969: 1970: for(i=1; i<= nlstate; i++){ 1971: for(j=1; j<i;j++){ 1972: for (nc=1, lnpijopii=0.;nc <=ncovmodel; nc++){ 1973: /*lnpijopii += param[i][j][nc]*cov[nc];*/ 1974: lnpijopii += x[nc+((i-1)*(nlstate+ndeath-1)+j-1)*ncovmodel]*cov[nc]; 1975: /* printf("Int j<i s1=%.17e, lnpijopii=%.17e\n",s1,lnpijopii); */ 1976: } 1977: ps[i][j]=lnpijopii; /* In fact ln(pij/pii) */ 1978: /* printf("s1=%.17e, lnpijopii=%.17e\n",s1,lnpijopii); */ 1979: } 1980: for(j=i+1; j<=nlstate+ndeath;j++){ 1981: for (nc=1, lnpijopii=0.;nc <=ncovmodel; nc++){ 1982: /*lnpijopii += x[(i-1)*nlstate*ncovmodel+(j-2)*ncovmodel+nc+(i-1)*(ndeath-1)*ncovmodel]*cov[nc];*/ 1983: lnpijopii += x[nc + ((i-1)*(nlstate+ndeath-1)+(j-2))*ncovmodel]*cov[nc]; 1984: /* printf("Int j>i s1=%.17e, lnpijopii=%.17e %lx %lx\n",s1,lnpijopii,s1,lnpijopii); */ 1985: } 1986: ps[i][j]=lnpijopii; /* In fact ln(pij/pii) */ 1987: } 1988: } 1989: 1990: for(i=1; i<= nlstate; i++){ 1991: s1=0; 1992: for(j=1; j<i; j++){ 1993: s1+=exp(ps[i][j]); /* In fact sums pij/pii */ 1994: /*printf("debug1 %d %d ps=%lf exp(ps)=%lf s1+=%lf\n",i,j,ps[i][j],exp(ps[i][j]),s1); */ 1995: } 1996: for(j=i+1; j<=nlstate+ndeath; j++){ 1997: s1+=exp(ps[i][j]); /* In fact sums pij/pii */ 1998: /*printf("debug2 %d %d ps=%lf exp(ps)=%lf s1+=%lf\n",i,j,ps[i][j],exp(ps[i][j]),s1); */ 1999: } 2000: /* s1= sum_{j<>i} pij/pii=(1-pii)/pii and thus pii is known from s1 */ 2001: ps[i][i]=1./(s1+1.); 2002: /* Computing other pijs */ 2003: for(j=1; j<i; j++) 2004: ps[i][j]= exp(ps[i][j])*ps[i][i]; 2005: for(j=i+1; j<=nlstate+ndeath; j++) 2006: ps[i][j]= exp(ps[i][j])*ps[i][i]; 2007: /* ps[i][nlstate+1]=1.-s1- ps[i][i];*/ /* Sum should be 1 */ 2008: } /* end i */ 2009: 2010: for(ii=nlstate+1; ii<= nlstate+ndeath; ii++){ 2011: for(jj=1; jj<= nlstate+ndeath; jj++){ 2012: ps[ii][jj]=0; 2013: ps[ii][ii]=1; 2014: } 2015: } 2016: 2017: 2018: /* for(ii=1; ii<= nlstate+ndeath; ii++){ */ 2019: /* for(jj=1; jj<= nlstate+ndeath; jj++){ */ 2020: /* printf(" pmij ps[%d][%d]=%lf ",ii,jj,ps[ii][jj]); */ 2021: /* } */ 2022: /* printf("\n "); */ 2023: /* } */ 2024: /* printf("\n ");printf("%lf ",cov[2]);*/ 2025: /* 2026: for(i=1; i<= npar; i++) printf("%f ",x[i]); 2027: goto end;*/ 2028: return ps; 2029: } 2030: 2031: /**************** Product of 2 matrices ******************/ 2032: 2033: double **matprod2(double **out, double **in,int nrl, int nrh, int ncl, int nch, int ncolol, int ncoloh, double **b) 2034: { 2035: /* Computes the matrix product of in(1,nrh-nrl+1)(1,nch-ncl+1) times 2036: b(1,nch-ncl+1)(1,ncoloh-ncolol+1) into out(...) */ 2037: /* in, b, out are matrice of pointers which should have been initialized 2038: before: only the contents of out is modified. The function returns 2039: a pointer to pointers identical to out */ 2040: int i, j, k; 2041: for(i=nrl; i<= nrh; i++) 2042: for(k=ncolol; k<=ncoloh; k++){ 2043: out[i][k]=0.; 2044: for(j=ncl; j<=nch; j++) 2045: out[i][k] +=in[i][j]*b[j][k]; 2046: } 2047: return out; 2048: } 2049: 2050: 2051: /************* Higher Matrix Product ***************/ 2052: 2053: double ***hpxij(double ***po, int nhstepm, double age, int hstepm, double *x, int nlstate, int stepm, double **oldm, double **savm, int ij ) 2054: { 2055: /* Computes the transition matrix starting at age 'age' over 2056: 'nhstepm*hstepm*stepm' months (i.e. until 2057: age (in years) age+nhstepm*hstepm*stepm/12) by multiplying 2058: nhstepm*hstepm matrices. 2059: Output is stored in matrix po[i][j][h] for h every 'hstepm' step 2060: (typically every 2 years instead of every month which is too big 2061: for the memory). 2062: Model is determined by parameters x and covariates have to be 2063: included manually here. 2064: 2065: */ 2066: 2067: int i, j, d, h, k; 2068: double **out, cov[NCOVMAX+1]; 2069: double **newm; 2070: double agexact; 2071: 2072: /* Hstepm could be zero and should return the unit matrix */ 2073: for (i=1;i<=nlstate+ndeath;i++) 2074: for (j=1;j<=nlstate+ndeath;j++){ 2075: oldm[i][j]=(i==j ? 1.0 : 0.0); 2076: po[i][j][0]=(i==j ? 1.0 : 0.0); 2077: } 2078: /* Even if hstepm = 1, at least one multiplication by the unit matrix */ 2079: for(h=1; h <=nhstepm; h++){ 2080: for(d=1; d <=hstepm; d++){ 2081: newm=savm; 2082: /* Covariates have to be included here again */ 2083: cov[1]=1.; 2084: agexact=age+((h-1)*hstepm + (d-1))*stepm/YEARM; 2085: cov[2]=agexact; 2086: if(nagesqr==1) 2087: cov[3]= agexact*agexact; 2088: for (k=1; k<=cptcovn;k++) 2089: cov[2+nagesqr+k]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]]; 2090: for (k=1; k<=cptcovage;k++) /* Should start at cptcovn+1 */ 2091: /* cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2]; */ 2092: cov[2+nagesqr+Tage[k]]=nbcode[Tvar[Tage[k]]][codtab[ij][Tvar[Tage[k]]]]*cov[2]; 2093: for (k=1; k<=cptcovprod;k++) /* Useless because included in cptcovn */ 2094: cov[2+nagesqr+Tprod[k]]=nbcode[Tvard[k][1]][codtab[ij][Tvard[k][1]]]*nbcode[Tvard[k][2]][codtab[ij][Tvard[k][2]]]; 2095: 2096: 2097: /*printf("hxi cptcov=%d cptcode=%d\n",cptcov,cptcode);*/ 2098: /*printf("h=%d d=%d age=%f cov=%f\n",h,d,age,cov[2]);*/ 2099: out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, 2100: pmij(pmmij,cov,ncovmodel,x,nlstate)); 2101: savm=oldm; 2102: oldm=newm; 2103: } 2104: for(i=1; i<=nlstate+ndeath; i++) 2105: for(j=1;j<=nlstate+ndeath;j++) { 2106: po[i][j][h]=newm[i][j]; 2107: /*if(h==nhstepm) printf("po[%d][%d][%d]=%f ",i,j,h,po[i][j][h]);*/ 2108: } 2109: /*printf("h=%d ",h);*/ 2110: } /* end h */ 2111: /* printf("\n H=%d \n",h); */ 2112: return po; 2113: } 2114: 2115: #ifdef NLOPT 2116: double myfunc(unsigned n, const double *p1, double *grad, void *pd){ 2117: double fret; 2118: double *xt; 2119: int j; 2120: myfunc_data *d2 = (myfunc_data *) pd; 2121: /* xt = (p1-1); */ 2122: xt=vector(1,n); 2123: for (j=1;j<=n;j++) xt[j]=p1[j-1]; /* xt[1]=p1[0] */ 2124: 2125: fret=(d2->function)(xt); /* p xt[1]@8 is fine */ 2126: /* fret=(*func)(xt); /\* p xt[1]@8 is fine *\/ */ 2127: printf("Function = %.12lf ",fret); 2128: for (j=1;j<=n;j++) printf(" %d %.8lf", j, xt[j]); 2129: printf("\n"); 2130: free_vector(xt,1,n); 2131: return fret; 2132: } 2133: #endif 2134: 2135: /*************** log-likelihood *************/ 2136: double func( double *x) 2137: { 2138: int i, ii, j, k, mi, d, kk; 2139: double l, ll[NLSTATEMAX+1], cov[NCOVMAX+1]; 2140: double **out; 2141: double sw; /* Sum of weights */ 2142: double lli; /* Individual log likelihood */ 2143: int s1, s2; 2144: double bbh, survp; 2145: long ipmx; 2146: double agexact; 2147: /*extern weight */ 2148: /* We are differentiating ll according to initial status */ 2149: /* for (i=1;i<=npar;i++) printf("%f ", x[i]);*/ 2150: /*for(i=1;i<imx;i++) 2151: printf(" %d\n",s[4][i]); 2152: */ 2153: 2154: ++countcallfunc; 2155: 2156: cov[1]=1.; 2157: 2158: for(k=1; k<=nlstate; k++) ll[k]=0.; 2159: 2160: if(mle==1){ 2161: for (i=1,ipmx=0, sw=0.; i<=imx; i++){ 2162: /* Computes the values of the ncovmodel covariates of the model 2163: depending if the covariates are fixed or variying (age dependent) and stores them in cov[] 2164: Then computes with function pmij which return a matrix p[i][j] giving the elementary probability 2165: to be observed in j being in i according to the model. 2166: */ 2167: for (k=1; k<=cptcovn;k++){ /* Simple and product covariates without age* products */ 2168: cov[2+nagesqr+k]=covar[Tvar[k]][i]; 2169: } 2170: /* In model V2+V1*V4+age*V3+V3*V2 Tvar[1] is V2, Tvar[2=V1*V4] 2171: is 6, Tvar[3=age*V3] should not be computed because of age Tvar[4=V3*V2] 2172: has been calculated etc */ 2173: for(mi=1; mi<= wav[i]-1; mi++){ 2174: for (ii=1;ii<=nlstate+ndeath;ii++) 2175: for (j=1;j<=nlstate+ndeath;j++){ 2176: oldm[ii][j]=(ii==j ? 1.0 : 0.0); 2177: savm[ii][j]=(ii==j ? 1.0 : 0.0); 2178: } 2179: for(d=0; d<dh[mi][i]; d++){ 2180: newm=savm; 2181: agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; 2182: cov[2]=agexact; 2183: if(nagesqr==1) 2184: cov[3]= agexact*agexact; 2185: for (kk=1; kk<=cptcovage;kk++) { 2186: cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; /* Tage[kk] gives the data-covariate associated with age */ 2187: } 2188: out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, 2189: 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); 2190: savm=oldm; 2191: oldm=newm; 2192: } /* end mult */ 2193: 2194: /*lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]);*/ /* Original formula */ 2195: /* But now since version 0.9 we anticipate for bias at large stepm. 2196: * If stepm is larger than one month (smallest stepm) and if the exact delay 2197: * (in months) between two waves is not a multiple of stepm, we rounded to 2198: * the nearest (and in case of equal distance, to the lowest) interval but now 2199: * we keep into memory the bias bh[mi][i] and also the previous matrix product 2200: * (i.e to dh[mi][i]-1) saved in 'savm'. Then we inter(extra)polate the 2201: * probability in order to take into account the bias as a fraction of the way 2202: * from savm to out if bh is negative or even beyond if bh is positive. bh varies 2203: * -stepm/2 to stepm/2 . 2204: * For stepm=1 the results are the same as for previous versions of Imach. 2205: * For stepm > 1 the results are less biased than in previous versions. 2206: */ 2207: s1=s[mw[mi][i]][i]; 2208: s2=s[mw[mi+1][i]][i]; 2209: bbh=(double)bh[mi][i]/(double)stepm; 2210: /* bias bh is positive if real duration 2211: * is higher than the multiple of stepm and negative otherwise. 2212: */ 2213: /* lli= (savm[s1][s2]>1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2]));*/ 2214: if( s2 > nlstate){ 2215: /* i.e. if s2 is a death state and if the date of death is known 2216: then the contribution to the likelihood is the probability to 2217: die between last step unit time and current step unit time, 2218: which is also equal to probability to die before dh 2219: minus probability to die before dh-stepm . 2220: In version up to 0.92 likelihood was computed 2221: as if date of death was unknown. Death was treated as any other 2222: health state: the date of the interview describes the actual state 2223: and not the date of a change in health state. The former idea was 2224: to consider that at each interview the state was recorded 2225: (healthy, disable or death) and IMaCh was corrected; but when we 2226: introduced the exact date of death then we should have modified 2227: the contribution of an exact death to the likelihood. This new 2228: contribution is smaller and very dependent of the step unit 2229: stepm. It is no more the probability to die between last interview 2230: and month of death but the probability to survive from last 2231: interview up to one month before death multiplied by the 2232: probability to die within a month. Thanks to Chris 2233: Jackson for correcting this bug. Former versions increased 2234: mortality artificially. The bad side is that we add another loop 2235: which slows down the processing. The difference can be up to 10% 2236: lower mortality. 2237: */ 2238: /* If, at the beginning of the maximization mostly, the 2239: cumulative probability or probability to be dead is 2240: constant (ie = 1) over time d, the difference is equal to 2241: 0. out[s1][3] = savm[s1][3]: probability, being at state 2242: s1 at precedent wave, to be dead a month before current 2243: wave is equal to probability, being at state s1 at 2244: precedent wave, to be dead at mont of the current 2245: wave. Then the observed probability (that this person died) 2246: is null according to current estimated parameter. In fact, 2247: it should be very low but not zero otherwise the log go to 2248: infinity. 2249: */ 2250: /* #ifdef INFINITYORIGINAL */ 2251: /* lli=log(out[s1][s2] - savm[s1][s2]); */ 2252: /* #else */ 2253: /* if ((out[s1][s2] - savm[s1][s2]) < mytinydouble) */ 2254: /* lli=log(mytinydouble); */ 2255: /* else */ 2256: /* lli=log(out[s1][s2] - savm[s1][s2]); */ 2257: /* #endif */ 2258: lli=log(out[s1][s2] - savm[s1][s2]); 2259: 2260: } else if (s2==-2) { 2261: for (j=1,survp=0. ; j<=nlstate; j++) 2262: survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; 2263: /*survp += out[s1][j]; */ 2264: lli= log(survp); 2265: } 2266: 2267: else if (s2==-4) { 2268: for (j=3,survp=0. ; j<=nlstate; j++) 2269: survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; 2270: lli= log(survp); 2271: } 2272: 2273: else if (s2==-5) { 2274: for (j=1,survp=0. ; j<=2; j++) 2275: survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; 2276: lli= log(survp); 2277: } 2278: 2279: else{ 2280: lli= log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]); /* linear interpolation */ 2281: /* lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*(savm[s1][s2])):log((1.+bbh)*out[s1][s2]));*/ /* linear interpolation */ 2282: } 2283: /*lli=(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]);*/ 2284: /*if(lli ==000.0)*/ 2285: /*printf("bbh= %f lli=%f savm=%f out=%f %d\n",bbh,lli,savm[s1][s2], out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]],i); */ 2286: ipmx +=1; 2287: sw += weight[i]; 2288: ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; 2289: /* if (lli < log(mytinydouble)){ */ 2290: /* printf("Close to inf lli = %.10lf < %.10lf i= %d mi= %d, s[%d][i]=%d s1=%d s2=%d\n", lli,log(mytinydouble), i, mi,mw[mi][i], s[mw[mi][i]][i], s1,s2); */ 2291: /* fprintf(ficlog,"Close to inf lli = %.10lf i= %d mi= %d, s[mw[mi][i]][i]=%d\n", lli, i, mi,s[mw[mi][i]][i]); */ 2292: /* } */ 2293: } /* end of wave */ 2294: } /* end of individual */ 2295: } else if(mle==2){ 2296: for (i=1,ipmx=0, sw=0.; i<=imx; i++){ 2297: for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; 2298: for(mi=1; mi<= wav[i]-1; mi++){ 2299: for (ii=1;ii<=nlstate+ndeath;ii++) 2300: for (j=1;j<=nlstate+ndeath;j++){ 2301: oldm[ii][j]=(ii==j ? 1.0 : 0.0); 2302: savm[ii][j]=(ii==j ? 1.0 : 0.0); 2303: } 2304: for(d=0; d<=dh[mi][i]; d++){ 2305: newm=savm; 2306: agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; 2307: cov[2]=agexact; 2308: if(nagesqr==1) 2309: cov[3]= agexact*agexact; 2310: for (kk=1; kk<=cptcovage;kk++) { 2311: cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; 2312: } 2313: out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, 2314: 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); 2315: savm=oldm; 2316: oldm=newm; 2317: } /* end mult */ 2318: 2319: s1=s[mw[mi][i]][i]; 2320: s2=s[mw[mi+1][i]][i]; 2321: bbh=(double)bh[mi][i]/(double)stepm; 2322: lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*(savm[s1][s2])):log((1.+bbh)*out[s1][s2])); /* linear interpolation */ 2323: ipmx +=1; 2324: sw += weight[i]; 2325: ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; 2326: } /* end of wave */ 2327: } /* end of individual */ 2328: } else if(mle==3){ /* exponential inter-extrapolation */ 2329: for (i=1,ipmx=0, sw=0.; i<=imx; i++){ 2330: for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; 2331: for(mi=1; mi<= wav[i]-1; mi++){ 2332: for (ii=1;ii<=nlstate+ndeath;ii++) 2333: for (j=1;j<=nlstate+ndeath;j++){ 2334: oldm[ii][j]=(ii==j ? 1.0 : 0.0); 2335: savm[ii][j]=(ii==j ? 1.0 : 0.0); 2336: } 2337: for(d=0; d<dh[mi][i]; d++){ 2338: newm=savm; 2339: agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; 2340: cov[2]=agexact; 2341: if(nagesqr==1) 2342: cov[3]= agexact*agexact; 2343: for (kk=1; kk<=cptcovage;kk++) { 2344: cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; 2345: } 2346: out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, 2347: 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); 2348: savm=oldm; 2349: oldm=newm; 2350: } /* end mult */ 2351: 2352: s1=s[mw[mi][i]][i]; 2353: s2=s[mw[mi+1][i]][i]; 2354: bbh=(double)bh[mi][i]/(double)stepm; 2355: lli= (savm[s1][s2]>1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2])); /* exponential inter-extrapolation */ 2356: ipmx +=1; 2357: sw += weight[i]; 2358: ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; 2359: } /* end of wave */ 2360: } /* end of individual */ 2361: }else if (mle==4){ /* ml=4 no inter-extrapolation */ 2362: for (i=1,ipmx=0, sw=0.; i<=imx; i++){ 2363: for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; 2364: for(mi=1; mi<= wav[i]-1; mi++){ 2365: for (ii=1;ii<=nlstate+ndeath;ii++) 2366: for (j=1;j<=nlstate+ndeath;j++){ 2367: oldm[ii][j]=(ii==j ? 1.0 : 0.0); 2368: savm[ii][j]=(ii==j ? 1.0 : 0.0); 2369: } 2370: for(d=0; d<dh[mi][i]; d++){ 2371: newm=savm; 2372: agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; 2373: cov[2]=agexact; 2374: if(nagesqr==1) 2375: cov[3]= agexact*agexact; 2376: for (kk=1; kk<=cptcovage;kk++) { 2377: cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; 2378: } 2379: 2380: out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, 2381: 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); 2382: savm=oldm; 2383: oldm=newm; 2384: } /* end mult */ 2385: 2386: s1=s[mw[mi][i]][i]; 2387: s2=s[mw[mi+1][i]][i]; 2388: if( s2 > nlstate){ 2389: lli=log(out[s1][s2] - savm[s1][s2]); 2390: }else{ 2391: lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]); /* Original formula */ 2392: } 2393: ipmx +=1; 2394: sw += weight[i]; 2395: ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; 2396: /* printf("i=%6d s1=%1d s2=%1d mi=%1d mw=%1d dh=%3d prob=%10.6f w=%6.4f out=%10.6f sav=%10.6f\n",i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],out[s1][s2],savm[s1][s2]); */ 2397: } /* end of wave */ 2398: } /* end of individual */ 2399: }else{ /* ml=5 no inter-extrapolation no jackson =0.8a */ 2400: for (i=1,ipmx=0, sw=0.; i<=imx; i++){ 2401: for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; 2402: for(mi=1; mi<= wav[i]-1; mi++){ 2403: for (ii=1;ii<=nlstate+ndeath;ii++) 2404: for (j=1;j<=nlstate+ndeath;j++){ 2405: oldm[ii][j]=(ii==j ? 1.0 : 0.0); 2406: savm[ii][j]=(ii==j ? 1.0 : 0.0); 2407: } 2408: for(d=0; d<dh[mi][i]; d++){ 2409: newm=savm; 2410: agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; 2411: cov[2]=agexact; 2412: if(nagesqr==1) 2413: cov[3]= agexact*agexact; 2414: for (kk=1; kk<=cptcovage;kk++) { 2415: cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; 2416: } 2417: 2418: out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, 2419: 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); 2420: savm=oldm; 2421: oldm=newm; 2422: } /* end mult */ 2423: 2424: s1=s[mw[mi][i]][i]; 2425: s2=s[mw[mi+1][i]][i]; 2426: lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]); /* Original formula */ 2427: ipmx +=1; 2428: sw += weight[i]; 2429: ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; 2430: /*printf("i=%6d s1=%1d s2=%1d mi=%1d mw=%1d dh=%3d prob=%10.6f w=%6.4f out=%10.6f sav=%10.6f\n",i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],out[s1][s2],savm[s1][s2]);*/ 2431: } /* end of wave */ 2432: } /* end of individual */ 2433: } /* End of if */ 2434: for(k=1,l=0.; k<=nlstate; k++) l += ll[k]; 2435: /* printf("l1=%f l2=%f ",ll[1],ll[2]); */ 2436: l= l*ipmx/sw; /* To get the same order of magnitude as if weight=1 for every body */ 2437: return -l; 2438: } 2439: 2440: /*************** log-likelihood *************/ 2441: double funcone( double *x) 2442: { 2443: /* Same as likeli but slower because of a lot of printf and if */ 2444: int i, ii, j, k, mi, d, kk; 2445: double l, ll[NLSTATEMAX+1], cov[NCOVMAX+1]; 2446: double **out; 2447: double lli; /* Individual log likelihood */ 2448: double llt; 2449: int s1, s2; 2450: double bbh, survp; 2451: double agexact; 2452: /*extern weight */ 2453: /* We are differentiating ll according to initial status */ 2454: /* for (i=1;i<=npar;i++) printf("%f ", x[i]);*/ 2455: /*for(i=1;i<imx;i++) 2456: printf(" %d\n",s[4][i]); 2457: */ 2458: cov[1]=1.; 2459: 2460: for(k=1; k<=nlstate; k++) ll[k]=0.; 2461: 2462: for (i=1,ipmx=0, sw=0.; i<=imx; i++){ 2463: for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; 2464: for(mi=1; mi<= wav[i]-1; mi++){ 2465: for (ii=1;ii<=nlstate+ndeath;ii++) 2466: for (j=1;j<=nlstate+ndeath;j++){ 2467: oldm[ii][j]=(ii==j ? 1.0 : 0.0); 2468: savm[ii][j]=(ii==j ? 1.0 : 0.0); 2469: } 2470: for(d=0; d<dh[mi][i]; d++){ 2471: newm=savm; 2472: agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; 2473: cov[2]=agexact; 2474: if(nagesqr==1) 2475: cov[3]= agexact*agexact; 2476: for (kk=1; kk<=cptcovage;kk++) { 2477: cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; 2478: } 2479: 2480: /* savm=pmij(pmmij,cov,ncovmodel,x,nlstate); */ 2481: out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, 2482: 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); 2483: /* out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, */ 2484: /* 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); */ 2485: savm=oldm; 2486: oldm=newm; 2487: } /* end mult */ 2488: 2489: s1=s[mw[mi][i]][i]; 2490: s2=s[mw[mi+1][i]][i]; 2491: bbh=(double)bh[mi][i]/(double)stepm; 2492: /* bias is positive if real duration 2493: * is higher than the multiple of stepm and negative otherwise. 2494: */ 2495: if( s2 > nlstate && (mle <5) ){ /* Jackson */ 2496: lli=log(out[s1][s2] - savm[s1][s2]); 2497: } else if (s2==-2) { 2498: for (j=1,survp=0. ; j<=nlstate; j++) 2499: survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; 2500: lli= log(survp); 2501: }else if (mle==1){ 2502: lli= log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]); /* linear interpolation */ 2503: } else if(mle==2){ 2504: lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]):log((1.+bbh)*out[s1][s2])); /* linear interpolation */ 2505: } else if(mle==3){ /* exponential inter-extrapolation */ 2506: lli= (savm[s1][s2]>(double)1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2])); /* exponential inter-extrapolation */ 2507: } else if (mle==4){ /* mle=4 no inter-extrapolation */ 2508: lli=log(out[s1][s2]); /* Original formula */ 2509: } else{ /* mle=0 back to 1 */ 2510: lli= log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]); /* linear interpolation */ 2511: /*lli=log(out[s1][s2]); */ /* Original formula */ 2512: } /* End of if */ 2513: ipmx +=1; 2514: sw += weight[i]; 2515: ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; 2516: /*printf("i=%6d s1=%1d s2=%1d mi=%1d mw=%1d dh=%3d prob=%10.6f w=%6.4f out=%10.6f sav=%10.6f\n",i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],out[s1][s2],savm[s1][s2]); */ 2517: if(globpr){ 2518: fprintf(ficresilk,"%9ld %6d %2d %2d %1d %1d %3d %11.6f %8.4f\ 2519: %11.6f %11.6f %11.6f ", \ 2520: num[i],i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i], 2521: 2*weight[i]*lli,out[s1][s2],savm[s1][s2]); 2522: for(k=1,llt=0.,l=0.; k<=nlstate; k++){ 2523: llt +=ll[k]*gipmx/gsw; 2524: fprintf(ficresilk," %10.6f",-ll[k]*gipmx/gsw); 2525: } 2526: fprintf(ficresilk," %10.6f\n", -llt); 2527: } 2528: } /* end of wave */ 2529: } /* end of individual */ 2530: for(k=1,l=0.; k<=nlstate; k++) l += ll[k]; 2531: /* printf("l1=%f l2=%f ",ll[1],ll[2]); */ 2532: l= l*ipmx/sw; /* To get the same order of magnitude as if weight=1 for every body */ 2533: if(globpr==0){ /* First time we count the contributions and weights */ 2534: gipmx=ipmx; 2535: gsw=sw; 2536: } 2537: return -l; 2538: } 2539: 2540: 2541: /*************** function likelione ***********/ 2542: void likelione(FILE *ficres,double p[], int npar, int nlstate, int *globpri, long *ipmx, double *sw, double *fretone, double (*funcone)(double [])) 2543: { 2544: /* This routine should help understanding what is done with 2545: the selection of individuals/waves and 2546: to check the exact contribution to the likelihood. 2547: Plotting could be done. 2548: */ 2549: int k; 2550: 2551: if(*globpri !=0){ /* Just counts and sums, no printings */ 2552: strcpy(fileresilk,"ilk"); 2553: strcat(fileresilk,fileres); 2554: if((ficresilk=fopen(fileresilk,"w"))==NULL) { 2555: printf("Problem with resultfile: %s\n", fileresilk); 2556: fprintf(ficlog,"Problem with resultfile: %s\n", fileresilk); 2557: } 2558: fprintf(ficresilk, "#individual(line's_record) s1 s2 wave# effective_wave# number_of_matrices_product pij weight -2ln(pij)*weight 0pij_x 0pij_(x-stepm) cumulating_loglikeli_by_health_state(reweighted=-2ll*weightXnumber_of_contribs/sum_of_weights) and_total\n"); 2559: fprintf(ficresilk, "#num_i i s1 s2 mi mw dh likeli weight 2wlli out sav "); 2560: /* i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],2*weight[i]*lli,out[s1][s2],savm[s1][s2]); */ 2561: for(k=1; k<=nlstate; k++) 2562: fprintf(ficresilk," -2*gipw/gsw*weight*ll[%d]++",k); 2563: fprintf(ficresilk," -2*gipw/gsw*weight*ll(total)\n"); 2564: } 2565: 2566: *fretone=(*funcone)(p); 2567: if(*globpri !=0){ 2568: fclose(ficresilk); 2569: fprintf(fichtm,"\n File of contributions to the likelihood: <a href=\"%s\">%s</a> \n",subdirf(fileresilk),subdirf(fileresilk)); 2570: fflush(fichtm); 2571: } 2572: return; 2573: } 2574: 2575: 2576: /*********** Maximum Likelihood Estimation ***************/ 2577: 2578: void mlikeli(FILE *ficres,double p[], int npar, int ncovmodel, int nlstate, double ftol, double (*func)(double [])) 2579: { 2580: int i,j, iter=0; 2581: double **xi; 2582: double fret; 2583: double fretone; /* Only one call to likelihood */ 2584: /* char filerespow[FILENAMELENGTH];*/ 2585: 2586: #ifdef NLOPT 2587: int creturn; 2588: nlopt_opt opt; 2589: /* double lb[9] = { -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL }; /\* lower bounds *\/ */ 2590: double *lb; 2591: double minf; /* the minimum objective value, upon return */ 2592: double * p1; /* Shifted parameters from 0 instead of 1 */ 2593: myfunc_data dinst, *d = &dinst; 2594: #endif 2595: 2596: 2597: xi=matrix(1,npar,1,npar); 2598: for (i=1;i<=npar;i++) 2599: for (j=1;j<=npar;j++) 2600: xi[i][j]=(i==j ? 1.0 : 0.0); 2601: printf("Powell\n"); fprintf(ficlog,"Powell\n"); 2602: strcpy(filerespow,"pow"); 2603: strcat(filerespow,fileres); 2604: if((ficrespow=fopen(filerespow,"w"))==NULL) { 2605: printf("Problem with resultfile: %s\n", filerespow); 2606: fprintf(ficlog,"Problem with resultfile: %s\n", filerespow); 2607: } 2608: fprintf(ficrespow,"# Powell\n# iter -2*LL"); 2609: for (i=1;i<=nlstate;i++) 2610: for(j=1;j<=nlstate+ndeath;j++) 2611: if(j!=i)fprintf(ficrespow," p%1d%1d",i,j); 2612: fprintf(ficrespow,"\n"); 2613: #ifdef POWELL 2614: powell(p,xi,npar,ftol,&iter,&fret,func); 2615: #endif 2616: 2617: #ifdef NLOPT 2618: #ifdef NEWUOA 2619: opt = nlopt_create(NLOPT_LN_NEWUOA,npar); 2620: #else 2621: opt = nlopt_create(NLOPT_LN_BOBYQA,npar); 2622: #endif 2623: lb=vector(0,npar-1); 2624: for (i=0;i<npar;i++) lb[i]= -HUGE_VAL; 2625: nlopt_set_lower_bounds(opt, lb); 2626: nlopt_set_initial_step1(opt, 0.1); 2627: 2628: p1= (p+1); /* p *(p+1)@8 and p *(p1)@8 are equal p1[0]=p[1] */ 2629: d->function = func; 2630: printf(" Func %.12lf \n",myfunc(npar,p1,NULL,d)); 2631: nlopt_set_min_objective(opt, myfunc, d); 2632: nlopt_set_xtol_rel(opt, ftol); 2633: if ((creturn=nlopt_optimize(opt, p1, &minf)) < 0) { 2634: printf("nlopt failed! %d\n",creturn); 2635: } 2636: else { 2637: printf("found minimum after %d evaluations (NLOPT=%d)\n", countcallfunc ,NLOPT); 2638: printf("found minimum at f(%g,%g) = %0.10g\n", p[0], p[1], minf); 2639: iter=1; /* not equal */ 2640: } 2641: nlopt_destroy(opt); 2642: #endif 2643: free_matrix(xi,1,npar,1,npar); 2644: fclose(ficrespow); 2645: printf("#Number of iterations & function calls = %d & %d, -2 Log likelihood = %.12f\n",iter, countcallfunc,func(p)); 2646: fprintf(ficlog,"#Number of iterations & function calls = %d & %d, -2 Log likelihood = %.12f\n",iter, countcallfunc,func(p)); 2647: fprintf(ficres,"#Number of iterations & function calls = %d & %d, -2 Log likelihood = %.12f\n",iter, countcallfunc,func(p)); 2648: 2649: } 2650: 2651: /**** Computes Hessian and covariance matrix ***/ 2652: void hesscov(double **matcov, double p[], int npar, double delti[], double ftolhess, double (*func)(double [])) 2653: { 2654: double **a,**y,*x,pd; 2655: double **hess; 2656: int i, j; 2657: int *indx; 2658: 2659: double hessii(double p[], double delta, int theta, double delti[],double (*func)(double []),int npar); 2660: double hessij(double p[], double delti[], int i, int j,double (*func)(double []),int npar); 2661: void lubksb(double **a, int npar, int *indx, double b[]) ; 2662: void ludcmp(double **a, int npar, int *indx, double *d) ; 2663: double gompertz(double p[]); 2664: hess=matrix(1,npar,1,npar); 2665: 2666: printf("\nCalculation of the hessian matrix. Wait...\n"); 2667: fprintf(ficlog,"\nCalculation of the hessian matrix. Wait...\n"); 2668: for (i=1;i<=npar;i++){ 2669: printf("%d",i);fflush(stdout); 2670: fprintf(ficlog,"%d",i);fflush(ficlog); 2671: 2672: hess[i][i]=hessii(p,ftolhess,i,delti,func,npar); 2673: 2674: /* printf(" %f ",p[i]); 2675: printf(" %lf %lf %lf",hess[i][i],ftolhess,delti[i]);*/ 2676: } 2677: 2678: for (i=1;i<=npar;i++) { 2679: for (j=1;j<=npar;j++) { 2680: if (j>i) { 2681: printf(".%d%d",i,j);fflush(stdout); 2682: fprintf(ficlog,".%d%d",i,j);fflush(ficlog); 2683: hess[i][j]=hessij(p,delti,i,j,func,npar); 2684: 2685: hess[j][i]=hess[i][j]; 2686: /*printf(" %lf ",hess[i][j]);*/ 2687: } 2688: } 2689: } 2690: printf("\n"); 2691: fprintf(ficlog,"\n"); 2692: 2693: printf("\nInverting the hessian to get the covariance matrix. Wait...\n"); 2694: fprintf(ficlog,"\nInverting the hessian to get the covariance matrix. Wait...\n"); 2695: 2696: a=matrix(1,npar,1,npar); 2697: y=matrix(1,npar,1,npar); 2698: x=vector(1,npar); 2699: indx=ivector(1,npar); 2700: for (i=1;i<=npar;i++) 2701: for (j=1;j<=npar;j++) a[i][j]=hess[i][j]; 2702: ludcmp(a,npar,indx,&pd); 2703: 2704: for (j=1;j<=npar;j++) { 2705: for (i=1;i<=npar;i++) x[i]=0; 2706: x[j]=1; 2707: lubksb(a,npar,indx,x); 2708: for (i=1;i<=npar;i++){ 2709: matcov[i][j]=x[i]; 2710: } 2711: } 2712: 2713: printf("\n#Hessian matrix#\n"); 2714: fprintf(ficlog,"\n#Hessian matrix#\n"); 2715: for (i=1;i<=npar;i++) { 2716: for (j=1;j<=npar;j++) { 2717: printf("%.3e ",hess[i][j]); 2718: fprintf(ficlog,"%.3e ",hess[i][j]); 2719: } 2720: printf("\n"); 2721: fprintf(ficlog,"\n"); 2722: } 2723: 2724: /* Recompute Inverse */ 2725: for (i=1;i<=npar;i++) 2726: for (j=1;j<=npar;j++) a[i][j]=matcov[i][j]; 2727: ludcmp(a,npar,indx,&pd); 2728: 2729: /* printf("\n#Hessian matrix recomputed#\n"); 2730: 2731: for (j=1;j<=npar;j++) { 2732: for (i=1;i<=npar;i++) x[i]=0; 2733: x[j]=1; 2734: lubksb(a,npar,indx,x); 2735: for (i=1;i<=npar;i++){ 2736: y[i][j]=x[i]; 2737: printf("%.3e ",y[i][j]); 2738: fprintf(ficlog,"%.3e ",y[i][j]); 2739: } 2740: printf("\n"); 2741: fprintf(ficlog,"\n"); 2742: } 2743: */ 2744: 2745: free_matrix(a,1,npar,1,npar); 2746: free_matrix(y,1,npar,1,npar); 2747: free_vector(x,1,npar); 2748: free_ivector(indx,1,npar); 2749: free_matrix(hess,1,npar,1,npar); 2750: 2751: 2752: } 2753: 2754: /*************** hessian matrix ****************/ 2755: double hessii(double x[], double delta, int theta, double delti[], double (*func)(double []), int npar) 2756: { 2757: int i; 2758: int l=1, lmax=20; 2759: double k1,k2; 2760: double p2[MAXPARM+1]; /* identical to x */ 2761: double res; 2762: double delt=0.0001, delts, nkhi=10.,nkhif=1., khi=1.e-4; 2763: double fx; 2764: int k=0,kmax=10; 2765: double l1; 2766: 2767: fx=func(x); 2768: for (i=1;i<=npar;i++) p2[i]=x[i]; 2769: for(l=0 ; l <=lmax; l++){ /* Enlarging the zone around the Maximum */ 2770: l1=pow(10,l); 2771: delts=delt; 2772: for(k=1 ; k <kmax; k=k+1){ 2773: delt = delta*(l1*k); 2774: p2[theta]=x[theta] +delt; 2775: k1=func(p2)-fx; /* Might be negative if too close to the theoretical maximum */ 2776: p2[theta]=x[theta]-delt; 2777: k2=func(p2)-fx; 2778: /*res= (k1-2.0*fx+k2)/delt/delt; */ 2779: res= (k1+k2)/delt/delt/2.; /* Divided by because L and not 2*L */ 2780: 2781: #ifdef DEBUGHESS 2782: printf("%d %d k1=%.12e k2=%.12e xk1=%.12e xk2=%.12e delt=%.12e res=%.12e l=%d k=%d,fx=%.12e\n",theta,theta,k1,k2,x[theta]+delt,x[theta]-delt,delt,res, l, k,fx); 2783: fprintf(ficlog,"%d %d k1=%.12e k2=%.12e xk1=%.12e xk2=%.12e delt=%.12e res=%.12e l=%d k=%d,fx=%.12e\n",theta,theta,k1,k2,x[theta]+delt,x[theta]-delt,delt,res, l, k,fx); 2784: #endif 2785: /*if(fabs(k1-2.0*fx+k2) <1.e-13){ */ 2786: if((k1 <khi/nkhi/2.) || (k2 <khi/nkhi/2.)){ 2787: k=kmax; 2788: } 2789: else if((k1 >khi/nkhif) || (k2 >khi/nkhif)){ /* Keeps lastvalue before 3.84/2 KHI2 5% 1d.f. */ 2790: k=kmax; l=lmax*10; 2791: } 2792: else if((k1 >khi/nkhi) || (k2 >khi/nkhi)){ 2793: delts=delt; 2794: } 2795: } 2796: } 2797: delti[theta]=delts; 2798: return res; 2799: 2800: } 2801: 2802: double hessij( double x[], double delti[], int thetai,int thetaj,double (*func)(double []),int npar) 2803: { 2804: int i; 2805: int l=1, lmax=20; 2806: double k1,k2,k3,k4,res,fx; 2807: double p2[MAXPARM+1]; 2808: int k; 2809: 2810: fx=func(x); 2811: for (k=1; k<=2; k++) { 2812: for (i=1;i<=npar;i++) p2[i]=x[i]; 2813: p2[thetai]=x[thetai]+delti[thetai]/k; 2814: p2[thetaj]=x[thetaj]+delti[thetaj]/k; 2815: k1=func(p2)-fx; 2816: 2817: p2[thetai]=x[thetai]+delti[thetai]/k; 2818: p2[thetaj]=x[thetaj]-delti[thetaj]/k; 2819: k2=func(p2)-fx; 2820: 2821: p2[thetai]=x[thetai]-delti[thetai]/k; 2822: p2[thetaj]=x[thetaj]+delti[thetaj]/k; 2823: k3=func(p2)-fx; 2824: 2825: p2[thetai]=x[thetai]-delti[thetai]/k; 2826: p2[thetaj]=x[thetaj]-delti[thetaj]/k; 2827: k4=func(p2)-fx; 2828: res=(k1-k2-k3+k4)/4.0/delti[thetai]*k/delti[thetaj]*k/2.; /* Because of L not 2*L */ 2829: #ifdef DEBUG 2830: printf("%d %d k=%d, k1=%.12e k2=%.12e k3=%.12e k4=%.12e delti/k=%.12e deltj/k=%.12e, xi-de/k=%.12e xj-de/k=%.12e res=%.12e k1234=%.12e,k1-2=%.12e,k3-4=%.12e\n",thetai,thetaj,k,k1,k2,k3,k4,delti[thetai]/k,delti[thetaj]/k,x[thetai]-delti[thetai]/k,x[thetaj]-delti[thetaj]/k, res,k1-k2-k3+k4,k1-k2,k3-k4); 2831: fprintf(ficlog,"%d %d k=%d, k1=%.12e k2=%.12e k3=%.12e k4=%.12e delti/k=%.12e deltj/k=%.12e, xi-de/k=%.12e xj-de/k=%.12e res=%.12e k1234=%.12e,k1-2=%.12e,k3-4=%.12e\n",thetai,thetaj,k,k1,k2,k3,k4,delti[thetai]/k,delti[thetaj]/k,x[thetai]-delti[thetai]/k,x[thetaj]-delti[thetaj]/k, res,k1-k2-k3+k4,k1-k2,k3-k4); 2832: #endif 2833: } 2834: return res; 2835: } 2836: 2837: /************** Inverse of matrix **************/ 2838: void ludcmp(double **a, int n, int *indx, double *d) 2839: { 2840: int i,imax,j,k; 2841: double big,dum,sum,temp; 2842: double *vv; 2843: 2844: vv=vector(1,n); 2845: *d=1.0; 2846: for (i=1;i<=n;i++) { 2847: big=0.0; 2848: for (j=1;j<=n;j++) 2849: if ((temp=fabs(a[i][j])) > big) big=temp; 2850: if (big == 0.0) nrerror("Singular matrix in routine ludcmp"); 2851: vv[i]=1.0/big; 2852: } 2853: for (j=1;j<=n;j++) { 2854: for (i=1;i<j;i++) { 2855: sum=a[i][j]; 2856: for (k=1;k<i;k++) sum -= a[i][k]*a[k][j]; 2857: a[i][j]=sum; 2858: } 2859: big=0.0; 2860: for (i=j;i<=n;i++) { 2861: sum=a[i][j]; 2862: for (k=1;k<j;k++) 2863: sum -= a[i][k]*a[k][j]; 2864: a[i][j]=sum; 2865: if ( (dum=vv[i]*fabs(sum)) >= big) { 2866: big=dum; 2867: imax=i; 2868: } 2869: } 2870: if (j != imax) { 2871: for (k=1;k<=n;k++) { 2872: dum=a[imax][k]; 2873: a[imax][k]=a[j][k]; 2874: a[j][k]=dum; 2875: } 2876: *d = -(*d); 2877: vv[imax]=vv[j]; 2878: } 2879: indx[j]=imax; 2880: if (a[j][j] == 0.0) a[j][j]=TINY; 2881: if (j != n) { 2882: dum=1.0/(a[j][j]); 2883: for (i=j+1;i<=n;i++) a[i][j] *= dum; 2884: } 2885: } 2886: free_vector(vv,1,n); /* Doesn't work */ 2887: ; 2888: } 2889: 2890: void lubksb(double **a, int n, int *indx, double b[]) 2891: { 2892: int i,ii=0,ip,j; 2893: double sum; 2894: 2895: for (i=1;i<=n;i++) { 2896: ip=indx[i]; 2897: sum=b[ip]; 2898: b[ip]=b[i]; 2899: if (ii) 2900: for (j=ii;j<=i-1;j++) sum -= a[i][j]*b[j]; 2901: else if (sum) ii=i; 2902: b[i]=sum; 2903: } 2904: for (i=n;i>=1;i--) { 2905: sum=b[i]; 2906: for (j=i+1;j<=n;j++) sum -= a[i][j]*b[j]; 2907: b[i]=sum/a[i][i]; 2908: } 2909: } 2910: 2911: void pstamp(FILE *fichier) 2912: { 2913: fprintf(fichier,"# %s.%s\n#IMaCh version %s, %s\n#%s\n# %s", optionfilefiname,optionfilext,version,copyright, fullversion, strstart); 2914: } 2915: 2916: /************ Frequencies ********************/ 2917: void freqsummary(char fileres[], int iagemin, int iagemax, int **s, double **agev, int nlstate, int imx, int *Tvaraff, int **nbcode, int *ncodemax,double **mint,double **anint, char strstart[]) 2918: { /* Some frequencies */ 2919: 2920: int i, m, jk, j1, bool, z1,j; 2921: int first; 2922: double ***freq; /* Frequencies */ 2923: double *pp, **prop; 2924: double pos,posprop, k2, dateintsum=0,k2cpt=0; 2925: char fileresp[FILENAMELENGTH]; 2926: 2927: pp=vector(1,nlstate); 2928: prop=matrix(1,nlstate,iagemin,iagemax+3); 2929: strcpy(fileresp,"p"); 2930: strcat(fileresp,fileres); 2931: if((ficresp=fopen(fileresp,"w"))==NULL) { 2932: printf("Problem with prevalence resultfile: %s\n", fileresp); 2933: fprintf(ficlog,"Problem with prevalence resultfile: %s\n", fileresp); 2934: exit(0); 2935: } 2936: freq= ma3x(-5,nlstate+ndeath,-5,nlstate+ndeath,iagemin,iagemax+3); 2937: j1=0; 2938: 2939: j=cptcoveff; 2940: if (cptcovn<1) {j=1;ncodemax[1]=1;} 2941: 2942: first=1; 2943: 2944: /* for(k1=1; k1<=j ; k1++){ */ /* Loop on covariates */ 2945: /* for(i1=1; i1<=ncodemax[k1];i1++){ */ /* Now it is 2 */ 2946: /* j1++; */ 2947: for (j1 = 1; j1 <= (int) pow(2,cptcoveff); j1++){ 2948: /*printf("cptcoveff=%d Tvaraff=%d", cptcoveff,Tvaraff[1]); 2949: scanf("%d", i);*/ 2950: for (i=-5; i<=nlstate+ndeath; i++) 2951: for (jk=-5; jk<=nlstate+ndeath; jk++) 2952: for(m=iagemin; m <= iagemax+3; m++) 2953: freq[i][jk][m]=0; 2954: 2955: for (i=1; i<=nlstate; i++) 2956: for(m=iagemin; m <= iagemax+3; m++) 2957: prop[i][m]=0; 2958: 2959: dateintsum=0; 2960: k2cpt=0; 2961: for (i=1; i<=imx; i++) { 2962: bool=1; 2963: if (cptcovn>0) { /* Filter is here: Must be looked at for model=V1+V2+V3+V4 */ 2964: for (z1=1; z1<=cptcoveff; z1++) 2965: if (covar[Tvaraff[z1]][i]!= nbcode[Tvaraff[z1]][codtab[j1][z1]]){ 2966: /* Tests if the value of each of the covariates of i is equal to filter j1 */ 2967: bool=0; 2968: /* printf("bool=%d i=%d, z1=%d, Tvaraff[%d]=%d, covar[Tvarff][%d]=%2f, codtab[%d][%d]=%d, nbcode[Tvaraff][codtab[%d][%d]=%d, j1=%d\n", 2969: bool,i,z1, z1, Tvaraff[z1],i,covar[Tvaraff[z1]][i],j1,z1,codtab[j1][z1], 2970: j1,z1,nbcode[Tvaraff[z1]][codtab[j1][z1]],j1);*/ 2971: /* For j1=7 in V1+V2+V3+V4 = 0 1 1 0 and codtab[7][3]=1 and nbcde[3][?]=1*/ 2972: } 2973: } 2974: 2975: if (bool==1){ 2976: for(m=firstpass; m<=lastpass; m++){ 2977: k2=anint[m][i]+(mint[m][i]/12.); 2978: /*if ((k2>=dateprev1) && (k2<=dateprev2)) {*/ 2979: if(agev[m][i]==0) agev[m][i]=iagemax+1; 2980: if(agev[m][i]==1) agev[m][i]=iagemax+2; 2981: if (s[m][i]>0 && s[m][i]<=nlstate) prop[s[m][i]][(int)agev[m][i]] += weight[i]; 2982: if (m<lastpass) { 2983: freq[s[m][i]][s[m+1][i]][(int)agev[m][i]] += weight[i]; 2984: freq[s[m][i]][s[m+1][i]][iagemax+3] += weight[i]; 2985: } 2986: 2987: if ((agev[m][i]>1) && (agev[m][i]< (iagemax+3))) { 2988: dateintsum=dateintsum+k2; 2989: k2cpt++; 2990: } 2991: /*}*/ 2992: } 2993: } 2994: } /* end i */ 2995: 2996: /* fprintf(ficresp, "#Count between %.lf/%.lf/%.lf and %.lf/%.lf/%.lf\n",jprev1, mprev1,anprev1,jprev2, mprev2,anprev2);*/ 2997: pstamp(ficresp); 2998: if (cptcovn>0) { 2999: fprintf(ficresp, "\n#********** Variable "); 3000: for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresp, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); 3001: fprintf(ficresp, "**********\n#"); 3002: fprintf(ficlog, "\n#********** Variable "); 3003: for (z1=1; z1<=cptcoveff; z1++) fprintf(ficlog, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); 3004: fprintf(ficlog, "**********\n#"); 3005: } 3006: for(i=1; i<=nlstate;i++) 3007: fprintf(ficresp, " Age Prev(%d) N(%d) N",i,i); 3008: fprintf(ficresp, "\n"); 3009: 3010: for(i=iagemin; i <= iagemax+3; i++){ 3011: if(i==iagemax+3){ 3012: fprintf(ficlog,"Total"); 3013: }else{ 3014: if(first==1){ 3015: first=0; 3016: printf("See log file for details...\n"); 3017: } 3018: fprintf(ficlog,"Age %d", i); 3019: } 3020: for(jk=1; jk <=nlstate ; jk++){ 3021: for(m=-1, pp[jk]=0; m <=nlstate+ndeath ; m++) 3022: pp[jk] += freq[jk][m][i]; 3023: } 3024: for(jk=1; jk <=nlstate ; jk++){ 3025: for(m=-1, pos=0; m <=0 ; m++) 3026: pos += freq[jk][m][i]; 3027: if(pp[jk]>=1.e-10){ 3028: if(first==1){ 3029: printf(" %d.=%.0f loss[%d]=%.1f%%",jk,pp[jk],jk,100*pos/pp[jk]); 3030: } 3031: fprintf(ficlog," %d.=%.0f loss[%d]=%.1f%%",jk,pp[jk],jk,100*pos/pp[jk]); 3032: }else{ 3033: if(first==1) 3034: printf(" %d.=%.0f loss[%d]=NaNQ%%",jk,pp[jk],jk); 3035: fprintf(ficlog," %d.=%.0f loss[%d]=NaNQ%%",jk,pp[jk],jk); 3036: } 3037: } 3038: 3039: for(jk=1; jk <=nlstate ; jk++){ 3040: for(m=0, pp[jk]=0; m <=nlstate+ndeath; m++) 3041: pp[jk] += freq[jk][m][i]; 3042: } 3043: for(jk=1,pos=0,posprop=0; jk <=nlstate ; jk++){ 3044: pos += pp[jk]; 3045: posprop += prop[jk][i]; 3046: } 3047: for(jk=1; jk <=nlstate ; jk++){ 3048: if(pos>=1.e-5){ 3049: if(first==1) 3050: printf(" %d.=%.0f prev[%d]=%.1f%%",jk,pp[jk],jk,100*pp[jk]/pos); 3051: fprintf(ficlog," %d.=%.0f prev[%d]=%.1f%%",jk,pp[jk],jk,100*pp[jk]/pos); 3052: }else{ 3053: if(first==1) 3054: printf(" %d.=%.0f prev[%d]=NaNQ%%",jk,pp[jk],jk); 3055: fprintf(ficlog," %d.=%.0f prev[%d]=NaNQ%%",jk,pp[jk],jk); 3056: } 3057: if( i <= iagemax){ 3058: if(pos>=1.e-5){ 3059: fprintf(ficresp," %d %.5f %.0f %.0f",i,prop[jk][i]/posprop, prop[jk][i],posprop); 3060: /*probs[i][jk][j1]= pp[jk]/pos;*/ 3061: /*printf("\ni=%d jk=%d j1=%d %.5f %.0f %.0f %f",i,jk,j1,pp[jk]/pos, pp[jk],pos,probs[i][jk][j1]);*/ 3062: } 3063: else 3064: fprintf(ficresp," %d NaNq %.0f %.0f",i,prop[jk][i],posprop); 3065: } 3066: } 3067: 3068: for(jk=-1; jk <=nlstate+ndeath; jk++) 3069: for(m=-1; m <=nlstate+ndeath; m++) 3070: if(freq[jk][m][i] !=0 ) { 3071: if(first==1) 3072: printf(" %d%d=%.0f",jk,m,freq[jk][m][i]); 3073: fprintf(ficlog," %d%d=%.0f",jk,m,freq[jk][m][i]); 3074: } 3075: if(i <= iagemax) 3076: fprintf(ficresp,"\n"); 3077: if(first==1) 3078: printf("Others in log...\n"); 3079: fprintf(ficlog,"\n"); 3080: } 3081: /*}*/ 3082: } 3083: dateintmean=dateintsum/k2cpt; 3084: 3085: fclose(ficresp); 3086: free_ma3x(freq,-5,nlstate+ndeath,-5,nlstate+ndeath, iagemin, iagemax+3); 3087: free_vector(pp,1,nlstate); 3088: free_matrix(prop,1,nlstate,iagemin, iagemax+3); 3089: /* End of Freq */ 3090: } 3091: 3092: /************ Prevalence ********************/ 3093: void prevalence(double ***probs, double agemin, double agemax, int **s, double **agev, int nlstate, int imx, int *Tvar, int **nbcode, int *ncodemax,double **mint,double **anint, double dateprev1,double dateprev2, int firstpass, int lastpass) 3094: { 3095: /* Compute observed prevalence between dateprev1 and dateprev2 by counting the number of people 3096: in each health status at the date of interview (if between dateprev1 and dateprev2). 3097: We still use firstpass and lastpass as another selection. 3098: */ 3099: 3100: int i, m, jk, j1, bool, z1,j; 3101: 3102: double **prop; 3103: double posprop; 3104: double y2; /* in fractional years */ 3105: int iagemin, iagemax; 3106: int first; /** to stop verbosity which is redirected to log file */ 3107: 3108: iagemin= (int) agemin; 3109: iagemax= (int) agemax; 3110: /*pp=vector(1,nlstate);*/ 3111: prop=matrix(1,nlstate,iagemin,iagemax+3); 3112: /* freq=ma3x(-1,nlstate+ndeath,-1,nlstate+ndeath,iagemin,iagemax+3);*/ 3113: j1=0; 3114: 3115: /*j=cptcoveff;*/ 3116: if (cptcovn<1) {j=1;ncodemax[1]=1;} 3117: 3118: first=1; 3119: for(j1=1; j1<= (int) pow(2,cptcoveff);j1++){ 3120: /*for(i1=1; i1<=ncodemax[k1];i1++){ 3121: j1++;*/ 3122: 3123: for (i=1; i<=nlstate; i++) 3124: for(m=iagemin; m <= iagemax+3; m++) 3125: prop[i][m]=0.0; 3126: 3127: for (i=1; i<=imx; i++) { /* Each individual */ 3128: bool=1; 3129: if (cptcovn>0) { 3130: for (z1=1; z1<=cptcoveff; z1++) 3131: if (covar[Tvaraff[z1]][i]!= nbcode[Tvaraff[z1]][codtab[j1][z1]]) 3132: bool=0; 3133: } 3134: if (bool==1) { 3135: for(m=firstpass; m<=lastpass; m++){/* Other selection (we can limit to certain interviews*/ 3136: y2=anint[m][i]+(mint[m][i]/12.); /* Fractional date in year */ 3137: if ((y2>=dateprev1) && (y2<=dateprev2)) { /* Here is the main selection (fractional years) */ 3138: if(agev[m][i]==0) agev[m][i]=iagemax+1; 3139: if(agev[m][i]==1) agev[m][i]=iagemax+2; 3140: if((int)agev[m][i] <iagemin || (int)agev[m][i] >iagemax+3) printf("Error on individual =%d agev[m][i]=%f m=%d\n",i, agev[m][i],m); 3141: if (s[m][i]>0 && s[m][i]<=nlstate) { 3142: /*if(i>4620) printf(" i=%d m=%d s[m][i]=%d (int)agev[m][i]=%d weight[i]=%f prop=%f\n",i,m,s[m][i],(int)agev[m][m],weight[i],prop[s[m][i]][(int)agev[m][i]]);*/ 3143: prop[s[m][i]][(int)agev[m][i]] += weight[i]; 3144: prop[s[m][i]][iagemax+3] += weight[i]; 3145: } 3146: } 3147: } /* end selection of waves */ 3148: } 3149: } 3150: for(i=iagemin; i <= iagemax+3; i++){ 3151: for(jk=1,posprop=0; jk <=nlstate ; jk++) { 3152: posprop += prop[jk][i]; 3153: } 3154: 3155: for(jk=1; jk <=nlstate ; jk++){ 3156: if( i <= iagemax){ 3157: if(posprop>=1.e-5){ 3158: probs[i][jk][j1]= prop[jk][i]/posprop; 3159: } else{ 3160: if(first==1){ 3161: first=0; 3162: printf("Warning Observed prevalence probs[%d][%d][%d]=%lf because of lack of cases\nSee others on log file...\n",jk,i,j1,probs[i][jk][j1]); 3163: } 3164: } 3165: } 3166: }/* end jk */ 3167: }/* end i */ 3168: /*} *//* end i1 */ 3169: } /* end j1 */ 3170: 3171: /* free_ma3x(freq,-1,nlstate+ndeath,-1,nlstate+ndeath, iagemin, iagemax+3);*/ 3172: /*free_vector(pp,1,nlstate);*/ 3173: free_matrix(prop,1,nlstate, iagemin,iagemax+3); 3174: } /* End of prevalence */ 3175: 3176: /************* Waves Concatenation ***************/ 3177: 3178: void concatwav(int wav[], int **dh, int **bh, int **mw, int **s, double *agedc, double **agev, int firstpass, int lastpass, int imx, int nlstate, int stepm) 3179: { 3180: /* Concatenates waves: wav[i] is the number of effective (useful waves) of individual i. 3181: Death is a valid wave (if date is known). 3182: mw[mi][i] is the mi (mi=1 to wav[i]) effective wave of individual i 3183: dh[m][i] or dh[mw[mi][i]][i] is the delay between two effective waves m=mw[mi][i] 3184: and mw[mi+1][i]. dh depends on stepm. 3185: */ 3186: 3187: int i, mi, m; 3188: /* int j, k=0,jk, ju, jl,jmin=1e+5, jmax=-1; 3189: double sum=0., jmean=0.;*/ 3190: int first; 3191: int j, k=0,jk, ju, jl; 3192: double sum=0.; 3193: first=0; 3194: jmin=100000; 3195: jmax=-1; 3196: jmean=0.; 3197: for(i=1; i<=imx; i++){ 3198: mi=0; 3199: m=firstpass; 3200: while(s[m][i] <= nlstate){ 3201: if(s[m][i]>=1 || s[m][i]==-2 || s[m][i]==-4 || s[m][i]==-5) 3202: mw[++mi][i]=m; 3203: if(m >=lastpass) 3204: break; 3205: else 3206: m++; 3207: }/* end while */ 3208: if (s[m][i] > nlstate){ 3209: mi++; /* Death is another wave */ 3210: /* if(mi==0) never been interviewed correctly before death */ 3211: /* Only death is a correct wave */ 3212: mw[mi][i]=m; 3213: } 3214: 3215: wav[i]=mi; 3216: if(mi==0){ 3217: nbwarn++; 3218: if(first==0){ 3219: printf("Warning! No valid information for individual %ld line=%d (skipped) and may be others, see log file\n",num[i],i); 3220: first=1; 3221: } 3222: if(first==1){ 3223: fprintf(ficlog,"Warning! No valid information for individual %ld line=%d (skipped)\n",num[i],i); 3224: } 3225: } /* end mi==0 */ 3226: } /* End individuals */ 3227: 3228: for(i=1; i<=imx; i++){ 3229: for(mi=1; mi<wav[i];mi++){ 3230: if (stepm <=0) 3231: dh[mi][i]=1; 3232: else{ 3233: if (s[mw[mi+1][i]][i] > nlstate) { /* A death */ 3234: if (agedc[i] < 2*AGESUP) { 3235: j= rint(agedc[i]*12-agev[mw[mi][i]][i]*12); 3236: if(j==0) j=1; /* Survives at least one month after exam */ 3237: else if(j<0){ 3238: nberr++; 3239: printf("Error! Negative delay (%d to death) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); 3240: j=1; /* Temporary Dangerous patch */ 3241: printf(" We assumed that the date of interview was correct (and not the date of death) and postponed the death %d month(s) (one stepm) after the interview. You MUST fix the contradiction between dates.\n",stepm); 3242: fprintf(ficlog,"Error! Negative delay (%d to death) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); 3243: fprintf(ficlog," We assumed that the date of interview was correct (and not the date of death) and postponed the death %d month(s) (one stepm) after the interview. You MUST fix the contradiction between dates.\n",stepm); 3244: } 3245: k=k+1; 3246: if (j >= jmax){ 3247: jmax=j; 3248: ijmax=i; 3249: } 3250: if (j <= jmin){ 3251: jmin=j; 3252: ijmin=i; 3253: } 3254: sum=sum+j; 3255: /*if (j<0) printf("j=%d num=%d \n",j,i);*/ 3256: /* printf("%d %d %d %d\n", s[mw[mi][i]][i] ,s[mw[mi+1][i]][i],j,i);*/ 3257: } 3258: } 3259: else{ 3260: j= rint( (agev[mw[mi+1][i]][i]*12 - agev[mw[mi][i]][i]*12)); 3261: /* if (j<0) printf("%d %lf %lf %d %d %d\n", i,agev[mw[mi+1][i]][i], agev[mw[mi][i]][i],j,s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); */ 3262: 3263: k=k+1; 3264: if (j >= jmax) { 3265: jmax=j; 3266: ijmax=i; 3267: } 3268: else if (j <= jmin){ 3269: jmin=j; 3270: ijmin=i; 3271: } 3272: /* if (j<10) printf("j=%d jmin=%d num=%d ",j,jmin,i); */ 3273: /*printf("%d %lf %d %d %d\n", i,agev[mw[mi][i]][i],j,s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]);*/ 3274: if(j<0){ 3275: nberr++; 3276: printf("Error! Negative delay (%d) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); 3277: fprintf(ficlog,"Error! Negative delay (%d) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); 3278: } 3279: sum=sum+j; 3280: } 3281: jk= j/stepm; 3282: jl= j -jk*stepm; 3283: ju= j -(jk+1)*stepm; 3284: if(mle <=1){ /* only if we use a the linear-interpoloation pseudo-likelihood */ 3285: if(jl==0){ 3286: dh[mi][i]=jk; 3287: bh[mi][i]=0; 3288: }else{ /* We want a negative bias in order to only have interpolation ie 3289: * to avoid the price of an extra matrix product in likelihood */ 3290: dh[mi][i]=jk+1; 3291: bh[mi][i]=ju; 3292: } 3293: }else{ 3294: if(jl <= -ju){ 3295: dh[mi][i]=jk; 3296: bh[mi][i]=jl; /* bias is positive if real duration 3297: * is higher than the multiple of stepm and negative otherwise. 3298: */ 3299: } 3300: else{ 3301: dh[mi][i]=jk+1; 3302: bh[mi][i]=ju; 3303: } 3304: if(dh[mi][i]==0){ 3305: dh[mi][i]=1; /* At least one step */ 3306: bh[mi][i]=ju; /* At least one step */ 3307: /* printf(" bh=%d ju=%d jl=%d dh=%d jk=%d stepm=%d %d\n",bh[mi][i],ju,jl,dh[mi][i],jk,stepm,i);*/ 3308: } 3309: } /* end if mle */ 3310: } 3311: } /* end wave */ 3312: } 3313: jmean=sum/k; 3314: printf("Delay (in months) between two waves Min=%d (for indiviudal %ld) Max=%d (%ld) Mean=%f\n\n ",jmin, num[ijmin], jmax, num[ijmax], jmean); 3315: fprintf(ficlog,"Delay (in months) between two waves Min=%d (for indiviudal %d) Max=%d (%d) Mean=%f\n\n ",jmin, ijmin, jmax, ijmax, jmean); 3316: } 3317: 3318: /*********** Tricode ****************************/ 3319: void tricode(int *Tvar, int **nbcode, int imx, int *Ndum) 3320: { 3321: /**< Uses cptcovn+2*cptcovprod as the number of covariates */ 3322: /* Tvar[i]=atoi(stre); find 'n' in Vn and stores in Tvar. If model=V2+V1 Tvar[1]=2 and Tvar[2]=1 3323: * Boring subroutine which should only output nbcode[Tvar[j]][k] 3324: * Tvar[5] in V2+V1+V3*age+V2*V4 is 2 (V2) 3325: * nbcode[Tvar[j]][1]= 3326: */ 3327: 3328: int ij=1, k=0, j=0, i=0, maxncov=NCOVMAX; 3329: int modmaxcovj=0; /* Modality max of covariates j */ 3330: int cptcode=0; /* Modality max of covariates j */ 3331: int modmincovj=0; /* Modality min of covariates j */ 3332: 3333: 3334: cptcoveff=0; 3335: 3336: for (k=1; k <= maxncov; k++) ncodemax[k]=0; /* Horrible constant again replaced by NCOVMAX */ 3337: 3338: /* Loop on covariates without age and products */ 3339: for (j=1; j<=(cptcovs); j++) { /* From model V1 + V2*age+ V3 + V3*V4 keeps V1 + V3 = 2 only */ 3340: for (k=-1; k < maxncov; k++) Ndum[k]=0; 3341: for (i=1; i<=imx; i++) { /* Loop on individuals: reads the data file to get the maximum value of the 3342: modality of this covariate Vj*/ 3343: ij=(int)(covar[Tvar[j]][i]); /* ij=0 or 1 or -1. Value of the covariate Tvar[j] for individual i 3344: * If product of Vn*Vm, still boolean *: 3345: * If it was coded 1, 2, 3, 4 should be splitted into 3 boolean variables 3346: * 1 => 0 0 0, 2 => 0 0 1, 3 => 0 1 1, 4=1 0 0 */ 3347: /* Finds for covariate j, n=Tvar[j] of Vn . ij is the 3348: modality of the nth covariate of individual i. */ 3349: if (ij > modmaxcovj) 3350: modmaxcovj=ij; 3351: else if (ij < modmincovj) 3352: modmincovj=ij; 3353: if ((ij < -1) && (ij > NCOVMAX)){ 3354: printf( "Error: minimal is less than -1 or maximal is bigger than %d. Exiting. \n", NCOVMAX ); 3355: exit(1); 3356: }else 3357: Ndum[ij]++; /*counts and stores the occurence of this modality 0, 1, -1*/ 3358: /* If coded 1, 2, 3 , counts the number of 1 Ndum[1], number of 2, Ndum[2], etc */ 3359: /*printf("i=%d ij=%d Ndum[ij]=%d imx=%d",i,ij,Ndum[ij],imx);*/ 3360: /* getting the maximum value of the modality of the covariate 3361: (should be 0 or 1 now) Tvar[j]. If V=sex and male is coded 0 and 3362: female is 1, then modmaxcovj=1.*/ 3363: } /* end for loop on individuals i */ 3364: printf(" Minimal and maximal values of %d th covariate V%d: min=%d max=%d \n", j, Tvar[j], modmincovj, modmaxcovj); 3365: fprintf(ficlog," Minimal and maximal values of %d th covariate V%d: min=%d max=%d \n", j, Tvar[j], modmincovj, modmaxcovj); 3366: cptcode=modmaxcovj; 3367: /* Ndum[0] = frequency of 0 for model-covariate j, Ndum[1] frequency of 1 etc. */ 3368: /*for (i=0; i<=cptcode; i++) {*/ 3369: for (k=modmincovj; k<=modmaxcovj; k++) { /* k=-1 ? 0 and 1*//* For each value k of the modality of model-cov j */ 3370: printf("Frequencies of covariates %d ie V%d with value %d: %d\n", j, Tvar[j], k, Ndum[k]); 3371: fprintf(ficlog, "Frequencies of covariates %d ie V%d with value %d: %d\n", j, Tvar[j], k, Ndum[k]); 3372: if( Ndum[k] != 0 ){ /* Counts if nobody answered modality k ie empty modality, we skip it and reorder */ 3373: if( k != -1){ 3374: ncodemax[j]++; /* ncodemax[j]= Number of modalities of the j th 3375: covariate for which somebody answered excluding 3376: undefined. Usually 2: 0 and 1. */ 3377: } 3378: ncodemaxwundef[j]++; /* ncodemax[j]= Number of modalities of the j th 3379: covariate for which somebody answered including 3380: undefined. Usually 3: -1, 0 and 1. */ 3381: } 3382: /* In fact ncodemax[j]=2 (dichotom. variables only) but it could be more for 3383: historical reasons: 3 if coded 1, 2, 3 and 4 and Ndum[2]=0 */ 3384: } /* Ndum[-1] number of undefined modalities */ 3385: 3386: /* j is a covariate, n=Tvar[j] of Vn; Fills nbcode */ 3387: /* For covariate j, modalities could be 1, 2, 3, 4, 5, 6, 7. 3388: If Ndum[1]=0, Ndum[2]=0, Ndum[3]= 635, Ndum[4]=0, Ndum[5]=0, Ndum[6]=27, Ndum[7]=125; 3389: modmincovj=3; modmaxcovj = 7; 3390: There are only 3 modalities non empty 3, 6, 7 (or 2 if 27 is too few) : ncodemax[j]=3; 3391: which will be coded 0, 1, 2 which in binary on 2=3-1 digits are 0=00 1=01, 2=10; 3392: defining two dummy variables: variables V1_1 and V1_2. 3393: nbcode[Tvar[j]][ij]=k; 3394: nbcode[Tvar[j]][1]=0; 3395: nbcode[Tvar[j]][2]=1; 3396: nbcode[Tvar[j]][3]=2; 3397: */ 3398: ij=0; /* ij is similar to i but can jumps over null modalities */ 3399: for (i=modmincovj; i<=modmaxcovj; i++) { /* i= 1 to 2 for dichotomous, or from 1 to 3 or from -1 to 1*/ 3400: if (Ndum[i] == 0) { /* If at least one individual responded to this modality k */ 3401: break; 3402: } 3403: ij++; 3404: nbcode[Tvar[j]][ij]=i; /* stores the original modality i in an array nbcode, ij modality from 1 to last non-nul modality.*/ 3405: cptcode = ij; /* New max modality for covar j */ 3406: } /* end of loop on modality i=-1 to 1 or more */ 3407: 3408: /* for (k=0; k<= cptcode; k++) { /\* k=-1 ? k=0 to 1 *\//\* Could be 1 to 4 *\//\* cptcode=modmaxcovj *\/ */ 3409: /* /\*recode from 0 *\/ */ 3410: /* k is a modality. If we have model=V1+V1*sex */ 3411: /* then: nbcode[1][1]=0 ; nbcode[1][2]=1; nbcode[2][1]=0 ; nbcode[2][2]=1; */ 3412: /* But if some modality were not used, it is recoded from 0 to a newer modmaxcovj=cptcode *\/ */ 3413: /* } */ 3414: /* /\* cptcode = ij; *\/ /\* New max modality for covar j *\/ */ 3415: /* if (ij > ncodemax[j]) { */ 3416: /* printf( " Error ij=%d > ncodemax[%d]=%d\n", ij, j, ncodemax[j]); */ 3417: /* fprintf(ficlog, " Error ij=%d > ncodemax[%d]=%d\n", ij, j, ncodemax[j]); */ 3418: /* break; */ 3419: /* } */ 3420: /* } /\* end of loop on modality k *\/ */ 3421: } /* end of loop on model-covariate j. nbcode[Tvarj][1]=0 and nbcode[Tvarj][2]=1 sets the value of covariate j*/ 3422: 3423: for (k=-1; k< maxncov; k++) Ndum[k]=0; 3424: 3425: for (i=1; i<=ncovmodel-2-nagesqr; i++) { /* -2, cste and age and eventually age*age */ 3426: /* Listing of all covariables in statement model to see if some covariates appear twice. For example, V1 appears twice in V1+V1*V2.*/ 3427: ij=Tvar[i]; /* Tvar might be -1 if status was unknown */ 3428: Ndum[ij]++; /* Might be supersed V1 + V1*age */ 3429: } 3430: 3431: ij=0; 3432: for (i=0; i<= maxncov-1; i++) { /* modmaxcovj is unknown here. Only Ndum[2(V2),3(age*V3), 5(V3*V2) 6(V1*V4) */ 3433: /*printf("Ndum[%d]=%d\n",i, Ndum[i]);*/ 3434: if((Ndum[i]!=0) && (i<=ncovcol)){ 3435: ij++; 3436: /*printf("diff Ndum[%d]=%d\n",i, Ndum[i]);*/ 3437: Tvaraff[ij]=i; /*For printing (unclear) */ 3438: }else{ 3439: /* Tvaraff[ij]=0; */ 3440: } 3441: } 3442: /* ij--; */ 3443: cptcoveff=ij; /*Number of total covariates*/ 3444: 3445: } 3446: 3447: 3448: /*********** Health Expectancies ****************/ 3449: 3450: void evsij(double ***eij, double x[], int nlstate, int stepm, int bage, int fage, double **oldm, double **savm, int cij, int estepm,char strstart[] ) 3451: 3452: { 3453: /* Health expectancies, no variances */ 3454: int i, j, nhstepm, hstepm, h, nstepm; 3455: int nhstepma, nstepma; /* Decreasing with age */ 3456: double age, agelim, hf; 3457: double ***p3mat; 3458: double eip; 3459: 3460: pstamp(ficreseij); 3461: fprintf(ficreseij,"# (a) Life expectancies by health status at initial age and (b) health expectancies by health status at initial age\n"); 3462: fprintf(ficreseij,"# Age"); 3463: for(i=1; i<=nlstate;i++){ 3464: for(j=1; j<=nlstate;j++){ 3465: fprintf(ficreseij," e%1d%1d ",i,j); 3466: } 3467: fprintf(ficreseij," e%1d. ",i); 3468: } 3469: fprintf(ficreseij,"\n"); 3470: 3471: 3472: if(estepm < stepm){ 3473: printf ("Problem %d lower than %d\n",estepm, stepm); 3474: } 3475: else hstepm=estepm; 3476: /* We compute the life expectancy from trapezoids spaced every estepm months 3477: * This is mainly to measure the difference between two models: for example 3478: * if stepm=24 months pijx are given only every 2 years and by summing them 3479: * we are calculating an estimate of the Life Expectancy assuming a linear 3480: * progression in between and thus overestimating or underestimating according 3481: * to the curvature of the survival function. If, for the same date, we 3482: * estimate the model with stepm=1 month, we can keep estepm to 24 months 3483: * to compare the new estimate of Life expectancy with the same linear 3484: * hypothesis. A more precise result, taking into account a more precise 3485: * curvature will be obtained if estepm is as small as stepm. */ 3486: 3487: /* For example we decided to compute the life expectancy with the smallest unit */ 3488: /* hstepm beeing the number of stepms, if hstepm=1 the length of hstepm is stepm. 3489: nhstepm is the number of hstepm from age to agelim 3490: nstepm is the number of stepm from age to agelin. 3491: Look at hpijx to understand the reason of that which relies in memory size 3492: and note for a fixed period like estepm months */ 3493: /* We decided (b) to get a life expectancy respecting the most precise curvature of the 3494: survival function given by stepm (the optimization length). Unfortunately it 3495: means that if the survival funtion is printed only each two years of age and if 3496: you sum them up and add 1 year (area under the trapezoids) you won't get the same 3497: results. So we changed our mind and took the option of the best precision. 3498: */ 3499: hstepm=hstepm/stepm; /* Typically in stepm units, if stepm=6 & estepm=24 , = 24/6 months = 4 */ 3500: 3501: agelim=AGESUP; 3502: /* If stepm=6 months */ 3503: /* Computed by stepm unit matrices, product of hstepm matrices, stored 3504: in an array of nhstepm length: nhstepm=10, hstepm=4, stepm=6 months */ 3505: 3506: /* nhstepm age range expressed in number of stepm */ 3507: nstepm=(int) rint((agelim-bage)*YEARM/stepm); /* Biggest nstepm */ 3508: /* Typically if 20 years nstepm = 20*12/6=40 stepm */ 3509: /* if (stepm >= YEARM) hstepm=1;*/ 3510: nhstepm = nstepm/hstepm;/* Expressed in hstepm, typically nhstepm=40/4=10 */ 3511: p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 3512: 3513: for (age=bage; age<=fage; age ++){ 3514: nstepma=(int) rint((agelim-bage)*YEARM/stepm); /* Biggest nstepm */ 3515: /* Typically if 20 years nstepm = 20*12/6=40 stepm */ 3516: /* if (stepm >= YEARM) hstepm=1;*/ 3517: nhstepma = nstepma/hstepm;/* Expressed in hstepm, typically nhstepma=40/4=10 */ 3518: 3519: /* If stepm=6 months */ 3520: /* Computed by stepm unit matrices, product of hstepma matrices, stored 3521: in an array of nhstepma length: nhstepma=10, hstepm=4, stepm=6 months */ 3522: 3523: hpxij(p3mat,nhstepma,age,hstepm,x,nlstate,stepm,oldm, savm, cij); 3524: 3525: hf=hstepm*stepm/YEARM; /* Duration of hstepm expressed in year unit. */ 3526: 3527: printf("%d|",(int)age);fflush(stdout); 3528: fprintf(ficlog,"%d|",(int)age);fflush(ficlog); 3529: 3530: /* Computing expectancies */ 3531: for(i=1; i<=nlstate;i++) 3532: for(j=1; j<=nlstate;j++) 3533: for (h=0, eij[i][j][(int)age]=0; h<=nhstepm-1; h++){ 3534: eij[i][j][(int)age] += (p3mat[i][j][h]+p3mat[i][j][h+1])/2.0*hf; 3535: 3536: /* if((int)age==70)printf("i=%2d,j=%2d,h=%2d,age=%3d,%9.4f,%9.4f,%9.4f\n",i,j,h,(int)age,p3mat[i][j][h],hf,eij[i][j][(int)age]);*/ 3537: 3538: } 3539: 3540: fprintf(ficreseij,"%3.0f",age ); 3541: for(i=1; i<=nlstate;i++){ 3542: eip=0; 3543: for(j=1; j<=nlstate;j++){ 3544: eip +=eij[i][j][(int)age]; 3545: fprintf(ficreseij,"%9.4f", eij[i][j][(int)age] ); 3546: } 3547: fprintf(ficreseij,"%9.4f", eip ); 3548: } 3549: fprintf(ficreseij,"\n"); 3550: 3551: } 3552: free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 3553: printf("\n"); 3554: fprintf(ficlog,"\n"); 3555: 3556: } 3557: 3558: void cvevsij(double ***eij, double x[], int nlstate, int stepm, int bage, int fage, double **oldm, double **savm, int cij, int estepm,double delti[],double **matcov,char strstart[] ) 3559: 3560: { 3561: /* Covariances of health expectancies eij and of total life expectancies according 3562: to initial status i, ei. . 3563: */ 3564: int i, j, nhstepm, hstepm, h, nstepm, k, cptj, cptj2, i2, j2, ij, ji; 3565: int nhstepma, nstepma; /* Decreasing with age */ 3566: double age, agelim, hf; 3567: double ***p3matp, ***p3matm, ***varhe; 3568: double **dnewm,**doldm; 3569: double *xp, *xm; 3570: double **gp, **gm; 3571: double ***gradg, ***trgradg; 3572: int theta; 3573: 3574: double eip, vip; 3575: 3576: varhe=ma3x(1,nlstate*nlstate,1,nlstate*nlstate,(int) bage, (int) fage); 3577: xp=vector(1,npar); 3578: xm=vector(1,npar); 3579: dnewm=matrix(1,nlstate*nlstate,1,npar); 3580: doldm=matrix(1,nlstate*nlstate,1,nlstate*nlstate); 3581: 3582: pstamp(ficresstdeij); 3583: fprintf(ficresstdeij,"# Health expectancies with standard errors\n"); 3584: fprintf(ficresstdeij,"# Age"); 3585: for(i=1; i<=nlstate;i++){ 3586: for(j=1; j<=nlstate;j++) 3587: fprintf(ficresstdeij," e%1d%1d (SE)",i,j); 3588: fprintf(ficresstdeij," e%1d. ",i); 3589: } 3590: fprintf(ficresstdeij,"\n"); 3591: 3592: pstamp(ficrescveij); 3593: fprintf(ficrescveij,"# Subdiagonal matrix of covariances of health expectancies by age: cov(eij,ekl)\n"); 3594: fprintf(ficrescveij,"# Age"); 3595: for(i=1; i<=nlstate;i++) 3596: for(j=1; j<=nlstate;j++){ 3597: cptj= (j-1)*nlstate+i; 3598: for(i2=1; i2<=nlstate;i2++) 3599: for(j2=1; j2<=nlstate;j2++){ 3600: cptj2= (j2-1)*nlstate+i2; 3601: if(cptj2 <= cptj) 3602: fprintf(ficrescveij," %1d%1d,%1d%1d",i,j,i2,j2); 3603: } 3604: } 3605: fprintf(ficrescveij,"\n"); 3606: 3607: if(estepm < stepm){ 3608: printf ("Problem %d lower than %d\n",estepm, stepm); 3609: } 3610: else hstepm=estepm; 3611: /* We compute the life expectancy from trapezoids spaced every estepm months 3612: * This is mainly to measure the difference between two models: for example 3613: * if stepm=24 months pijx are given only every 2 years and by summing them 3614: * we are calculating an estimate of the Life Expectancy assuming a linear 3615: * progression in between and thus overestimating or underestimating according 3616: * to the curvature of the survival function. If, for the same date, we 3617: * estimate the model with stepm=1 month, we can keep estepm to 24 months 3618: * to compare the new estimate of Life expectancy with the same linear 3619: * hypothesis. A more precise result, taking into account a more precise 3620: * curvature will be obtained if estepm is as small as stepm. */ 3621: 3622: /* For example we decided to compute the life expectancy with the smallest unit */ 3623: /* hstepm beeing the number of stepms, if hstepm=1 the length of hstepm is stepm. 3624: nhstepm is the number of hstepm from age to agelim 3625: nstepm is the number of stepm from age to agelin. 3626: Look at hpijx to understand the reason of that which relies in memory size 3627: and note for a fixed period like estepm months */ 3628: /* We decided (b) to get a life expectancy respecting the most precise curvature of the 3629: survival function given by stepm (the optimization length). Unfortunately it 3630: means that if the survival funtion is printed only each two years of age and if 3631: you sum them up and add 1 year (area under the trapezoids) you won't get the same 3632: results. So we changed our mind and took the option of the best precision. 3633: */ 3634: hstepm=hstepm/stepm; /* Typically in stepm units, if stepm=6 & estepm=24 , = 24/6 months = 4 */ 3635: 3636: /* If stepm=6 months */ 3637: /* nhstepm age range expressed in number of stepm */ 3638: agelim=AGESUP; 3639: nstepm=(int) rint((agelim-bage)*YEARM/stepm); 3640: /* Typically if 20 years nstepm = 20*12/6=40 stepm */ 3641: /* if (stepm >= YEARM) hstepm=1;*/ 3642: nhstepm = nstepm/hstepm;/* Expressed in hstepm, typically nhstepm=40/4=10 */ 3643: 3644: p3matp=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 3645: p3matm=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 3646: gradg=ma3x(0,nhstepm,1,npar,1,nlstate*nlstate); 3647: trgradg =ma3x(0,nhstepm,1,nlstate*nlstate,1,npar); 3648: gp=matrix(0,nhstepm,1,nlstate*nlstate); 3649: gm=matrix(0,nhstepm,1,nlstate*nlstate); 3650: 3651: for (age=bage; age<=fage; age ++){ 3652: nstepma=(int) rint((agelim-bage)*YEARM/stepm); /* Biggest nstepm */ 3653: /* Typically if 20 years nstepm = 20*12/6=40 stepm */ 3654: /* if (stepm >= YEARM) hstepm=1;*/ 3655: nhstepma = nstepma/hstepm;/* Expressed in hstepm, typically nhstepma=40/4=10 */ 3656: 3657: /* If stepm=6 months */ 3658: /* Computed by stepm unit matrices, product of hstepma matrices, stored 3659: in an array of nhstepma length: nhstepma=10, hstepm=4, stepm=6 months */ 3660: 3661: hf=hstepm*stepm/YEARM; /* Duration of hstepm expressed in year unit. */ 3662: 3663: /* Computing Variances of health expectancies */ 3664: /* Gradient is computed with plus gp and minus gm. Code is duplicated in order to 3665: decrease memory allocation */ 3666: for(theta=1; theta <=npar; theta++){ 3667: for(i=1; i<=npar; i++){ 3668: xp[i] = x[i] + (i==theta ?delti[theta]:0); 3669: xm[i] = x[i] - (i==theta ?delti[theta]:0); 3670: } 3671: hpxij(p3matp,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm, cij); 3672: hpxij(p3matm,nhstepm,age,hstepm,xm,nlstate,stepm,oldm,savm, cij); 3673: 3674: for(j=1; j<= nlstate; j++){ 3675: for(i=1; i<=nlstate; i++){ 3676: for(h=0; h<=nhstepm-1; h++){ 3677: gp[h][(j-1)*nlstate + i] = (p3matp[i][j][h]+p3matp[i][j][h+1])/2.; 3678: gm[h][(j-1)*nlstate + i] = (p3matm[i][j][h]+p3matm[i][j][h+1])/2.; 3679: } 3680: } 3681: } 3682: 3683: for(ij=1; ij<= nlstate*nlstate; ij++) 3684: for(h=0; h<=nhstepm-1; h++){ 3685: gradg[h][theta][ij]= (gp[h][ij]-gm[h][ij])/2./delti[theta]; 3686: } 3687: }/* End theta */ 3688: 3689: 3690: for(h=0; h<=nhstepm-1; h++) 3691: for(j=1; j<=nlstate*nlstate;j++) 3692: for(theta=1; theta <=npar; theta++) 3693: trgradg[h][j][theta]=gradg[h][theta][j]; 3694: 3695: 3696: for(ij=1;ij<=nlstate*nlstate;ij++) 3697: for(ji=1;ji<=nlstate*nlstate;ji++) 3698: varhe[ij][ji][(int)age] =0.; 3699: 3700: printf("%d|",(int)age);fflush(stdout); 3701: fprintf(ficlog,"%d|",(int)age);fflush(ficlog); 3702: for(h=0;h<=nhstepm-1;h++){ 3703: for(k=0;k<=nhstepm-1;k++){ 3704: matprod2(dnewm,trgradg[h],1,nlstate*nlstate,1,npar,1,npar,matcov); 3705: matprod2(doldm,dnewm,1,nlstate*nlstate,1,npar,1,nlstate*nlstate,gradg[k]); 3706: for(ij=1;ij<=nlstate*nlstate;ij++) 3707: for(ji=1;ji<=nlstate*nlstate;ji++) 3708: varhe[ij][ji][(int)age] += doldm[ij][ji]*hf*hf; 3709: } 3710: } 3711: 3712: /* Computing expectancies */ 3713: hpxij(p3matm,nhstepm,age,hstepm,x,nlstate,stepm,oldm, savm, cij); 3714: for(i=1; i<=nlstate;i++) 3715: for(j=1; j<=nlstate;j++) 3716: for (h=0, eij[i][j][(int)age]=0; h<=nhstepm-1; h++){ 3717: eij[i][j][(int)age] += (p3matm[i][j][h]+p3matm[i][j][h+1])/2.0*hf; 3718: 3719: /* if((int)age==70)printf("i=%2d,j=%2d,h=%2d,age=%3d,%9.4f,%9.4f,%9.4f\n",i,j,h,(int)age,p3mat[i][j][h],hf,eij[i][j][(int)age]);*/ 3720: 3721: } 3722: 3723: fprintf(ficresstdeij,"%3.0f",age ); 3724: for(i=1; i<=nlstate;i++){ 3725: eip=0.; 3726: vip=0.; 3727: for(j=1; j<=nlstate;j++){ 3728: eip += eij[i][j][(int)age]; 3729: for(k=1; k<=nlstate;k++) /* Sum on j and k of cov(eij,eik) */ 3730: vip += varhe[(j-1)*nlstate+i][(k-1)*nlstate+i][(int)age]; 3731: fprintf(ficresstdeij," %9.4f (%.4f)", eij[i][j][(int)age], sqrt(varhe[(j-1)*nlstate+i][(j-1)*nlstate+i][(int)age]) ); 3732: } 3733: fprintf(ficresstdeij," %9.4f (%.4f)", eip, sqrt(vip)); 3734: } 3735: fprintf(ficresstdeij,"\n"); 3736: 3737: fprintf(ficrescveij,"%3.0f",age ); 3738: for(i=1; i<=nlstate;i++) 3739: for(j=1; j<=nlstate;j++){ 3740: cptj= (j-1)*nlstate+i; 3741: for(i2=1; i2<=nlstate;i2++) 3742: for(j2=1; j2<=nlstate;j2++){ 3743: cptj2= (j2-1)*nlstate+i2; 3744: if(cptj2 <= cptj) 3745: fprintf(ficrescveij," %.4f", varhe[cptj][cptj2][(int)age]); 3746: } 3747: } 3748: fprintf(ficrescveij,"\n"); 3749: 3750: } 3751: free_matrix(gm,0,nhstepm,1,nlstate*nlstate); 3752: free_matrix(gp,0,nhstepm,1,nlstate*nlstate); 3753: free_ma3x(gradg,0,nhstepm,1,npar,1,nlstate*nlstate); 3754: free_ma3x(trgradg,0,nhstepm,1,nlstate*nlstate,1,npar); 3755: free_ma3x(p3matm,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 3756: free_ma3x(p3matp,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 3757: printf("\n"); 3758: fprintf(ficlog,"\n"); 3759: 3760: free_vector(xm,1,npar); 3761: free_vector(xp,1,npar); 3762: free_matrix(dnewm,1,nlstate*nlstate,1,npar); 3763: free_matrix(doldm,1,nlstate*nlstate,1,nlstate*nlstate); 3764: free_ma3x(varhe,1,nlstate*nlstate,1,nlstate*nlstate,(int) bage, (int)fage); 3765: } 3766: 3767: /************ Variance ******************/ 3768: void varevsij(char optionfilefiname[], double ***vareij, double **matcov, double x[], double delti[], int nlstate, int stepm, double bage, double fage, double **oldm, double **savm, double **prlim, double ftolpl, int ij, int estepm, int cptcov, int cptcod, int popbased, int mobilav, char strstart[]) 3769: { 3770: /* Variance of health expectancies */ 3771: /* double **prevalim(double **prlim, int nlstate, double *xp, double age, double **oldm, double ** savm,double ftolpl);*/ 3772: /* double **newm;*/ 3773: /* int movingaverage(double ***probs, double bage,double fage, double ***mobaverage, int mobilav)*/ 3774: 3775: int movingaverage(); 3776: double **dnewm,**doldm; 3777: double **dnewmp,**doldmp; 3778: int i, j, nhstepm, hstepm, h, nstepm ; 3779: int k; 3780: double *xp; 3781: double **gp, **gm; /* for var eij */ 3782: double ***gradg, ***trgradg; /*for var eij */ 3783: double **gradgp, **trgradgp; /* for var p point j */ 3784: double *gpp, *gmp; /* for var p point j */ 3785: double **varppt; /* for var p point j nlstate to nlstate+ndeath */ 3786: double ***p3mat; 3787: double age,agelim, hf; 3788: double ***mobaverage; 3789: int theta; 3790: char digit[4]; 3791: char digitp[25]; 3792: 3793: char fileresprobmorprev[FILENAMELENGTH]; 3794: 3795: if(popbased==1){ 3796: if(mobilav!=0) 3797: strcpy(digitp,"-populbased-mobilav-"); 3798: else strcpy(digitp,"-populbased-nomobil-"); 3799: } 3800: else 3801: strcpy(digitp,"-stablbased-"); 3802: 3803: if (mobilav!=0) { 3804: mobaverage= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 3805: if (movingaverage(probs, bage, fage, mobaverage,mobilav)!=0){ 3806: fprintf(ficlog," Error in movingaverage mobilav=%d\n",mobilav); 3807: printf(" Error in movingaverage mobilav=%d\n",mobilav); 3808: } 3809: } 3810: 3811: strcpy(fileresprobmorprev,"prmorprev"); 3812: sprintf(digit,"%-d",ij); 3813: /*printf("DIGIT=%s, ij=%d ijr=%-d|\n",digit, ij,ij);*/ 3814: strcat(fileresprobmorprev,digit); /* Tvar to be done */ 3815: strcat(fileresprobmorprev,digitp); /* Popbased or not, mobilav or not */ 3816: strcat(fileresprobmorprev,fileres); 3817: if((ficresprobmorprev=fopen(fileresprobmorprev,"w"))==NULL) { 3818: printf("Problem with resultfile: %s\n", fileresprobmorprev); 3819: fprintf(ficlog,"Problem with resultfile: %s\n", fileresprobmorprev); 3820: } 3821: printf("Computing total mortality p.j=w1*p1j+w2*p2j+..: result on file '%s' \n",fileresprobmorprev); 3822: 3823: fprintf(ficlog,"Computing total mortality p.j=w1*p1j+w2*p2j+..: result on file '%s' \n",fileresprobmorprev); 3824: pstamp(ficresprobmorprev); 3825: fprintf(ficresprobmorprev,"# probabilities of dying before estepm=%d months for people of exact age and weighted probabilities w1*p1j+w2*p2j+... stand dev in()\n",estepm); 3826: fprintf(ficresprobmorprev,"# Age cov=%-d",ij); 3827: for(j=nlstate+1; j<=(nlstate+ndeath);j++){ 3828: fprintf(ficresprobmorprev," p.%-d SE",j); 3829: for(i=1; i<=nlstate;i++) 3830: fprintf(ficresprobmorprev," w%1d p%-d%-d",i,i,j); 3831: } 3832: fprintf(ficresprobmorprev,"\n"); 3833: fprintf(ficgp,"\n# Routine varevsij"); 3834: /* fprintf(fichtm, "#Local time at start: %s", strstart);*/ 3835: fprintf(fichtm,"\n<li><h4> Computing probabilities of dying over estepm months as a weighted average (i.e global mortality independent of initial healh state)</h4></li>\n"); 3836: fprintf(fichtm,"\n %s \n",digitp); 3837: /* } */ 3838: varppt = matrix(nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath); 3839: pstamp(ficresvij); 3840: fprintf(ficresvij,"# Variance and covariance of health expectancies e.j \n# (weighted average of eij where weights are "); 3841: if(popbased==1) 3842: fprintf(ficresvij,"the age specific prevalence observed (cross-sectionally) in the population i.e cross-sectionally\n in each health state (popbased=1) (mobilav=%d\n",mobilav); 3843: else 3844: fprintf(ficresvij,"the age specific period (stable) prevalences in each health state \n"); 3845: fprintf(ficresvij,"# Age"); 3846: for(i=1; i<=nlstate;i++) 3847: for(j=1; j<=nlstate;j++) 3848: fprintf(ficresvij," Cov(e.%1d, e.%1d)",i,j); 3849: fprintf(ficresvij,"\n"); 3850: 3851: xp=vector(1,npar); 3852: dnewm=matrix(1,nlstate,1,npar); 3853: doldm=matrix(1,nlstate,1,nlstate); 3854: dnewmp= matrix(nlstate+1,nlstate+ndeath,1,npar); 3855: doldmp= matrix(nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath); 3856: 3857: gradgp=matrix(1,npar,nlstate+1,nlstate+ndeath); 3858: gpp=vector(nlstate+1,nlstate+ndeath); 3859: gmp=vector(nlstate+1,nlstate+ndeath); 3860: trgradgp =matrix(nlstate+1,nlstate+ndeath,1,npar); /* mu or p point j*/ 3861: 3862: if(estepm < stepm){ 3863: printf ("Problem %d lower than %d\n",estepm, stepm); 3864: } 3865: else hstepm=estepm; 3866: /* For example we decided to compute the life expectancy with the smallest unit */ 3867: /* hstepm beeing the number of stepms, if hstepm=1 the length of hstepm is stepm. 3868: nhstepm is the number of hstepm from age to agelim 3869: nstepm is the number of stepm from age to agelin. 3870: Look at function hpijx to understand why (it is linked to memory size questions) */ 3871: /* We decided (b) to get a life expectancy respecting the most precise curvature of the 3872: survival function given by stepm (the optimization length). Unfortunately it 3873: means that if the survival funtion is printed every two years of age and if 3874: you sum them up and add 1 year (area under the trapezoids) you won't get the same 3875: results. So we changed our mind and took the option of the best precision. 3876: */ 3877: hstepm=hstepm/stepm; /* Typically in stepm units, if stepm=6 & estepm=24 , = 24/6 months = 4 */ 3878: agelim = AGESUP; 3879: for (age=bage; age<=fage; age ++){ /* If stepm=6 months */ 3880: nstepm=(int) rint((agelim-age)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ 3881: nhstepm = nstepm/hstepm;/* Expressed in hstepm, typically nhstepm=40/4=10 */ 3882: p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 3883: gradg=ma3x(0,nhstepm,1,npar,1,nlstate); 3884: gp=matrix(0,nhstepm,1,nlstate); 3885: gm=matrix(0,nhstepm,1,nlstate); 3886: 3887: 3888: for(theta=1; theta <=npar; theta++){ 3889: for(i=1; i<=npar; i++){ /* Computes gradient x + delta*/ 3890: xp[i] = x[i] + (i==theta ?delti[theta]:0); 3891: } 3892: hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm, ij); 3893: prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij); 3894: 3895: if (popbased==1) { 3896: if(mobilav ==0){ 3897: for(i=1; i<=nlstate;i++) 3898: prlim[i][i]=probs[(int)age][i][ij]; 3899: }else{ /* mobilav */ 3900: for(i=1; i<=nlstate;i++) 3901: prlim[i][i]=mobaverage[(int)age][i][ij]; 3902: } 3903: } 3904: 3905: for(j=1; j<= nlstate; j++){ 3906: for(h=0; h<=nhstepm; h++){ 3907: for(i=1, gp[h][j]=0.;i<=nlstate;i++) 3908: gp[h][j] += prlim[i][i]*p3mat[i][j][h]; 3909: } 3910: } 3911: /* This for computing probability of death (h=1 means 3912: computed over hstepm matrices product = hstepm*stepm months) 3913: as a weighted average of prlim. 3914: */ 3915: for(j=nlstate+1;j<=nlstate+ndeath;j++){ 3916: for(i=1,gpp[j]=0.; i<= nlstate; i++) 3917: gpp[j] += prlim[i][i]*p3mat[i][j][1]; 3918: } 3919: /* end probability of death */ 3920: 3921: for(i=1; i<=npar; i++) /* Computes gradient x - delta */ 3922: xp[i] = x[i] - (i==theta ?delti[theta]:0); 3923: hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm, ij); 3924: prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij); 3925: 3926: if (popbased==1) { 3927: if(mobilav ==0){ 3928: for(i=1; i<=nlstate;i++) 3929: prlim[i][i]=probs[(int)age][i][ij]; 3930: }else{ /* mobilav */ 3931: for(i=1; i<=nlstate;i++) 3932: prlim[i][i]=mobaverage[(int)age][i][ij]; 3933: } 3934: } 3935: 3936: for(j=1; j<= nlstate; j++){ /* Sum of wi * eij = e.j */ 3937: for(h=0; h<=nhstepm; h++){ 3938: for(i=1, gm[h][j]=0.;i<=nlstate;i++) 3939: gm[h][j] += prlim[i][i]*p3mat[i][j][h]; 3940: } 3941: } 3942: /* This for computing probability of death (h=1 means 3943: computed over hstepm matrices product = hstepm*stepm months) 3944: as a weighted average of prlim. 3945: */ 3946: for(j=nlstate+1;j<=nlstate+ndeath;j++){ 3947: for(i=1,gmp[j]=0.; i<= nlstate; i++) 3948: gmp[j] += prlim[i][i]*p3mat[i][j][1]; 3949: } 3950: /* end probability of death */ 3951: 3952: for(j=1; j<= nlstate; j++) /* vareij */ 3953: for(h=0; h<=nhstepm; h++){ 3954: gradg[h][theta][j]= (gp[h][j]-gm[h][j])/2./delti[theta]; 3955: } 3956: 3957: for(j=nlstate+1; j<= nlstate+ndeath; j++){ /* var mu */ 3958: gradgp[theta][j]= (gpp[j]-gmp[j])/2./delti[theta]; 3959: } 3960: 3961: } /* End theta */ 3962: 3963: trgradg =ma3x(0,nhstepm,1,nlstate,1,npar); /* veij */ 3964: 3965: for(h=0; h<=nhstepm; h++) /* veij */ 3966: for(j=1; j<=nlstate;j++) 3967: for(theta=1; theta <=npar; theta++) 3968: trgradg[h][j][theta]=gradg[h][theta][j]; 3969: 3970: for(j=nlstate+1; j<=nlstate+ndeath;j++) /* mu */ 3971: for(theta=1; theta <=npar; theta++) 3972: trgradgp[j][theta]=gradgp[theta][j]; 3973: 3974: 3975: hf=hstepm*stepm/YEARM; /* Duration of hstepm expressed in year unit. */ 3976: for(i=1;i<=nlstate;i++) 3977: for(j=1;j<=nlstate;j++) 3978: vareij[i][j][(int)age] =0.; 3979: 3980: for(h=0;h<=nhstepm;h++){ 3981: for(k=0;k<=nhstepm;k++){ 3982: matprod2(dnewm,trgradg[h],1,nlstate,1,npar,1,npar,matcov); 3983: matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg[k]); 3984: for(i=1;i<=nlstate;i++) 3985: for(j=1;j<=nlstate;j++) 3986: vareij[i][j][(int)age] += doldm[i][j]*hf*hf; 3987: } 3988: } 3989: 3990: /* pptj */ 3991: matprod2(dnewmp,trgradgp,nlstate+1,nlstate+ndeath,1,npar,1,npar,matcov); 3992: matprod2(doldmp,dnewmp,nlstate+1,nlstate+ndeath,1,npar,nlstate+1,nlstate+ndeath,gradgp); 3993: for(j=nlstate+1;j<=nlstate+ndeath;j++) 3994: for(i=nlstate+1;i<=nlstate+ndeath;i++) 3995: varppt[j][i]=doldmp[j][i]; 3996: /* end ppptj */ 3997: /* x centered again */ 3998: hpxij(p3mat,nhstepm,age,hstepm,x,nlstate,stepm,oldm,savm, ij); 3999: prevalim(prlim,nlstate,x,age,oldm,savm,ftolpl,ij); 4000: 4001: if (popbased==1) { 4002: if(mobilav ==0){ 4003: for(i=1; i<=nlstate;i++) 4004: prlim[i][i]=probs[(int)age][i][ij]; 4005: }else{ /* mobilav */ 4006: for(i=1; i<=nlstate;i++) 4007: prlim[i][i]=mobaverage[(int)age][i][ij]; 4008: } 4009: } 4010: 4011: /* This for computing probability of death (h=1 means 4012: computed over hstepm (estepm) matrices product = hstepm*stepm months) 4013: as a weighted average of prlim. 4014: */ 4015: for(j=nlstate+1;j<=nlstate+ndeath;j++){ 4016: for(i=1,gmp[j]=0.;i<= nlstate; i++) 4017: gmp[j] += prlim[i][i]*p3mat[i][j][1]; 4018: } 4019: /* end probability of death */ 4020: 4021: fprintf(ficresprobmorprev,"%3d %d ",(int) age, ij); 4022: for(j=nlstate+1; j<=(nlstate+ndeath);j++){ 4023: fprintf(ficresprobmorprev," %11.3e %11.3e",gmp[j], sqrt(varppt[j][j])); 4024: for(i=1; i<=nlstate;i++){ 4025: fprintf(ficresprobmorprev," %11.3e %11.3e ",prlim[i][i],p3mat[i][j][1]); 4026: } 4027: } 4028: fprintf(ficresprobmorprev,"\n"); 4029: 4030: fprintf(ficresvij,"%.0f ",age ); 4031: for(i=1; i<=nlstate;i++) 4032: for(j=1; j<=nlstate;j++){ 4033: fprintf(ficresvij," %.4f", vareij[i][j][(int)age]); 4034: } 4035: fprintf(ficresvij,"\n"); 4036: free_matrix(gp,0,nhstepm,1,nlstate); 4037: free_matrix(gm,0,nhstepm,1,nlstate); 4038: free_ma3x(gradg,0,nhstepm,1,npar,1,nlstate); 4039: free_ma3x(trgradg,0,nhstepm,1,nlstate,1,npar); 4040: free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 4041: } /* End age */ 4042: free_vector(gpp,nlstate+1,nlstate+ndeath); 4043: free_vector(gmp,nlstate+1,nlstate+ndeath); 4044: free_matrix(gradgp,1,npar,nlstate+1,nlstate+ndeath); 4045: free_matrix(trgradgp,nlstate+1,nlstate+ndeath,1,npar); /* mu or p point j*/ 4046: fprintf(ficgp,"\nunset parametric;unset label; set ter png small size 320, 240"); 4047: /* for(j=nlstate+1; j<= nlstate+ndeath; j++){ *//* Only the first actually */ 4048: fprintf(ficgp,"\n set log y; unset log x;set xlabel \"Age\"; set ylabel \"Force of mortality (year-1)\";"); 4049: /* fprintf(ficgp,"\n plot \"%s\" u 1:($3*%6.3f) not w l 1 ",fileresprobmorprev,YEARM/estepm); */ 4050: /* fprintf(ficgp,"\n replot \"%s\" u 1:(($3+1.96*$4)*%6.3f) t \"95\%% interval\" w l 2 ",fileresprobmorprev,YEARM/estepm); */ 4051: /* fprintf(ficgp,"\n replot \"%s\" u 1:(($3-1.96*$4)*%6.3f) not w l 2 ",fileresprobmorprev,YEARM/estepm); */ 4052: fprintf(ficgp,"\n plot \"%s\" u 1:($3) not w l lt 1 ",subdirf(fileresprobmorprev)); 4053: fprintf(ficgp,"\n replot \"%s\" u 1:(($3+1.96*$4)) t \"95%% interval\" w l lt 2 ",subdirf(fileresprobmorprev)); 4054: fprintf(ficgp,"\n replot \"%s\" u 1:(($3-1.96*$4)) not w l lt 2 ",subdirf(fileresprobmorprev)); 4055: fprintf(fichtm,"\n File (multiple files are possible if covariates are present): <A href=\"%s\">%s</a>\n",subdirf(fileresprobmorprev),subdirf(fileresprobmorprev)); 4056: fprintf(fichtm,"\n Probability is computed over estepm=%d months. <img src=\"%s%s.png\"> \n", estepm,subdirf3(optionfilefiname,"varmuptjgr",digitp),digit); 4057: /* fprintf(fichtm,"\n Probability is computed over estepm=%d months and then divided by estepm and multiplied by %.0f in order to have the probability to die over a year <img src=\"varmuptjgr%s%s.png\"> \n", stepm,YEARM,digitp,digit); 4058: */ 4059: /* fprintf(ficgp,"\nset out \"varmuptjgr%s%s%s.png\";replot;",digitp,optionfilefiname,digit); */ 4060: fprintf(ficgp,"\nset out \"%s%s.png\";replot;\n",subdirf3(optionfilefiname,"varmuptjgr",digitp),digit); 4061: 4062: free_vector(xp,1,npar); 4063: free_matrix(doldm,1,nlstate,1,nlstate); 4064: free_matrix(dnewm,1,nlstate,1,npar); 4065: free_matrix(doldmp,nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath); 4066: free_matrix(dnewmp,nlstate+1,nlstate+ndeath,1,npar); 4067: free_matrix(varppt,nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath); 4068: if (mobilav!=0) free_ma3x(mobaverage,1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 4069: fclose(ficresprobmorprev); 4070: fflush(ficgp); 4071: fflush(fichtm); 4072: } /* end varevsij */ 4073: 4074: /************ Variance of prevlim ******************/ 4075: void varprevlim(char fileres[], double **varpl, double **matcov, double x[], double delti[], int nlstate, int stepm, double bage, double fage, double **oldm, double **savm, double **prlim, double ftolpl, int ij, char strstart[]) 4076: { 4077: /* Variance of prevalence limit */ 4078: /* double **prevalim(double **prlim, int nlstate, double *xp, double age, double **oldm, double **savm,double ftolpl);*/ 4079: 4080: double **dnewm,**doldm; 4081: int i, j, nhstepm, hstepm; 4082: double *xp; 4083: double *gp, *gm; 4084: double **gradg, **trgradg; 4085: double age,agelim; 4086: int theta; 4087: 4088: pstamp(ficresvpl); 4089: fprintf(ficresvpl,"# Standard deviation of period (stable) prevalences \n"); 4090: fprintf(ficresvpl,"# Age"); 4091: for(i=1; i<=nlstate;i++) 4092: fprintf(ficresvpl," %1d-%1d",i,i); 4093: fprintf(ficresvpl,"\n"); 4094: 4095: xp=vector(1,npar); 4096: dnewm=matrix(1,nlstate,1,npar); 4097: doldm=matrix(1,nlstate,1,nlstate); 4098: 4099: hstepm=1*YEARM; /* Every year of age */ 4100: hstepm=hstepm/stepm; /* Typically in stepm units, if j= 2 years, = 2/6 months = 4 */ 4101: agelim = AGESUP; 4102: for (age=bage; age<=fage; age ++){ /* If stepm=6 months */ 4103: nhstepm=(int) rint((agelim-age)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ 4104: if (stepm >= YEARM) hstepm=1; 4105: nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ 4106: gradg=matrix(1,npar,1,nlstate); 4107: gp=vector(1,nlstate); 4108: gm=vector(1,nlstate); 4109: 4110: for(theta=1; theta <=npar; theta++){ 4111: for(i=1; i<=npar; i++){ /* Computes gradient */ 4112: xp[i] = x[i] + (i==theta ?delti[theta]:0); 4113: } 4114: prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij); 4115: for(i=1;i<=nlstate;i++) 4116: gp[i] = prlim[i][i]; 4117: 4118: for(i=1; i<=npar; i++) /* Computes gradient */ 4119: xp[i] = x[i] - (i==theta ?delti[theta]:0); 4120: prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij); 4121: for(i=1;i<=nlstate;i++) 4122: gm[i] = prlim[i][i]; 4123: 4124: for(i=1;i<=nlstate;i++) 4125: gradg[theta][i]= (gp[i]-gm[i])/2./delti[theta]; 4126: } /* End theta */ 4127: 4128: trgradg =matrix(1,nlstate,1,npar); 4129: 4130: for(j=1; j<=nlstate;j++) 4131: for(theta=1; theta <=npar; theta++) 4132: trgradg[j][theta]=gradg[theta][j]; 4133: 4134: for(i=1;i<=nlstate;i++) 4135: varpl[i][(int)age] =0.; 4136: matprod2(dnewm,trgradg,1,nlstate,1,npar,1,npar,matcov); 4137: matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg); 4138: for(i=1;i<=nlstate;i++) 4139: varpl[i][(int)age] = doldm[i][i]; /* Covariances are useless */ 4140: 4141: fprintf(ficresvpl,"%.0f ",age ); 4142: for(i=1; i<=nlstate;i++) 4143: fprintf(ficresvpl," %.5f (%.5f)",prlim[i][i],sqrt(varpl[i][(int)age])); 4144: fprintf(ficresvpl,"\n"); 4145: free_vector(gp,1,nlstate); 4146: free_vector(gm,1,nlstate); 4147: free_matrix(gradg,1,npar,1,nlstate); 4148: free_matrix(trgradg,1,nlstate,1,npar); 4149: } /* End age */ 4150: 4151: free_vector(xp,1,npar); 4152: free_matrix(doldm,1,nlstate,1,npar); 4153: free_matrix(dnewm,1,nlstate,1,nlstate); 4154: 4155: } 4156: 4157: /************ Variance of one-step probabilities ******************/ 4158: void varprob(char optionfilefiname[], double **matcov, double x[], double delti[], int nlstate, double bage, double fage, int ij, int *Tvar, int **nbcode, int *ncodemax, char strstart[]) 4159: { 4160: int i, j=0, k1, l1, tj; 4161: int k2, l2, j1, z1; 4162: int k=0, l; 4163: int first=1, first1, first2; 4164: double cv12, mu1, mu2, lc1, lc2, v12, v21, v11, v22,v1,v2, c12, tnalp; 4165: double **dnewm,**doldm; 4166: double *xp; 4167: double *gp, *gm; 4168: double **gradg, **trgradg; 4169: double **mu; 4170: double age, cov[NCOVMAX+1]; 4171: double std=2.0; /* Number of standard deviation wide of confidence ellipsoids */ 4172: int theta; 4173: char fileresprob[FILENAMELENGTH]; 4174: char fileresprobcov[FILENAMELENGTH]; 4175: char fileresprobcor[FILENAMELENGTH]; 4176: double ***varpij; 4177: 4178: strcpy(fileresprob,"prob"); 4179: strcat(fileresprob,fileres); 4180: if((ficresprob=fopen(fileresprob,"w"))==NULL) { 4181: printf("Problem with resultfile: %s\n", fileresprob); 4182: fprintf(ficlog,"Problem with resultfile: %s\n", fileresprob); 4183: } 4184: strcpy(fileresprobcov,"probcov"); 4185: strcat(fileresprobcov,fileres); 4186: if((ficresprobcov=fopen(fileresprobcov,"w"))==NULL) { 4187: printf("Problem with resultfile: %s\n", fileresprobcov); 4188: fprintf(ficlog,"Problem with resultfile: %s\n", fileresprobcov); 4189: } 4190: strcpy(fileresprobcor,"probcor"); 4191: strcat(fileresprobcor,fileres); 4192: if((ficresprobcor=fopen(fileresprobcor,"w"))==NULL) { 4193: printf("Problem with resultfile: %s\n", fileresprobcor); 4194: fprintf(ficlog,"Problem with resultfile: %s\n", fileresprobcor); 4195: } 4196: printf("Computing standard deviation of one-step probabilities: result on file '%s' \n",fileresprob); 4197: fprintf(ficlog,"Computing standard deviation of one-step probabilities: result on file '%s' \n",fileresprob); 4198: printf("Computing matrix of variance covariance of one-step probabilities: result on file '%s' \n",fileresprobcov); 4199: fprintf(ficlog,"Computing matrix of variance covariance of one-step probabilities: result on file '%s' \n",fileresprobcov); 4200: printf("and correlation matrix of one-step probabilities: result on file '%s' \n",fileresprobcor); 4201: fprintf(ficlog,"and correlation matrix of one-step probabilities: result on file '%s' \n",fileresprobcor); 4202: pstamp(ficresprob); 4203: fprintf(ficresprob,"#One-step probabilities and stand. devi in ()\n"); 4204: fprintf(ficresprob,"# Age"); 4205: pstamp(ficresprobcov); 4206: fprintf(ficresprobcov,"#One-step probabilities and covariance matrix\n"); 4207: fprintf(ficresprobcov,"# Age"); 4208: pstamp(ficresprobcor); 4209: fprintf(ficresprobcor,"#One-step probabilities and correlation matrix\n"); 4210: fprintf(ficresprobcor,"# Age"); 4211: 4212: 4213: for(i=1; i<=nlstate;i++) 4214: for(j=1; j<=(nlstate+ndeath);j++){ 4215: fprintf(ficresprob," p%1d-%1d (SE)",i,j); 4216: fprintf(ficresprobcov," p%1d-%1d ",i,j); 4217: fprintf(ficresprobcor," p%1d-%1d ",i,j); 4218: } 4219: /* fprintf(ficresprob,"\n"); 4220: fprintf(ficresprobcov,"\n"); 4221: fprintf(ficresprobcor,"\n"); 4222: */ 4223: xp=vector(1,npar); 4224: dnewm=matrix(1,(nlstate)*(nlstate+ndeath),1,npar); 4225: doldm=matrix(1,(nlstate)*(nlstate+ndeath),1,(nlstate)*(nlstate+ndeath)); 4226: mu=matrix(1,(nlstate)*(nlstate+ndeath), (int) bage, (int)fage); 4227: varpij=ma3x(1,nlstate*(nlstate+ndeath),1,nlstate*(nlstate+ndeath),(int) bage, (int) fage); 4228: first=1; 4229: fprintf(ficgp,"\n# Routine varprob"); 4230: fprintf(fichtm,"\n<li><h4> Computing and drawing one step probabilities with their confidence intervals</h4></li>\n"); 4231: fprintf(fichtm,"\n"); 4232: 4233: fprintf(fichtm,"\n<li><h4> <a href=\"%s\">Matrix of variance-covariance of pairs of step probabilities (drawings)</a></h4></li>\n",optionfilehtmcov); 4234: fprintf(fichtmcov,"\n<h4>Matrix of variance-covariance of pairs of step probabilities</h4>\n\ 4235: file %s \n",optionfilehtmcov); 4236: fprintf(fichtmcov,"\nEllipsoids of confidence centered on point (p<inf>ij</inf>, p<inf>kl</inf>) are estimated\ 4237: and drawn. It helps understanding how is the covariance between two incidences.\ 4238: They are expressed in year-1 in order to be less dependent of stepm. \n"); 4239: fprintf(fichtmcov,"\n Contour plot corresponding to x'cov-1x = 4 (where x is the column vector (pij,pkl)) are drawn. \ 4240: It can be understood this way: if pij and pkl where uncorrelated the (2x2) matrix of covariance \ 4241: would have been (1/(var pij), 0 , 0, 1/(var pkl)), and the confidence interval would be 2 \ 4242: standard deviations wide on each axis. \ 4243: Now, if both incidences are correlated (usual case) we diagonalised the inverse of the covariance matrix\ 4244: and made the appropriate rotation to look at the uncorrelated principal directions. \ 4245: To be simple, these graphs help to understand the significativity of each parameter in relation to a second other one. \n"); 4246: 4247: cov[1]=1; 4248: /* tj=cptcoveff; */ 4249: tj = (int) pow(2,cptcoveff); 4250: if (cptcovn<1) {tj=1;ncodemax[1]=1;} 4251: j1=0; 4252: for(j1=1; j1<=tj;j1++){ 4253: /*for(i1=1; i1<=ncodemax[t];i1++){ */ 4254: /*j1++;*/ 4255: if (cptcovn>0) { 4256: fprintf(ficresprob, "\n#********** Variable "); 4257: for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresprob, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); 4258: fprintf(ficresprob, "**********\n#\n"); 4259: fprintf(ficresprobcov, "\n#********** Variable "); 4260: for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresprobcov, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); 4261: fprintf(ficresprobcov, "**********\n#\n"); 4262: 4263: fprintf(ficgp, "\n#********** Variable "); 4264: for (z1=1; z1<=cptcoveff; z1++) fprintf(ficgp, " V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); 4265: fprintf(ficgp, "**********\n#\n"); 4266: 4267: 4268: fprintf(fichtmcov, "\n<hr size=\"2\" color=\"#EC5E5E\">********** Variable "); 4269: for (z1=1; z1<=cptcoveff; z1++) fprintf(fichtm, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); 4270: fprintf(fichtmcov, "**********\n<hr size=\"2\" color=\"#EC5E5E\">"); 4271: 4272: fprintf(ficresprobcor, "\n#********** Variable "); 4273: for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresprobcor, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); 4274: fprintf(ficresprobcor, "**********\n#"); 4275: } 4276: 4277: gradg=matrix(1,npar,1,(nlstate)*(nlstate+ndeath)); 4278: trgradg=matrix(1,(nlstate)*(nlstate+ndeath),1,npar); 4279: gp=vector(1,(nlstate)*(nlstate+ndeath)); 4280: gm=vector(1,(nlstate)*(nlstate+ndeath)); 4281: for (age=bage; age<=fage; age ++){ 4282: cov[2]=age; 4283: if(nagesqr==1) 4284: cov[3]= age*age; 4285: for (k=1; k<=cptcovn;k++) { 4286: cov[2+nagesqr+k]=nbcode[Tvar[k]][codtab[j1][Tvar[k]]];/* j1 1 2 3 4 4287: * 1 1 1 1 1 4288: * 2 2 1 1 1 4289: * 3 1 2 1 1 4290: */ 4291: /* nbcode[1][1]=0 nbcode[1][2]=1;*/ 4292: } 4293: /* for (k=1; k<=cptcovage;k++) cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2]; */ 4294: for (k=1; k<=cptcovage;k++) cov[2+Tage[k]]=nbcode[Tvar[Tage[k]]][codtab[ij][Tvar[Tage[k]]]]*cov[2]; 4295: for (k=1; k<=cptcovprod;k++) 4296: cov[2+nagesqr+Tprod[k]]=nbcode[Tvard[k][1]][codtab[ij][Tvard[k][1]]]*nbcode[Tvard[k][2]][codtab[ij][Tvard[k][2]]]; 4297: 4298: 4299: for(theta=1; theta <=npar; theta++){ 4300: for(i=1; i<=npar; i++) 4301: xp[i] = x[i] + (i==theta ?delti[theta]:(double)0); 4302: 4303: pmij(pmmij,cov,ncovmodel,xp,nlstate); 4304: 4305: k=0; 4306: for(i=1; i<= (nlstate); i++){ 4307: for(j=1; j<=(nlstate+ndeath);j++){ 4308: k=k+1; 4309: gp[k]=pmmij[i][j]; 4310: } 4311: } 4312: 4313: for(i=1; i<=npar; i++) 4314: xp[i] = x[i] - (i==theta ?delti[theta]:(double)0); 4315: 4316: pmij(pmmij,cov,ncovmodel,xp,nlstate); 4317: k=0; 4318: for(i=1; i<=(nlstate); i++){ 4319: for(j=1; j<=(nlstate+ndeath);j++){ 4320: k=k+1; 4321: gm[k]=pmmij[i][j]; 4322: } 4323: } 4324: 4325: for(i=1; i<= (nlstate)*(nlstate+ndeath); i++) 4326: gradg[theta][i]=(gp[i]-gm[i])/(double)2./delti[theta]; 4327: } 4328: 4329: for(j=1; j<=(nlstate)*(nlstate+ndeath);j++) 4330: for(theta=1; theta <=npar; theta++) 4331: trgradg[j][theta]=gradg[theta][j]; 4332: 4333: matprod2(dnewm,trgradg,1,(nlstate)*(nlstate+ndeath),1,npar,1,npar,matcov); 4334: matprod2(doldm,dnewm,1,(nlstate)*(nlstate+ndeath),1,npar,1,(nlstate)*(nlstate+ndeath),gradg); 4335: 4336: pmij(pmmij,cov,ncovmodel,x,nlstate); 4337: 4338: k=0; 4339: for(i=1; i<=(nlstate); i++){ 4340: for(j=1; j<=(nlstate+ndeath);j++){ 4341: k=k+1; 4342: mu[k][(int) age]=pmmij[i][j]; 4343: } 4344: } 4345: for(i=1;i<=(nlstate)*(nlstate+ndeath);i++) 4346: for(j=1;j<=(nlstate)*(nlstate+ndeath);j++) 4347: varpij[i][j][(int)age] = doldm[i][j]; 4348: 4349: /*printf("\n%d ",(int)age); 4350: for (i=1; i<=(nlstate)*(nlstate+ndeath);i++){ 4351: printf("%e [%e ;%e] ",gm[i],gm[i]-2*sqrt(doldm[i][i]),gm[i]+2*sqrt(doldm[i][i])); 4352: fprintf(ficlog,"%e [%e ;%e] ",gm[i],gm[i]-2*sqrt(doldm[i][i]),gm[i]+2*sqrt(doldm[i][i])); 4353: }*/ 4354: 4355: fprintf(ficresprob,"\n%d ",(int)age); 4356: fprintf(ficresprobcov,"\n%d ",(int)age); 4357: fprintf(ficresprobcor,"\n%d ",(int)age); 4358: 4359: for (i=1; i<=(nlstate)*(nlstate+ndeath);i++) 4360: fprintf(ficresprob,"%11.3e (%11.3e) ",mu[i][(int) age],sqrt(varpij[i][i][(int)age])); 4361: for (i=1; i<=(nlstate)*(nlstate+ndeath);i++){ 4362: fprintf(ficresprobcov,"%11.3e ",mu[i][(int) age]); 4363: fprintf(ficresprobcor,"%11.3e ",mu[i][(int) age]); 4364: } 4365: i=0; 4366: for (k=1; k<=(nlstate);k++){ 4367: for (l=1; l<=(nlstate+ndeath);l++){ 4368: i++; 4369: fprintf(ficresprobcov,"\n%d %d-%d",(int)age,k,l); 4370: fprintf(ficresprobcor,"\n%d %d-%d",(int)age,k,l); 4371: for (j=1; j<=i;j++){ 4372: /* printf(" k=%d l=%d i=%d j=%d\n",k,l,i,j);fflush(stdout); */ 4373: fprintf(ficresprobcov," %11.3e",varpij[i][j][(int)age]); 4374: fprintf(ficresprobcor," %11.3e",varpij[i][j][(int) age]/sqrt(varpij[i][i][(int) age])/sqrt(varpij[j][j][(int)age])); 4375: } 4376: } 4377: }/* end of loop for state */ 4378: } /* end of loop for age */ 4379: free_vector(gp,1,(nlstate+ndeath)*(nlstate+ndeath)); 4380: free_vector(gm,1,(nlstate+ndeath)*(nlstate+ndeath)); 4381: free_matrix(trgradg,1,(nlstate+ndeath)*(nlstate+ndeath),1,npar); 4382: free_matrix(gradg,1,(nlstate+ndeath)*(nlstate+ndeath),1,npar); 4383: 4384: /* Confidence intervalle of pij */ 4385: /* 4386: fprintf(ficgp,"\nunset parametric;unset label"); 4387: fprintf(ficgp,"\nset log y;unset log x; set xlabel \"Age\";set ylabel \"probability (year-1)\""); 4388: fprintf(ficgp,"\nset ter png small\nset size 0.65,0.65"); 4389: fprintf(fichtm,"\n Probability with confidence intervals expressed in year-1 :<a href=\"pijgr%s.png\">pijgr%s.png</A>, ",optionfilefiname,optionfilefiname); 4390: fprintf(fichtm,"\n <img src=\"pijgr%s.png\"> ",optionfilefiname); 4391: fprintf(ficgp,"\nset out \"pijgr%s.png\"",optionfilefiname); 4392: fprintf(ficgp,"\nplot \"%s\" every :::%d::%d u 1:2 \"\%%lf",k1,k2,xfilevarprob); 4393: */ 4394: 4395: /* Drawing ellipsoids of confidence of two variables p(k1-l1,k2-l2)*/ 4396: first1=1;first2=2; 4397: for (k2=1; k2<=(nlstate);k2++){ 4398: for (l2=1; l2<=(nlstate+ndeath);l2++){ 4399: if(l2==k2) continue; 4400: j=(k2-1)*(nlstate+ndeath)+l2; 4401: for (k1=1; k1<=(nlstate);k1++){ 4402: for (l1=1; l1<=(nlstate+ndeath);l1++){ 4403: if(l1==k1) continue; 4404: i=(k1-1)*(nlstate+ndeath)+l1; 4405: if(i<=j) continue; 4406: for (age=bage; age<=fage; age ++){ 4407: if ((int)age %5==0){ 4408: v1=varpij[i][i][(int)age]/stepm*YEARM/stepm*YEARM; 4409: v2=varpij[j][j][(int)age]/stepm*YEARM/stepm*YEARM; 4410: cv12=varpij[i][j][(int)age]/stepm*YEARM/stepm*YEARM; 4411: mu1=mu[i][(int) age]/stepm*YEARM ; 4412: mu2=mu[j][(int) age]/stepm*YEARM; 4413: c12=cv12/sqrt(v1*v2); 4414: /* Computing eigen value of matrix of covariance */ 4415: lc1=((v1+v2)+sqrt((v1+v2)*(v1+v2) - 4*(v1*v2-cv12*cv12)))/2.; 4416: lc2=((v1+v2)-sqrt((v1+v2)*(v1+v2) - 4*(v1*v2-cv12*cv12)))/2.; 4417: if ((lc2 <0) || (lc1 <0) ){ 4418: if(first2==1){ 4419: first1=0; 4420: printf("Strange: j1=%d One eigen value of 2x2 matrix of covariance is negative, lc1=%11.3e, lc2=%11.3e, v1=%11.3e, v2=%11.3e, cv12=%11.3e.\n It means that the matrix was not well estimated (varpij), for i=%2d, j=%2d, age=%4d .\n See files %s and %s. Probably WRONG RESULTS. See log file for details...\n", j1, lc1, lc2, v1, v2, cv12, i, j, (int)age,fileresprobcov, fileresprobcor); 4421: } 4422: fprintf(ficlog,"Strange: j1=%d One eigen value of 2x2 matrix of covariance is negative, lc1=%11.3e, lc2=%11.3e, v1=%11.3e, v2=%11.3e, cv12=%11.3e.\n It means that the matrix was not well estimated (varpij), for i=%2d, j=%2d, age=%4d .\n See files %s and %s. Probably WRONG RESULTS.\n", j1, lc1, lc2, v1, v2, cv12, i, j, (int)age,fileresprobcov, fileresprobcor);fflush(ficlog); 4423: /* lc1=fabs(lc1); */ /* If we want to have them positive */ 4424: /* lc2=fabs(lc2); */ 4425: } 4426: 4427: /* Eigen vectors */ 4428: v11=(1./sqrt(1+(v1-lc1)*(v1-lc1)/cv12/cv12)); 4429: /*v21=sqrt(1.-v11*v11); *//* error */ 4430: v21=(lc1-v1)/cv12*v11; 4431: v12=-v21; 4432: v22=v11; 4433: tnalp=v21/v11; 4434: if(first1==1){ 4435: first1=0; 4436: printf("%d %d%d-%d%d mu %.4e %.4e Var %.4e %.4e cor %.3f cov %.4e Eig %.3e %.3e 1stv %.3f %.3f tang %.3f\nOthers in log...\n",(int) age,k1,l1,k2,l2,mu1,mu2,v1,v2,c12,cv12,lc1,lc2,v11,v21,tnalp); 4437: } 4438: fprintf(ficlog,"%d %d%d-%d%d mu %.4e %.4e Var %.4e %.4e cor %.3f cov %.4e Eig %.3e %.3e 1stv %.3f %.3f tan %.3f\n",(int) age,k1,l1,k2,l2,mu1,mu2,v1,v2,c12,cv12,lc1,lc2,v11,v21,tnalp); 4439: /*printf(fignu*/ 4440: /* mu1+ v11*lc1*cost + v12*lc2*sin(t) */ 4441: /* mu2+ v21*lc1*cost + v22*lc2*sin(t) */ 4442: if(first==1){ 4443: first=0; 4444: fprintf(ficgp,"\nset parametric;unset label"); 4445: fprintf(ficgp,"\nset log y;set log x; set xlabel \"p%1d%1d (year-1)\";set ylabel \"p%1d%1d (year-1)\"",k1,l1,k2,l2); 4446: fprintf(ficgp,"\nset ter png small size 320, 240"); 4447: fprintf(fichtmcov,"\n Ellipsoids of confidence cov(p%1d%1d,p%1d%1d) expressed in year-1\ 4448: :<a href=\"%s%d%1d%1d-%1d%1d.png\">\ 4449: %s%d%1d%1d-%1d%1d.png</A>, ",k1,l1,k2,l2,\ 4450: subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2,\ 4451: subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2); 4452: fprintf(fichtmcov,"\n <img src=\"%s%d%1d%1d-%1d%1d.png\"> ",subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2); 4453: fprintf(fichtmcov,"\n Correlation at age %d (%.3f),",(int) age, c12); 4454: fprintf(ficgp,"\nset out \"%s%d%1d%1d-%1d%1d.png\"",subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2); 4455: fprintf(ficgp,"\nset label \"%d\" at %11.3e,%11.3e center",(int) age, mu1,mu2); 4456: fprintf(ficgp,"\n# Age %d, p%1d%1d - p%1d%1d",(int) age, k1,l1,k2,l2); 4457: fprintf(ficgp,"\nplot [-pi:pi] %11.3e+ %.3f*(%11.3e*%11.3e*cos(t)+%11.3e*%11.3e*sin(t)), %11.3e +%.3f*(%11.3e*%11.3e*cos(t)+%11.3e*%11.3e*sin(t)) not",\ 4458: mu1,std,v11,sqrt(lc1),v12,sqrt(lc2),\ 4459: mu2,std,v21,sqrt(lc1),v22,sqrt(lc2)); 4460: }else{ 4461: first=0; 4462: fprintf(fichtmcov," %d (%.3f),",(int) age, c12); 4463: fprintf(ficgp,"\n# Age %d, p%1d%1d - p%1d%1d",(int) age, k1,l1,k2,l2); 4464: fprintf(ficgp,"\nset label \"%d\" at %11.3e,%11.3e center",(int) age, mu1,mu2); 4465: fprintf(ficgp,"\nreplot %11.3e+ %.3f*(%11.3e*%11.3e*cos(t)+%11.3e*%11.3e*sin(t)), %11.3e +%.3f*(%11.3e*%11.3e*cos(t)+%11.3e*%11.3e*sin(t)) not",\ 4466: mu1,std,v11,sqrt(lc1),v12,sqrt(lc2),\ 4467: mu2,std,v21,sqrt(lc1),v22,sqrt(lc2)); 4468: }/* if first */ 4469: } /* age mod 5 */ 4470: } /* end loop age */ 4471: fprintf(ficgp,"\nset out \"%s%d%1d%1d-%1d%1d.png\";replot;",subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2); 4472: first=1; 4473: } /*l12 */ 4474: } /* k12 */ 4475: } /*l1 */ 4476: }/* k1 */ 4477: /* } */ /* loop covariates */ 4478: } 4479: free_ma3x(varpij,1,nlstate,1,nlstate+ndeath,(int) bage, (int)fage); 4480: free_matrix(mu,1,(nlstate+ndeath)*(nlstate+ndeath),(int) bage, (int)fage); 4481: free_matrix(doldm,1,(nlstate)*(nlstate+ndeath),1,(nlstate)*(nlstate+ndeath)); 4482: free_matrix(dnewm,1,(nlstate)*(nlstate+ndeath),1,npar); 4483: free_vector(xp,1,npar); 4484: fclose(ficresprob); 4485: fclose(ficresprobcov); 4486: fclose(ficresprobcor); 4487: fflush(ficgp); 4488: fflush(fichtmcov); 4489: } 4490: 4491: 4492: /******************* Printing html file ***********/ 4493: void printinghtml(char fileres[], char title[], char datafile[], int firstpass, \ 4494: int lastpass, int stepm, int weightopt, char model[],\ 4495: int imx,int jmin, int jmax, double jmeanint,char rfileres[],\ 4496: int popforecast, int estepm ,\ 4497: double jprev1, double mprev1,double anprev1, \ 4498: double jprev2, double mprev2,double anprev2){ 4499: int jj1, k1, i1, cpt; 4500: 4501: fprintf(fichtm,"<ul><li><a href='#firstorder'>Result files (first order: no variance)</a>\n \ 4502: <li><a href='#secondorder'>Result files (second order (variance)</a>\n \ 4503: </ul>"); 4504: fprintf(fichtm,"<ul><li><h4><a name='firstorder'>Result files (first order: no variance)</a></h4>\n \ 4505: - Observed prevalence in each state (during the period defined between %.lf/%.lf/%.lf and %.lf/%.lf/%.lf): <a href=\"%s\">%s</a> \n ", 4506: jprev1, mprev1,anprev1,jprev2, mprev2,anprev2,subdirf2(fileres,"p"),subdirf2(fileres,"p")); 4507: fprintf(fichtm,"\ 4508: - Estimated transition probabilities over %d (stepm) months: <a href=\"%s\">%s</a> \n ", 4509: stepm,subdirf2(fileres,"pij"),subdirf2(fileres,"pij")); 4510: fprintf(fichtm,"\ 4511: - Period (stable) prevalence in each health state: <a href=\"%s\">%s</a> \n", 4512: subdirf2(fileres,"pl"),subdirf2(fileres,"pl")); 4513: fprintf(fichtm,"\ 4514: - (a) Life expectancies by health status at initial age, ei. (b) health expectancies by health status at initial age, eij . If one or more covariates are included, specific tables for each value of the covariate are output in sequences within the same file (estepm=%2d months): \ 4515: <a href=\"%s\">%s</a> \n", 4516: estepm,subdirf2(fileres,"e"),subdirf2(fileres,"e")); 4517: fprintf(fichtm,"\ 4518: - Population projections by age and states: \ 4519: <a href=\"%s\">%s</a> \n</li>", subdirf2(fileres,"f"),subdirf2(fileres,"f")); 4520: 4521: fprintf(fichtm," \n<ul><li>Graphs</li>"); 4522: 4523: m=pow(2,cptcoveff); 4524: if (cptcovn < 1) {m=1;ncodemax[1]=1;} 4525: 4526: jj1=0; 4527: for(k1=1; k1<=m;k1++){ 4528: /* for(i1=1; i1<=ncodemax[k1];i1++){ */ 4529: jj1++; 4530: if (cptcovn > 0) { 4531: fprintf(fichtm,"<hr size=\"2\" color=\"#EC5E5E\">************ Results for covariates"); 4532: for (cpt=1; cpt<=cptcoveff;cpt++){ 4533: fprintf(fichtm," V%d=%d ",Tvaraff[cpt],nbcode[Tvaraff[cpt]][codtab[jj1][cpt]]); 4534: printf(" V%d=%d ",Tvaraff[cpt],nbcode[Tvaraff[cpt]][codtab[jj1][cpt]]);fflush(stdout); 4535: } 4536: fprintf(fichtm," ************\n<hr size=\"2\" color=\"#EC5E5E\">"); 4537: } 4538: /* Pij */ 4539: fprintf(fichtm," - Pij or Conditional probabilities to be observed in state j being in state i, %d (stepm) months before: <a href=\"%s%d_1.png\">%s%d_1.png</a> \ 4540: <img src=\"%s%d_1.png\">",stepm,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1); 4541: /* Quasi-incidences */ 4542: fprintf(fichtm," - Pij or Conditional probabilities to be observed in state j being in state i %d (stepm) months\ 4543: before but expressed in per year i.e. quasi incidences if stepm is small and probabilities too: <a href=\"%s%d_2.png\">%s%d_2.png</a> \ 4544: <img src=\"%s%d_2.png\">",stepm,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1); 4545: /* Period (stable) prevalence in each health state */ 4546: for(cpt=1; cpt<=nlstate;cpt++){ 4547: fprintf(fichtm," - Convergence to period (stable) prevalence in state %d. Or probability to be in state %d being in state (1 to %d) at different ages. <a href=\"%s%d_%d.png\">%s%d_%d.png</a> \ 4548: <img src=\"%s%d_%d.png\">", cpt, cpt, nlstate, subdirf2(optionfilefiname,"p"),cpt,jj1,subdirf2(optionfilefiname,"p"),cpt,jj1,subdirf2(optionfilefiname,"p"),cpt,jj1); 4549: } 4550: for(cpt=1; cpt<=nlstate;cpt++) { 4551: fprintf(fichtm,"\n - Life expectancy by health state (%d) at initial age and its decomposition into health expectancies in each alive state (1 to %d) : <a href=\"%s%d%d.png\">%s%d%d.png</a> \ 4552: <img src=\"%s%d%d.png\">",cpt,nlstate,subdirf2(optionfilefiname,"exp"),cpt,jj1,subdirf2(optionfilefiname,"exp"),cpt,jj1,subdirf2(optionfilefiname,"exp"),cpt,jj1); 4553: } 4554: /* } /\* end i1 *\/ */ 4555: }/* End k1 */ 4556: fprintf(fichtm,"</ul>"); 4557: 4558: fprintf(fichtm,"\ 4559: \n <li><h4> <a name='secondorder'>Result files (second order: variances)</a></h4>\n\ 4560: - Parameter file with estimated parameters and covariance matrix: <a href=\"%s\">%s</a> \ 4561: - 95%% confidence intervals and T statistics are in the log file. \n", rfileres,rfileres); 4562: 4563: fprintf(fichtm," - Standard deviation of one-step probabilities: <a href=\"%s\">%s</a> \n", 4564: subdirf2(fileres,"prob"),subdirf2(fileres,"prob")); 4565: fprintf(fichtm,"\ 4566: - Variance-covariance of one-step probabilities: <a href=\"%s\">%s</a> \n", 4567: subdirf2(fileres,"probcov"),subdirf2(fileres,"probcov")); 4568: 4569: fprintf(fichtm,"\ 4570: - Correlation matrix of one-step probabilities: <a href=\"%s\">%s</a> \n", 4571: subdirf2(fileres,"probcor"),subdirf2(fileres,"probcor")); 4572: fprintf(fichtm,"\ 4573: - Variances and covariances of health expectancies by age and initial health status (cov(eij,ekl)(estepm=%2d months): \ 4574: <a href=\"%s\">%s</a> \n</li>", 4575: estepm,subdirf2(fileres,"cve"),subdirf2(fileres,"cve")); 4576: fprintf(fichtm,"\ 4577: - (a) Health expectancies by health status at initial age (eij) and standard errors (in parentheses) (b) life expectancies and standard errors (ei.=ei1+ei2+...)(estepm=%2d months): \ 4578: <a href=\"%s\">%s</a> \n</li>", 4579: estepm,subdirf2(fileres,"stde"),subdirf2(fileres,"stde")); 4580: fprintf(fichtm,"\ 4581: - Variances and covariances of health expectancies by age. Status (i) based health expectancies (in state j), eij are weighted by the period prevalences in each state i (if popbased=1, an additional computation is done using the cross-sectional prevalences, i.e population based) (estepm=%d months): <a href=\"%s\">%s</a> \n", 4582: estepm, subdirf2(fileres,"v"),subdirf2(fileres,"v")); 4583: fprintf(fichtm,"\ 4584: - Total life expectancy and total health expectancies to be spent in each health state e.j with their standard errors (if popbased=1, an additional computation is done using the cross-sectional prevalences, i.e population based) (estepm=%d months): <a href=\"%s\">%s</a> \n", 4585: estepm, subdirf2(fileres,"t"),subdirf2(fileres,"t")); 4586: fprintf(fichtm,"\ 4587: - Standard deviation of period (stable) prevalences: <a href=\"%s\">%s</a> \n",\ 4588: subdirf2(fileres,"vpl"),subdirf2(fileres,"vpl")); 4589: 4590: /* if(popforecast==1) fprintf(fichtm,"\n */ 4591: /* - Prevalences forecasting: <a href=\"f%s\">f%s</a> \n */ 4592: /* - Population forecasting (if popforecast=1): <a href=\"pop%s\">pop%s</a> \n */ 4593: /* ",fileres,fileres,fileres,fileres); */ 4594: /* else */ 4595: /* fprintf(fichtm,"\n No population forecast: popforecast = %d (instead of 1) or stepm = %d (instead of 1) or model=%s (instead of .) </li>\n",popforecast, stepm, model); */ 4596: fflush(fichtm); 4597: fprintf(fichtm," <ul><li>Graphs</li>"); 4598: 4599: m=pow(2,cptcoveff); 4600: if (cptcovn < 1) {m=1;ncodemax[1]=1;} 4601: 4602: jj1=0; 4603: for(k1=1; k1<=m;k1++){ 4604: /* for(i1=1; i1<=ncodemax[k1];i1++){ */ 4605: jj1++; 4606: if (cptcovn > 0) { 4607: fprintf(fichtm,"<hr size=\"2\" color=\"#EC5E5E\">************ Results for covariates"); 4608: for (cpt=1; cpt<=cptcoveff;cpt++) 4609: fprintf(fichtm," V%d=%d ",Tvaraff[cpt],nbcode[Tvaraff[cpt]][codtab[jj1][cpt]]); 4610: fprintf(fichtm," ************\n<hr size=\"2\" color=\"#EC5E5E\">"); 4611: } 4612: for(cpt=1; cpt<=nlstate;cpt++) { 4613: fprintf(fichtm," - Observed (cross-sectional) and period (incidence based) \ 4614: prevalence (with 95%% confidence interval) in state (%d): %s%d_%d.png \ 4615: <img src=\"%s%d_%d.png\">",cpt,subdirf2(optionfilefiname,"v"),cpt,jj1,subdirf2(optionfilefiname,"v"),cpt,jj1); 4616: } 4617: fprintf(fichtm,"\n - Total life expectancy by age and \ 4618: health expectancies in states (1) and (2). If popbased=1 the smooth (due to the model) \ 4619: true period expectancies (those weighted with period prevalences are also\ 4620: drawn in addition to the population based expectancies computed using\ 4621: observed and cahotic prevalences: %s%d.png \ 4622: <img src=\"%s%d.png\">",subdirf2(optionfilefiname,"e"),jj1,subdirf2(optionfilefiname,"e"),jj1); 4623: /* } /\* end i1 *\/ */ 4624: }/* End k1 */ 4625: fprintf(fichtm,"</ul>"); 4626: fflush(fichtm); 4627: } 4628: 4629: /******************* Gnuplot file **************/ 4630: void printinggnuplot(char fileres[], char optionfilefiname[], double ageminpar, double agemaxpar, double fage , char pathc[], double p[]){ 4631: 4632: char dirfileres[132],optfileres[132]; 4633: int cpt=0,k1=0,i=0,k=0,j=0,jk=0,k2=0,k3=0,ij=0,l=0; 4634: int ng=0; 4635: /* if((ficgp=fopen(optionfilegnuplot,"a"))==NULL) { */ 4636: /* printf("Problem with file %s",optionfilegnuplot); */ 4637: /* fprintf(ficlog,"Problem with file %s",optionfilegnuplot); */ 4638: /* } */ 4639: 4640: /*#ifdef windows */ 4641: fprintf(ficgp,"cd \"%s\" \n",pathc); 4642: /*#endif */ 4643: m=pow(2,cptcoveff); 4644: 4645: strcpy(dirfileres,optionfilefiname); 4646: strcpy(optfileres,"vpl"); 4647: /* 1eme*/ 4648: fprintf(ficgp,"\n# 1st: Period (stable) prevalence with CI: 'vpl' files\n"); 4649: for (cpt=1; cpt<= nlstate ; cpt ++) { 4650: for (k1=1; k1<= m ; k1 ++) { /* plot [100000000000000000000:-100000000000000000000] "mysbiaspar/vplrmysbiaspar.txt to check */ 4651: fprintf(ficgp,"\nset out \"%s%d_%d.png\" \n",subdirf2(optionfilefiname,"v"),cpt,k1); 4652: fprintf(ficgp,"\n#set out \"v%s%d_%d.png\" \n",optionfilefiname,cpt,k1); 4653: fprintf(ficgp,"set xlabel \"Age\" \n\ 4654: set ylabel \"Probability\" \n\ 4655: set ter png small size 320, 240\n\ 4656: plot [%.f:%.f] \"%s\" every :::%d::%d u 1:2 \"%%lf",ageminpar,fage,subdirf2(fileres,"vpl"),k1-1,k1-1); 4657: 4658: for (i=1; i<= nlstate ; i ++) { 4659: if (i==cpt) fprintf(ficgp," %%lf (%%lf)"); 4660: else fprintf(ficgp," %%*lf (%%*lf)"); 4661: } 4662: fprintf(ficgp,"\" t\"Period (stable) prevalence\" w l lt 0,\"%s\" every :::%d::%d u 1:($2+1.96*$3) \"%%lf",subdirf2(fileres,"vpl"),k1-1,k1-1); 4663: for (i=1; i<= nlstate ; i ++) { 4664: if (i==cpt) fprintf(ficgp," %%lf (%%lf)"); 4665: else fprintf(ficgp," %%*lf (%%*lf)"); 4666: } 4667: fprintf(ficgp,"\" t\"95%% CI\" w l lt 1,\"%s\" every :::%d::%d u 1:($2-1.96*$3) \"%%lf",subdirf2(fileres,"vpl"),k1-1,k1-1); 4668: for (i=1; i<= nlstate ; i ++) { 4669: if (i==cpt) fprintf(ficgp," %%lf (%%lf)"); 4670: else fprintf(ficgp," %%*lf (%%*lf)"); 4671: } 4672: fprintf(ficgp,"\" t\"\" w l lt 1,\"%s\" every :::%d::%d u 1:($%d) t\"Observed prevalence \" w l lt 2",subdirf2(fileres,"p"),k1-1,k1-1,2+4*(cpt-1)); 4673: } 4674: } 4675: /*2 eme*/ 4676: fprintf(ficgp,"\n# 2nd: Total life expectancy with CI: 't' files\n"); 4677: for (k1=1; k1<= m ; k1 ++) { 4678: fprintf(ficgp,"\nset out \"%s%d.png\" \n",subdirf2(optionfilefiname,"e"),k1); 4679: fprintf(ficgp,"set ylabel \"Years\" \nset ter png small size 320, 240\nplot [%.f:%.f] ",ageminpar,fage); 4680: 4681: for (i=1; i<= nlstate+1 ; i ++) { 4682: k=2*i; 4683: fprintf(ficgp,"\"%s\" every :::%d::%d u 1:2 \"%%lf",subdirf2(fileres,"t"),k1-1,k1-1); 4684: for (j=1; j<= nlstate+1 ; j ++) { 4685: if (j==i) fprintf(ficgp," %%lf (%%lf)"); 4686: else fprintf(ficgp," %%*lf (%%*lf)"); 4687: } 4688: if (i== 1) fprintf(ficgp,"\" t\"TLE\" w l ,"); 4689: else fprintf(ficgp,"\" t\"LE in state (%d)\" w l ,",i-1); 4690: fprintf(ficgp,"\"%s\" every :::%d::%d u 1:($2-$3*2) \"%%lf",subdirf2(fileres,"t"),k1-1,k1-1); 4691: for (j=1; j<= nlstate+1 ; j ++) { 4692: if (j==i) fprintf(ficgp," %%lf (%%lf)"); 4693: else fprintf(ficgp," %%*lf (%%*lf)"); 4694: } 4695: fprintf(ficgp,"\" t\"\" w l lt 0,"); 4696: fprintf(ficgp,"\"%s\" every :::%d::%d u 1:($2+$3*2) \"%%lf",subdirf2(fileres,"t"),k1-1,k1-1); 4697: for (j=1; j<= nlstate+1 ; j ++) { 4698: if (j==i) fprintf(ficgp," %%lf (%%lf)"); 4699: else fprintf(ficgp," %%*lf (%%*lf)"); 4700: } 4701: if (i== (nlstate+1)) fprintf(ficgp,"\" t\"\" w l lt 0"); 4702: else fprintf(ficgp,"\" t\"\" w l lt 0,"); 4703: } 4704: } 4705: 4706: /*3eme*/ 4707: 4708: for (k1=1; k1<= m ; k1 ++) { 4709: for (cpt=1; cpt<= nlstate ; cpt ++) { 4710: /* k=2+nlstate*(2*cpt-2); */ 4711: k=2+(nlstate+1)*(cpt-1); 4712: fprintf(ficgp,"\nset out \"%s%d%d.png\" \n",subdirf2(optionfilefiname,"exp"),cpt,k1); 4713: fprintf(ficgp,"set ter png small size 320, 240\n\ 4714: plot [%.f:%.f] \"%s\" every :::%d::%d u 1:%d t \"e%d1\" w l",ageminpar,fage,subdirf2(fileres,"e"),k1-1,k1-1,k,cpt); 4715: /*fprintf(ficgp,",\"e%s\" every :::%d::%d u 1:($%d-2*$%d) \"\%%lf ",fileres,k1-1,k1-1,k,k+1); 4716: for (i=1; i<= nlstate*2 ; i ++) fprintf(ficgp,"\%%lf (\%%lf) "); 4717: fprintf(ficgp,"\" t \"e%d1\" w l",cpt); 4718: fprintf(ficgp,",\"e%s\" every :::%d::%d u 1:($%d+2*$%d) \"\%%lf ",fileres,k1-1,k1-1,k,k+1); 4719: for (i=1; i<= nlstate*2 ; i ++) fprintf(ficgp,"\%%lf (\%%lf) "); 4720: fprintf(ficgp,"\" t \"e%d1\" w l",cpt); 4721: 4722: */ 4723: for (i=1; i< nlstate ; i ++) { 4724: fprintf(ficgp," ,\"%s\" every :::%d::%d u 1:%d t \"e%d%d\" w l",subdirf2(fileres,"e"),k1-1,k1-1,k+i,cpt,i+1); 4725: /* fprintf(ficgp," ,\"%s\" every :::%d::%d u 1:%d t \"e%d%d\" w l",subdirf2(fileres,"e"),k1-1,k1-1,k+2*i,cpt,i+1);*/ 4726: 4727: } 4728: fprintf(ficgp," ,\"%s\" every :::%d::%d u 1:%d t \"e%d.\" w l",subdirf2(fileres,"e"),k1-1,k1-1,k+nlstate,cpt); 4729: } 4730: } 4731: 4732: /* CV preval stable (period) */ 4733: for (k1=1; k1<= m ; k1 ++) { /* For each multivariate if any */ 4734: for (cpt=1; cpt<=nlstate ; cpt ++) { /* For each life state */ 4735: k=3; 4736: fprintf(ficgp,"\n#\n#\n#CV preval stable (period): 'pij' files, cov=%d state=%d",k1, cpt); 4737: fprintf(ficgp,"\nset out \"%s%d_%d.png\" \n",subdirf2(optionfilefiname,"p"),cpt,k1); 4738: fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \n\ 4739: set ter png small size 320, 240\n\ 4740: unset log y\n\ 4741: plot [%.f:%.f] ", ageminpar, agemaxpar); 4742: for (i=1; i<= nlstate ; i ++){ 4743: if(i==1) 4744: fprintf(ficgp,"\"%s\"",subdirf2(fileres,"pij")); 4745: else 4746: fprintf(ficgp,", '' "); 4747: l=(nlstate+ndeath)*(i-1)+1; 4748: fprintf(ficgp," u ($1==%d ? ($3):1/0):($%d/($%d",k1,k+l+(cpt-1),k+l); 4749: for (j=1; j<= (nlstate-1) ; j ++) 4750: fprintf(ficgp,"+$%d",k+l+j); 4751: fprintf(ficgp,")) t \"prev(%d,%d)\" w l",i,cpt); 4752: } /* nlstate */ 4753: fprintf(ficgp,"\n"); 4754: } /* end cpt state*/ 4755: } /* end covariate */ 4756: 4757: /* proba elementaires */ 4758: fprintf(ficgp,"\n##############\n#MLE estimated parameters\n#############\n"); 4759: for(i=1,jk=1; i <=nlstate; i++){ 4760: fprintf(ficgp,"# initial state %d\n",i); 4761: for(k=1; k <=(nlstate+ndeath); k++){ 4762: if (k != i) { 4763: fprintf(ficgp,"# current state %d\n",k); 4764: for(j=1; j <=ncovmodel; j++){ 4765: fprintf(ficgp,"p%d=%f; ",jk,p[jk]); 4766: jk++; 4767: } 4768: fprintf(ficgp,"\n"); 4769: } 4770: } 4771: } 4772: fprintf(ficgp,"##############\n#\n"); 4773: 4774: /*goto avoid;*/ 4775: fprintf(ficgp,"\n##############\n#Graphics of of probabilities or incidences\n#############\n"); 4776: fprintf(ficgp,"# logi(p12/p11)=a12+b12*age+c12age*age+d12*V1+e12*V1*age\n"); 4777: fprintf(ficgp,"# logi(p12/p11)=p1 +p2*age +p3*age*age+ p4*V1+ p5*V1*age\n"); 4778: fprintf(ficgp,"# logi(p13/p11)=a13+b13*age+c13age*age+d13*V1+e13*V1*age\n"); 4779: fprintf(ficgp,"# logi(p13/p11)=p6 +p7*age +p8*age*age+ p9*V1+ p10*V1*age\n"); 4780: fprintf(ficgp,"# p12+p13+p14+p11=1=p11(1+exp(a12+b12*age+c12age*age+d12*V1+e12*V1*age)\n"); 4781: fprintf(ficgp,"# +exp(a13+b13*age+c13age*age+d13*V1+e13*V1*age)+...)\n"); 4782: fprintf(ficgp,"# p11=1/(1+exp(a12+b12*age+c12age*age+d12*V1+e12*V1*age)\n"); 4783: fprintf(ficgp,"# +exp(a13+b13*age+c13age*age+d13*V1+e13*V1*age)+...)\n"); 4784: fprintf(ficgp,"# p12=exp(a12+b12*age+c12age*age+d12*V1+e12*V1*age)/\n"); 4785: fprintf(ficgp,"# (1+exp(a12+b12*age+c12age*age+d12*V1+e12*V1*age)\n"); 4786: fprintf(ficgp,"# +exp(a13+b13*age+c13age*age+d13*V1+e13*V1*age))\n"); 4787: fprintf(ficgp,"# +exp(a14+b14*age+c14age*age+d14*V1+e14*V1*age)+...)\n"); 4788: fprintf(ficgp,"#\n"); 4789: for(ng=1; ng<=2;ng++){ /* Number of graphics: first is probabilities second is incidence per year*/ 4790: fprintf(ficgp,"# ng=%d\n",ng); 4791: fprintf(ficgp,"# jk=1 to 2^%d=%d\n",cptcoveff,m); 4792: for(jk=1; jk <=m; jk++) { 4793: fprintf(ficgp,"# jk=%d\n",jk); 4794: fprintf(ficgp,"\nset out \"%s%d_%d.png\" \n",subdirf2(optionfilefiname,"pe"),jk,ng); 4795: if (ng==2) 4796: fprintf(ficgp,"\nset ylabel \"Quasi-incidence per year\"\n"); 4797: else 4798: fprintf(ficgp,"\nset title \"Probability\"\n"); 4799: fprintf(ficgp,"\nset ter png small size 320, 240\nset log y\nplot [%.f:%.f] ",ageminpar,agemaxpar); 4800: i=1; 4801: for(k2=1; k2<=nlstate; k2++) { 4802: k3=i; 4803: for(k=1; k<=(nlstate+ndeath); k++) { 4804: if (k != k2){ 4805: if(ng==2) 4806: if(nagesqr==0) 4807: fprintf(ficgp," %f*exp(p%d+p%d*x",YEARM/stepm,i,i+1); 4808: else /* nagesqr =1 */ 4809: fprintf(ficgp," %f*exp(p%d+p%d*x+p%d*x*x",YEARM/stepm,i,i+1,i+1+nagesqr); 4810: else 4811: if(nagesqr==0) 4812: fprintf(ficgp," exp(p%d+p%d*x",i,i+1); 4813: else /* nagesqr =1 */ 4814: fprintf(ficgp," exp(p%d+p%d*x+p%d*x*x",i,i+1,i+1+nagesqr); 4815: ij=1;/* To be checked else nbcode[0][0] wrong */ 4816: for(j=3; j <=ncovmodel-nagesqr; j++) { 4817: if(((j-2)==Tage[ij]) &&(ij <=cptcovage)) { /* Bug valgrind */ 4818: fprintf(ficgp,"+p%d*%d*x",i+j+nagesqr-1,nbcode[Tvar[j-2]][codtab[jk][Tvar[j-2]]]); 4819: ij++; 4820: } 4821: else 4822: fprintf(ficgp,"+p%d*%d",i+j+nagesqr-1,nbcode[Tvar[j-2]][codtab[jk][j-2]]); 4823: } 4824: fprintf(ficgp,")/(1"); 4825: 4826: for(k1=1; k1 <=nlstate; k1++){ 4827: if(nagesqr==0) 4828: fprintf(ficgp,"+exp(p%d+p%d*x",k3+(k1-1)*ncovmodel,k3+(k1-1)*ncovmodel+1); 4829: else /* nagesqr =1 */ 4830: fprintf(ficgp,"+exp(p%d+p%d*x+p%d*x*x",k3+(k1-1)*ncovmodel,k3+(k1-1)*ncovmodel+1,k3+(k1-1)*ncovmodel+1+nagesqr); 4831: 4832: ij=1; 4833: for(j=3; j <=ncovmodel-nagesqr; j++){ 4834: if(((j-2)==Tage[ij]) &&(ij <=cptcovage)) { 4835: fprintf(ficgp,"+p%d*%d*x",k3+(k1-1)*ncovmodel+1+j-2+nagesqr,nbcode[Tvar[j-2]][codtab[jk][Tvar[j-2]]]); 4836: ij++; 4837: } 4838: else 4839: fprintf(ficgp,"+p%d*%d",k3+(k1-1)*ncovmodel+1+j-2+nagesqr,nbcode[Tvar[j-2]][codtab[jk][j-2]]); 4840: } 4841: fprintf(ficgp,")"); 4842: } 4843: fprintf(ficgp,") t \"p%d%d\" ", k2,k); 4844: if ((k+k2)!= (nlstate*2+ndeath)) fprintf(ficgp,","); 4845: i=i+ncovmodel; 4846: } 4847: } /* end k */ 4848: } /* end k2 */ 4849: } /* end jk */ 4850: } /* end ng */ 4851: /* avoid: */ 4852: fflush(ficgp); 4853: } /* end gnuplot */ 4854: 4855: 4856: /*************** Moving average **************/ 4857: int movingaverage(double ***probs, double bage,double fage, double ***mobaverage, int mobilav){ 4858: 4859: int i, cpt, cptcod; 4860: int modcovmax =1; 4861: int mobilavrange, mob; 4862: double age; 4863: 4864: modcovmax=2*cptcoveff;/* Max number of modalities. We suppose 4865: a covariate has 2 modalities */ 4866: if (cptcovn<1) modcovmax=1; /* At least 1 pass */ 4867: 4868: if(mobilav==1||mobilav ==3 ||mobilav==5 ||mobilav== 7){ 4869: if(mobilav==1) mobilavrange=5; /* default */ 4870: else mobilavrange=mobilav; 4871: for (age=bage; age<=fage; age++) 4872: for (i=1; i<=nlstate;i++) 4873: for (cptcod=1;cptcod<=modcovmax;cptcod++) 4874: mobaverage[(int)age][i][cptcod]=probs[(int)age][i][cptcod]; 4875: /* We keep the original values on the extreme ages bage, fage and for 4876: fage+1 and bage-1 we use a 3 terms moving average; for fage+2 bage+2 4877: we use a 5 terms etc. until the borders are no more concerned. 4878: */ 4879: for (mob=3;mob <=mobilavrange;mob=mob+2){ 4880: for (age=bage+(mob-1)/2; age<=fage-(mob-1)/2; age++){ 4881: for (i=1; i<=nlstate;i++){ 4882: for (cptcod=1;cptcod<=modcovmax;cptcod++){ 4883: mobaverage[(int)age][i][cptcod] =probs[(int)age][i][cptcod]; 4884: for (cpt=1;cpt<=(mob-1)/2;cpt++){ 4885: mobaverage[(int)age][i][cptcod] +=probs[(int)age-cpt][i][cptcod]; 4886: mobaverage[(int)age][i][cptcod] +=probs[(int)age+cpt][i][cptcod]; 4887: } 4888: mobaverage[(int)age][i][cptcod]=mobaverage[(int)age][i][cptcod]/mob; 4889: } 4890: } 4891: }/* end age */ 4892: }/* end mob */ 4893: }else return -1; 4894: return 0; 4895: }/* End movingaverage */ 4896: 4897: 4898: /************** Forecasting ******************/ 4899: void prevforecast(char fileres[], double anproj1, double mproj1, double jproj1, double ageminpar, double agemax, double dateprev1, double dateprev2, int mobilav, double bage, double fage, int firstpass, int lastpass, double anproj2, double p[], int cptcoveff){ 4900: /* proj1, year, month, day of starting projection 4901: agemin, agemax range of age 4902: dateprev1 dateprev2 range of dates during which prevalence is computed 4903: anproj2 year of en of projection (same day and month as proj1). 4904: */ 4905: int yearp, stepsize, hstepm, nhstepm, j, k, cptcod, i, h, i1; 4906: double agec; /* generic age */ 4907: double agelim, ppij, yp,yp1,yp2,jprojmean,mprojmean,anprojmean; 4908: double *popeffectif,*popcount; 4909: double ***p3mat; 4910: double ***mobaverage; 4911: char fileresf[FILENAMELENGTH]; 4912: 4913: agelim=AGESUP; 4914: prevalence(probs, ageminpar, agemax, s, agev, nlstate, imx, Tvar, nbcode, ncodemax, mint, anint, dateprev1, dateprev2, firstpass, lastpass); 4915: 4916: strcpy(fileresf,"f"); 4917: strcat(fileresf,fileres); 4918: if((ficresf=fopen(fileresf,"w"))==NULL) { 4919: printf("Problem with forecast resultfile: %s\n", fileresf); 4920: fprintf(ficlog,"Problem with forecast resultfile: %s\n", fileresf); 4921: } 4922: printf("Computing forecasting: result on file '%s' \n", fileresf); 4923: fprintf(ficlog,"Computing forecasting: result on file '%s' \n", fileresf); 4924: 4925: if (cptcoveff==0) ncodemax[cptcoveff]=1; 4926: 4927: if (mobilav!=0) { 4928: mobaverage= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 4929: if (movingaverage(probs, ageminpar, fage, mobaverage,mobilav)!=0){ 4930: fprintf(ficlog," Error in movingaverage mobilav=%d\n",mobilav); 4931: printf(" Error in movingaverage mobilav=%d\n",mobilav); 4932: } 4933: } 4934: 4935: stepsize=(int) (stepm+YEARM-1)/YEARM; 4936: if (stepm<=12) stepsize=1; 4937: if(estepm < stepm){ 4938: printf ("Problem %d lower than %d\n",estepm, stepm); 4939: } 4940: else hstepm=estepm; 4941: 4942: hstepm=hstepm/stepm; 4943: yp1=modf(dateintmean,&yp);/* extracts integral of datemean in yp and 4944: fractional in yp1 */ 4945: anprojmean=yp; 4946: yp2=modf((yp1*12),&yp); 4947: mprojmean=yp; 4948: yp1=modf((yp2*30.5),&yp); 4949: jprojmean=yp; 4950: if(jprojmean==0) jprojmean=1; 4951: if(mprojmean==0) jprojmean=1; 4952: 4953: i1=cptcoveff; 4954: if (cptcovn < 1){i1=1;} 4955: 4956: fprintf(ficresf,"# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jprojmean,mprojmean,anprojmean,dateintmean,dateprev1,dateprev2); 4957: 4958: fprintf(ficresf,"#****** Routine prevforecast **\n"); 4959: 4960: /* if (h==(int)(YEARM*yearp)){ */ 4961: for(cptcov=1, k=0;cptcov<=i1;cptcov++){ 4962: for(cptcod=1;cptcod<=ncodemax[cptcoveff];cptcod++){ 4963: k=k+1; 4964: fprintf(ficresf,"\n#******"); 4965: for(j=1;j<=cptcoveff;j++) { 4966: fprintf(ficresf," V%d=%d, hpijx=probability over h years, hp.jx is weighted by observed prev ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 4967: } 4968: fprintf(ficresf,"******\n"); 4969: fprintf(ficresf,"# Covariate valuofcovar yearproj age"); 4970: for(j=1; j<=nlstate+ndeath;j++){ 4971: for(i=1; i<=nlstate;i++) 4972: fprintf(ficresf," p%d%d",i,j); 4973: fprintf(ficresf," p.%d",j); 4974: } 4975: for (yearp=0; yearp<=(anproj2-anproj1);yearp +=stepsize) { 4976: fprintf(ficresf,"\n"); 4977: fprintf(ficresf,"\n# Forecasting at date %.lf/%.lf/%.lf ",jproj1,mproj1,anproj1+yearp); 4978: 4979: for (agec=fage; agec>=(ageminpar-1); agec--){ 4980: nhstepm=(int) rint((agelim-agec)*YEARM/stepm); 4981: nhstepm = nhstepm/hstepm; 4982: p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 4983: oldm=oldms;savm=savms; 4984: hpxij(p3mat,nhstepm,agec,hstepm,p,nlstate,stepm,oldm,savm, k); 4985: 4986: for (h=0; h<=nhstepm; h++){ 4987: if (h*hstepm/YEARM*stepm ==yearp) { 4988: fprintf(ficresf,"\n"); 4989: for(j=1;j<=cptcoveff;j++) 4990: fprintf(ficresf,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 4991: fprintf(ficresf,"%.f %.f ",anproj1+yearp,agec+h*hstepm/YEARM*stepm); 4992: } 4993: for(j=1; j<=nlstate+ndeath;j++) { 4994: ppij=0.; 4995: for(i=1; i<=nlstate;i++) { 4996: if (mobilav==1) 4997: ppij=ppij+p3mat[i][j][h]*mobaverage[(int)agec][i][cptcod]; 4998: else { 4999: ppij=ppij+p3mat[i][j][h]*probs[(int)(agec)][i][cptcod]; 5000: } 5001: if (h*hstepm/YEARM*stepm== yearp) { 5002: fprintf(ficresf," %.3f", p3mat[i][j][h]); 5003: } 5004: } /* end i */ 5005: if (h*hstepm/YEARM*stepm==yearp) { 5006: fprintf(ficresf," %.3f", ppij); 5007: } 5008: }/* end j */ 5009: } /* end h */ 5010: free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 5011: } /* end agec */ 5012: } /* end yearp */ 5013: } /* end cptcod */ 5014: } /* end cptcov */ 5015: 5016: if (mobilav!=0) free_ma3x(mobaverage,1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 5017: 5018: fclose(ficresf); 5019: } 5020: 5021: /************** Forecasting *****not tested NB*************/ 5022: void populforecast(char fileres[], double anpyram,double mpyram,double jpyram,double ageminpar, double agemax,double dateprev1, double dateprev2, int mobilav, double agedeb, double fage, int popforecast, char popfile[], double anpyram1,double p[], int i2){ 5023: 5024: int cpt, stepsize, hstepm, nhstepm, j,k,c, cptcod, i,h; 5025: int *popage; 5026: double calagedatem, agelim, kk1, kk2; 5027: double *popeffectif,*popcount; 5028: double ***p3mat,***tabpop,***tabpopprev; 5029: double ***mobaverage; 5030: char filerespop[FILENAMELENGTH]; 5031: 5032: tabpop= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 5033: tabpopprev= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 5034: agelim=AGESUP; 5035: calagedatem=(anpyram+mpyram/12.+jpyram/365.-dateintmean)*YEARM; 5036: 5037: prevalence(probs, ageminpar, agemax, s, agev, nlstate, imx, Tvar, nbcode, ncodemax, mint, anint, dateprev1, dateprev2, firstpass, lastpass); 5038: 5039: 5040: strcpy(filerespop,"pop"); 5041: strcat(filerespop,fileres); 5042: if((ficrespop=fopen(filerespop,"w"))==NULL) { 5043: printf("Problem with forecast resultfile: %s\n", filerespop); 5044: fprintf(ficlog,"Problem with forecast resultfile: %s\n", filerespop); 5045: } 5046: printf("Computing forecasting: result on file '%s' \n", filerespop); 5047: fprintf(ficlog,"Computing forecasting: result on file '%s' \n", filerespop); 5048: 5049: if (cptcoveff==0) ncodemax[cptcoveff]=1; 5050: 5051: if (mobilav!=0) { 5052: mobaverage= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 5053: if (movingaverage(probs, ageminpar, fage, mobaverage,mobilav)!=0){ 5054: fprintf(ficlog," Error in movingaverage mobilav=%d\n",mobilav); 5055: printf(" Error in movingaverage mobilav=%d\n",mobilav); 5056: } 5057: } 5058: 5059: stepsize=(int) (stepm+YEARM-1)/YEARM; 5060: if (stepm<=12) stepsize=1; 5061: 5062: agelim=AGESUP; 5063: 5064: hstepm=1; 5065: hstepm=hstepm/stepm; 5066: 5067: if (popforecast==1) { 5068: if((ficpop=fopen(popfile,"r"))==NULL) { 5069: printf("Problem with population file : %s\n",popfile);exit(0); 5070: fprintf(ficlog,"Problem with population file : %s\n",popfile);exit(0); 5071: } 5072: popage=ivector(0,AGESUP); 5073: popeffectif=vector(0,AGESUP); 5074: popcount=vector(0,AGESUP); 5075: 5076: i=1; 5077: while ((c=fscanf(ficpop,"%d %lf\n",&popage[i],&popcount[i])) != EOF) i=i+1; 5078: 5079: imx=i; 5080: for (i=1; i<imx;i++) popeffectif[popage[i]]=popcount[i]; 5081: } 5082: 5083: for(cptcov=1,k=0;cptcov<=i2;cptcov++){ 5084: for(cptcod=1;cptcod<=ncodemax[cptcoveff];cptcod++){ 5085: k=k+1; 5086: fprintf(ficrespop,"\n#******"); 5087: for(j=1;j<=cptcoveff;j++) { 5088: fprintf(ficrespop," V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 5089: } 5090: fprintf(ficrespop,"******\n"); 5091: fprintf(ficrespop,"# Age"); 5092: for(j=1; j<=nlstate+ndeath;j++) fprintf(ficrespop," P.%d",j); 5093: if (popforecast==1) fprintf(ficrespop," [Population]"); 5094: 5095: for (cpt=0; cpt<=0;cpt++) { 5096: fprintf(ficrespop,"\n\n# Forecasting at date %.lf/%.lf/%.lf ",jpyram,mpyram,anpyram+cpt); 5097: 5098: for (agedeb=(fage-((int)calagedatem %12/12.)); agedeb>=(ageminpar-((int)calagedatem %12)/12.); agedeb--){ 5099: nhstepm=(int) rint((agelim-agedeb)*YEARM/stepm); 5100: nhstepm = nhstepm/hstepm; 5101: 5102: p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 5103: oldm=oldms;savm=savms; 5104: hpxij(p3mat,nhstepm,agedeb,hstepm,p,nlstate,stepm,oldm,savm, k); 5105: 5106: for (h=0; h<=nhstepm; h++){ 5107: if (h==(int) (calagedatem+YEARM*cpt)) { 5108: fprintf(ficrespop,"\n %3.f ",agedeb+h*hstepm/YEARM*stepm); 5109: } 5110: for(j=1; j<=nlstate+ndeath;j++) { 5111: kk1=0.;kk2=0; 5112: for(i=1; i<=nlstate;i++) { 5113: if (mobilav==1) 5114: kk1=kk1+p3mat[i][j][h]*mobaverage[(int)agedeb+1][i][cptcod]; 5115: else { 5116: kk1=kk1+p3mat[i][j][h]*probs[(int)(agedeb+1)][i][cptcod]; 5117: } 5118: } 5119: if (h==(int)(calagedatem+12*cpt)){ 5120: tabpop[(int)(agedeb)][j][cptcod]=kk1; 5121: /*fprintf(ficrespop," %.3f", kk1); 5122: if (popforecast==1) fprintf(ficrespop," [%.f]", kk1*popeffectif[(int)agedeb+1]);*/ 5123: } 5124: } 5125: for(i=1; i<=nlstate;i++){ 5126: kk1=0.; 5127: for(j=1; j<=nlstate;j++){ 5128: kk1= kk1+tabpop[(int)(agedeb)][j][cptcod]; 5129: } 5130: tabpopprev[(int)(agedeb)][i][cptcod]=tabpop[(int)(agedeb)][i][cptcod]/kk1*popeffectif[(int)(agedeb+(calagedatem+12*cpt)*hstepm/YEARM*stepm-1)]; 5131: } 5132: 5133: if (h==(int)(calagedatem+12*cpt)) for(j=1; j<=nlstate;j++) 5134: fprintf(ficrespop," %15.2f",tabpopprev[(int)(agedeb+1)][j][cptcod]); 5135: } 5136: free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 5137: } 5138: } 5139: 5140: /******/ 5141: 5142: for (cpt=1; cpt<=(anpyram1-anpyram);cpt++) { 5143: fprintf(ficrespop,"\n\n# Forecasting at date %.lf/%.lf/%.lf ",jpyram,mpyram,anpyram+cpt); 5144: for (agedeb=(fage-((int)calagedatem %12/12.)); agedeb>=(ageminpar-((int)calagedatem %12)/12.); agedeb--){ 5145: nhstepm=(int) rint((agelim-agedeb)*YEARM/stepm); 5146: nhstepm = nhstepm/hstepm; 5147: 5148: p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 5149: oldm=oldms;savm=savms; 5150: hpxij(p3mat,nhstepm,agedeb,hstepm,p,nlstate,stepm,oldm,savm, k); 5151: for (h=0; h<=nhstepm; h++){ 5152: if (h==(int) (calagedatem+YEARM*cpt)) { 5153: fprintf(ficresf,"\n %3.f ",agedeb+h*hstepm/YEARM*stepm); 5154: } 5155: for(j=1; j<=nlstate+ndeath;j++) { 5156: kk1=0.;kk2=0; 5157: for(i=1; i<=nlstate;i++) { 5158: kk1=kk1+p3mat[i][j][h]*tabpopprev[(int)agedeb+1][i][cptcod]; 5159: } 5160: if (h==(int)(calagedatem+12*cpt)) fprintf(ficresf," %15.2f", kk1); 5161: } 5162: } 5163: free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 5164: } 5165: } 5166: } 5167: } 5168: 5169: if (mobilav!=0) free_ma3x(mobaverage,1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 5170: 5171: if (popforecast==1) { 5172: free_ivector(popage,0,AGESUP); 5173: free_vector(popeffectif,0,AGESUP); 5174: free_vector(popcount,0,AGESUP); 5175: } 5176: free_ma3x(tabpop,1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 5177: free_ma3x(tabpopprev,1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 5178: fclose(ficrespop); 5179: } /* End of popforecast */ 5180: 5181: int fileappend(FILE *fichier, char *optionfich) 5182: { 5183: if((fichier=fopen(optionfich,"a"))==NULL) { 5184: printf("Problem with file: %s\n", optionfich); 5185: fprintf(ficlog,"Problem with file: %s\n", optionfich); 5186: return (0); 5187: } 5188: fflush(fichier); 5189: return (1); 5190: } 5191: 5192: 5193: /**************** function prwizard **********************/ 5194: void prwizard(int ncovmodel, int nlstate, int ndeath, char model[], FILE *ficparo) 5195: { 5196: 5197: /* Wizard to print covariance matrix template */ 5198: 5199: char ca[32], cb[32]; 5200: int i,j, k, li, lj, lk, ll, jj, npar, itimes; 5201: int numlinepar; 5202: 5203: printf("# Parameters nlstate*nlstate*ncov a12*1 + b12 * age + ...\n"); 5204: fprintf(ficparo,"# Parameters nlstate*nlstate*ncov a12*1 + b12 * age + ...\n"); 5205: for(i=1; i <=nlstate; i++){ 5206: jj=0; 5207: for(j=1; j <=nlstate+ndeath; j++){ 5208: if(j==i) continue; 5209: jj++; 5210: /*ca[0]= k+'a'-1;ca[1]='\0';*/ 5211: printf("%1d%1d",i,j); 5212: fprintf(ficparo,"%1d%1d",i,j); 5213: for(k=1; k<=ncovmodel;k++){ 5214: /* printf(" %lf",param[i][j][k]); */ 5215: /* fprintf(ficparo," %lf",param[i][j][k]); */ 5216: printf(" 0."); 5217: fprintf(ficparo," 0."); 5218: } 5219: printf("\n"); 5220: fprintf(ficparo,"\n"); 5221: } 5222: } 5223: printf("# Scales (for hessian or gradient estimation)\n"); 5224: fprintf(ficparo,"# Scales (for hessian or gradient estimation)\n"); 5225: npar= (nlstate+ndeath-1)*nlstate*ncovmodel; /* Number of parameters*/ 5226: for(i=1; i <=nlstate; i++){ 5227: jj=0; 5228: for(j=1; j <=nlstate+ndeath; j++){ 5229: if(j==i) continue; 5230: jj++; 5231: fprintf(ficparo,"%1d%1d",i,j); 5232: printf("%1d%1d",i,j); 5233: fflush(stdout); 5234: for(k=1; k<=ncovmodel;k++){ 5235: /* printf(" %le",delti3[i][j][k]); */ 5236: /* fprintf(ficparo," %le",delti3[i][j][k]); */ 5237: printf(" 0."); 5238: fprintf(ficparo," 0."); 5239: } 5240: numlinepar++; 5241: printf("\n"); 5242: fprintf(ficparo,"\n"); 5243: } 5244: } 5245: printf("# Covariance matrix\n"); 5246: /* # 121 Var(a12)\n\ */ 5247: /* # 122 Cov(b12,a12) Var(b12)\n\ */ 5248: /* # 131 Cov(a13,a12) Cov(a13,b12, Var(a13)\n\ */ 5249: /* # 132 Cov(b13,a12) Cov(b13,b12, Cov(b13,a13) Var(b13)\n\ */ 5250: /* # 212 Cov(a21,a12) Cov(a21,b12, Cov(a21,a13) Cov(a21,b13) Var(a21)\n\ */ 5251: /* # 212 Cov(b21,a12) Cov(b21,b12, Cov(b21,a13) Cov(b21,b13) Cov(b21,a21) Var(b21)\n\ */ 5252: /* # 232 Cov(a23,a12) Cov(a23,b12, Cov(a23,a13) Cov(a23,b13) Cov(a23,a21) Cov(a23,b21) Var(a23)\n\ */ 5253: /* # 232 Cov(b23,a12) Cov(b23,b12) ... Var (b23)\n" */ 5254: fflush(stdout); 5255: fprintf(ficparo,"# Covariance matrix\n"); 5256: /* # 121 Var(a12)\n\ */ 5257: /* # 122 Cov(b12,a12) Var(b12)\n\ */ 5258: /* # ...\n\ */ 5259: /* # 232 Cov(b23,a12) Cov(b23,b12) ... Var (b23)\n" */ 5260: 5261: for(itimes=1;itimes<=2;itimes++){ 5262: jj=0; 5263: for(i=1; i <=nlstate; i++){ 5264: for(j=1; j <=nlstate+ndeath; j++){ 5265: if(j==i) continue; 5266: for(k=1; k<=ncovmodel;k++){ 5267: jj++; 5268: ca[0]= k+'a'-1;ca[1]='\0'; 5269: if(itimes==1){ 5270: printf("#%1d%1d%d",i,j,k); 5271: fprintf(ficparo,"#%1d%1d%d",i,j,k); 5272: }else{ 5273: printf("%1d%1d%d",i,j,k); 5274: fprintf(ficparo,"%1d%1d%d",i,j,k); 5275: /* printf(" %.5le",matcov[i][j]); */ 5276: } 5277: ll=0; 5278: for(li=1;li <=nlstate; li++){ 5279: for(lj=1;lj <=nlstate+ndeath; lj++){ 5280: if(lj==li) continue; 5281: for(lk=1;lk<=ncovmodel;lk++){ 5282: ll++; 5283: if(ll<=jj){ 5284: cb[0]= lk +'a'-1;cb[1]='\0'; 5285: if(ll<jj){ 5286: if(itimes==1){ 5287: printf(" Cov(%s%1d%1d,%s%1d%1d)",ca,i,j,cb, li,lj); 5288: fprintf(ficparo," Cov(%s%1d%1d,%s%1d%1d)",ca,i,j,cb, li,lj); 5289: }else{ 5290: printf(" 0."); 5291: fprintf(ficparo," 0."); 5292: } 5293: }else{ 5294: if(itimes==1){ 5295: printf(" Var(%s%1d%1d)",ca,i,j); 5296: fprintf(ficparo," Var(%s%1d%1d)",ca,i,j); 5297: }else{ 5298: printf(" 0."); 5299: fprintf(ficparo," 0."); 5300: } 5301: } 5302: } 5303: } /* end lk */ 5304: } /* end lj */ 5305: } /* end li */ 5306: printf("\n"); 5307: fprintf(ficparo,"\n"); 5308: numlinepar++; 5309: } /* end k*/ 5310: } /*end j */ 5311: } /* end i */ 5312: } /* end itimes */ 5313: 5314: } /* end of prwizard */ 5315: /******************* Gompertz Likelihood ******************************/ 5316: double gompertz(double x[]) 5317: { 5318: double A,B,L=0.0,sump=0.,num=0.; 5319: int i,n=0; /* n is the size of the sample */ 5320: 5321: for (i=0;i<=imx-1 ; i++) { 5322: sump=sump+weight[i]; 5323: /* sump=sump+1;*/ 5324: num=num+1; 5325: } 5326: 5327: 5328: /* for (i=0; i<=imx; i++) 5329: if (wav[i]>0) printf("i=%d ageex=%lf agecens=%lf agedc=%lf cens=%d %d\n" ,i,ageexmed[i],agecens[i],agedc[i],cens[i],wav[i]);*/ 5330: 5331: for (i=1;i<=imx ; i++) 5332: { 5333: if (cens[i] == 1 && wav[i]>1) 5334: A=-x[1]/(x[2])*(exp(x[2]*(agecens[i]-agegomp))-exp(x[2]*(ageexmed[i]-agegomp))); 5335: 5336: if (cens[i] == 0 && wav[i]>1) 5337: A=-x[1]/(x[2])*(exp(x[2]*(agedc[i]-agegomp))-exp(x[2]*(ageexmed[i]-agegomp))) 5338: +log(x[1]/YEARM)+x[2]*(agedc[i]-agegomp)+log(YEARM); 5339: 5340: /*if (wav[i] > 1 && agecens[i] > 15) {*/ /* ??? */ 5341: if (wav[i] > 1 ) { /* ??? */ 5342: L=L+A*weight[i]; 5343: /* printf("\ni=%d A=%f L=%lf x[1]=%lf x[2]=%lf ageex=%lf agecens=%lf cens=%d agedc=%lf weight=%lf\n",i,A,L,x[1],x[2],ageexmed[i]*12,agecens[i]*12,cens[i],agedc[i]*12,weight[i]);*/ 5344: } 5345: } 5346: 5347: /*printf("x1=%2.9f x2=%2.9f x3=%2.9f L=%f\n",x[1],x[2],x[3],L);*/ 5348: 5349: return -2*L*num/sump; 5350: } 5351: 5352: #ifdef GSL 5353: /******************* Gompertz_f Likelihood ******************************/ 5354: double gompertz_f(const gsl_vector *v, void *params) 5355: { 5356: double A,B,LL=0.0,sump=0.,num=0.; 5357: double *x= (double *) v->data; 5358: int i,n=0; /* n is the size of the sample */ 5359: 5360: for (i=0;i<=imx-1 ; i++) { 5361: sump=sump+weight[i]; 5362: /* sump=sump+1;*/ 5363: num=num+1; 5364: } 5365: 5366: 5367: /* for (i=0; i<=imx; i++) 5368: if (wav[i]>0) printf("i=%d ageex=%lf agecens=%lf agedc=%lf cens=%d %d\n" ,i,ageexmed[i],agecens[i],agedc[i],cens[i],wav[i]);*/ 5369: printf("x[0]=%lf x[1]=%lf\n",x[0],x[1]); 5370: for (i=1;i<=imx ; i++) 5371: { 5372: if (cens[i] == 1 && wav[i]>1) 5373: A=-x[0]/(x[1])*(exp(x[1]*(agecens[i]-agegomp))-exp(x[1]*(ageexmed[i]-agegomp))); 5374: 5375: if (cens[i] == 0 && wav[i]>1) 5376: A=-x[0]/(x[1])*(exp(x[1]*(agedc[i]-agegomp))-exp(x[1]*(ageexmed[i]-agegomp))) 5377: +log(x[0]/YEARM)+x[1]*(agedc[i]-agegomp)+log(YEARM); 5378: 5379: /*if (wav[i] > 1 && agecens[i] > 15) {*/ /* ??? */ 5380: if (wav[i] > 1 ) { /* ??? */ 5381: LL=LL+A*weight[i]; 5382: /* printf("\ni=%d A=%f L=%lf x[1]=%lf x[2]=%lf ageex=%lf agecens=%lf cens=%d agedc=%lf weight=%lf\n",i,A,L,x[1],x[2],ageexmed[i]*12,agecens[i]*12,cens[i],agedc[i]*12,weight[i]);*/ 5383: } 5384: } 5385: 5386: /*printf("x1=%2.9f x2=%2.9f x3=%2.9f L=%f\n",x[1],x[2],x[3],L);*/ 5387: printf("x[0]=%lf x[1]=%lf -2*LL*num/sump=%lf\n",x[0],x[1],-2*LL*num/sump); 5388: 5389: return -2*LL*num/sump; 5390: } 5391: #endif 5392: 5393: /******************* Printing html file ***********/ 5394: void printinghtmlmort(char fileres[], char title[], char datafile[], int firstpass, \ 5395: int lastpass, int stepm, int weightopt, char model[],\ 5396: int imx, double p[],double **matcov,double agemortsup){ 5397: int i,k; 5398: 5399: fprintf(fichtm,"<ul><li><h4>Result files </h4>\n Force of mortality. Parameters of the Gompertz fit (with confidence interval in brackets): "); 5400: fprintf(fichtm," mu(age) =%lf*exp(%lf*(age-%d)) per year ",p[1],p[2],agegomp); 5401: for (i=1;i<=2;i++) 5402: fprintf(fichtm," p[%d] = %lf [%f ; %f] \n",i,p[i],p[i]-2*sqrt(matcov[i][i]),p[i]+2*sqrt(matcov[i][i])); 5403: fprintf(fichtm," <img src=\"graphmort.png\">"); 5404: fprintf(fichtm,"</ul>"); 5405: 5406: fprintf(fichtm,"<ul><li><h4>Life table</h4>\n "); 5407: 5408: fprintf(fichtm,"\nAge l<inf>x</inf> q<inf>x</inf> d(x,x+1) L<inf>x</inf> T<inf>x</inf> e<infx</inf> "); 5409: 5410: for (k=agegomp;k<(agemortsup-2);k++) 5411: fprintf(fichtm,"%d %.0lf %lf %.0lf %.0lf %.0lf %lf \n",k,lsurv[k],p[1]*exp(p[2]*(k-agegomp)),(p[1]*exp(p[2]*(k-agegomp)))*lsurv[k],lpop[k],tpop[k],tpop[k]/lsurv[k]); 5412: 5413: 5414: fflush(fichtm); 5415: } 5416: 5417: /******************* Gnuplot file **************/ 5418: void printinggnuplotmort(char fileres[], char optionfilefiname[], double ageminpar, double agemaxpar, double fage , char pathc[], double p[]){ 5419: 5420: char dirfileres[132],optfileres[132]; 5421: 5422: int ng; 5423: 5424: 5425: /*#ifdef windows */ 5426: fprintf(ficgp,"cd \"%s\" \n",pathc); 5427: /*#endif */ 5428: 5429: 5430: strcpy(dirfileres,optionfilefiname); 5431: strcpy(optfileres,"vpl"); 5432: fprintf(ficgp,"set out \"graphmort.png\"\n "); 5433: fprintf(ficgp,"set xlabel \"Age\"\n set ylabel \"Force of mortality (per year)\" \n "); 5434: fprintf(ficgp, "set ter png small size 320, 240\n set log y\n"); 5435: /* fprintf(ficgp, "set size 0.65,0.65\n"); */ 5436: fprintf(ficgp,"plot [%d:100] %lf*exp(%lf*(x-%d))",agegomp,p[1],p[2],agegomp); 5437: 5438: } 5439: 5440: int readdata(char datafile[], int firstobs, int lastobs, int *imax) 5441: { 5442: 5443: /*-------- data file ----------*/ 5444: FILE *fic; 5445: char dummy[]=" "; 5446: int i=0, j=0, n=0; 5447: int linei, month, year,iout; 5448: char line[MAXLINE], linetmp[MAXLINE]; 5449: char stra[MAXLINE], strb[MAXLINE]; 5450: char *stratrunc; 5451: int lstra; 5452: 5453: 5454: if((fic=fopen(datafile,"r"))==NULL) { 5455: printf("Problem while opening datafile: %s\n", datafile);fflush(stdout); 5456: fprintf(ficlog,"Problem while opening datafile: %s\n", datafile);fflush(ficlog);return 1; 5457: } 5458: 5459: i=1; 5460: linei=0; 5461: while ((fgets(line, MAXLINE, fic) != NULL) &&((i >= firstobs) && (i <=lastobs))) { 5462: linei=linei+1; 5463: for(j=strlen(line); j>=0;j--){ /* Untabifies line */ 5464: if(line[j] == '\t') 5465: line[j] = ' '; 5466: } 5467: for(j=strlen(line)-1; (line[j]==' ')||(line[j]==10)||(line[j]==13);j--){ 5468: ; 5469: }; 5470: line[j+1]=0; /* Trims blanks at end of line */ 5471: if(line[0]=='#'){ 5472: fprintf(ficlog,"Comment line\n%s\n",line); 5473: printf("Comment line\n%s\n",line); 5474: continue; 5475: } 5476: trimbb(linetmp,line); /* Trims multiple blanks in line */ 5477: strcpy(line, linetmp); 5478: 5479: 5480: for (j=maxwav;j>=1;j--){ 5481: cutv(stra, strb, line, ' '); 5482: if(strb[0]=='.') { /* Missing status */ 5483: lval=-1; 5484: }else{ 5485: errno=0; 5486: lval=strtol(strb,&endptr,10); 5487: /* if (errno == ERANGE && (lval == LONG_MAX || lval == LONG_MIN))*/ 5488: if( strb[0]=='\0' || (*endptr != '\0')){ 5489: printf("Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a status of wave %d. Setting maxwav=%d might be wrong. Exiting.\n", strb, linei,i,line,j,maxwav); 5490: fprintf(ficlog,"Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a status of wave %d. Setting maxwav=%d might be wrong. Exiting.\n", strb, linei,i,line,j,maxwav);fflush(ficlog); 5491: return 1; 5492: } 5493: } 5494: s[j][i]=lval; 5495: 5496: strcpy(line,stra); 5497: cutv(stra, strb,line,' '); 5498: if( (iout=sscanf(strb,"%d/%d",&month, &year)) != 0){ 5499: } 5500: else if( (iout=sscanf(strb,"%s.",dummy)) != 0){ 5501: month=99; 5502: year=9999; 5503: }else{ 5504: printf("Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of interview (mm/yyyy or .) at wave %d. Exiting.\n",strb, linei,i, line,j); 5505: fprintf(ficlog,"Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of interview (mm/yyyy or .) at wave %d. Exiting.\n",strb, linei,i, line,j);fflush(ficlog); 5506: return 1; 5507: } 5508: anint[j][i]= (double) year; 5509: mint[j][i]= (double)month; 5510: strcpy(line,stra); 5511: } /* ENd Waves */ 5512: 5513: cutv(stra, strb,line,' '); 5514: if( (iout=sscanf(strb,"%d/%d",&month, &year)) != 0){ 5515: } 5516: else if( (iout=sscanf(strb,"%s.",dummy)) != 0){ 5517: month=99; 5518: year=9999; 5519: }else{ 5520: printf("Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of death (mm/yyyy or .). Exiting.\n",strb, linei,i,line); 5521: fprintf(ficlog,"Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of death (mm/yyyy or .). Exiting.\n",strb, linei,i,line);fflush(ficlog); 5522: return 1; 5523: } 5524: andc[i]=(double) year; 5525: moisdc[i]=(double) month; 5526: strcpy(line,stra); 5527: 5528: cutv(stra, strb,line,' '); 5529: if( (iout=sscanf(strb,"%d/%d",&month, &year)) != 0){ 5530: } 5531: else if( (iout=sscanf(strb,"%s.", dummy)) != 0){ 5532: month=99; 5533: year=9999; 5534: }else{ 5535: printf("Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of birth (mm/yyyy or .). Exiting.\n",strb, linei,i,line); 5536: fprintf(ficlog,"Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of birth (mm/yyyy or .). Exiting.\n",strb, linei,i,line);fflush(ficlog); 5537: return 1; 5538: } 5539: if (year==9999) { 5540: printf("Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of birth (mm/yyyy) but at least the year of birth should be given. Exiting.\n",strb, linei,i,line); 5541: fprintf(ficlog,"Error reading data around '%s' at line number %d for individual %d, '%s'\nShould be a date of birth (mm/yyyy) but at least the year of birth should be given. Exiting.\n",strb, linei,i,line);fflush(ficlog); 5542: return 1; 5543: 5544: } 5545: annais[i]=(double)(year); 5546: moisnais[i]=(double)(month); 5547: strcpy(line,stra); 5548: 5549: cutv(stra, strb,line,' '); 5550: errno=0; 5551: dval=strtod(strb,&endptr); 5552: if( strb[0]=='\0' || (*endptr != '\0')){ 5553: printf("Error reading data around '%f' at line number %d, \"%s\" for individual %d\nShould be a weight. Exiting.\n",dval, i,line,linei); 5554: fprintf(ficlog,"Error reading data around '%f' at line number %d, \"%s\" for individual %d\nShould be a weight. Exiting.\n",dval, i,line,linei); 5555: fflush(ficlog); 5556: return 1; 5557: } 5558: weight[i]=dval; 5559: strcpy(line,stra); 5560: 5561: for (j=ncovcol;j>=1;j--){ 5562: cutv(stra, strb,line,' '); 5563: if(strb[0]=='.') { /* Missing status */ 5564: lval=-1; 5565: }else{ 5566: errno=0; 5567: lval=strtol(strb,&endptr,10); 5568: if( strb[0]=='\0' || (*endptr != '\0')){ 5569: printf("Error reading data around '%ld' at line number %d for individual %d, '%s'\nShould be a covariate value (=0 for the reference or 1 for alternative). Exiting.\n",lval, linei,i, line); 5570: fprintf(ficlog,"Error reading data around '%ld' at line number %d for individual %d, '%s'\nShould be a covariate value (=0 for the reference or 1 for alternative). Exiting.\n",lval, linei,i, line);fflush(ficlog); 5571: return 1; 5572: } 5573: } 5574: if(lval <-1 || lval >1){ 5575: printf("Error reading data around '%ld' at line number %d for individual %d, '%s'\n \ 5576: Should be a value of %d(nth) covariate (0 should be the value for the reference and 1\n \ 5577: for the alternative. IMaCh does not build design variables automatically, do it yourself.\n \ 5578: For example, for multinomial values like 1, 2 and 3,\n \ 5579: build V1=0 V2=0 for the reference value (1),\n \ 5580: V1=1 V2=0 for (2) \n \ 5581: and V1=0 V2=1 for (3). V1=1 V2=1 should not exist and the corresponding\n \ 5582: output of IMaCh is often meaningless.\n \ 5583: Exiting.\n",lval,linei, i,line,j); 5584: fprintf(ficlog,"Error reading data around '%ld' at line number %d for individual %d, '%s'\n \ 5585: Should be a value of %d(nth) covariate (0 should be the value for the reference and 1\n \ 5586: for the alternative. IMaCh does not build design variables automatically, do it yourself.\n \ 5587: For example, for multinomial values like 1, 2 and 3,\n \ 5588: build V1=0 V2=0 for the reference value (1),\n \ 5589: V1=1 V2=0 for (2) \n \ 5590: and V1=0 V2=1 for (3). V1=1 V2=1 should not exist and the corresponding\n \ 5591: output of IMaCh is often meaningless.\n \ 5592: Exiting.\n",lval,linei, i,line,j);fflush(ficlog); 5593: return 1; 5594: } 5595: covar[j][i]=(double)(lval); 5596: strcpy(line,stra); 5597: } 5598: lstra=strlen(stra); 5599: 5600: if(lstra > 9){ /* More than 2**32 or max of what printf can write with %ld */ 5601: stratrunc = &(stra[lstra-9]); 5602: num[i]=atol(stratrunc); 5603: } 5604: else 5605: num[i]=atol(stra); 5606: /*if((s[2][i]==2) && (s[3][i]==-1)&&(s[4][i]==9)){ 5607: printf("%ld %.lf %.lf %.lf %.lf/%.lf %.lf/%.lf %.lf/%.lf %d %.lf/%.lf %d %.lf/%.lf %d %.lf/%.lf %d\n",num[i],(covar[1][i]), (covar[2][i]),weight[i], (moisnais[i]), (annais[i]), (moisdc[i]), (andc[i]), (mint[1][i]), (anint[1][i]), (s[1][i]), (mint[2][i]), (anint[2][i]), (s[2][i]), (mint[3][i]), (anint[3][i]), (s[3][i]), (mint[4][i]), (anint[4][i]), (s[4][i])); ij=ij+1;}*/ 5608: 5609: i=i+1; 5610: } /* End loop reading data */ 5611: 5612: *imax=i-1; /* Number of individuals */ 5613: fclose(fic); 5614: 5615: return (0); 5616: /* endread: */ 5617: printf("Exiting readdata: "); 5618: fclose(fic); 5619: return (1); 5620: 5621: 5622: 5623: } 5624: void removespace(char *str) { 5625: char *p1 = str, *p2 = str; 5626: do 5627: while (*p2 == ' ') 5628: p2++; 5629: while (*p1++ == *p2++); 5630: } 5631: 5632: int decodemodel ( char model[], int lastobs) /**< This routine decode the model and returns: 5633: * Model V1+V2+V3+V8+V7*V8+V5*V6+V8*age+V3*age+age*age 5634: * - nagesqr = 1 if age*age in the model, otherwise 0. 5635: * - cptcovt total number of covariates of the model nbocc(+)+1 = 8 excepting constant and age and age*age 5636: * - cptcovn or number of covariates k of the models excluding age*products =6 and age*age 5637: * - cptcovage number of covariates with age*products =2 5638: * - cptcovs number of simple covariates 5639: * - Tvar[k] is the id of the kth covariate Tvar[1]@12 {1, 2, 3, 8, 10, 11, 8, 3, 7, 8, 5, 6}, thus Tvar[5=V7*V8]=10 5640: * which is a new column after the 9 (ncovcol) variables. 5641: * - if k is a product Vn*Vm covar[k][i] is filled with correct values for each individual 5642: * - Tprod[l] gives the kth covariates of the product Vn*Vm l=1 to cptcovprod-cptcovage 5643: * Tprod[1]@2 {5, 6}: position of first product V7*V8 is 5, and second V5*V6 is 6. 5644: * - Tvard[k] p Tvard[1][1]@4 {7, 8, 5, 6} for V7*V8 and V5*V6 . 5645: */ 5646: { 5647: int i, j, k, ks; 5648: int j1, k1, k2; 5649: char modelsav[80]; 5650: char stra[80], strb[80], strc[80], strd[80],stre[80]; 5651: char *strpt; 5652: 5653: /*removespace(model);*/ 5654: if (strlen(model) >1){ /* If there is at least 1 covariate */ 5655: j=0, j1=0, k1=0, k2=-1, ks=0, cptcovn=0; 5656: if (strstr(model,"AGE") !=0){ 5657: printf("Error. AGE must be in lower case 'age' model=1+age+%s. ",model); 5658: fprintf(ficlog,"Error. AGE must be in lower case model=1+age+%s. ",model);fflush(ficlog); 5659: return 1; 5660: } 5661: if (strstr(model,"v") !=0){ 5662: printf("Error. 'v' must be in upper case 'V' model=%s ",model); 5663: fprintf(ficlog,"Error. 'v' must be in upper case model=%s ",model);fflush(ficlog); 5664: return 1; 5665: } 5666: strcpy(modelsav,model); 5667: if ((strpt=strstr(model,"age*age")) !=0){ 5668: printf(" strpt=%s, model=%s\n",strpt, model); 5669: if(strpt != model){ 5670: printf("Error in model: 'model=%s'; 'age*age' should in first place before other covariates\n \ 5671: 'model=1+age+age*age+V1.' or 'model=1+age+age*age+V1+V1*age.', please swap as well as \n \ 5672: corresponding column of parameters.\n",model); 5673: fprintf(ficlog,"Error in model: 'model=%s'; 'age*age' should in first place before other covariates\n \ 5674: 'model=1+age+age*age+V1.' or 'model=1+age+age*age+V1+V1*age.', please swap as well as \n \ 5675: corresponding column of parameters.\n",model); fflush(ficlog); 5676: return 1; 5677: } 5678: 5679: nagesqr=1; 5680: if (strstr(model,"+age*age") !=0) 5681: substrchaine(modelsav, model, "+age*age"); 5682: else if (strstr(model,"age*age+") !=0) 5683: substrchaine(modelsav, model, "age*age+"); 5684: else 5685: substrchaine(modelsav, model, "age*age"); 5686: }else 5687: nagesqr=0; 5688: if (strlen(modelsav) >1){ 5689: j=nbocc(modelsav,'+'); /**< j=Number of '+' */ 5690: j1=nbocc(modelsav,'*'); /**< j1=Number of '*' */ 5691: cptcovs=j+1-j1; /**< Number of simple covariates V1+V1*age+V3 +V3*V4+age*age=> V1 + V3 =2 */ 5692: cptcovt= j+1; /* Number of total covariates in the model, not including 5693: * cst, age and age*age 5694: * V1+V1*age+ V3 + V3*V4+age*age=> 4*/ 5695: /* including age products which are counted in cptcovage. 5696: * but the covariates which are products must be treated 5697: * separately: ncovn=4- 2=2 (V1+V3). */ 5698: cptcovprod=j1; /**< Number of products V1*V2 +v3*age = 2 */ 5699: cptcovprodnoage=0; /**< Number of covariate products without age: V3*V4 =1 */ 5700: 5701: 5702: /* Design 5703: * V1 V2 V3 V4 V5 V6 V7 V8 V9 Weight 5704: * < ncovcol=8 > 5705: * Model V2 + V1 + V3*age + V3 + V5*V6 + V7*V8 + V8*age + V8 5706: * k= 1 2 3 4 5 6 7 8 5707: * cptcovn number of covariates (not including constant and age ) = # of + plus 1 = 7+1=8 5708: * covar[k,i], value of kth covariate if not including age for individual i: 5709: * covar[1][i]= (V2), covar[4][i]=(V3), covar[8][i]=(V8) 5710: * Tvar[k] # of the kth covariate: Tvar[1]=2 Tvar[4]=3 Tvar[8]=8 5711: * if multiplied by age: V3*age Tvar[3=V3*age]=3 (V3) Tvar[7]=8 and 5712: * Tage[++cptcovage]=k 5713: * if products, new covar are created after ncovcol with k1 5714: * Tvar[k]=ncovcol+k1; # of the kth covariate product: Tvar[5]=ncovcol+1=10 Tvar[6]=ncovcol+1=11 5715: * Tprod[k1]=k; Tprod[1]=5 Tprod[2]= 6; gives the position of the k1th product 5716: * Tvard[k1][1]=m Tvard[k1][2]=m; Tvard[1][1]=5 (V5) Tvard[1][2]=6 Tvard[2][1]=7 (V7) Tvard[2][2]=8 5717: * Tvar[cptcovn+k2]=Tvard[k1][1];Tvar[cptcovn+k2+1]=Tvard[k1][2]; 5718: * Tvar[8+1]=5;Tvar[8+2]=6;Tvar[8+3]=7;Tvar[8+4]=8 inverted 5719: * V1 V2 V3 V4 V5 V6 V7 V8 V9 V10 V11 5720: * < ncovcol=8 > 5721: * Model V2 + V1 + V3*age + V3 + V5*V6 + V7*V8 + V8*age + V8 d1 d1 d2 d2 5722: * k= 1 2 3 4 5 6 7 8 9 10 11 12 5723: * Tvar[k]= 2 1 3 3 10 11 8 8 5 6 7 8 5724: * p Tvar[1]@12={2, 1, 3, 3, 11, 10, 8, 8, 7, 8, 5, 6} 5725: * p Tprod[1]@2={ 6, 5} 5726: *p Tvard[1][1]@4= {7, 8, 5, 6} 5727: * covar[k][i]= V2 V1 ? V3 V5*V6? V7*V8? ? V8 5728: * cov[Tage[kk]+2]=covar[Tvar[Tage[kk]]][i]*cov[2]; 5729: *How to reorganize? 5730: * Model V1 + V2 + V3 + V8 + V5*V6 + V7*V8 + V3*age + V8*age 5731: * Tvars {2, 1, 3, 3, 11, 10, 8, 8, 7, 8, 5, 6} 5732: * {2, 1, 4, 8, 5, 6, 3, 7} 5733: * Struct [] 5734: */ 5735: 5736: /* This loop fills the array Tvar from the string 'model'.*/ 5737: /* j is the number of + signs in the model V1+V2+V3 j=2 i=3 to 1 */ 5738: /* modelsav=V2+V1+V4+age*V3 strb=age*V3 stra=V2+V1+V4 */ 5739: /* k=4 (age*V3) Tvar[k=4]= 3 (from V3) Tage[cptcovage=1]=4 */ 5740: /* k=3 V4 Tvar[k=3]= 4 (from V4) */ 5741: /* k=2 V1 Tvar[k=2]= 1 (from V1) */ 5742: /* k=1 Tvar[1]=2 (from V2) */ 5743: /* k=5 Tvar[5] */ 5744: /* for (k=1; k<=cptcovn;k++) { */ 5745: /* cov[2+k]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]]; */ 5746: /* } */ 5747: /* for (k=1; k<=cptcovage;k++) cov[2+Tage[k]]=nbcode[Tvar[Tage[k]]][codtab[ij][Tvar[Tage[k]]]]*cov[2]; */ 5748: /* 5749: * Treating invertedly V2+V1+V3*age+V2*V4 is as if written V2*V4 +V3*age + V1 + V2 */ 5750: for(k=cptcovt; k>=1;k--) /**< Number of covariates */ 5751: Tvar[k]=0; 5752: cptcovage=0; 5753: for(k=1; k<=cptcovt;k++){ /* Loop on total covariates of the model */ 5754: cutl(stra,strb,modelsav,'+'); /* keeps in strb after the first '+' 5755: modelsav==V2+V1+V4+V3*age strb=V3*age stra=V2+V1+V4 */ 5756: if (nbocc(modelsav,'+')==0) strcpy(strb,modelsav); /* and analyzes it */ 5757: /* printf("i=%d a=%s b=%s sav=%s\n",i, stra,strb,modelsav);*/ 5758: /*scanf("%d",i);*/ 5759: if (strchr(strb,'*')) { /**< Model includes a product V2+V1+V4+V3*age strb=V3*age */ 5760: cutl(strc,strd,strb,'*'); /**< strd*strc Vm*Vn: strb=V3*age(input) strc=age strd=V3 ; V3*V2 strc=V2, strd=V3 */ 5761: if (strcmp(strc,"age")==0) { /**< Model includes age: Vn*age */ 5762: /* covar is not filled and then is empty */ 5763: cptcovprod--; 5764: cutl(stre,strb,strd,'V'); /* strd=V3(input): stre="3" */ 5765: Tvar[k]=atoi(stre); /* V2+V1+V4+V3*age Tvar[4]=3 ; V1+V2*age Tvar[2]=2; V1+V1*age Tvar[2]=1 */ 5766: cptcovage++; /* Sums the number of covariates which include age as a product */ 5767: Tage[cptcovage]=k; /* Tvar[4]=3, Tage[1] = 4 or V1+V1*age Tvar[2]=1, Tage[1]=2 */ 5768: /*printf("stre=%s ", stre);*/ 5769: } else if (strcmp(strd,"age")==0) { /* or age*Vn */ 5770: cptcovprod--; 5771: cutl(stre,strb,strc,'V'); 5772: Tvar[k]=atoi(stre); 5773: cptcovage++; 5774: Tage[cptcovage]=k; 5775: } else { /* Age is not in the model product V2+V1+V1*V4+V3*age+V3*V2 strb=V3*V2*/ 5776: /* loops on k1=1 (V3*V2) and k1=2 V4*V3 */ 5777: cptcovn++; 5778: cptcovprodnoage++;k1++; 5779: cutl(stre,strb,strc,'V'); /* strc= Vn, stre is n; strb=V3*V2 stre=3 strc=*/ 5780: Tvar[k]=ncovcol+k1; /* For model-covariate k tells which data-covariate to use but 5781: because this model-covariate is a construction we invent a new column 5782: ncovcol + k1 5783: If already ncovcol=4 and model=V2+V1+V1*V4+age*V3+V3*V2 5784: Tvar[3=V1*V4]=4+1 Tvar[5=V3*V2]=4 + 2= 6, etc */ 5785: cutl(strc,strb,strd,'V'); /* strd was Vm, strc is m */ 5786: Tprod[k1]=k; /* Tprod[1]=3(=V1*V4) for V2+V1+V1*V4+age*V3+V3*V2 */ 5787: Tvard[k1][1] =atoi(strc); /* m 1 for V1*/ 5788: Tvard[k1][2] =atoi(stre); /* n 4 for V4*/ 5789: k2=k2+2; 5790: Tvar[cptcovt+k2]=Tvard[k1][1]; /* Tvar[(cptcovt=4+k2=1)=5]= 1 (V1) */ 5791: Tvar[cptcovt+k2+1]=Tvard[k1][2]; /* Tvar[(cptcovt=4+(k2=1)+1)=6]= 4 (V4) */ 5792: for (i=1; i<=lastobs;i++){ 5793: /* Computes the new covariate which is a product of 5794: covar[n][i]* covar[m][i] and stores it at ncovol+k1 May not be defined */ 5795: covar[ncovcol+k1][i]=covar[atoi(stre)][i]*covar[atoi(strc)][i]; 5796: } 5797: } /* End age is not in the model */ 5798: } /* End if model includes a product */ 5799: else { /* no more sum */ 5800: /*printf("d=%s c=%s b=%s\n", strd,strc,strb);*/ 5801: /* scanf("%d",i);*/ 5802: cutl(strd,strc,strb,'V'); 5803: ks++; /**< Number of simple covariates */ 5804: cptcovn++; 5805: Tvar[k]=atoi(strd); 5806: } 5807: strcpy(modelsav,stra); /* modelsav=V2+V1+V4 stra=V2+V1+V4 */ 5808: /*printf("a=%s b=%s sav=%s\n", stra,strb,modelsav); 5809: scanf("%d",i);*/ 5810: } /* end of loop + on total covariates */ 5811: } /* end if strlen(modelsave == 0) age*age might exist */ 5812: } /* end if strlen(model == 0) */ 5813: 5814: /*The number n of Vn is stored in Tvar. cptcovage =number of age covariate. Tage gives the position of age. cptcovprod= number of products. 5815: If model=V1+V1*age then Tvar[1]=1 Tvar[2]=1 cptcovage=1 Tage[1]=2 cptcovprod=0*/ 5816: 5817: /* printf("tvar1=%d tvar2=%d tvar3=%d cptcovage=%d Tage=%d",Tvar[1],Tvar[2],Tvar[3],cptcovage,Tage[1]); 5818: printf("cptcovprod=%d ", cptcovprod); 5819: fprintf(ficlog,"cptcovprod=%d ", cptcovprod); 5820: 5821: scanf("%d ",i);*/ 5822: 5823: 5824: return (0); /* with covar[new additional covariate if product] and Tage if age */ 5825: /*endread:*/ 5826: printf("Exiting decodemodel: "); 5827: return (1); 5828: } 5829: 5830: int calandcheckages(int imx, int maxwav, double *agemin, double *agemax, int *nberr, int *nbwarn ) 5831: { 5832: int i, m; 5833: 5834: for (i=1; i<=imx; i++) { 5835: for(m=2; (m<= maxwav); m++) { 5836: if (((int)mint[m][i]== 99) && (s[m][i] <= nlstate)){ 5837: anint[m][i]=9999; 5838: s[m][i]=-1; 5839: } 5840: if((int)moisdc[i]==99 && (int)andc[i]==9999 && s[m][i]>nlstate){ 5841: *nberr = *nberr + 1; 5842: printf("Error! Date of death (month %2d and year %4d) of individual %ld on line %d was unknown, you must set an arbitrary year of death or he/she is skipped and results are biased (%d)\n",(int)moisdc[i],(int)andc[i],num[i],i, *nberr); 5843: fprintf(ficlog,"Error! Date of death (month %2d and year %4d) of individual %ld on line %d was unknown, you must set an arbitrary year of death or he/she is skipped and results are biased (%d)\n",(int)moisdc[i],(int)andc[i],num[i],i, *nberr); 5844: s[m][i]=-1; 5845: } 5846: if((int)moisdc[i]==99 && (int)andc[i]!=9999 && s[m][i]>nlstate){ 5847: (*nberr)++; 5848: printf("Error! Month of death of individual %ld on line %d was unknown %2d, you should set it otherwise the information on the death is skipped and results are biased.\n",num[i],i,(int)moisdc[i]); 5849: fprintf(ficlog,"Error! Month of death of individual %ld on line %d was unknown %f, you should set it otherwise the information on the death is skipped and results are biased.\n",num[i],i,moisdc[i]); 5850: s[m][i]=-1; /* We prefer to skip it (and to skip it in version 0.8a1 too */ 5851: } 5852: } 5853: } 5854: 5855: for (i=1; i<=imx; i++) { 5856: agedc[i]=(moisdc[i]/12.+andc[i])-(moisnais[i]/12.+annais[i]); 5857: for(m=firstpass; (m<= lastpass); m++){ 5858: if(s[m][i] >0 || s[m][i]==-2 || s[m][i]==-4 || s[m][i]==-5){ 5859: if (s[m][i] >= nlstate+1) { 5860: if(agedc[i]>0){ 5861: if((int)moisdc[i]!=99 && (int)andc[i]!=9999){ 5862: agev[m][i]=agedc[i]; 5863: /*if(moisdc[i]==99 && andc[i]==9999) s[m][i]=-1;*/ 5864: }else { 5865: if ((int)andc[i]!=9999){ 5866: nbwarn++; 5867: printf("Warning negative age at death: %ld line:%d\n",num[i],i); 5868: fprintf(ficlog,"Warning negative age at death: %ld line:%d\n",num[i],i); 5869: agev[m][i]=-1; 5870: } 5871: } 5872: } /* agedc > 0 */ 5873: } 5874: else if(s[m][i] !=9){ /* Standard case, age in fractional 5875: years but with the precision of a month */ 5876: agev[m][i]=(mint[m][i]/12.+1./24.+anint[m][i])-(moisnais[i]/12.+1./24.+annais[i]); 5877: if((int)mint[m][i]==99 || (int)anint[m][i]==9999) 5878: agev[m][i]=1; 5879: else if(agev[m][i] < *agemin){ 5880: *agemin=agev[m][i]; 5881: printf(" Min anint[%d][%d]=%.2f annais[%d]=%.2f, agemin=%.2f\n",m,i,anint[m][i], i,annais[i], *agemin); 5882: } 5883: else if(agev[m][i] >*agemax){ 5884: *agemax=agev[m][i]; 5885: /* printf(" Max anint[%d][%d]=%.0f annais[%d]=%.0f, agemax=%.2f\n",m,i,anint[m][i], i,annais[i], *agemax);*/ 5886: } 5887: /*agev[m][i]=anint[m][i]-annais[i];*/ 5888: /* agev[m][i] = age[i]+2*m;*/ 5889: } 5890: else { /* =9 */ 5891: agev[m][i]=1; 5892: s[m][i]=-1; 5893: } 5894: } 5895: else /*= 0 Unknown */ 5896: agev[m][i]=1; 5897: } 5898: 5899: } 5900: for (i=1; i<=imx; i++) { 5901: for(m=firstpass; (m<=lastpass); m++){ 5902: if (s[m][i] > (nlstate+ndeath)) { 5903: (*nberr)++; 5904: printf("Error: on wave %d of individual %d status %d > (nlstate+ndeath)=(%d+%d)=%d\n",m,i,s[m][i],nlstate, ndeath, nlstate+ndeath); 5905: fprintf(ficlog,"Error: on wave %d of individual %d status %d > (nlstate+ndeath)=(%d+%d)=%d\n",m,i,s[m][i],nlstate, ndeath, nlstate+ndeath); 5906: return 1; 5907: } 5908: } 5909: } 5910: 5911: /*for (i=1; i<=imx; i++){ 5912: for (m=firstpass; (m<lastpass); m++){ 5913: printf("%ld %d %.lf %d %d\n", num[i],(covar[1][i]),agev[m][i],s[m][i],s[m+1][i]); 5914: } 5915: 5916: }*/ 5917: 5918: 5919: printf("Total number of individuals= %d, Agemin = %.2f, Agemax= %.2f\n\n", imx, *agemin, *agemax); 5920: fprintf(ficlog,"Total number of individuals= %d, Agemin = %.2f, Agemax= %.2f\n\n", imx, *agemin, *agemax); 5921: 5922: return (0); 5923: /* endread:*/ 5924: printf("Exiting calandcheckages: "); 5925: return (1); 5926: } 5927: 5928: #if defined(_MSC_VER) 5929: /*printf("Visual C++ compiler: %s \n;", _MSC_FULL_VER);*/ 5930: /*fprintf(ficlog, "Visual C++ compiler: %s \n;", _MSC_FULL_VER);*/ 5931: //#include "stdafx.h" 5932: //#include <stdio.h> 5933: //#include <tchar.h> 5934: //#include <windows.h> 5935: //#include <iostream> 5936: typedef BOOL(WINAPI *LPFN_ISWOW64PROCESS) (HANDLE, PBOOL); 5937: 5938: LPFN_ISWOW64PROCESS fnIsWow64Process; 5939: 5940: BOOL IsWow64() 5941: { 5942: BOOL bIsWow64 = FALSE; 5943: 5944: //typedef BOOL (APIENTRY *LPFN_ISWOW64PROCESS) 5945: // (HANDLE, PBOOL); 5946: 5947: //LPFN_ISWOW64PROCESS fnIsWow64Process; 5948: 5949: HMODULE module = GetModuleHandle(_T("kernel32")); 5950: const char funcName[] = "IsWow64Process"; 5951: fnIsWow64Process = (LPFN_ISWOW64PROCESS) 5952: GetProcAddress(module, funcName); 5953: 5954: if (NULL != fnIsWow64Process) 5955: { 5956: if (!fnIsWow64Process(GetCurrentProcess(), 5957: &bIsWow64)) 5958: //throw std::exception("Unknown error"); 5959: printf("Unknown error\n"); 5960: } 5961: return bIsWow64 != FALSE; 5962: } 5963: #endif 5964: 5965: void syscompilerinfo(int logged) 5966: { 5967: /* #include "syscompilerinfo.h"*/ 5968: /* command line Intel compiler 32bit windows, XP compatible:*/ 5969: /* /GS /W3 /Gy 5970: /Zc:wchar_t /Zi /O2 /Fd"Release\vc120.pdb" /D "WIN32" /D "NDEBUG" /D 5971: "_CONSOLE" /D "_LIB" /D "_USING_V110_SDK71_" /D "_UNICODE" /D 5972: "UNICODE" /Qipo /Zc:forScope /Gd /Oi /MT /Fa"Release\" /EHsc /nologo 5973: /Fo"Release\" /Qprof-dir "Release\" /Fp"Release\IMaCh.pch" 5974: */ 5975: /* 64 bits */ 5976: /* 5977: /GS /W3 /Gy 5978: /Zc:wchar_t /Zi /O2 /Fd"x64\Release\vc120.pdb" /D "WIN32" /D "NDEBUG" 5979: /D "_CONSOLE" /D "_LIB" /D "_UNICODE" /D "UNICODE" /Qipo /Zc:forScope 5980: /Oi /MD /Fa"x64\Release\" /EHsc /nologo /Fo"x64\Release\" /Qprof-dir 5981: "x64\Release\" /Fp"x64\Release\IMaCh.pch" */ 5982: /* Optimization are useless and O3 is slower than O2 */ 5983: /* 5984: /GS /W3 /Gy /Zc:wchar_t /Zi /O3 /Fd"x64\Release\vc120.pdb" /D "WIN32" 5985: /D "NDEBUG" /D "_CONSOLE" /D "_LIB" /D "_UNICODE" /D "UNICODE" /Qipo 5986: /Zc:forScope /Oi /MD /Fa"x64\Release\" /EHsc /nologo /Qparallel 5987: /Fo"x64\Release\" /Qprof-dir "x64\Release\" /Fp"x64\Release\IMaCh.pch" 5988: */ 5989: /* Link is */ /* /OUT:"visual studio 5990: 2013\Projects\IMaCh\Release\IMaCh.exe" /MANIFEST /NXCOMPAT 5991: /PDB:"visual studio 5992: 2013\Projects\IMaCh\Release\IMaCh.pdb" /DYNAMICBASE 5993: "kernel32.lib" "user32.lib" "gdi32.lib" "winspool.lib" 5994: "comdlg32.lib" "advapi32.lib" "shell32.lib" "ole32.lib" 5995: "oleaut32.lib" "uuid.lib" "odbc32.lib" "odbccp32.lib" 5996: /MACHINE:X86 /OPT:REF /SAFESEH /INCREMENTAL:NO 5997: /SUBSYSTEM:CONSOLE",5.01" /MANIFESTUAC:"level='asInvoker' 5998: uiAccess='false'" 5999: /ManifestFile:"Release\IMaCh.exe.intermediate.manifest" /OPT:ICF 6000: /NOLOGO /TLBID:1 6001: */ 6002: #if defined __INTEL_COMPILER 6003: #if defined(__GNUC__) 6004: struct utsname sysInfo; /* For Intel on Linux and OS/X */ 6005: #endif 6006: #elif defined(__GNUC__) 6007: #ifndef __APPLE__ 6008: #include <gnu/libc-version.h> /* Only on gnu */ 6009: #endif 6010: struct utsname sysInfo; 6011: int cross = CROSS; 6012: if (cross){ 6013: printf("Cross-"); 6014: if(logged) fprintf(ficlog, "Cross-"); 6015: } 6016: #endif 6017: 6018: #include <stdint.h> 6019: 6020: printf("Compiled with:");if(logged)fprintf(ficlog,"Compiled with:"); 6021: #if defined(__clang__) 6022: printf(" Clang/LLVM");if(logged)fprintf(ficlog," Clang/LLVM"); /* Clang/LLVM. ---------------------------------------------- */ 6023: #endif 6024: #if defined(__ICC) || defined(__INTEL_COMPILER) 6025: printf(" Intel ICC/ICPC");if(logged)fprintf(ficlog," Intel ICC/ICPC");/* Intel ICC/ICPC. ------------------------------------------ */ 6026: #endif 6027: #if defined(__GNUC__) || defined(__GNUG__) 6028: printf(" GNU GCC/G++");if(logged)fprintf(ficlog," GNU GCC/G++");/* GNU GCC/G++. --------------------------------------------- */ 6029: #endif 6030: #if defined(__HP_cc) || defined(__HP_aCC) 6031: printf(" Hewlett-Packard C/aC++");if(logged)fprintf(fcilog," Hewlett-Packard C/aC++"); /* Hewlett-Packard C/aC++. ---------------------------------- */ 6032: #endif 6033: #if defined(__IBMC__) || defined(__IBMCPP__) 6034: printf(" IBM XL C/C++"); if(logged) fprintf(ficlog," IBM XL C/C++");/* IBM XL C/C++. -------------------------------------------- */ 6035: #endif 6036: #if defined(_MSC_VER) 6037: printf(" Microsoft Visual Studio");if(logged)fprintf(ficlog," Microsoft Visual Studio");/* Microsoft Visual Studio. --------------------------------- */ 6038: #endif 6039: #if defined(__PGI) 6040: printf(" Portland Group PGCC/PGCPP");if(logged) fprintf(ficlog," Portland Group PGCC/PGCPP");/* Portland Group PGCC/PGCPP. ------------------------------- */ 6041: #endif 6042: #if defined(__SUNPRO_C) || defined(__SUNPRO_CC) 6043: printf(" Oracle Solaris Studio");if(logged)fprintf(ficlog," Oracle Solaris Studio\n");/* Oracle Solaris Studio. ----------------------------------- */ 6044: #endif 6045: printf(" for "); if (logged) fprintf(ficlog, " for "); 6046: 6047: // http://stackoverflow.com/questions/4605842/how-to-identify-platform-compiler-from-preprocessor-macros 6048: #ifdef _WIN32 // note the underscore: without it, it's not msdn official! 6049: // Windows (x64 and x86) 6050: printf("Windows (x64 and x86) ");if(logged) fprintf(ficlog,"Windows (x64 and x86) "); 6051: #elif __unix__ // all unices, not all compilers 6052: // Unix 6053: printf("Unix ");if(logged) fprintf(ficlog,"Unix "); 6054: #elif __linux__ 6055: // linux 6056: printf("linux ");if(logged) fprintf(ficlog,"linux "); 6057: #elif __APPLE__ 6058: // Mac OS, not sure if this is covered by __posix__ and/or __unix__ though.. 6059: printf("Mac OS ");if(logged) fprintf(ficlog,"Mac OS "); 6060: #endif 6061: 6062: /* __MINGW32__ */ 6063: /* __CYGWIN__ */ 6064: /* __MINGW64__ */ 6065: // http://msdn.microsoft.com/en-us/library/b0084kay.aspx 6066: /* _MSC_VER //the Visual C++ compiler is 17.00.51106.1, the _MSC_VER macro evaluates to 1700. Type cl /? */ 6067: /* _MSC_FULL_VER //the Visual C++ compiler is 15.00.20706.01, the _MSC_FULL_VER macro evaluates to 150020706 */ 6068: /* _WIN64 // Defined for applications for Win64. */ 6069: /* _M_X64 // Defined for compilations that target x64 processors. */ 6070: /* _DEBUG // Defined when you compile with /LDd, /MDd, and /MTd. */ 6071: 6072: #if UINTPTR_MAX == 0xffffffff 6073: printf(" 32-bit"); if(logged) fprintf(ficlog," 32-bit");/* 32-bit */ 6074: #elif UINTPTR_MAX == 0xffffffffffffffff 6075: printf(" 64-bit"); if(logged) fprintf(ficlog," 64-bit");/* 64-bit */ 6076: #else 6077: printf(" wtf-bit"); if(logged) fprintf(ficlog," wtf-bit");/* wtf */ 6078: #endif 6079: 6080: #if defined(__GNUC__) 6081: # if defined(__GNUC_PATCHLEVEL__) 6082: # define __GNUC_VERSION__ (__GNUC__ * 10000 \ 6083: + __GNUC_MINOR__ * 100 \ 6084: + __GNUC_PATCHLEVEL__) 6085: # else 6086: # define __GNUC_VERSION__ (__GNUC__ * 10000 \ 6087: + __GNUC_MINOR__ * 100) 6088: # endif 6089: printf(" using GNU C version %d.\n", __GNUC_VERSION__); 6090: if(logged) fprintf(ficlog, " using GNU C version %d.\n", __GNUC_VERSION__); 6091: 6092: if (uname(&sysInfo) != -1) { 6093: printf("Running on: %s %s %s %s %s\n",sysInfo.sysname, sysInfo.nodename, sysInfo.release, sysInfo.version, sysInfo.machine); 6094: if(logged) fprintf(ficlog,"Running on: %s %s %s %s %s\n ",sysInfo.sysname, sysInfo.nodename, sysInfo.release, sysInfo.version, sysInfo.machine); 6095: } 6096: else 6097: perror("uname() error"); 6098: //#ifndef __INTEL_COMPILER 6099: #if !defined (__INTEL_COMPILER) && !defined(__APPLE__) 6100: printf("GNU libc version: %s\n", gnu_get_libc_version()); 6101: if(logged) fprintf(ficlog,"GNU libc version: %s\n", gnu_get_libc_version()); 6102: #endif 6103: #endif 6104: 6105: // void main() 6106: // { 6107: #if defined(_MSC_VER) 6108: if (IsWow64()){ 6109: printf("\nThe program (probably compiled for 32bit) is running under WOW64 (64bit) emulation.\n"); 6110: if (logged) fprintf(ficlog, "\nThe program (probably compiled for 32bit) is running under WOW64 (64bit) emulation.\n"); 6111: } 6112: else{ 6113: printf("\nThe program is not running under WOW64 (i.e probably on a 64bit Windows).\n"); 6114: if (logged) fprintf(ficlog, "\nThe programm is not running under WOW64 (i.e probably on a 64bit Windows).\n"); 6115: } 6116: // printf("\nPress Enter to continue..."); 6117: // getchar(); 6118: // } 6119: 6120: #endif 6121: 6122: 6123: } 6124: 6125: int prevalence_limit(double *p, double **prlim, double ageminpar, double agemaxpar){ 6126: /*--------------- Prevalence limit (period or stable prevalence) --------------*/ 6127: int i, j, k, i1 ; 6128: double ftolpl = 1.e-10; 6129: double age, agebase, agelim; 6130: 6131: strcpy(filerespl,"pl"); 6132: strcat(filerespl,fileres); 6133: if((ficrespl=fopen(filerespl,"w"))==NULL) { 6134: printf("Problem with period (stable) prevalence resultfile: %s\n", filerespl);return 1; 6135: fprintf(ficlog,"Problem with period (stable) prevalence resultfile: %s\n", filerespl);return 1; 6136: } 6137: printf("Computing period (stable) prevalence: result on file '%s' \n", filerespl); 6138: fprintf(ficlog,"Computing period (stable) prevalence: result on file '%s' \n", filerespl); 6139: pstamp(ficrespl); 6140: fprintf(ficrespl,"# Period (stable) prevalence \n"); 6141: fprintf(ficrespl,"#Age "); 6142: for(i=1; i<=nlstate;i++) fprintf(ficrespl,"%d-%d ",i,i); 6143: fprintf(ficrespl,"\n"); 6144: 6145: /* prlim=matrix(1,nlstate,1,nlstate);*/ /* back in main */ 6146: 6147: agebase=ageminpar; 6148: agelim=agemaxpar; 6149: 6150: i1=pow(2,cptcoveff); 6151: if (cptcovn < 1){i1=1;} 6152: 6153: for(cptcov=1,k=0;cptcov<=i1;cptcov++){ 6154: /* for(cptcov=1,k=0;cptcov<=1;cptcov++){ */ 6155: //for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){ 6156: k=k+1; 6157: /* to clean */ 6158: //printf("cptcov=%d cptcod=%d codtab=%d\n",cptcov, cptcod,codtab[cptcod][cptcov]); 6159: fprintf(ficrespl,"\n#******"); 6160: printf("\n#******"); 6161: fprintf(ficlog,"\n#******"); 6162: for(j=1;j<=cptcoveff;j++) { 6163: fprintf(ficrespl," V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 6164: printf(" V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 6165: fprintf(ficlog," V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 6166: } 6167: fprintf(ficrespl,"******\n"); 6168: printf("******\n"); 6169: fprintf(ficlog,"******\n"); 6170: 6171: fprintf(ficrespl,"#Age "); 6172: for(j=1;j<=cptcoveff;j++) { 6173: fprintf(ficrespl,"V%d %d",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 6174: } 6175: for(i=1; i<=nlstate;i++) fprintf(ficrespl,"%d-%d ",i,i); 6176: fprintf(ficrespl,"\n"); 6177: 6178: for (age=agebase; age<=agelim; age++){ 6179: /* for (age=agebase; age<=agebase; age++){ */ 6180: prevalim(prlim, nlstate, p, age, oldm, savm,ftolpl,k); 6181: fprintf(ficrespl,"%.0f ",age ); 6182: for(j=1;j<=cptcoveff;j++) 6183: fprintf(ficrespl,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 6184: for(i=1; i<=nlstate;i++) 6185: fprintf(ficrespl," %.5f", prlim[i][i]); 6186: fprintf(ficrespl,"\n"); 6187: } /* Age */ 6188: /* was end of cptcod */ 6189: } /* cptcov */ 6190: return 0; 6191: } 6192: 6193: int hPijx(double *p, int bage, int fage){ 6194: /*------------- h Pij x at various ages ------------*/ 6195: 6196: int stepsize; 6197: int agelim; 6198: int hstepm; 6199: int nhstepm; 6200: int h, i, i1, j, k; 6201: 6202: double agedeb; 6203: double ***p3mat; 6204: 6205: strcpy(filerespij,"pij"); strcat(filerespij,fileres); 6206: if((ficrespij=fopen(filerespij,"w"))==NULL) { 6207: printf("Problem with Pij resultfile: %s\n", filerespij); return 1; 6208: fprintf(ficlog,"Problem with Pij resultfile: %s\n", filerespij); return 1; 6209: } 6210: printf("Computing pij: result on file '%s' \n", filerespij); 6211: fprintf(ficlog,"Computing pij: result on file '%s' \n", filerespij); 6212: 6213: stepsize=(int) (stepm+YEARM-1)/YEARM; 6214: /*if (stepm<=24) stepsize=2;*/ 6215: 6216: agelim=AGESUP; 6217: hstepm=stepsize*YEARM; /* Every year of age */ 6218: hstepm=hstepm/stepm; /* Typically 2 years, = 2/6 months = 4 */ 6219: 6220: /* hstepm=1; aff par mois*/ 6221: pstamp(ficrespij); 6222: fprintf(ficrespij,"#****** h Pij x Probability to be in state j at age x+h being in i at x "); 6223: i1= pow(2,cptcoveff); 6224: /* for(cptcov=1,k=0;cptcov<=i1;cptcov++){ */ 6225: /* /\*for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){*\/ */ 6226: /* k=k+1; */ 6227: for (k=1; k <= (int) pow(2,cptcoveff); k++){ 6228: fprintf(ficrespij,"\n#****** "); 6229: for(j=1;j<=cptcoveff;j++) 6230: fprintf(ficrespij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 6231: fprintf(ficrespij,"******\n"); 6232: 6233: for (agedeb=fage; agedeb>=bage; agedeb--){ /* If stepm=6 months */ 6234: nhstepm=(int) rint((agelim-agedeb)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ 6235: nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ 6236: 6237: /* nhstepm=nhstepm*YEARM; aff par mois*/ 6238: 6239: p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 6240: oldm=oldms;savm=savms; 6241: hpxij(p3mat,nhstepm,agedeb,hstepm,p,nlstate,stepm,oldm,savm, k); 6242: fprintf(ficrespij,"# Cov Agex agex+h hpijx with i,j="); 6243: for(i=1; i<=nlstate;i++) 6244: for(j=1; j<=nlstate+ndeath;j++) 6245: fprintf(ficrespij," %1d-%1d",i,j); 6246: fprintf(ficrespij,"\n"); 6247: for (h=0; h<=nhstepm; h++){ 6248: /*agedebphstep = agedeb + h*hstepm/YEARM*stepm;*/ 6249: fprintf(ficrespij,"%d %3.f %3.f",k, agedeb, agedeb + h*hstepm/YEARM*stepm ); 6250: for(i=1; i<=nlstate;i++) 6251: for(j=1; j<=nlstate+ndeath;j++) 6252: fprintf(ficrespij," %.5f", p3mat[i][j][h]); 6253: fprintf(ficrespij,"\n"); 6254: } 6255: free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); 6256: fprintf(ficrespij,"\n"); 6257: } 6258: /*}*/ 6259: } 6260: return 0; 6261: } 6262: 6263: 6264: /***********************************************/ 6265: /**************** Main Program *****************/ 6266: /***********************************************/ 6267: 6268: int main(int argc, char *argv[]) 6269: { 6270: #ifdef GSL 6271: const gsl_multimin_fminimizer_type *T; 6272: size_t iteri = 0, it; 6273: int rval = GSL_CONTINUE; 6274: int status = GSL_SUCCESS; 6275: double ssval; 6276: #endif 6277: int movingaverage(double ***probs, double bage,double fage, double ***mobaverage, int mobilav); 6278: int i,j, k, n=MAXN,iter=0,m,size=100, cptcod; 6279: 6280: int jj, ll, li, lj, lk; 6281: int numlinepar=0; /* Current linenumber of parameter file */ 6282: int itimes; 6283: int NDIM=2; 6284: int vpopbased=0; 6285: 6286: char ca[32], cb[32]; 6287: /* FILE *fichtm; *//* Html File */ 6288: /* FILE *ficgp;*/ /*Gnuplot File */ 6289: struct stat info; 6290: double agedeb=0.; 6291: 6292: double ageminpar=AGEOVERFLOW,agemin=AGEOVERFLOW, agemaxpar=-AGEOVERFLOW, agemax=-AGEOVERFLOW; 6293: 6294: double fret; 6295: double dum=0.; /* Dummy variable */ 6296: double ***p3mat; 6297: double ***mobaverage; 6298: 6299: char line[MAXLINE]; 6300: char path[MAXLINE],pathc[MAXLINE],pathcd[MAXLINE],pathtot[MAXLINE],model[MAXLINE]; 6301: char pathr[MAXLINE], pathimach[MAXLINE]; 6302: char *tok, *val; /* pathtot */ 6303: int firstobs=1, lastobs=10; 6304: int c, h , cpt, c2; 6305: int jl=0; 6306: int i1, j1, jk, stepsize=0; 6307: int count=0; 6308: 6309: int *tab; 6310: int mobilavproj=0 , prevfcast=0 ; /* moving average of prev, If prevfcast=1 prevalence projection */ 6311: int mobilav=0,popforecast=0; 6312: int hstepm=0, nhstepm=0; 6313: int agemortsup; 6314: float sumlpop=0.; 6315: double jprev1=1, mprev1=1,anprev1=2000,jprev2=1, mprev2=1,anprev2=2000; 6316: double jpyram=1, mpyram=1,anpyram=2000,jpyram1=1, mpyram1=1,anpyram1=2000; 6317: 6318: double bage=0, fage=110., age, agelim=0., agebase=0.; 6319: double ftolpl=FTOL; 6320: double **prlim; 6321: double ***param; /* Matrix of parameters */ 6322: double *p; 6323: double **matcov; /* Matrix of covariance */ 6324: double ***delti3; /* Scale */ 6325: double *delti; /* Scale */ 6326: double ***eij, ***vareij; 6327: double **varpl; /* Variances of prevalence limits by age */ 6328: double *epj, vepp; 6329: 6330: double dateprev1, dateprev2,jproj1=1,mproj1=1,anproj1=2000,jproj2=1,mproj2=1,anproj2=2000; 6331: double **ximort; 6332: char *alph[]={"a","a","b","c","d","e"}, str[4]="1234"; 6333: int *dcwave; 6334: 6335: char z[1]="c"; 6336: 6337: /*char *strt;*/ 6338: char strtend[80]; 6339: 6340: 6341: /* setlocale (LC_ALL, ""); */ 6342: /* bindtextdomain (PACKAGE, LOCALEDIR); */ 6343: /* textdomain (PACKAGE); */ 6344: /* setlocale (LC_CTYPE, ""); */ 6345: /* setlocale (LC_MESSAGES, ""); */ 6346: 6347: /* gettimeofday(&start_time, (struct timezone*)0); */ /* at first time */ 6348: rstart_time = time(NULL); 6349: /* (void) gettimeofday(&start_time,&tzp);*/ 6350: start_time = *localtime(&rstart_time); 6351: curr_time=start_time; 6352: /*tml = *localtime(&start_time.tm_sec);*/ 6353: /* strcpy(strstart,asctime(&tml)); */ 6354: strcpy(strstart,asctime(&start_time)); 6355: 6356: /* printf("Localtime (at start)=%s",strstart); */ 6357: /* tp.tm_sec = tp.tm_sec +86400; */ 6358: /* tm = *localtime(&start_time.tm_sec); */ 6359: /* tmg.tm_year=tmg.tm_year +dsign*dyear; */ 6360: /* tmg.tm_mon=tmg.tm_mon +dsign*dmonth; */ 6361: /* tmg.tm_hour=tmg.tm_hour + 1; */ 6362: /* tp.tm_sec = mktime(&tmg); */ 6363: /* strt=asctime(&tmg); */ 6364: /* printf("Time(after) =%s",strstart); */ 6365: /* (void) time (&time_value); 6366: * printf("time=%d,t-=%d\n",time_value,time_value-86400); 6367: * tm = *localtime(&time_value); 6368: * strstart=asctime(&tm); 6369: * printf("tim_value=%d,asctime=%s\n",time_value,strstart); 6370: */ 6371: 6372: nberr=0; /* Number of errors and warnings */ 6373: nbwarn=0; 6374: #ifdef WIN32 6375: _getcwd(pathcd, size); 6376: #else 6377: getcwd(pathcd, size); 6378: #endif 6379: syscompilerinfo(0); 6380: printf("\nIMaCh version %s, %s\n%s",version, copyright, fullversion); 6381: if(argc <=1){ 6382: printf("\nEnter the parameter file name: "); 6383: fgets(pathr,FILENAMELENGTH,stdin); 6384: i=strlen(pathr); 6385: if(pathr[i-1]=='\n') 6386: pathr[i-1]='\0'; 6387: i=strlen(pathr); 6388: if(pathr[i-1]==' ') /* This may happen when dragging on oS/X! */ 6389: pathr[i-1]='\0'; 6390: for (tok = pathr; tok != NULL; ){ 6391: printf("Pathr |%s|\n",pathr); 6392: while ((val = strsep(&tok, "\"" )) != NULL && *val == '\0'); 6393: printf("val= |%s| pathr=%s\n",val,pathr); 6394: strcpy (pathtot, val); 6395: if(pathr[0] == '\0') break; /* Dirty */ 6396: } 6397: } 6398: else{ 6399: strcpy(pathtot,argv[1]); 6400: } 6401: /*if(getcwd(pathcd, MAXLINE)!= NULL)printf ("Error pathcd\n");*/ 6402: /*cygwin_split_path(pathtot,path,optionfile); 6403: printf("pathtot=%s, path=%s, optionfile=%s\n",pathtot,path,optionfile);*/ 6404: /* cutv(path,optionfile,pathtot,'\\');*/ 6405: 6406: /* Split argv[0], imach program to get pathimach */ 6407: printf("\nargv[0]=%s argv[1]=%s, \n",argv[0],argv[1]); 6408: split(argv[0],pathimach,optionfile,optionfilext,optionfilefiname); 6409: printf("\nargv[0]=%s pathimach=%s, \noptionfile=%s \noptionfilext=%s \noptionfilefiname=%s\n",argv[0],pathimach,optionfile,optionfilext,optionfilefiname); 6410: /* strcpy(pathimach,argv[0]); */ 6411: /* Split argv[1]=pathtot, parameter file name to get path, optionfile, extension and name */ 6412: split(pathtot,path,optionfile,optionfilext,optionfilefiname); 6413: printf("\npathtot=%s,\npath=%s,\noptionfile=%s \noptionfilext=%s \noptionfilefiname=%s\n",pathtot,path,optionfile,optionfilext,optionfilefiname); 6414: #ifdef WIN32 6415: _chdir(path); /* Can be a relative path */ 6416: if(_getcwd(pathcd,MAXLINE) > 0) /* So pathcd is the full path */ 6417: #else 6418: chdir(path); /* Can be a relative path */ 6419: if (getcwd(pathcd, MAXLINE) > 0) /* So pathcd is the full path */ 6420: #endif 6421: printf("Current directory %s!\n",pathcd); 6422: strcpy(command,"mkdir "); 6423: strcat(command,optionfilefiname); 6424: if((outcmd=system(command)) != 0){ 6425: printf("Directory already exists (or can't create it) %s%s, err=%d\n",path,optionfilefiname,outcmd); 6426: /* fprintf(ficlog,"Problem creating directory %s%s\n",path,optionfilefiname); */ 6427: /* fclose(ficlog); */ 6428: /* exit(1); */ 6429: } 6430: /* if((imk=mkdir(optionfilefiname))<0){ */ 6431: /* perror("mkdir"); */ 6432: /* } */ 6433: 6434: /*-------- arguments in the command line --------*/ 6435: 6436: /* Main Log file */ 6437: strcat(filelog, optionfilefiname); 6438: strcat(filelog,".log"); /* */ 6439: if((ficlog=fopen(filelog,"w"))==NULL) { 6440: printf("Problem with logfile %s\n",filelog); 6441: goto end; 6442: } 6443: fprintf(ficlog,"Log filename:%s\n",filelog); 6444: fprintf(ficlog,"\n%s\n%s",version,fullversion); 6445: fprintf(ficlog,"\nEnter the parameter file name: \n"); 6446: fprintf(ficlog,"pathimach=%s\npathtot=%s\n\ 6447: path=%s \n\ 6448: optionfile=%s\n\ 6449: optionfilext=%s\n\ 6450: optionfilefiname='%s'\n",pathimach,pathtot,path,optionfile,optionfilext,optionfilefiname); 6451: 6452: syscompilerinfo(0); 6453: 6454: printf("Local time (at start):%s",strstart); 6455: fprintf(ficlog,"Local time (at start): %s",strstart); 6456: fflush(ficlog); 6457: /* (void) gettimeofday(&curr_time,&tzp); */ 6458: /* printf("Elapsed time %d\n", asc_diff_time(curr_time.tm_sec-start_time.tm_sec,tmpout)); */ 6459: 6460: /* */ 6461: strcpy(fileres,"r"); 6462: strcat(fileres, optionfilefiname); 6463: strcat(fileres,".txt"); /* Other files have txt extension */ 6464: 6465: /* Main ---------arguments file --------*/ 6466: 6467: if((ficpar=fopen(optionfile,"r"))==NULL) { 6468: printf("Problem with optionfile '%s' with errno='%s'\n",optionfile,strerror(errno)); 6469: fprintf(ficlog,"Problem with optionfile '%s' with errno='%s'\n",optionfile,strerror(errno)); 6470: fflush(ficlog); 6471: /* goto end; */ 6472: exit(70); 6473: } 6474: 6475: 6476: 6477: strcpy(filereso,"o"); 6478: strcat(filereso,fileres); 6479: if((ficparo=fopen(filereso,"w"))==NULL) { /* opened on subdirectory */ 6480: printf("Problem with Output resultfile: %s\n", filereso); 6481: fprintf(ficlog,"Problem with Output resultfile: %s\n", filereso); 6482: fflush(ficlog); 6483: goto end; 6484: } 6485: 6486: /* Reads comments: lines beginning with '#' */ 6487: numlinepar=0; 6488: while((c=getc(ficpar))=='#' && c!= EOF){ 6489: ungetc(c,ficpar); 6490: fgets(line, MAXLINE, ficpar); 6491: numlinepar++; 6492: fputs(line,stdout); 6493: fputs(line,ficparo); 6494: fputs(line,ficlog); 6495: } 6496: ungetc(c,ficpar); 6497: 6498: fscanf(ficpar,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%lf stepm=%d ncovcol=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d model=1+age+%s\n",title, datafile, &lastobs, &firstpass,&lastpass,&ftol, &stepm, &ncovcol, &nlstate,&ndeath, &maxwav, &mle, &weightopt,model); 6499: numlinepar=numlinepar+3; /* In general */ 6500: printf("title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncovcol=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\nmodel=1+age+%s\n", title, datafile, lastobs, firstpass,lastpass,ftol, stepm, ncovcol, nlstate,ndeath, maxwav, mle, weightopt,model); 6501: if(model[strlen(model)-1]=='.') /* Suppressing leading dot in the model */ 6502: model[strlen(model)-1]='\0'; 6503: fprintf(ficparo,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncovcol=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\nmodel=1+age+%s.\n", title, datafile, lastobs, firstpass,lastpass,ftol,stepm,ncovcol,nlstate,ndeath,maxwav, mle, weightopt,model); 6504: fprintf(ficlog,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncovcol=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\nmodel=1+age+%s.\n", title, datafile, lastobs, firstpass,lastpass,ftol,stepm,ncovcol,nlstate,ndeath,maxwav, mle, weightopt,model); 6505: fflush(ficlog); 6506: /* if(model[0]=='#'|| model[0]== '\0'){ */ 6507: if(model[0]=='#'){ 6508: printf("Error in 'model' line: model should start with 'model=1+age+' and end with '.' \n \ 6509: 'model=1+age+.' or 'model=1+age+V1.' or 'model=1+age+age*age+V1+V1*age.' or \n \ 6510: 'model=1+age+V1+V2.' or 'model=1+age+V1+V2+V1*V2.' etc. \n"); \ 6511: if(mle != -1){ 6512: printf("Fix the model line and run imach with mle=-1 to get a correct template of the parameter file.\n"); 6513: exit(1); 6514: } 6515: } 6516: while((c=getc(ficpar))=='#' && c!= EOF){ 6517: ungetc(c,ficpar); 6518: fgets(line, MAXLINE, ficpar); 6519: numlinepar++; 6520: if(line[1]=='q'){ /* This #q will quit imach (the answer is q) */ 6521: z[0]=line[1]; 6522: } 6523: /* printf("****line [1] = %c \n",line[1]); */ 6524: fputs(line, stdout); 6525: //puts(line); 6526: fputs(line,ficparo); 6527: fputs(line,ficlog); 6528: } 6529: ungetc(c,ficpar); 6530: 6531: 6532: covar=matrix(0,NCOVMAX,1,n); /**< used in readdata */ 6533: cptcovn=0; /*Number of covariates, i.e. number of '+' in model statement plus one, indepently of n in Vn*/ 6534: /* v1+v2+v3+v2*v4+v5*age makes cptcovn = 5 6535: v1+v2*age+v2*v3 makes cptcovn = 3 6536: */ 6537: if (strlen(model)>1) 6538: ncovmodel=2+nbocc(model,'+')+1; /*Number of variables including intercept and age = cptcovn + intercept + age : v1+v2+v3+v2*v4+v5*age makes 5+2=7,age*age makes 3*/ 6539: else 6540: ncovmodel=2; /* Constant and age */ 6541: nforce= (nlstate+ndeath-1)*nlstate; /* Number of forces ij from state i to j */ 6542: npar= nforce*ncovmodel; /* Number of parameters like aij*/ 6543: if(npar >MAXPARM || nlstate >NLSTATEMAX || ndeath >NDEATHMAX || ncovmodel>NCOVMAX){ 6544: printf("Too complex model for current IMaCh: npar=(nlstate+ndeath-1)*nlstate*ncovmodel=%d >= %d(MAXPARM) or nlstate=%d >= %d(NLSTATEMAX) or ndeath=%d >= %d(NDEATHMAX) or ncovmodel=(k+age+#of+signs)=%d(NCOVMAX) >= %d\n",npar, MAXPARM, nlstate, NLSTATEMAX, ndeath, NDEATHMAX, ncovmodel, NCOVMAX); 6545: fprintf(ficlog,"Too complex model for current IMaCh: %d >=%d(MAXPARM) or %d >=%d(NLSTATEMAX) or %d >=%d(NDEATHMAX) or %d(NCOVMAX) >=%d\n",npar, MAXPARM, nlstate, NLSTATEMAX, ndeath, NDEATHMAX, ncovmodel, NCOVMAX); 6546: fflush(stdout); 6547: fclose (ficlog); 6548: goto end; 6549: } 6550: delti3= ma3x(1,nlstate,1,nlstate+ndeath-1,1,ncovmodel); 6551: delti=delti3[1][1]; 6552: /*delti=vector(1,npar); *//* Scale of each paramater (output from hesscov)*/ 6553: if(mle==-1){ /* Print a wizard for help writing covariance matrix */ 6554: prwizard(ncovmodel, nlstate, ndeath, model, ficparo); 6555: printf(" You chose mle=-1, look at file %s for a template of covariance matrix \n",filereso); 6556: fprintf(ficlog," You chose mle=-1, look at file %s for a template of covariance matrix \n",filereso); 6557: free_ma3x(delti3,1,nlstate,1, nlstate+ndeath-1,1,ncovmodel); 6558: fclose (ficparo); 6559: fclose (ficlog); 6560: goto end; 6561: exit(0); 6562: } 6563: else if(mle==-3) { /* Main Wizard */ 6564: prwizard(ncovmodel, nlstate, ndeath, model, ficparo); 6565: printf(" You chose mle=-3, look at file %s for a template of covariance matrix \n",filereso); 6566: fprintf(ficlog," You chose mle=-3, look at file %s for a template of covariance matrix \n",filereso); 6567: param= ma3x(1,nlstate,1,nlstate+ndeath-1,1,ncovmodel); 6568: matcov=matrix(1,npar,1,npar); 6569: } 6570: else{ 6571: /* Read guessed parameters */ 6572: /* Reads comments: lines beginning with '#' */ 6573: while((c=getc(ficpar))=='#' && c!= EOF){ 6574: ungetc(c,ficpar); 6575: fgets(line, MAXLINE, ficpar); 6576: numlinepar++; 6577: fputs(line,stdout); 6578: fputs(line,ficparo); 6579: fputs(line,ficlog); 6580: } 6581: ungetc(c,ficpar); 6582: 6583: param= ma3x(1,nlstate,1,nlstate+ndeath-1,1,ncovmodel); 6584: for(i=1; i <=nlstate; i++){ 6585: j=0; 6586: for(jj=1; jj <=nlstate+ndeath; jj++){ 6587: if(jj==i) continue; 6588: j++; 6589: fscanf(ficpar,"%1d%1d",&i1,&j1); 6590: if ((i1 != i) || (j1 != jj)){ 6591: printf("Error in line parameters number %d, %1d%1d instead of %1d%1d \n \ 6592: It might be a problem of design; if ncovcol and the model are correct\n \ 6593: run imach with mle=-1 to get a correct template of the parameter file.\n",numlinepar, i,j, i1, j1); 6594: exit(1); 6595: } 6596: fprintf(ficparo,"%1d%1d",i1,j1); 6597: if(mle==1) 6598: printf("%1d%1d",i,jj); 6599: fprintf(ficlog,"%1d%1d",i,jj); 6600: for(k=1; k<=ncovmodel;k++){ 6601: fscanf(ficpar," %lf",&param[i][j][k]); 6602: if(mle==1){ 6603: printf(" %lf",param[i][j][k]); 6604: fprintf(ficlog," %lf",param[i][j][k]); 6605: } 6606: else 6607: fprintf(ficlog," %lf",param[i][j][k]); 6608: fprintf(ficparo," %lf",param[i][j][k]); 6609: } 6610: fscanf(ficpar,"\n"); 6611: numlinepar++; 6612: if(mle==1) 6613: printf("\n"); 6614: fprintf(ficlog,"\n"); 6615: fprintf(ficparo,"\n"); 6616: } 6617: } 6618: fflush(ficlog); 6619: 6620: /* Reads scales values */ 6621: p=param[1][1]; 6622: 6623: /* Reads comments: lines beginning with '#' */ 6624: while((c=getc(ficpar))=='#' && c!= EOF){ 6625: ungetc(c,ficpar); 6626: fgets(line, MAXLINE, ficpar); 6627: numlinepar++; 6628: fputs(line,stdout); 6629: fputs(line,ficparo); 6630: fputs(line,ficlog); 6631: } 6632: ungetc(c,ficpar); 6633: 6634: for(i=1; i <=nlstate; i++){ 6635: for(j=1; j <=nlstate+ndeath-1; j++){ 6636: fscanf(ficpar,"%1d%1d",&i1,&j1); 6637: if ( (i1-i) * (j1-j) != 0){ 6638: printf("Error in line parameters number %d, %1d%1d instead of %1d%1d \n",numlinepar, i,j, i1, j1); 6639: exit(1); 6640: } 6641: printf("%1d%1d",i,j); 6642: fprintf(ficparo,"%1d%1d",i1,j1); 6643: fprintf(ficlog,"%1d%1d",i1,j1); 6644: for(k=1; k<=ncovmodel;k++){ 6645: fscanf(ficpar,"%le",&delti3[i][j][k]); 6646: printf(" %le",delti3[i][j][k]); 6647: fprintf(ficparo," %le",delti3[i][j][k]); 6648: fprintf(ficlog," %le",delti3[i][j][k]); 6649: } 6650: fscanf(ficpar,"\n"); 6651: numlinepar++; 6652: printf("\n"); 6653: fprintf(ficparo,"\n"); 6654: fprintf(ficlog,"\n"); 6655: } 6656: } 6657: fflush(ficlog); 6658: 6659: /* Reads covariance matrix */ 6660: delti=delti3[1][1]; 6661: 6662: 6663: /* free_ma3x(delti3,1,nlstate,1,nlstate+ndeath-1,1,ncovmodel); */ /* Hasn't to to freed here otherwise delti is no more allocated */ 6664: 6665: /* Reads comments: lines beginning with '#' */ 6666: while((c=getc(ficpar))=='#' && c!= EOF){ 6667: ungetc(c,ficpar); 6668: fgets(line, MAXLINE, ficpar); 6669: numlinepar++; 6670: fputs(line,stdout); 6671: fputs(line,ficparo); 6672: fputs(line,ficlog); 6673: } 6674: ungetc(c,ficpar); 6675: 6676: matcov=matrix(1,npar,1,npar); 6677: for(i=1; i <=npar; i++) 6678: for(j=1; j <=npar; j++) matcov[i][j]=0.; 6679: 6680: /* Scans npar lines */ 6681: for(i=1; i <=npar; i++){ 6682: count=fscanf(ficpar,"%1d%1d%1d",&i1,&j1,&jk); 6683: if(count != 3){ 6684: printf("Error! Error in parameter file %s at line %d after line starting with %1d%1d%1d\n\ 6685: This is probably because your covariance matrix doesn't \n contain exactly %d lines corresponding to your model line '1+age+%s'.\n\ 6686: Please run with mle=-1 to get a correct covariance matrix.\n",optionfile,numlinepar, i1,j1,jk, npar, model); 6687: fprintf(ficlog,"Error! Error in parameter file %s at line %d after line starting with %1d%1d%1d\n\ 6688: This is probably because your covariance matrix doesn't \n contain exactly %d lines corresponding to your model line '1+age+%s'.\n\ 6689: Please run with mle=-1 to get a correct covariance matrix.\n",optionfile,numlinepar, i1,j1,jk, npar, model); 6690: exit(1); 6691: }else 6692: if(mle==1) 6693: printf("%1d%1d%1d",i1,j1,jk); 6694: fprintf(ficlog,"%1d%1d%1d",i1,j1,jk); 6695: fprintf(ficparo,"%1d%1d%1d",i1,j1,jk); 6696: for(j=1; j <=i; j++){ 6697: fscanf(ficpar," %le",&matcov[i][j]); 6698: if(mle==1){ 6699: printf(" %.5le",matcov[i][j]); 6700: } 6701: fprintf(ficlog," %.5le",matcov[i][j]); 6702: fprintf(ficparo," %.5le",matcov[i][j]); 6703: } 6704: fscanf(ficpar,"\n"); 6705: numlinepar++; 6706: if(mle==1) 6707: printf("\n"); 6708: fprintf(ficlog,"\n"); 6709: fprintf(ficparo,"\n"); 6710: } 6711: /* End of read covariance matrix npar lines */ 6712: for(i=1; i <=npar; i++) 6713: for(j=i+1;j<=npar;j++) 6714: matcov[i][j]=matcov[j][i]; 6715: 6716: if(mle==1) 6717: printf("\n"); 6718: fprintf(ficlog,"\n"); 6719: 6720: fflush(ficlog); 6721: 6722: /*-------- Rewriting parameter file ----------*/ 6723: strcpy(rfileres,"r"); /* "Rparameterfile */ 6724: strcat(rfileres,optionfilefiname); /* Parameter file first name*/ 6725: strcat(rfileres,"."); /* */ 6726: strcat(rfileres,optionfilext); /* Other files have txt extension */ 6727: if((ficres =fopen(rfileres,"w"))==NULL) { 6728: printf("Problem writing new parameter file: %s\n", fileres);goto end; 6729: fprintf(ficlog,"Problem writing new parameter file: %s\n", fileres);goto end; 6730: } 6731: fprintf(ficres,"#%s\n",version); 6732: } /* End of mle != -3 */ 6733: 6734: /* Main data 6735: */ 6736: n= lastobs; 6737: num=lvector(1,n); 6738: moisnais=vector(1,n); 6739: annais=vector(1,n); 6740: moisdc=vector(1,n); 6741: andc=vector(1,n); 6742: agedc=vector(1,n); 6743: cod=ivector(1,n); 6744: weight=vector(1,n); 6745: for(i=1;i<=n;i++) weight[i]=1.0; /* Equal weights, 1 by default */ 6746: mint=matrix(1,maxwav,1,n); 6747: anint=matrix(1,maxwav,1,n); 6748: s=imatrix(1,maxwav+1,1,n); /* s[i][j] health state for wave i and individual j */ 6749: tab=ivector(1,NCOVMAX); 6750: ncodemax=ivector(1,NCOVMAX); /* Number of code per covariate; if O and 1 only, 2**ncov; V1+V2+V3+V4=>16 */ 6751: ncodemaxwundef=ivector(1,NCOVMAX); /* Number of code per covariate; if - 1 O and 1 only, 2**ncov; V1+V2+V3+V4=>16 */ 6752: 6753: /* Reads data from file datafile */ 6754: if (readdata(datafile, firstobs, lastobs, &imx)==1) 6755: goto end; 6756: 6757: /* Calculation of the number of parameters from char model */ 6758: /* modelsav=V2+V1+V4+age*V3 strb=age*V3 stra=V2+V1+V4 6759: k=4 (age*V3) Tvar[k=4]= 3 (from V3) Tag[cptcovage=1]=4 6760: k=3 V4 Tvar[k=3]= 4 (from V4) 6761: k=2 V1 Tvar[k=2]= 1 (from V1) 6762: k=1 Tvar[1]=2 (from V2) 6763: */ 6764: Tvar=ivector(1,NCOVMAX); /* Was 15 changed to NCOVMAX. */ 6765: /* V2+V1+V4+age*V3 is a model with 4 covariates (3 plus signs). 6766: For each model-covariate stores the data-covariate id. Tvar[1]=2, Tvar[2]=1, Tvar[3]=4, 6767: Tvar[4=age*V3] is 3 and 'age' is recorded in Tage. 6768: */ 6769: /* For model-covariate k tells which data-covariate to use but 6770: because this model-covariate is a construction we invent a new column 6771: ncovcol + k1 6772: If already ncovcol=4 and model=V2+V1+V1*V4+age*V3 6773: Tvar[3=V1*V4]=4+1 etc */ 6774: Tprod=ivector(1,NCOVMAX); /* Gives the position of a product */ 6775: /* Tprod[k1=1]=3(=V1*V4) for V2+V1+V1*V4+age*V3 6776: if V2+V1+V1*V4+age*V3+V3*V2 TProd[k1=2]=5 (V3*V2) 6777: */ 6778: Tvaraff=ivector(1,NCOVMAX); /* Unclear */ 6779: Tvard=imatrix(1,NCOVMAX,1,2); /* n=Tvard[k1][1] and m=Tvard[k1][2] gives the couple n,m of the k1 th product Vn*Vm 6780: * For V3*V2 (in V2+V1+V1*V4+age*V3+V3*V2), V3*V2 position is 2nd. 6781: * Tvard[k1=2][1]=3 (V3) Tvard[k1=2][2]=2(V2) */ 6782: Tage=ivector(1,NCOVMAX); /* Gives the covariate id of covariates associated with age: V2 + V1 + age*V4 + V3*age 6783: 4 covariates (3 plus signs) 6784: Tage[1=V3*age]= 4; Tage[2=age*V4] = 3 6785: */ 6786: 6787: /* Main decodemodel */ 6788: 6789: 6790: if(decodemodel(model, lastobs) == 1) 6791: goto end; 6792: 6793: if((double)(lastobs-imx)/(double)imx > 1.10){ 6794: nbwarn++; 6795: printf("Warning: The value of parameter lastobs=%d is big compared to the \n effective number of cases imx=%d, please adjust, \n otherwise you are allocating more memory than necessary.\n",lastobs, imx); 6796: fprintf(ficlog,"Warning: The value of parameter lastobs=%d is big compared to the \n effective number of cases imx=%d, please adjust, \n otherwise you are allocating more memory than necessary.\n",lastobs, imx); 6797: } 6798: /* if(mle==1){*/ 6799: if (weightopt != 1) { /* Maximisation without weights. We can have weights different from 1 but want no weight*/ 6800: for(i=1;i<=imx;i++) weight[i]=1.0; /* changed to imx */ 6801: } 6802: 6803: /*-calculation of age at interview from date of interview and age at death -*/ 6804: agev=matrix(1,maxwav,1,imx); 6805: 6806: if(calandcheckages(imx, maxwav, &agemin, &agemax, &nberr, &nbwarn) == 1) 6807: goto end; 6808: 6809: 6810: agegomp=(int)agemin; 6811: free_vector(moisnais,1,n); 6812: free_vector(annais,1,n); 6813: /* free_matrix(mint,1,maxwav,1,n); 6814: free_matrix(anint,1,maxwav,1,n);*/ 6815: free_vector(moisdc,1,n); 6816: free_vector(andc,1,n); 6817: /* */ 6818: 6819: wav=ivector(1,imx); 6820: dh=imatrix(1,lastpass-firstpass+1,1,imx); 6821: bh=imatrix(1,lastpass-firstpass+1,1,imx); 6822: mw=imatrix(1,lastpass-firstpass+1,1,imx); 6823: 6824: /* Concatenates waves */ 6825: concatwav(wav, dh, bh, mw, s, agedc, agev, firstpass, lastpass, imx, nlstate, stepm); 6826: /* */ 6827: 6828: /* Routine tricode is to calculate cptcoveff (real number of unique covariates) and to associate covariable number and modality */ 6829: 6830: nbcode=imatrix(0,NCOVMAX,0,NCOVMAX); 6831: ncodemax[1]=1; 6832: Ndum =ivector(-1,NCOVMAX); 6833: if (ncovmodel-nagesqr > 2 ) /* That is if covariate other than cst, age and age*age */ 6834: tricode(Tvar,nbcode,imx, Ndum); /**< Fills nbcode[Tvar[j]][l]; */ 6835: /* Nbcode gives the value of the lth modality of jth covariate, in 6836: V2+V1*age, there are 3 covariates Tvar[2]=1 (V1).*/ 6837: /* 1 to ncodemax[j] is the maximum value of this jth covariate */ 6838: 6839: codtab=imatrix(1,100,1,10); /* codtab[h,k]=( (h-1) - mod(k-1,2**(k-1) )/2**(k-1) */ 6840: /*printf(" codtab[1,1],codtab[100,10]=%d,%d\n", codtab[1][1],codtab[100][10]);*/ 6841: /* codtab gives the value 1 or 2 of the hth combination of k covariates (1 or 2).*/ 6842: h=0; 6843: 6844: 6845: /*if (cptcovn > 0) */ 6846: 6847: 6848: m=pow(2,cptcoveff); 6849: 6850: for(k=1;k<=cptcoveff; k++){ /* scans any effective covariate */ 6851: for(i=1; i <=pow(2,cptcoveff-k);i++){ /* i=1 to 8/1=8; i=1 to 8/2=4; i=1 to 8/8=1 */ 6852: for(j=1; j <= ncodemax[k]; j++){ /* For each modality of this covariate ncodemax=2*/ 6853: for(cpt=1; cpt <=pow(2,k-1); cpt++){ /* cpt=1 to 8/2**(3+1-1 or 3+1-3) =1 or 4 */ 6854: h++; 6855: if (h>m) 6856: h=1; 6857: /**< codtab(h,k) k = codtab[h,k]=( (h-1) - mod(k-1,2**(k-1) )/2**(k-1) + 1 6858: * For k=4 covariates, h goes from 1 to 2**k 6859: * codtabm(h,k)= 1 & (h-1) >> (k-1) ; 6860: * h\k 1 2 3 4 6861: *______________________________ 6862: * 1 i=1 1 i=1 1 i=1 1 i=1 1 6863: * 2 2 1 1 1 6864: * 3 i=2 1 2 1 1 6865: * 4 2 2 1 1 6866: * 5 i=3 1 i=2 1 2 1 6867: * 6 2 1 2 1 6868: * 7 i=4 1 2 2 1 6869: * 8 2 2 2 1 6870: * 9 i=5 1 i=3 1 i=2 1 1 6871: * 10 2 1 1 1 6872: * 11 i=6 1 2 1 1 6873: * 12 2 2 1 1 6874: * 13 i=7 1 i=4 1 2 1 6875: * 14 2 1 2 1 6876: * 15 i=8 1 2 2 1 6877: * 16 2 2 2 1 6878: */ 6879: codtab[h][k]=j; 6880: /* codtab[12][3]=1; */ 6881: /*codtab[h][Tvar[k]]=j;*/ 6882: printf("h=%d k=%d j=%d codtab[h][k]=%d Tvar[k]=%d codtab[h][Tvar[k]]=%d \n",h, k,j,codtab[h][k],Tvar[k],codtab[h][Tvar[k]]); 6883: } 6884: } 6885: } 6886: } 6887: /* printf("codtab[1][2]=%d codtab[2][2]=%d",codtab[1][2],codtab[2][2]); 6888: codtab[1][2]=1;codtab[2][2]=2; */ 6889: /* for(i=1; i <=m ;i++){ 6890: for(k=1; k <=cptcovn; k++){ 6891: printf("i=%d k=%d %d %d ",i,k,codtab[i][k], cptcoveff); 6892: } 6893: printf("\n"); 6894: } 6895: scanf("%d",i);*/ 6896: 6897: free_ivector(Ndum,-1,NCOVMAX); 6898: 6899: 6900: 6901: /* Initialisation of ----------- gnuplot -------------*/ 6902: strcpy(optionfilegnuplot,optionfilefiname); 6903: if(mle==-3) 6904: strcat(optionfilegnuplot,"-mort"); 6905: strcat(optionfilegnuplot,".gp"); 6906: 6907: if((ficgp=fopen(optionfilegnuplot,"w"))==NULL) { 6908: printf("Problem with file %s",optionfilegnuplot); 6909: } 6910: else{ 6911: fprintf(ficgp,"\n# %s\n", version); 6912: fprintf(ficgp,"# %s\n", optionfilegnuplot); 6913: //fprintf(ficgp,"set missing 'NaNq'\n"); 6914: fprintf(ficgp,"set datafile missing 'NaNq'\n"); 6915: } 6916: /* fclose(ficgp);*/ 6917: 6918: 6919: /* Initialisation of --------- index.htm --------*/ 6920: 6921: strcpy(optionfilehtm,optionfilefiname); /* Main html file */ 6922: if(mle==-3) 6923: strcat(optionfilehtm,"-mort"); 6924: strcat(optionfilehtm,".htm"); 6925: if((fichtm=fopen(optionfilehtm,"w"))==NULL) { 6926: printf("Problem with %s \n",optionfilehtm); 6927: exit(0); 6928: } 6929: 6930: strcpy(optionfilehtmcov,optionfilefiname); /* Only for matrix of covariance */ 6931: strcat(optionfilehtmcov,"-cov.htm"); 6932: if((fichtmcov=fopen(optionfilehtmcov,"w"))==NULL) { 6933: printf("Problem with %s \n",optionfilehtmcov), exit(0); 6934: } 6935: else{ 6936: fprintf(fichtmcov,"<html><head>\n<title>IMaCh Cov %s</title></head>\n <body>%s %s \ 6937: <hr size=\"2\" color=\"#EC5E5E\"> \n\ 6938: Title=%s Datafile=%s Firstpass=%d Lastpass=%d Stepm=%d Weight=%d Model=%s \n",\ 6939: optionfilehtmcov,version,fullversion,title,datafile,firstpass,lastpass,stepm, weightopt, model); 6940: } 6941: 6942: fprintf(fichtm,"<html><head>\n<title>IMaCh %s</title></head>\n <body>%s %s \ 6943: <hr size=\"2\" color=\"#EC5E5E\"> \n\ 6944: Title=%s Datafile=%s Firstpass=%d Lastpass=%d Stepm=%d Weight=%d Model=%s \n\ 6945: \n\ 6946: <hr size=\"2\" color=\"#EC5E5E\">\ 6947: <ul><li><h4>Parameter files</h4>\n\ 6948: - Parameter file: <a href=\"%s.%s\">%s.%s</a> \n\ 6949: - Copy of the parameter file: <a href=\"o%s\">o%s</a> \n\ 6950: - Log file of the run: <a href=\"%s\">%s</a> \n\ 6951: - Gnuplot file name: <a href=\"%s\">%s</a> \n\ 6952: - Date and time at start: %s</ul>\n",\ 6953: optionfilehtm,version,fullversion,title,datafile,firstpass,lastpass,stepm, weightopt, model,\ 6954: optionfilefiname,optionfilext,optionfilefiname,optionfilext,\ 6955: fileres,fileres,\ 6956: filelog,filelog,optionfilegnuplot,optionfilegnuplot,strstart); 6957: fflush(fichtm); 6958: 6959: strcpy(pathr,path); 6960: strcat(pathr,optionfilefiname); 6961: #ifdef WIN32 6962: _chdir(optionfilefiname); /* Move to directory named optionfile */ 6963: #else 6964: chdir(optionfilefiname); /* Move to directory named optionfile */ 6965: #endif 6966: 6967: 6968: /* Calculates basic frequencies. Computes observed prevalence at single age 6969: and prints on file fileres'p'. */ 6970: freqsummary(fileres, agemin, agemax, s, agev, nlstate, imx,Tvaraff,nbcode, ncodemax,mint,anint,strstart); 6971: 6972: fprintf(fichtm,"\n"); 6973: fprintf(fichtm," Total number of observations=%d \n\ 6974: Youngest age at first (selected) pass %.2f, oldest age %.2f \n\ 6975: Interval (in months) between two waves: Min=%d Max=%d Mean=%.2lf \n",\ 6976: imx,agemin,agemax,jmin,jmax,jmean); 6977: pmmij= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ 6978: oldms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ 6979: newms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ 6980: savms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ 6981: oldm=oldms; newm=newms; savm=savms; /* Keeps fixed addresses to free */ 6982: 6983: 6984: /* For Powell, parameters are in a vector p[] starting at p[1] 6985: so we point p on param[1][1] so that p[1] maps on param[1][1][1] */ 6986: p=param[1][1]; /* *(*(*(param +1)+1)+0) */ 6987: 6988: globpr=0; /* To get the number ipmx of contributions and the sum of weights*/ 6989: /* For mortality only */ 6990: if (mle==-3){ 6991: ximort=matrix(1,NDIM,1,NDIM); 6992: /* ximort=gsl_matrix_alloc(1,NDIM,1,NDIM); */ 6993: cens=ivector(1,n); 6994: ageexmed=vector(1,n); 6995: agecens=vector(1,n); 6996: dcwave=ivector(1,n); 6997: 6998: for (i=1; i<=imx; i++){ 6999: dcwave[i]=-1; 7000: for (m=firstpass; m<=lastpass; m++) 7001: if (s[m][i]>nlstate) { 7002: dcwave[i]=m; 7003: /* printf("i=%d j=%d s=%d dcwave=%d\n",i,j, s[j][i],dcwave[i]);*/ 7004: break; 7005: } 7006: } 7007: 7008: for (i=1; i<=imx; i++) { 7009: if (wav[i]>0){ 7010: ageexmed[i]=agev[mw[1][i]][i]; 7011: j=wav[i]; 7012: agecens[i]=1.; 7013: 7014: if (ageexmed[i]> 1 && wav[i] > 0){ 7015: agecens[i]=agev[mw[j][i]][i]; 7016: cens[i]= 1; 7017: }else if (ageexmed[i]< 1) 7018: cens[i]= -1; 7019: if (agedc[i]< AGESUP && agedc[i]>1 && dcwave[i]>firstpass && dcwave[i]<=lastpass) 7020: cens[i]=0 ; 7021: } 7022: else cens[i]=-1; 7023: } 7024: 7025: for (i=1;i<=NDIM;i++) { 7026: for (j=1;j<=NDIM;j++) 7027: ximort[i][j]=(i == j ? 1.0 : 0.0); 7028: } 7029: 7030: /*p[1]=0.0268; p[NDIM]=0.083;*/ 7031: /*printf("%lf %lf", p[1], p[2]);*/ 7032: 7033: 7034: #ifdef GSL 7035: printf("GSL optimization\n"); fprintf(ficlog,"Powell\n"); 7036: #else 7037: printf("Powell\n"); fprintf(ficlog,"Powell\n"); 7038: #endif 7039: strcpy(filerespow,"pow-mort"); 7040: strcat(filerespow,fileres); 7041: if((ficrespow=fopen(filerespow,"w"))==NULL) { 7042: printf("Problem with resultfile: %s\n", filerespow); 7043: fprintf(ficlog,"Problem with resultfile: %s\n", filerespow); 7044: } 7045: #ifdef GSL 7046: fprintf(ficrespow,"# GSL optimization\n# iter -2*LL"); 7047: #else 7048: fprintf(ficrespow,"# Powell\n# iter -2*LL"); 7049: #endif 7050: /* for (i=1;i<=nlstate;i++) 7051: for(j=1;j<=nlstate+ndeath;j++) 7052: if(j!=i)fprintf(ficrespow," p%1d%1d",i,j); 7053: */ 7054: fprintf(ficrespow,"\n"); 7055: #ifdef GSL 7056: /* gsl starts here */ 7057: T = gsl_multimin_fminimizer_nmsimplex; 7058: gsl_multimin_fminimizer *sfm = NULL; 7059: gsl_vector *ss, *x; 7060: gsl_multimin_function minex_func; 7061: 7062: /* Initial vertex size vector */ 7063: ss = gsl_vector_alloc (NDIM); 7064: 7065: if (ss == NULL){ 7066: GSL_ERROR_VAL ("failed to allocate space for ss", GSL_ENOMEM, 0); 7067: } 7068: /* Set all step sizes to 1 */ 7069: gsl_vector_set_all (ss, 0.001); 7070: 7071: /* Starting point */ 7072: 7073: x = gsl_vector_alloc (NDIM); 7074: 7075: if (x == NULL){ 7076: gsl_vector_free(ss); 7077: GSL_ERROR_VAL ("failed to allocate space for x", GSL_ENOMEM, 0); 7078: } 7079: 7080: /* Initialize method and iterate */ 7081: /* p[1]=0.0268; p[NDIM]=0.083; */ 7082: /* gsl_vector_set(x, 0, 0.0268); */ 7083: /* gsl_vector_set(x, 1, 0.083); */ 7084: gsl_vector_set(x, 0, p[1]); 7085: gsl_vector_set(x, 1, p[2]); 7086: 7087: minex_func.f = &gompertz_f; 7088: minex_func.n = NDIM; 7089: minex_func.params = (void *)&p; /* ??? */ 7090: 7091: sfm = gsl_multimin_fminimizer_alloc (T, NDIM); 7092: gsl_multimin_fminimizer_set (sfm, &minex_func, x, ss); 7093: 7094: printf("Iterations beginning .....\n\n"); 7095: printf("Iter. # Intercept Slope -Log Likelihood Simplex size\n"); 7096: 7097: iteri=0; 7098: while (rval == GSL_CONTINUE){ 7099: iteri++; 7100: status = gsl_multimin_fminimizer_iterate(sfm); 7101: 7102: if (status) printf("error: %s\n", gsl_strerror (status)); 7103: fflush(0); 7104: 7105: if (status) 7106: break; 7107: 7108: rval = gsl_multimin_test_size (gsl_multimin_fminimizer_size (sfm), 1e-6); 7109: ssval = gsl_multimin_fminimizer_size (sfm); 7110: 7111: if (rval == GSL_SUCCESS) 7112: printf ("converged to a local maximum at\n"); 7113: 7114: printf("%5d ", iteri); 7115: for (it = 0; it < NDIM; it++){ 7116: printf ("%10.5f ", gsl_vector_get (sfm->x, it)); 7117: } 7118: printf("f() = %-10.5f ssize = %.7f\n", sfm->fval, ssval); 7119: } 7120: 7121: printf("\n\n Please note: Program should be run many times with varying starting points to detemine global maximum\n\n"); 7122: 7123: gsl_vector_free(x); /* initial values */ 7124: gsl_vector_free(ss); /* inital step size */ 7125: for (it=0; it<NDIM; it++){ 7126: p[it+1]=gsl_vector_get(sfm->x,it); 7127: fprintf(ficrespow," %.12lf", p[it]); 7128: } 7129: gsl_multimin_fminimizer_free (sfm); /* p *(sfm.x.data) et p *(sfm.x.data+1) */ 7130: #endif 7131: #ifdef POWELL 7132: powell(p,ximort,NDIM,ftol,&iter,&fret,gompertz); 7133: #endif 7134: fclose(ficrespow); 7135: 7136: hesscov(matcov, p, NDIM, delti, 1e-4, gompertz); 7137: 7138: for(i=1; i <=NDIM; i++) 7139: for(j=i+1;j<=NDIM;j++) 7140: matcov[i][j]=matcov[j][i]; 7141: 7142: printf("\nCovariance matrix\n "); 7143: for(i=1; i <=NDIM; i++) { 7144: for(j=1;j<=NDIM;j++){ 7145: printf("%f ",matcov[i][j]); 7146: } 7147: printf("\n "); 7148: } 7149: 7150: printf("iter=%d MLE=%f Eq=%lf*exp(%lf*(age-%d))\n",iter,-gompertz(p),p[1],p[2],agegomp); 7151: for (i=1;i<=NDIM;i++) { 7152: printf("%f [%f ; %f]\n",p[i],p[i]-2*sqrt(matcov[i][i]),p[i]+2*sqrt(matcov[i][i])); 7153: fprintf(ficlog,"%f [%f ; %f]\n",p[i],p[i]-2*sqrt(matcov[i][i]),p[i]+2*sqrt(matcov[i][i])); 7154: } 7155: lsurv=vector(1,AGESUP); 7156: lpop=vector(1,AGESUP); 7157: tpop=vector(1,AGESUP); 7158: lsurv[agegomp]=100000; 7159: 7160: for (k=agegomp;k<=AGESUP;k++) { 7161: agemortsup=k; 7162: if (p[1]*exp(p[2]*(k-agegomp))>1) break; 7163: } 7164: 7165: for (k=agegomp;k<agemortsup;k++) 7166: lsurv[k+1]=lsurv[k]-lsurv[k]*(p[1]*exp(p[2]*(k-agegomp))); 7167: 7168: for (k=agegomp;k<agemortsup;k++){ 7169: lpop[k]=(lsurv[k]+lsurv[k+1])/2.; 7170: sumlpop=sumlpop+lpop[k]; 7171: } 7172: 7173: tpop[agegomp]=sumlpop; 7174: for (k=agegomp;k<(agemortsup-3);k++){ 7175: /* tpop[k+1]=2;*/ 7176: tpop[k+1]=tpop[k]-lpop[k]; 7177: } 7178: 7179: 7180: printf("\nAge lx qx dx Lx Tx e(x)\n"); 7181: for (k=agegomp;k<(agemortsup-2);k++) 7182: printf("%d %.0lf %lf %.0lf %.0lf %.0lf %lf\n",k,lsurv[k],p[1]*exp(p[2]*(k-agegomp)),(p[1]*exp(p[2]*(k-agegomp)))*lsurv[k],lpop[k],tpop[k],tpop[k]/lsurv[k]); 7183: 7184: 7185: replace_back_to_slash(pathc,pathcd); /* Even gnuplot wants a / */ 7186: if(ageminpar == AGEOVERFLOW ||agemaxpar == AGEOVERFLOW){ 7187: printf("Warning! Error in gnuplot file with ageminpar %f or agemaxpar %f overflow\n\ 7188: This is probably because your parameter file doesn't \n contain the exact number of lines (or columns) corresponding to your model line.\n\ 7189: Please run with mle=-1 to get a correct covariance matrix.\n",ageminpar,agemaxpar); 7190: fprintf(ficlog,"Warning! Error in gnuplot file with ageminpar %f or agemaxpar %f overflow\n\ 7191: This is probably because your parameter file doesn't \n contain the exact number of lines (or columns) corresponding to your model line.\n\ 7192: Please run with mle=-1 to get a correct covariance matrix.\n",ageminpar,agemaxpar); 7193: }else 7194: printinggnuplotmort(fileres, optionfilefiname,ageminpar,agemaxpar,fage, pathc,p); 7195: printinghtmlmort(fileres,title,datafile, firstpass, lastpass, \ 7196: stepm, weightopt,\ 7197: model,imx,p,matcov,agemortsup); 7198: 7199: free_vector(lsurv,1,AGESUP); 7200: free_vector(lpop,1,AGESUP); 7201: free_vector(tpop,1,AGESUP); 7202: #ifdef GSL 7203: free_ivector(cens,1,n); 7204: free_vector(agecens,1,n); 7205: free_ivector(dcwave,1,n); 7206: free_matrix(ximort,1,NDIM,1,NDIM); 7207: #endif 7208: } /* Endof if mle==-3 mortality only */ 7209: /* Standard maximisation */ 7210: else{ /* For mle >=1 */ 7211: globpr=0;/* debug */ 7212: /* Computes likelihood for initial parameters */ 7213: likelione(ficres, p, npar, nlstate, &globpr, &ipmx, &sw, &fretone, funcone); /* Prints the contributions to the likelihood */ 7214: printf("First Likeli=%12.6f ipmx=%ld sw=%12.6f",fretone,ipmx,sw); 7215: for (k=1; k<=npar;k++) 7216: printf(" %d %8.5f",k,p[k]); 7217: printf("\n"); 7218: globpr=1; /* again, to print the contributions */ 7219: likelione(ficres, p, npar, nlstate, &globpr, &ipmx, &sw, &fretone, funcone); /* Prints the contributions to the likelihood */ 7220: printf("Second Likeli=%12.6f ipmx=%ld sw=%12.6f",fretone,ipmx,sw); 7221: for (k=1; k<=npar;k++) 7222: printf(" %d %8.5f",k,p[k]); 7223: printf("\n"); 7224: if(mle>=1){ /* Could be 1 or 2, Real Maximisation */ 7225: mlikeli(ficres,p, npar, ncovmodel, nlstate, ftol, func); 7226: } 7227: 7228: /*--------- results files --------------*/ 7229: fprintf(ficres,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncovcol=%d nlstate=%d ndeath=%d maxwav=%d mle= 0 weight=%d\nmodel=1+age+%s.\n", title, datafile, lastobs, firstpass,lastpass,ftol, stepm, ncovcol, nlstate, ndeath, maxwav, weightopt,model); 7230: 7231: 7232: fprintf(ficres,"# Parameters nlstate*nlstate*ncov a12*1 + b12 * age + ...\n"); 7233: printf("# Parameters nlstate*nlstate*ncov a12*1 + b12 * age + ...\n"); 7234: fprintf(ficlog,"# Parameters nlstate*nlstate*ncov a12*1 + b12 * age + ...\n"); 7235: for(i=1,jk=1; i <=nlstate; i++){ 7236: for(k=1; k <=(nlstate+ndeath); k++){ 7237: if (k != i) { 7238: printf("%d%d ",i,k); 7239: fprintf(ficlog,"%d%d ",i,k); 7240: fprintf(ficres,"%1d%1d ",i,k); 7241: for(j=1; j <=ncovmodel; j++){ 7242: printf("%12.7f ",p[jk]); 7243: fprintf(ficlog,"%12.7f ",p[jk]); 7244: fprintf(ficres,"%12.7f ",p[jk]); 7245: jk++; 7246: } 7247: printf("\n"); 7248: fprintf(ficlog,"\n"); 7249: fprintf(ficres,"\n"); 7250: } 7251: } 7252: } 7253: if(mle!=0){ 7254: /* Computing hessian and covariance matrix */ 7255: ftolhess=ftol; /* Usually correct */ 7256: hesscov(matcov, p, npar, delti, ftolhess, func); 7257: } 7258: printf("Parameters and 95%% confidence intervals\n"); 7259: fprintf(ficlog, "Parameters, T and confidence intervals\n"); 7260: for(i=1,jk=1; i <=nlstate; i++){ 7261: for(k=1; k <=(nlstate+ndeath); k++){ 7262: if (k != i) { 7263: printf("%d%d ",i,k); 7264: fprintf(ficlog,"%d%d ",i,k); 7265: for(j=1; j <=ncovmodel; j++){ 7266: printf("%12.7f T=%8.3f CI=[%12.7f ; %12.7f] ",p[jk], p[jk]/sqrt(matcov[jk][jk]), p[jk]-2*sqrt(matcov[jk][jk]),p[jk]+2*sqrt(matcov[jk][jk])); 7267: fprintf(ficlog,"%12.7f T=%8.3f CI=[%12.7f ; %12.7f] ",p[jk], p[jk]/sqrt(matcov[jk][jk]), p[jk]-2*sqrt(matcov[jk][jk]),p[jk]+2*sqrt(matcov[jk][jk])); 7268: jk++; 7269: } 7270: printf("\n"); 7271: fprintf(ficlog,"\n"); 7272: } 7273: } 7274: } 7275: 7276: fprintf(ficres,"# Scales (for hessian or gradient estimation)\n"); 7277: printf("# Scales (for hessian or gradient estimation)\n"); 7278: fprintf(ficlog,"# Scales (for hessian or gradient estimation)\n"); 7279: for(i=1,jk=1; i <=nlstate; i++){ 7280: for(j=1; j <=nlstate+ndeath; j++){ 7281: if (j!=i) { 7282: fprintf(ficres,"%1d%1d",i,j); 7283: printf("%1d%1d",i,j); 7284: fprintf(ficlog,"%1d%1d",i,j); 7285: for(k=1; k<=ncovmodel;k++){ 7286: printf(" %.5e",delti[jk]); 7287: fprintf(ficlog," %.5e",delti[jk]); 7288: fprintf(ficres," %.5e",delti[jk]); 7289: jk++; 7290: } 7291: printf("\n"); 7292: fprintf(ficlog,"\n"); 7293: fprintf(ficres,"\n"); 7294: } 7295: } 7296: } 7297: 7298: fprintf(ficres,"# Covariance matrix \n# 121 Var(a12)\n# 122 Cov(b12,a12) Var(b12)\n# ...\n# 232 Cov(b23,a12) Cov(b23,b12) ... Var (b23)\n"); 7299: if(mle>=1) 7300: printf("# Covariance matrix \n# 121 Var(a12)\n# 122 Cov(b12,a12) Var(b12)\n# ...\n# 232 Cov(b23,a12) Cov(b23,b12) ... Var (b23)\n"); 7301: fprintf(ficlog,"# Covariance matrix \n# 121 Var(a12)\n# 122 Cov(b12,a12) Var(b12)\n# ...\n# 232 Cov(b23,a12) Cov(b23,b12) ... Var (b23)\n"); 7302: /* # 121 Var(a12)\n\ */ 7303: /* # 122 Cov(b12,a12) Var(b12)\n\ */ 7304: /* # 131 Cov(a13,a12) Cov(a13,b12, Var(a13)\n\ */ 7305: /* # 132 Cov(b13,a12) Cov(b13,b12, Cov(b13,a13) Var(b13)\n\ */ 7306: /* # 212 Cov(a21,a12) Cov(a21,b12, Cov(a21,a13) Cov(a21,b13) Var(a21)\n\ */ 7307: /* # 212 Cov(b21,a12) Cov(b21,b12, Cov(b21,a13) Cov(b21,b13) Cov(b21,a21) Var(b21)\n\ */ 7308: /* # 232 Cov(a23,a12) Cov(a23,b12, Cov(a23,a13) Cov(a23,b13) Cov(a23,a21) Cov(a23,b21) Var(a23)\n\ */ 7309: /* # 232 Cov(b23,a12) Cov(b23,b12) ... Var (b23)\n" */ 7310: 7311: 7312: /* Just to have a covariance matrix which will be more understandable 7313: even is we still don't want to manage dictionary of variables 7314: */ 7315: for(itimes=1;itimes<=2;itimes++){ 7316: jj=0; 7317: for(i=1; i <=nlstate; i++){ 7318: for(j=1; j <=nlstate+ndeath; j++){ 7319: if(j==i) continue; 7320: for(k=1; k<=ncovmodel;k++){ 7321: jj++; 7322: ca[0]= k+'a'-1;ca[1]='\0'; 7323: if(itimes==1){ 7324: if(mle>=1) 7325: printf("#%1d%1d%d",i,j,k); 7326: fprintf(ficlog,"#%1d%1d%d",i,j,k); 7327: fprintf(ficres,"#%1d%1d%d",i,j,k); 7328: }else{ 7329: if(mle>=1) 7330: printf("%1d%1d%d",i,j,k); 7331: fprintf(ficlog,"%1d%1d%d",i,j,k); 7332: fprintf(ficres,"%1d%1d%d",i,j,k); 7333: } 7334: ll=0; 7335: for(li=1;li <=nlstate; li++){ 7336: for(lj=1;lj <=nlstate+ndeath; lj++){ 7337: if(lj==li) continue; 7338: for(lk=1;lk<=ncovmodel;lk++){ 7339: ll++; 7340: if(ll<=jj){ 7341: cb[0]= lk +'a'-1;cb[1]='\0'; 7342: if(ll<jj){ 7343: if(itimes==1){ 7344: if(mle>=1) 7345: printf(" Cov(%s%1d%1d,%s%1d%1d)",ca,i,j,cb, li,lj); 7346: fprintf(ficlog," Cov(%s%1d%1d,%s%1d%1d)",ca,i,j,cb, li,lj); 7347: fprintf(ficres," Cov(%s%1d%1d,%s%1d%1d)",ca,i,j,cb, li,lj); 7348: }else{ 7349: if(mle>=1) 7350: printf(" %.5e",matcov[jj][ll]); 7351: fprintf(ficlog," %.5e",matcov[jj][ll]); 7352: fprintf(ficres," %.5e",matcov[jj][ll]); 7353: } 7354: }else{ 7355: if(itimes==1){ 7356: if(mle>=1) 7357: printf(" Var(%s%1d%1d)",ca,i,j); 7358: fprintf(ficlog," Var(%s%1d%1d)",ca,i,j); 7359: fprintf(ficres," Var(%s%1d%1d)",ca,i,j); 7360: }else{ 7361: if(mle>=1) 7362: printf(" %.5e",matcov[jj][ll]); 7363: fprintf(ficlog," %.5e",matcov[jj][ll]); 7364: fprintf(ficres," %.5e",matcov[jj][ll]); 7365: } 7366: } 7367: } 7368: } /* end lk */ 7369: } /* end lj */ 7370: } /* end li */ 7371: if(mle>=1) 7372: printf("\n"); 7373: fprintf(ficlog,"\n"); 7374: fprintf(ficres,"\n"); 7375: numlinepar++; 7376: } /* end k*/ 7377: } /*end j */ 7378: } /* end i */ 7379: } /* end itimes */ 7380: 7381: fflush(ficlog); 7382: fflush(ficres); 7383: 7384: while((c=getc(ficpar))=='#' && c!= EOF){ 7385: ungetc(c,ficpar); 7386: fgets(line, MAXLINE, ficpar); 7387: fputs(line,stdout); 7388: fputs(line,ficparo); 7389: } 7390: ungetc(c,ficpar); 7391: 7392: estepm=0; 7393: fscanf(ficpar,"agemin=%lf agemax=%lf bage=%lf fage=%lf estepm=%d\n",&ageminpar,&agemaxpar, &bage, &fage, &estepm); 7394: if (estepm==0 || estepm < stepm) estepm=stepm; 7395: if (fage <= 2) { 7396: bage = ageminpar; 7397: fage = agemaxpar; 7398: } 7399: 7400: fprintf(ficres,"# agemin agemax for life expectancy, bage fage (if mle==0 ie no data nor Max likelihood).\n"); 7401: fprintf(ficres,"agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f estepm=%d\n",ageminpar,agemaxpar,bage,fage, estepm); 7402: fprintf(ficparo,"agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f estepm=%d\n",ageminpar,agemaxpar,bage,fage, estepm); 7403: 7404: /* Other stuffs, more or less useful */ 7405: while((c=getc(ficpar))=='#' && c!= EOF){ 7406: ungetc(c,ficpar); 7407: fgets(line, MAXLINE, ficpar); 7408: fputs(line,stdout); 7409: fputs(line,ficparo); 7410: } 7411: ungetc(c,ficpar); 7412: 7413: fscanf(ficpar,"begin-prev-date=%lf/%lf/%lf end-prev-date=%lf/%lf/%lf mov_average=%d\n",&jprev1, &mprev1,&anprev1,&jprev2, &mprev2,&anprev2,&mobilav); 7414: fprintf(ficparo,"begin-prev-date=%.lf/%.lf/%.lf end-prev-date=%.lf/%.lf/%.lf mov_average=%d\n",jprev1, mprev1,anprev1,jprev2, mprev2,anprev2,mobilav); 7415: fprintf(ficres,"begin-prev-date=%.lf/%.lf/%.lf end-prev-date=%.lf/%.lf/%.lf mov_average=%d\n",jprev1, mprev1,anprev1,jprev2, mprev2,anprev2,mobilav); 7416: printf("begin-prev-date=%.lf/%.lf/%.lf end-prev-date=%.lf/%.lf/%.lf mov_average=%d\n",jprev1, mprev1,anprev1,jprev2, mprev2,anprev2,mobilav); 7417: fprintf(ficlog,"begin-prev-date=%.lf/%.lf/%.lf end-prev-date=%.lf/%.lf/%.lf mov_average=%d\n",jprev1, mprev1,anprev1,jprev2, mprev2,anprev2,mobilav); 7418: 7419: while((c=getc(ficpar))=='#' && c!= EOF){ 7420: ungetc(c,ficpar); 7421: fgets(line, MAXLINE, ficpar); 7422: fputs(line,stdout); 7423: fputs(line,ficparo); 7424: } 7425: ungetc(c,ficpar); 7426: 7427: 7428: dateprev1=anprev1+(mprev1-1)/12.+(jprev1-1)/365.; 7429: dateprev2=anprev2+(mprev2-1)/12.+(jprev2-1)/365.; 7430: 7431: fscanf(ficpar,"pop_based=%d\n",&popbased); 7432: fprintf(ficlog,"pop_based=%d\n",popbased); 7433: fprintf(ficparo,"pop_based=%d\n",popbased); 7434: fprintf(ficres,"pop_based=%d\n",popbased); 7435: 7436: while((c=getc(ficpar))=='#' && c!= EOF){ 7437: ungetc(c,ficpar); 7438: fgets(line, MAXLINE, ficpar); 7439: fputs(line,stdout); 7440: fputs(line,ficparo); 7441: } 7442: ungetc(c,ficpar); 7443: 7444: fscanf(ficpar,"prevforecast=%d starting-proj-date=%lf/%lf/%lf final-proj-date=%lf/%lf/%lf mobil_average=%d\n",&prevfcast,&jproj1,&mproj1,&anproj1,&jproj2,&mproj2,&anproj2,&mobilavproj); 7445: fprintf(ficparo,"prevforecast=%d starting-proj-date=%.lf/%.lf/%.lf final-proj-date=%.lf/%.lf/%.lf mobil_average=%d\n",prevfcast,jproj1,mproj1,anproj1,jproj2,mproj2,anproj2,mobilavproj); 7446: printf("prevforecast=%d starting-proj-date=%.lf/%.lf/%.lf final-proj-date=%.lf/%.lf/%.lf mobil_average=%d\n",prevfcast,jproj1,mproj1,anproj1,jproj2,mproj2,anproj2,mobilavproj); 7447: fprintf(ficlog,"prevforecast=%d starting-proj-date=%.lf/%.lf/%.lf final-proj-date=%.lf/%.lf/%.lf mobil_average=%d\n",prevfcast,jproj1,mproj1,anproj1,jproj2,mproj2,anproj2,mobilavproj); 7448: fprintf(ficres,"prevforecast=%d starting-proj-date=%.lf/%.lf/%.lf final-proj-date=%.lf/%.lf/%.lf mobil_average=%d\n",prevfcast,jproj1,mproj1,anproj1,jproj2,mproj2,anproj2,mobilavproj); 7449: /* day and month of proj2 are not used but only year anproj2.*/ 7450: 7451: 7452: 7453: /* freqsummary(fileres, agemin, agemax, s, agev, nlstate, imx,Tvaraff,nbcode, ncodemax,mint,anint); */ 7454: /* ,dateprev1,dateprev2,jprev1, mprev1,anprev1,jprev2, mprev2,anprev2); */ 7455: 7456: replace_back_to_slash(pathc,pathcd); /* Even gnuplot wants a / */ 7457: if(ageminpar == AGEOVERFLOW ||agemaxpar == -AGEOVERFLOW){ 7458: printf("Warning! Error in gnuplot file with ageminpar %f or agemaxpar %f overflow\n\ 7459: This is probably because your parameter file doesn't \n contain the exact number of lines (or columns) corresponding to your model line.\n\ 7460: Please run with mle=-1 to get a correct covariance matrix.\n",ageminpar,agemaxpar); 7461: fprintf(ficlog,"Warning! Error in gnuplot file with ageminpar %f or agemaxpar %f overflow\n\ 7462: This is probably because your parameter file doesn't \n contain the exact number of lines (or columns) corresponding to your model line.\n\ 7463: Please run with mle=-1 to get a correct covariance matrix.\n",ageminpar,agemaxpar); 7464: }else 7465: printinggnuplot(fileres, optionfilefiname,ageminpar,agemaxpar,fage, pathc,p); 7466: 7467: printinghtml(fileres,title,datafile, firstpass, lastpass, stepm, weightopt,\ 7468: model,imx,jmin,jmax,jmean,rfileres,popforecast,estepm,\ 7469: jprev1,mprev1,anprev1,jprev2,mprev2,anprev2); 7470: 7471: /*------------ free_vector -------------*/ 7472: /* chdir(path); */ 7473: 7474: free_ivector(wav,1,imx); 7475: free_imatrix(dh,1,lastpass-firstpass+1,1,imx); 7476: free_imatrix(bh,1,lastpass-firstpass+1,1,imx); 7477: free_imatrix(mw,1,lastpass-firstpass+1,1,imx); 7478: free_lvector(num,1,n); 7479: free_vector(agedc,1,n); 7480: /*free_matrix(covar,0,NCOVMAX,1,n);*/ 7481: /*free_matrix(covar,1,NCOVMAX,1,n);*/ 7482: fclose(ficparo); 7483: fclose(ficres); 7484: 7485: 7486: /* Other results (useful)*/ 7487: 7488: 7489: /*--------------- Prevalence limit (period or stable prevalence) --------------*/ 7490: /*#include "prevlim.h"*/ /* Use ficrespl, ficlog */ 7491: prlim=matrix(1,nlstate,1,nlstate); 7492: prevalence_limit(p, prlim, ageminpar, agemaxpar); 7493: fclose(ficrespl); 7494: 7495: #ifdef FREEEXIT2 7496: #include "freeexit2.h" 7497: #endif 7498: 7499: /*------------- h Pij x at various ages ------------*/ 7500: /*#include "hpijx.h"*/ 7501: hPijx(p, bage, fage); 7502: fclose(ficrespij); 7503: 7504: /*-------------- Variance of one-step probabilities---*/ 7505: k=1; 7506: varprob(optionfilefiname, matcov, p, delti, nlstate, bage, fage,k,Tvar,nbcode, ncodemax,strstart); 7507: 7508: 7509: probs= ma3x(1,AGESUP,1,NCOVMAX, 1,NCOVMAX); 7510: for(i=1;i<=AGESUP;i++) 7511: for(j=1;j<=NCOVMAX;j++) 7512: for(k=1;k<=NCOVMAX;k++) 7513: probs[i][j][k]=0.; 7514: 7515: /*---------- Forecasting ------------------*/ 7516: /*if((stepm == 1) && (strcmp(model,".")==0)){*/ 7517: if(prevfcast==1){ 7518: /* if(stepm ==1){*/ 7519: prevforecast(fileres, anproj1, mproj1, jproj1, agemin, agemax, dateprev1, dateprev2, mobilavproj, bage, fage, firstpass, lastpass, anproj2, p, cptcoveff); 7520: /* (popforecast==1) populforecast(fileres, anpyram,mpyram,jpyram, agemin,agemax, dateprev1, dateprev2,mobilav, agedeb, fage, popforecast, popfile, anpyram1,p, i1);*/ 7521: /* } */ 7522: /* else{ */ 7523: /* erreur=108; */ 7524: /* printf("Warning %d!! You can only forecast the prevalences if the optimization\n has been performed with stepm = 1 (month) instead of %d or model=. instead of '%s'\n", erreur, stepm, model); */ 7525: /* fprintf(ficlog,"Warning %d!! You can only forecast the prevalences if the optimization\n has been performed with stepm = 1 (month) instead of %d or model=. instead of '%s'\n", erreur, stepm, model); */ 7526: /* } */ 7527: } 7528: 7529: /* ------ Other prevalence ratios------------ */ 7530: 7531: /* Computes prevalence between agemin (i.e minimal age computed) and no more ageminpar */ 7532: 7533: prevalence(probs, agemin, agemax, s, agev, nlstate, imx, Tvar, nbcode, ncodemax, mint, anint, dateprev1, dateprev2, firstpass, lastpass); 7534: /* printf("ageminpar=%f, agemax=%f, s[lastpass][imx]=%d, agev[lastpass][imx]=%f, nlstate=%d, imx=%d, mint[lastpass][imx]=%f, anint[lastpass][imx]=%f,dateprev1=%f, dateprev2=%f, firstpass=%d, lastpass=%d\n",\ 7535: ageminpar, agemax, s[lastpass][imx], agev[lastpass][imx], nlstate, imx, mint[lastpass][imx],anint[lastpass][imx], dateprev1, dateprev2, firstpass, lastpass); 7536: */ 7537: 7538: if (mobilav!=0) { 7539: mobaverage= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 7540: if (movingaverage(probs, bage, fage, mobaverage,mobilav)!=0){ 7541: fprintf(ficlog," Error in movingaverage mobilav=%d\n",mobilav); 7542: printf(" Error in movingaverage mobilav=%d\n",mobilav); 7543: } 7544: } 7545: 7546: 7547: /*---------- Health expectancies, no variances ------------*/ 7548: 7549: strcpy(filerese,"e"); 7550: strcat(filerese,fileres); 7551: if((ficreseij=fopen(filerese,"w"))==NULL) { 7552: printf("Problem with Health Exp. resultfile: %s\n", filerese); exit(0); 7553: fprintf(ficlog,"Problem with Health Exp. resultfile: %s\n", filerese); exit(0); 7554: } 7555: printf("Computing Health Expectancies: result on file '%s' \n", filerese); 7556: fprintf(ficlog,"Computing Health Expectancies: result on file '%s' \n", filerese); 7557: /*for(cptcov=1,k=0;cptcov<=i1;cptcov++){ 7558: for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){*/ 7559: 7560: for (k=1; k <= (int) pow(2,cptcoveff); k++){ 7561: fprintf(ficreseij,"\n#****** "); 7562: for(j=1;j<=cptcoveff;j++) { 7563: fprintf(ficreseij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 7564: } 7565: fprintf(ficreseij,"******\n"); 7566: 7567: eij=ma3x(1,nlstate,1,nlstate,(int) bage, (int) fage); 7568: oldm=oldms;savm=savms; 7569: evsij(eij, p, nlstate, stepm, (int) bage, (int)fage, oldm, savm, k, estepm, strstart); 7570: 7571: free_ma3x(eij,1,nlstate,1,nlstate,(int) bage, (int)fage); 7572: /*}*/ 7573: } 7574: fclose(ficreseij); 7575: 7576: 7577: /*---------- Health expectancies and variances ------------*/ 7578: 7579: 7580: strcpy(filerest,"t"); 7581: strcat(filerest,fileres); 7582: if((ficrest=fopen(filerest,"w"))==NULL) { 7583: printf("Problem with total LE resultfile: %s\n", filerest);goto end; 7584: fprintf(ficlog,"Problem with total LE resultfile: %s\n", filerest);goto end; 7585: } 7586: printf("Computing Total Life expectancies with their standard errors: file '%s' \n", filerest); 7587: fprintf(ficlog,"Computing Total Life expectancies with their standard errors: file '%s' \n", filerest); 7588: 7589: 7590: strcpy(fileresstde,"stde"); 7591: strcat(fileresstde,fileres); 7592: if((ficresstdeij=fopen(fileresstde,"w"))==NULL) { 7593: printf("Problem with Health Exp. and std errors resultfile: %s\n", fileresstde); exit(0); 7594: fprintf(ficlog,"Problem with Health Exp. and std errors resultfile: %s\n", fileresstde); exit(0); 7595: } 7596: printf("Computing Health Expectancies and standard errors: result on file '%s' \n", fileresstde); 7597: fprintf(ficlog,"Computing Health Expectancies and standard errors: result on file '%s' \n", fileresstde); 7598: 7599: strcpy(filerescve,"cve"); 7600: strcat(filerescve,fileres); 7601: if((ficrescveij=fopen(filerescve,"w"))==NULL) { 7602: printf("Problem with Covar. Health Exp. resultfile: %s\n", filerescve); exit(0); 7603: fprintf(ficlog,"Problem with Covar. Health Exp. resultfile: %s\n", filerescve); exit(0); 7604: } 7605: printf("Computing Covar. of Health Expectancies: result on file '%s' \n", filerescve); 7606: fprintf(ficlog,"Computing Covar. of Health Expectancies: result on file '%s' \n", filerescve); 7607: 7608: strcpy(fileresv,"v"); 7609: strcat(fileresv,fileres); 7610: if((ficresvij=fopen(fileresv,"w"))==NULL) { 7611: printf("Problem with variance resultfile: %s\n", fileresv);exit(0); 7612: fprintf(ficlog,"Problem with variance resultfile: %s\n", fileresv);exit(0); 7613: } 7614: printf("Computing Variance-covariance of DFLEs: file '%s' \n", fileresv); 7615: fprintf(ficlog,"Computing Variance-covariance of DFLEs: file '%s' \n", fileresv); 7616: 7617: /*for(cptcov=1,k=0;cptcov<=i1;cptcov++){ 7618: for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){*/ 7619: 7620: for (k=1; k <= (int) pow(2,cptcoveff); k++){ 7621: fprintf(ficrest,"\n#****** "); 7622: for(j=1;j<=cptcoveff;j++) 7623: fprintf(ficrest,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 7624: fprintf(ficrest,"******\n"); 7625: 7626: fprintf(ficresstdeij,"\n#****** "); 7627: fprintf(ficrescveij,"\n#****** "); 7628: for(j=1;j<=cptcoveff;j++) { 7629: fprintf(ficresstdeij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 7630: fprintf(ficrescveij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 7631: } 7632: fprintf(ficresstdeij,"******\n"); 7633: fprintf(ficrescveij,"******\n"); 7634: 7635: fprintf(ficresvij,"\n#****** "); 7636: for(j=1;j<=cptcoveff;j++) 7637: fprintf(ficresvij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 7638: fprintf(ficresvij,"******\n"); 7639: 7640: eij=ma3x(1,nlstate,1,nlstate,(int) bage, (int) fage); 7641: oldm=oldms;savm=savms; 7642: cvevsij(eij, p, nlstate, stepm, (int) bage, (int)fage, oldm, savm, k, estepm, delti, matcov, strstart); 7643: /* 7644: */ 7645: /* goto endfree; */ 7646: 7647: vareij=ma3x(1,nlstate,1,nlstate,(int) bage, (int) fage); 7648: pstamp(ficrest); 7649: 7650: 7651: for(vpopbased=0; vpopbased <= popbased; vpopbased++){ /* Done for vpopbased=0 and vpopbased=1 if popbased==1*/ 7652: oldm=oldms;savm=savms; /* Segmentation fault */ 7653: cptcod= 0; /* To be deleted */ 7654: varevsij(optionfilefiname, vareij, matcov, p, delti, nlstate, stepm, (int) bage, (int) fage, oldm, savm, prlim, ftolpl,k, estepm, cptcov,cptcod,vpopbased,mobilav, strstart); /* cptcod not initialized Intel */ 7655: fprintf(ficrest,"# Total life expectancy with std error and decomposition into time to be expected in each health state\n# (weighted average of eij where weights are "); 7656: if(vpopbased==1) 7657: fprintf(ficrest,"the age specific prevalence observed (cross-sectionally) in the population i.e cross-sectionally\n in each health state (popbased=1) (mobilav=%d)\n",mobilav); 7658: else 7659: fprintf(ficrest,"the age specific period (stable) prevalences in each health state \n"); 7660: fprintf(ficrest,"# Age e.. (std) "); 7661: for (i=1;i<=nlstate;i++) fprintf(ficrest,"e.%d (std) ",i); 7662: fprintf(ficrest,"\n"); 7663: 7664: epj=vector(1,nlstate+1); 7665: for(age=bage; age <=fage ;age++){ 7666: prevalim(prlim, nlstate, p, age, oldm, savm,ftolpl,k); 7667: if (vpopbased==1) { 7668: if(mobilav ==0){ 7669: for(i=1; i<=nlstate;i++) 7670: prlim[i][i]=probs[(int)age][i][k]; 7671: }else{ /* mobilav */ 7672: for(i=1; i<=nlstate;i++) 7673: prlim[i][i]=mobaverage[(int)age][i][k]; 7674: } 7675: } 7676: 7677: fprintf(ficrest," %4.0f",age); 7678: for(j=1, epj[nlstate+1]=0.;j <=nlstate;j++){ 7679: for(i=1, epj[j]=0.;i <=nlstate;i++) { 7680: epj[j] += prlim[i][i]*eij[i][j][(int)age]; 7681: /* printf("%lf %lf ", prlim[i][i] ,eij[i][j][(int)age]);*/ 7682: } 7683: epj[nlstate+1] +=epj[j]; 7684: } 7685: 7686: for(i=1, vepp=0.;i <=nlstate;i++) 7687: for(j=1;j <=nlstate;j++) 7688: vepp += vareij[i][j][(int)age]; 7689: fprintf(ficrest," %7.3f (%7.3f)", epj[nlstate+1],sqrt(vepp)); 7690: for(j=1;j <=nlstate;j++){ 7691: fprintf(ficrest," %7.3f (%7.3f)", epj[j],sqrt(vareij[j][j][(int)age])); 7692: } 7693: fprintf(ficrest,"\n"); 7694: } 7695: } 7696: free_ma3x(eij,1,nlstate,1,nlstate,(int) bage, (int)fage); 7697: free_ma3x(vareij,1,nlstate,1,nlstate,(int) bage, (int)fage); 7698: free_vector(epj,1,nlstate+1); 7699: /*}*/ 7700: } 7701: free_vector(weight,1,n); 7702: free_imatrix(Tvard,1,NCOVMAX,1,2); 7703: free_imatrix(s,1,maxwav+1,1,n); 7704: free_matrix(anint,1,maxwav,1,n); 7705: free_matrix(mint,1,maxwav,1,n); 7706: free_ivector(cod,1,n); 7707: free_ivector(tab,1,NCOVMAX); 7708: fclose(ficresstdeij); 7709: fclose(ficrescveij); 7710: fclose(ficresvij); 7711: fclose(ficrest); 7712: fclose(ficpar); 7713: 7714: /*------- Variance of period (stable) prevalence------*/ 7715: 7716: strcpy(fileresvpl,"vpl"); 7717: strcat(fileresvpl,fileres); 7718: if((ficresvpl=fopen(fileresvpl,"w"))==NULL) { 7719: printf("Problem with variance of period (stable) prevalence resultfile: %s\n", fileresvpl); 7720: exit(0); 7721: } 7722: printf("Computing Variance-covariance of period (stable) prevalence: file '%s' \n", fileresvpl); 7723: 7724: /*for(cptcov=1,k=0;cptcov<=i1;cptcov++){ 7725: for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){*/ 7726: 7727: for (k=1; k <= (int) pow(2,cptcoveff); k++){ 7728: fprintf(ficresvpl,"\n#****** "); 7729: for(j=1;j<=cptcoveff;j++) 7730: fprintf(ficresvpl,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); 7731: fprintf(ficresvpl,"******\n"); 7732: 7733: varpl=matrix(1,nlstate,(int) bage, (int) fage); 7734: oldm=oldms;savm=savms; 7735: varprevlim(fileres, varpl, matcov, p, delti, nlstate, stepm, (int) bage, (int) fage, oldm, savm, prlim, ftolpl,k,strstart); 7736: free_matrix(varpl,1,nlstate,(int) bage, (int)fage); 7737: /*}*/ 7738: } 7739: 7740: fclose(ficresvpl); 7741: 7742: /*---------- End : free ----------------*/ 7743: if (mobilav!=0) free_ma3x(mobaverage,1, AGESUP,1,NCOVMAX, 1,NCOVMAX); 7744: free_ma3x(probs,1,AGESUP,1,NCOVMAX, 1,NCOVMAX); 7745: } /* mle==-3 arrives here for freeing */ 7746: /* endfree:*/ 7747: free_matrix(prlim,1,nlstate,1,nlstate); /*here or after loop ? */ 7748: free_matrix(pmmij,1,nlstate+ndeath,1,nlstate+ndeath); 7749: free_matrix(oldms, 1,nlstate+ndeath,1,nlstate+ndeath); 7750: free_matrix(newms, 1,nlstate+ndeath,1,nlstate+ndeath); 7751: free_matrix(savms, 1,nlstate+ndeath,1,nlstate+ndeath); 7752: free_matrix(covar,0,NCOVMAX,1,n); 7753: free_matrix(matcov,1,npar,1,npar); 7754: /*free_vector(delti,1,npar);*/ 7755: free_ma3x(delti3,1,nlstate,1, nlstate+ndeath-1,1,ncovmodel); 7756: free_matrix(agev,1,maxwav,1,imx); 7757: free_ma3x(param,1,nlstate,1, nlstate+ndeath-1,1,ncovmodel); 7758: 7759: free_ivector(ncodemax,1,NCOVMAX); 7760: free_ivector(ncodemaxwundef,1,NCOVMAX); 7761: free_ivector(Tvar,1,NCOVMAX); 7762: free_ivector(Tprod,1,NCOVMAX); 7763: free_ivector(Tvaraff,1,NCOVMAX); 7764: free_ivector(Tage,1,NCOVMAX); 7765: 7766: free_imatrix(nbcode,0,NCOVMAX,0,NCOVMAX); 7767: free_imatrix(codtab,1,100,1,10); 7768: fflush(fichtm); 7769: fflush(ficgp); 7770: 7771: 7772: if((nberr >0) || (nbwarn>0)){ 7773: printf("End of Imach with %d errors and/or %d warnings\n",nberr,nbwarn); 7774: fprintf(ficlog,"End of Imach with %d errors and/or warnings %d\n",nberr,nbwarn); 7775: }else{ 7776: printf("End of Imach\n"); 7777: fprintf(ficlog,"End of Imach\n"); 7778: } 7779: printf("See log file on %s\n",filelog); 7780: /* gettimeofday(&end_time, (struct timezone*)0);*/ /* after time */ 7781: /*(void) gettimeofday(&end_time,&tzp);*/ 7782: rend_time = time(NULL); 7783: end_time = *localtime(&rend_time); 7784: /* tml = *localtime(&end_time.tm_sec); */ 7785: strcpy(strtend,asctime(&end_time)); 7786: printf("Local time at start %s\nLocal time at end %s",strstart, strtend); 7787: fprintf(ficlog,"Local time at start %s\nLocal time at end %s\n",strstart, strtend); 7788: printf("Total time used %s\n", asc_diff_time(rend_time -rstart_time,tmpout)); 7789: 7790: printf("Total time was %.0lf Sec.\n", difftime(rend_time,rstart_time)); 7791: fprintf(ficlog,"Total time used %s\n", asc_diff_time(rend_time -rstart_time,tmpout)); 7792: fprintf(ficlog,"Total time was %.0lf Sec.\n", difftime(rend_time,rstart_time)); 7793: /* printf("Total time was %d uSec.\n", total_usecs);*/ 7794: /* if(fileappend(fichtm,optionfilehtm)){ */ 7795: fprintf(fichtm," Local time at start %s Local time at end %s \n</body></html>",strstart, strtend); 7796: fclose(fichtm); 7797: fprintf(fichtmcov," Local time at start %s Local time at end %s \n</body></html>",strstart, strtend); 7798: fclose(fichtmcov); 7799: fclose(ficgp); 7800: fclose(ficlog); 7801: /*------ End -----------*/ 7802: 7803: 7804: printf("Before Current directory %s!\n",pathcd); 7805: #ifdef WIN32 7806: if (_chdir(pathcd) != 0) 7807: printf("Can't move to directory %s!\n",path); 7808: if(_getcwd(pathcd,MAXLINE) > 0) 7809: #else 7810: if(chdir(pathcd) != 0) 7811: printf("Can't move to directory %s!\n", path); 7812: if (getcwd(pathcd, MAXLINE) > 0) 7813: #endif 7814: printf("Current directory %s!\n",pathcd); 7815: /*strcat(plotcmd,CHARSEPARATOR);*/ 7816: sprintf(plotcmd,"gnuplot"); 7817: #ifdef _WIN32 7818: sprintf(plotcmd,"\"%sgnuplot.exe\"",pathimach); 7819: #endif 7820: if(!stat(plotcmd,&info)){ 7821: printf("Error or gnuplot program not found: '%s'\n",plotcmd);fflush(stdout); 7822: if(!stat(getenv("GNUPLOTBIN"),&info)){ 7823: printf("Error or gnuplot program not found: '%s' Environment GNUPLOTBIN not set.\n",plotcmd);fflush(stdout); 7824: }else 7825: strcpy(pplotcmd,plotcmd); 7826: #ifdef __unix 7827: strcpy(plotcmd,GNUPLOTPROGRAM); 7828: if(!stat(plotcmd,&info)){ 7829: printf("Error gnuplot program not found: '%s'\n",plotcmd);fflush(stdout); 7830: }else 7831: strcpy(pplotcmd,plotcmd); 7832: #endif 7833: }else 7834: strcpy(pplotcmd,plotcmd); 7835: 7836: sprintf(plotcmd,"%s %s",pplotcmd, optionfilegnuplot); 7837: printf("Starting graphs with: '%s'\n",plotcmd);fflush(stdout); 7838: 7839: if((outcmd=system(plotcmd)) != 0){ 7840: printf("gnuplot command might not be in your path: '%s', err=%d\n", plotcmd, outcmd); 7841: printf("\n Trying if gnuplot resides on the same directory that IMaCh\n"); 7842: sprintf(plotcmd,"%sgnuplot %s", pathimach, optionfilegnuplot); 7843: if((outcmd=system(plotcmd)) != 0) 7844: printf("\n Still a problem with gnuplot command %s, err=%d\n", plotcmd, outcmd); 7845: } 7846: printf(" Successful, please wait..."); 7847: while (z[0] != 'q') { 7848: /* chdir(path); */ 7849: printf("\nType e to edit results with your browser, g to graph again and q for exit: "); 7850: scanf("%s",z); 7851: /* if (z[0] == 'c') system("./imach"); */ 7852: if (z[0] == 'e') { 7853: #ifdef __APPLE__ 7854: sprintf(pplotcmd, "open %s", optionfilehtm); 7855: #elif __linux 7856: sprintf(pplotcmd, "xdg-open %s", optionfilehtm); 7857: #else 7858: sprintf(pplotcmd, "%s", optionfilehtm); 7859: #endif 7860: printf("Starting browser with: %s",pplotcmd);fflush(stdout); 7861: system(pplotcmd); 7862: } 7863: else if (z[0] == 'g') system(plotcmd); 7864: else if (z[0] == 'q') exit(0); 7865: } 7866: end: 7867: while (z[0] != 'q') { 7868: printf("\nType q for exiting: "); fflush(stdout); 7869: scanf("%s",z); 7870: } 7871: }