/* $Id: imach.c,v 1.179 2015/01/04 09:57:06 brouard Exp $ $State: Exp $ $Log: imach.c,v $ Revision 1.179 2015/01/04 09:57:06 brouard Summary: back to OS/X Revision 1.178 2015/01/04 09:35:48 brouard *** empty log message *** Revision 1.177 2015/01/03 18:40:56 brouard Summary: Still testing ilc32 on OSX Revision 1.176 2015/01/03 16:45:04 brouard *** empty log message *** Revision 1.175 2015/01/03 16:33:42 brouard *** empty log message *** Revision 1.174 2015/01/03 16:15:49 brouard Summary: Still in cross-compilation Revision 1.173 2015/01/03 12:06:26 brouard Summary: trying to detect cross-compilation Revision 1.172 2014/12/27 12:07:47 brouard Summary: Back from Visual Studio and Intel, options for compiling for Windows XP Revision 1.171 2014/12/23 13:26:59 brouard Summary: Back from Visual C Still problem with utsname.h on Windows Revision 1.170 2014/12/23 11:17:12 brouard Summary: Cleaning some \%% back to %% The escape was mandatory for a specific compiler (which one?), but too many warnings. Revision 1.169 2014/12/22 23:08:31 brouard Summary: 0.98p Outputs some informations on compiler used, OS etc. Testing on different platforms. Revision 1.168 2014/12/22 15:17:42 brouard Summary: update Revision 1.167 2014/12/22 13:50:56 brouard Summary: Testing uname and compiler version and if compiled 32 or 64 Testing on Linux 64 Revision 1.166 2014/12/22 11:40:47 brouard *** empty log message *** Revision 1.165 2014/12/16 11:20:36 brouard Summary: After compiling on Visual C * imach.c (Module): Merging 1.61 to 1.162 Revision 1.164 2014/12/16 10:52:11 brouard Summary: Merging with Visual C after suppressing some warnings for unused variables. Also fixing Saito's bug 0.98Xn * imach.c (Module): Merging 1.61 to 1.162 Revision 1.163 2014/12/16 10:30:11 brouard * imach.c (Module): Merging 1.61 to 1.162 Revision 1.162 2014/09/25 11:43:39 brouard Summary: temporary backup 0.99! Revision 1.1 2014/09/16 11:06:58 brouard Summary: With some code (wrong) for nlopt Author: Revision 1.161 2014/09/15 20:41:41 brouard Summary: Problem with macro SQR on Intel compiler Revision 1.160 2014/09/02 09:24:05 brouard *** empty log message *** Revision 1.159 2014/09/01 10:34:10 brouard Summary: WIN32 Author: Brouard Revision 1.158 2014/08/27 17:11:51 brouard *** empty log message *** Revision 1.157 2014/08/27 16:26:55 brouard Summary: Preparing windows Visual studio version Author: Brouard In order to compile on Visual studio, time.h is now correct and time_t and tm struct should be used. difftime should be used but sometimes I just make the differences in raw time format (time(&now). Trying to suppress #ifdef LINUX Add xdg-open for __linux in order to open default browser. Revision 1.156 2014/08/25 20:10:10 brouard *** empty log message *** Revision 1.155 2014/08/25 18:32:34 brouard Summary: New compile, minor changes Author: Brouard Revision 1.154 2014/06/20 17:32:08 brouard Summary: Outputs now all graphs of convergence to period prevalence Revision 1.153 2014/06/20 16:45:46 brouard Summary: If 3 live state, convergence to period prevalence on same graph Author: Brouard Revision 1.152 2014/06/18 17:54:09 brouard Summary: open browser, use gnuplot on same dir than imach if not found in the path Revision 1.151 2014/06/18 16:43:30 brouard *** empty log message *** Revision 1.150 2014/06/18 16:42:35 brouard Summary: If gnuplot is not in the path try on same directory than imach binary (OSX) Author: brouard Revision 1.149 2014/06/18 15:51:14 brouard Summary: Some fixes in parameter files errors Author: Nicolas Brouard Revision 1.148 2014/06/17 17:38:48 brouard Summary: Nothing new Author: Brouard Just a new packaging for OS/X version 0.98nS Revision 1.147 2014/06/16 10:33:11 brouard *** empty log message *** Revision 1.146 2014/06/16 10:20:28 brouard Summary: Merge Author: Brouard Merge, before building revised version. Revision 1.145 2014/06/10 21:23:15 brouard Summary: Debugging with valgrind Author: Nicolas Brouard Lot of changes in order to output the results with some covariates After the Edimburgh REVES conference 2014, it seems mandatory to improve the code. No more memory valgrind error but a lot has to be done in order to continue the work of splitting the code into subroutines. Also, decodemodel has been improved. Tricode is still not optimal. nbcode should be improved. Documentation has been added in the source code. Revision 1.143 2014/01/26 09:45:38 brouard Summary: Version 0.98nR (to be improved, but gives same optimization results as 0.98k. Nice, promising * imach.c (Module): Trying to merge old staffs together while being at Tokyo. Not tested... (Module): Version 0.98nR Running ok, but output format still only works for three covariates. Revision 1.142 2014/01/26 03:57:36 brouard Summary: gnuplot changed plot w l 1 has to be changed to plot w l lt 2 * imach.c (Module): Trying to merge old staffs together while being at Tokyo. Not tested... Revision 1.141 2014/01/26 02:42:01 brouard * imach.c (Module): Trying to merge old staffs together while being at Tokyo. Not tested... Revision 1.140 2011/09/02 10:37:54 brouard Summary: times.h is ok with mingw32 now. Revision 1.139 2010/06/14 07:50:17 brouard After the theft of my laptop, I probably lost some lines of codes which were not uploaded to the CVS tree. I remember having already fixed agemin agemax which are pointers now but not cvs saved. Revision 1.138 2010/04/30 18:19:40 brouard *** empty log message *** Revision 1.137 2010/04/29 18:11:38 brouard (Module): Checking covariates for more complex models than V1+V2. A lot of change to be done. Unstable. Revision 1.136 2010/04/26 20:30:53 brouard (Module): merging some libgsl code. Fixing computation of likelione (using inter/intrapolation if mle = 0) in order to get same likelihood as if mle=1. Some cleaning of code and comments added. Revision 1.135 2009/10/29 15:33:14 brouard (Module): Now imach stops if date of birth, at least year of birth, is not given. Some cleaning of the code. Revision 1.134 2009/10/29 13:18:53 brouard (Module): Now imach stops if date of birth, at least year of birth, is not given. Some cleaning of the code. Revision 1.133 2009/07/06 10:21:25 brouard just nforces Revision 1.132 2009/07/06 08:22:05 brouard Many tings Revision 1.131 2009/06/20 16:22:47 brouard Some dimensions resccaled Revision 1.130 2009/05/26 06:44:34 brouard (Module): Max Covariate is now set to 20 instead of 8. A lot of cleaning with variables initialized to 0. Trying to make V2+V3*age+V1+V4 strb=V3*age+V1+V4 working better. Revision 1.129 2007/08/31 13:49:27 lievre Modification of the way of exiting when the covariate is not binary in order to see on the window the error message before exiting Revision 1.128 2006/06/30 13:02:05 brouard (Module): Clarifications on computing e.j Revision 1.127 2006/04/28 18:11:50 brouard (Module): Yes the sum of survivors was wrong since imach-114 because nhstepm was no more computed in the age loop. Now we define nhstepma in the age loop. (Module): In order to speed up (in case of numerous covariates) we compute health expectancies (without variances) in a first step and then all the health expectancies with variances or standard deviation (needs data from the Hessian matrices) which slows the computation. In the future we should be able to stop the program is only health expectancies and graph are needed without standard deviations. Revision 1.126 2006/04/28 17:23:28 brouard (Module): Yes the sum of survivors was wrong since imach-114 because nhstepm was no more computed in the age loop. Now we define nhstepma in the age loop. Version 0.98h Revision 1.125 2006/04/04 15:20:31 lievre Errors in calculation of health expectancies. Age was not initialized. Forecasting file added. Revision 1.124 2006/03/22 17:13:53 lievre Parameters are printed with %lf instead of %f (more numbers after the comma). The log-likelihood is printed in the log file Revision 1.123 2006/03/20 10:52:43 brouard * imach.c (Module):
=(p+1))(v[j-p-1] = t[j]); */
/* } */
/* } */
#ifdef _WIN32
char * strsep(char **pp, const char *delim)
{
char *p, *q;
if ((p = *pp) == NULL)
return 0;
if ((q = strpbrk (p, delim)) != NULL)
{
*pp = q + 1;
*q = '\0';
}
else
*pp = 0;
return p;
}
#endif
/********************** nrerror ********************/
void nrerror(char error_text[])
{
fprintf(stderr,"ERREUR ...\n");
fprintf(stderr,"%s\n",error_text);
exit(EXIT_FAILURE);
}
/*********************** vector *******************/
double *vector(int nl, int nh)
{
double *v;
v=(double *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(double)));
if (!v) nrerror("allocation failure in vector");
return v-nl+NR_END;
}
/************************ free vector ******************/
void free_vector(double*v, int nl, int nh)
{
free((FREE_ARG)(v+nl-NR_END));
}
/************************ivector *******************************/
int *ivector(long nl,long nh)
{
int *v;
v=(int *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(int)));
if (!v) nrerror("allocation failure in ivector");
return v-nl+NR_END;
}
/******************free ivector **************************/
void free_ivector(int *v, long nl, long nh)
{
free((FREE_ARG)(v+nl-NR_END));
}
/************************lvector *******************************/
long *lvector(long nl,long nh)
{
long *v;
v=(long *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(long)));
if (!v) nrerror("allocation failure in ivector");
return v-nl+NR_END;
}
/******************free lvector **************************/
void free_lvector(long *v, long nl, long nh)
{
free((FREE_ARG)(v+nl-NR_END));
}
/******************* imatrix *******************************/
int **imatrix(long nrl, long nrh, long ncl, long nch)
/* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */
{
long i, nrow=nrh-nrl+1,ncol=nch-ncl+1;
int **m;
/* allocate pointers to rows */
m=(int **) malloc((size_t)((nrow+NR_END)*sizeof(int*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
/* allocate rows and set pointers to them */
m[nrl]=(int *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(int)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
/****************** free_imatrix *************************/
void free_imatrix(m,nrl,nrh,ncl,nch)
int **m;
long nch,ncl,nrh,nrl;
/* free an int matrix allocated by imatrix() */
{
free((FREE_ARG) (m[nrl]+ncl-NR_END));
free((FREE_ARG) (m+nrl-NR_END));
}
/******************* matrix *******************************/
double **matrix(long nrl, long nrh, long ncl, long nch)
{
long i, nrow=nrh-nrl+1, ncol=nch-ncl+1;
double **m;
m=(double **) malloc((size_t)((nrow+NR_END)*sizeof(double*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
m[nrl]=(double *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol;
return m;
/* print *(*(m+1)+70) or print m[1][70]; print m+1 or print &(m[1]) or &(m[1][0])
m[i] = address of ith row of the table. &(m[i]) is its value which is another adress
that of m[i][0]. In order to get the value p m[i][0] but it is unitialized.
*/
}
/*************************free matrix ************************/
void free_matrix(double **m, long nrl, long nrh, long ncl, long nch)
{
free((FREE_ARG)(m[nrl]+ncl-NR_END));
free((FREE_ARG)(m+nrl-NR_END));
}
/******************* ma3x *******************************/
double ***ma3x(long nrl, long nrh, long ncl, long nch, long nll, long nlh)
{
long i, j, nrow=nrh-nrl+1, ncol=nch-ncl+1, nlay=nlh-nll+1;
double ***m;
m=(double ***) malloc((size_t)((nrow+NR_END)*sizeof(double*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
m[nrl]=(double **) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol;
m[nrl][ncl]=(double *) malloc((size_t)((nrow*ncol*nlay+NR_END)*sizeof(double)));
if (!m[nrl][ncl]) nrerror("allocation failure 3 in matrix()");
m[nrl][ncl] += NR_END;
m[nrl][ncl] -= nll;
for (j=ncl+1; j<=nch; j++)
m[nrl][j]=m[nrl][j-1]+nlay;
for (i=nrl+1; i<=nrh; i++) {
m[i][ncl]=m[i-1l][ncl]+ncol*nlay;
for (j=ncl+1; j<=nch; j++)
m[i][j]=m[i][j-1]+nlay;
}
return m;
/* gdb: p *(m+1) <=> p m[1] and p (m+1) <=> p (m+1) <=> p &(m[1])
&(m[i][j][k]) <=> *((*(m+i) + j)+k)
*/
}
/*************************free ma3x ************************/
void free_ma3x(double ***m, long nrl, long nrh, long ncl, long nch,long nll, long nlh)
{
free((FREE_ARG)(m[nrl][ncl]+ nll-NR_END));
free((FREE_ARG)(m[nrl]+ncl-NR_END));
free((FREE_ARG)(m+nrl-NR_END));
}
/*************** function subdirf ***********/
char *subdirf(char fileres[])
{
/* Caution optionfilefiname is hidden */
strcpy(tmpout,optionfilefiname);
strcat(tmpout,"/"); /* Add to the right */
strcat(tmpout,fileres);
return tmpout;
}
/*************** function subdirf2 ***********/
char *subdirf2(char fileres[], char *preop)
{
/* Caution optionfilefiname is hidden */
strcpy(tmpout,optionfilefiname);
strcat(tmpout,"/");
strcat(tmpout,preop);
strcat(tmpout,fileres);
return tmpout;
}
/*************** function subdirf3 ***********/
char *subdirf3(char fileres[], char *preop, char *preop2)
{
/* Caution optionfilefiname is hidden */
strcpy(tmpout,optionfilefiname);
strcat(tmpout,"/");
strcat(tmpout,preop);
strcat(tmpout,preop2);
strcat(tmpout,fileres);
return tmpout;
}
char *asc_diff_time(long time_sec, char ascdiff[])
{
long sec_left, days, hours, minutes;
days = (time_sec) / (60*60*24);
sec_left = (time_sec) % (60*60*24);
hours = (sec_left) / (60*60) ;
sec_left = (sec_left) %(60*60);
minutes = (sec_left) /60;
sec_left = (sec_left) % (60);
sprintf(ascdiff,"%ld day(s) %ld hour(s) %ld minute(s) %ld second(s)",days, hours, minutes, sec_left);
return ascdiff;
}
/***************** f1dim *************************/
extern int ncom;
extern double *pcom,*xicom;
extern double (*nrfunc)(double []);
double f1dim(double x)
{
int j;
double f;
double *xt;
xt=vector(1,ncom);
for (j=1;j<=ncom;j++) xt[j]=pcom[j]+x*xicom[j];
f=(*nrfunc)(xt);
free_vector(xt,1,ncom);
return f;
}
/*****************brent *************************/
double brent(double ax, double bx, double cx, double (*f)(double), double tol, double *xmin)
{
int iter;
double a,b,d,etemp;
double fu=0,fv,fw,fx;
double ftemp=0.;
double p,q,r,tol1,tol2,u,v,w,x,xm;
double e=0.0;
a=(ax < cx ? ax : cx);
b=(ax > cx ? ax : cx);
x=w=v=bx;
fw=fv=fx=(*f)(x);
for (iter=1;iter<=ITMAX;iter++) {
xm=0.5*(a+b);
tol2=2.0*(tol1=tol*fabs(x)+ZEPS);
/* if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret)))*/
printf(".");fflush(stdout);
fprintf(ficlog,".");fflush(ficlog);
#ifdef DEBUGBRENT
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);
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);
/* if ((fabs(x-xm) <= (tol2-0.5*(b-a)))||(2.0*fabs(fu-ftemp) <= ftol*1.e-2*(fabs(fu)+fabs(ftemp)))) { */
#endif
if (fabs(x-xm) <= (tol2-0.5*(b-a))){
*xmin=x;
return fx;
}
ftemp=fu;
if (fabs(e) > tol1) {
r=(x-w)*(fx-fv);
q=(x-v)*(fx-fw);
p=(x-v)*q-(x-w)*r;
q=2.0*(q-r);
if (q > 0.0) p = -p;
q=fabs(q);
etemp=e;
e=d;
if (fabs(p) >= fabs(0.5*q*etemp) || p <= q*(a-x) || p >= q*(b-x))
d=CGOLD*(e=(x >= xm ? a-x : b-x));
else {
d=p/q;
u=x+d;
if (u-a < tol2 || b-u < tol2)
d=SIGN(tol1,xm-x);
}
} else {
d=CGOLD*(e=(x >= xm ? a-x : b-x));
}
u=(fabs(d) >= tol1 ? x+d : x+SIGN(tol1,d));
fu=(*f)(u);
if (fu <= fx) {
if (u >= x) a=x; else b=x;
SHFT(v,w,x,u)
SHFT(fv,fw,fx,fu)
} else {
if (u < x) a=u; else b=u;
if (fu <= fw || w == x) {
v=w;
w=u;
fv=fw;
fw=fu;
} else if (fu <= fv || v == x || v == w) {
v=u;
fv=fu;
}
}
}
nrerror("Too many iterations in brent");
*xmin=x;
return fx;
}
/****************** mnbrak ***********************/
void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, double *fc,
double (*func)(double))
{
double ulim,u,r,q, dum;
double fu;
*fa=(*func)(*ax);
*fb=(*func)(*bx);
if (*fb > *fa) {
SHFT(dum,*ax,*bx,dum)
SHFT(dum,*fb,*fa,dum)
}
*cx=(*bx)+GOLD*(*bx-*ax);
*fc=(*func)(*cx);
while (*fb > *fc) { /* Declining fa, fb, fc */
r=(*bx-*ax)*(*fb-*fc);
q=(*bx-*cx)*(*fb-*fa);
u=(*bx)-((*bx-*cx)*q-(*bx-*ax)*r)/
(2.0*SIGN(FMAX(fabs(q-r),TINY),q-r)); /* Minimum abscisse of a parabolic estimated from (a,fa), (b,fb) and (c,fc). */
ulim=(*bx)+GLIMIT*(*cx-*bx); /* Maximum abscisse where function can be evaluated */
if ((*bx-u)*(u-*cx) > 0.0) { /* if u between b and c */
fu=(*func)(u);
#ifdef DEBUG
/* f(x)=A(x-u)**2+f(u) */
double A, fparabu;
A= (*fb - *fa)/(*bx-*ax)/(*bx+*ax-2*u);
fparabu= *fa - A*(*ax-u)*(*ax-u);
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);
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);
#endif
} else if ((*cx-u)*(u-ulim) > 0.0) { /* u is after c but before ulim */
fu=(*func)(u);
if (fu < *fc) {
SHFT(*bx,*cx,u,*cx+GOLD*(*cx-*bx))
SHFT(*fb,*fc,fu,(*func)(u))
}
} else if ((u-ulim)*(ulim-*cx) >= 0.0) { /* u outside ulim (verifying that ulim is beyond c) */
u=ulim;
fu=(*func)(u);
} else {
u=(*cx)+GOLD*(*cx-*bx);
fu=(*func)(u);
}
SHFT(*ax,*bx,*cx,u)
SHFT(*fa,*fb,*fc,fu)
}
}
/*************** linmin ************************/
/* Given an n -dimensional point p[1..n] and an n -dimensional direction xi[1..n] , moves and
resets p to where the function func(p) takes on a minimum along the direction xi from p ,
and replaces xi by the actual vector displacement that p was moved. Also returns as fret
the value of func at the returned location p . This is actually all accomplished by calling the
routines mnbrak and brent .*/
int ncom;
double *pcom,*xicom;
double (*nrfunc)(double []);
void linmin(double p[], double xi[], int n, double *fret,double (*func)(double []))
{
double brent(double ax, double bx, double cx,
double (*f)(double), double tol, double *xmin);
double f1dim(double x);
void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb,
double *fc, double (*func)(double));
int j;
double xx,xmin,bx,ax;
double fx,fb,fa;
ncom=n;
pcom=vector(1,n);
xicom=vector(1,n);
nrfunc=func;
for (j=1;j<=n;j++) {
pcom[j]=p[j];
xicom[j]=xi[j];
}
ax=0.0;
xx=1.0;
mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,f1dim); /* Find a bracket a,x,b in direction n=xi ie xicom */
*fret=brent(ax,xx,bx,f1dim,TOL,&xmin); /* Find a minimum P+lambda n in that direction (lambdamin), with TOL between abscisses */
#ifdef DEBUG
printf("retour brent fret=%.12e xmin=%.12e\n",*fret,xmin);
fprintf(ficlog,"retour brent fret=%.12e xmin=%.12e\n",*fret,xmin);
#endif
for (j=1;j<=n;j++) {
xi[j] *= xmin;
p[j] += xi[j];
}
free_vector(xicom,1,n);
free_vector(pcom,1,n);
}
/*************** powell ************************/
/*
Minimization of a function func of n variables. Input consists of an initial starting point
p[1..n] ; an initial matrix xi[1..n][1..n] , whose columns contain the initial set of di-
rections (usually the n unit vectors); and ftol , the fractional tolerance in the function value
such that failure to decrease by more than this amount on one iteration signals doneness. On
output, p is set to the best point found, xi is the then-current direction set, fret is the returned
function value at p , and iter is the number of iterations taken. The routine linmin is used.
*/
void powell(double p[], double **xi, int n, double ftol, int *iter, double *fret,
double (*func)(double []))
{
void linmin(double p[], double xi[], int n, double *fret,
double (*func)(double []));
int i,ibig,j;
double del,t,*pt,*ptt,*xit;
double fp,fptt;
double *xits;
int niterf, itmp;
pt=vector(1,n);
ptt=vector(1,n);
xit=vector(1,n);
xits=vector(1,n);
*fret=(*func)(p);
for (j=1;j<=n;j++) pt[j]=p[j];
rcurr_time = time(NULL);
for (*iter=1;;++(*iter)) {
fp=(*fret);
ibig=0;
del=0.0;
rlast_time=rcurr_time;
/* (void) gettimeofday(&curr_time,&tzp); */
rcurr_time = time(NULL);
curr_time = *localtime(&rcurr_time);
printf("\nPowell iter=%d -2*LL=%.12f %ld sec. %ld sec.",*iter,*fret, rcurr_time-rlast_time, rcurr_time-rstart_time);fflush(stdout);
fprintf(ficlog,"\nPowell iter=%d -2*LL=%.12f %ld sec. %ld sec.",*iter,*fret,rcurr_time-rlast_time, rcurr_time-rstart_time); fflush(ficlog);
/* fprintf(ficrespow,"%d %.12f %ld",*iter,*fret,curr_time.tm_sec-start_time.tm_sec); */
for (i=1;i<=n;i++) {
printf(" %d %.12f",i, p[i]);
fprintf(ficlog," %d %.12lf",i, p[i]);
fprintf(ficrespow," %.12lf", p[i]);
}
printf("\n");
fprintf(ficlog,"\n");
fprintf(ficrespow,"\n");fflush(ficrespow);
if(*iter <=3){
tml = *localtime(&rcurr_time);
strcpy(strcurr,asctime(&tml));
rforecast_time=rcurr_time;
itmp = strlen(strcurr);
if(strcurr[itmp-1]=='\n') /* Windows outputs with a new line */
strcurr[itmp-1]='\0';
printf("\nConsidering the time needed for the last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time);
fprintf(ficlog,"\nConsidering the time needed for this last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time);
for(niterf=10;niterf<=30;niterf+=10){
rforecast_time=rcurr_time+(niterf-*iter)*(rcurr_time-rlast_time);
forecast_time = *localtime(&rforecast_time);
strcpy(strfor,asctime(&forecast_time));
itmp = strlen(strfor);
if(strfor[itmp-1]=='\n')
strfor[itmp-1]='\0';
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);
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);
}
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) xit[j]=xi[j][i];
fptt=(*fret);
#ifdef DEBUG
printf("fret=%lf, %lf, %lf \n", *fret, *fret, *fret);
fprintf(ficlog, "fret=%lf, %lf, %lf \n", *fret, *fret, *fret);
#endif
printf("%d",i);fflush(stdout);
fprintf(ficlog,"%d",i);fflush(ficlog);
linmin(p,xit,n,fret,func);
if (fabs(fptt-(*fret)) > del) {
del=fabs(fptt-(*fret));
ibig=i;
}
#ifdef DEBUG
printf("%d %.12e",i,(*fret));
fprintf(ficlog,"%d %.12e",i,(*fret));
for (j=1;j<=n;j++) {
xits[j]=FMAX(fabs(p[j]-pt[j]),1.e-5);
printf(" x(%d)=%.12e",j,xit[j]);
fprintf(ficlog," x(%d)=%.12e",j,xit[j]);
}
for(j=1;j<=n;j++) {
printf(" p(%d)=%.12e",j,p[j]);
fprintf(ficlog," p(%d)=%.12e",j,p[j]);
}
printf("\n");
fprintf(ficlog,"\n");
#endif
} /* end i */
if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret))) {
#ifdef DEBUG
int k[2],l;
k[0]=1;
k[1]=-1;
printf("Max: %.12e",(*func)(p));
fprintf(ficlog,"Max: %.12e",(*func)(p));
for (j=1;j<=n;j++) {
printf(" %.12e",p[j]);
fprintf(ficlog," %.12e",p[j]);
}
printf("\n");
fprintf(ficlog,"\n");
for(l=0;l<=1;l++) {
for (j=1;j<=n;j++) {
ptt[j]=p[j]+(p[j]-pt[j])*k[l];
printf("l=%d j=%d ptt=%.12e, xits=%.12e, p=%.12e, xit=%.12e", l,j,ptt[j],xits[j],p[j],xit[j]);
fprintf(ficlog,"l=%d j=%d ptt=%.12e, xits=%.12e, p=%.12e, xit=%.12e", l,j,ptt[j],xits[j],p[j],xit[j]);
}
printf("func(ptt)=%.12e, deriv=%.12e\n",(*func)(ptt),(ptt[j]-p[j])/((*func)(ptt)-(*func)(p)));
fprintf(ficlog,"func(ptt)=%.12e, deriv=%.12e\n",(*func)(ptt),(ptt[j]-p[j])/((*func)(ptt)-(*func)(p)));
}
#endif
free_vector(xit,1,n);
free_vector(xits,1,n);
free_vector(ptt,1,n);
free_vector(pt,1,n);
return;
}
if (*iter == ITMAX) nrerror("powell exceeding maximum iterations.");
for (j=1;j<=n;j++) { /* Computes an extrapolated point */
ptt[j]=2.0*p[j]-pt[j];
xit[j]=p[j]-pt[j];
pt[j]=p[j];
}
fptt=(*func)(ptt);
if (fptt < fp) { /* If extrapolated point is better, decide if we keep that new direction or not */
/* (x1 f1=fp), (x2 f2=*fret), (x3 f3=fptt), (xm fm) */
/* From x1 (P0) distance of x2 is at h and x3 is 2h */
/* Let f"(x2) be the 2nd derivative equal everywhere. */
/* Then the parabolic through (x1,f1), (x2,f2) and (x3,f3) */
/* will reach at f3 = fm + h^2/2 f"m ; f" = (f1 -2f2 +f3 ) / h**2 */
/* f1-f3 = delta(2h) = 2 h**2 f'' = 2(f1- 2f2 +f3) */
/* Thus we compare delta(2h) with observed f1-f3 */
/* or best gain on one ancient line 'del' with total */
/* gain f1-f2 = f1 - f2 - 'del' with del */
/* t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)-del*SQR(fp-fptt); */
t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del);
t= t- del*SQR(fp-fptt);
printf("t1= %.12lf, t2= %.12lf, t=%.12lf\n", 2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del),del*SQR(fp-fptt),t);
fprintf(ficlog,"t1= %.12lf, t2= %.12lf, t=%.12lf\n", 2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del),del*SQR(fp-fptt),t);
#ifdef DEBUG
printf("t3= %.12lf, t4= %.12lf, t3*= %.12lf, t4*= %.12lf\n",SQR(fp-(*fret)-del),SQR(fp-fptt),
(fp-(*fret)-del)*(fp-(*fret)-del),(fp-fptt)*(fp-fptt));
fprintf(ficlog,"t3= %.12lf, t4= %.12lf, t3*= %.12lf, t4*= %.12lf\n",SQR(fp-(*fret)-del),SQR(fp-fptt),
(fp-(*fret)-del)*(fp-(*fret)-del),(fp-fptt)*(fp-fptt));
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);
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);
#endif
if (t < 0.0) { /* Then we use it for last direction */
linmin(p,xit,n,fret,func); /* computes mean on the extrapolated direction.*/
for (j=1;j<=n;j++) {
xi[j][ibig]=xi[j][n]; /* Replace the direction with biggest decrease by n */
xi[j][n]=xit[j]; /* and nth direction by the extrapolated */
}
printf("Gaining to use average direction of P0 P%d instead of biggest increase direction %d :\n",n,ibig);
fprintf(ficlog,"Gaining to use average direction of P0 P%d instead of biggest increase direction %d :\n",n,ibig);
#ifdef DEBUG
printf("Direction changed last moved %d in place of ibig=%d, new last is the average:\n",n,ibig);
fprintf(ficlog,"Direction changed last moved %d in place of ibig=%d, new last is the average:\n",n,ibig);
for(j=1;j<=n;j++){
printf(" %.12e",xit[j]);
fprintf(ficlog," %.12e",xit[j]);
}
printf("\n");
fprintf(ficlog,"\n");
#endif
} /* end of t negative */
} /* end if (fptt < fp) */
}
}
/**** Prevalence limit (stable or period prevalence) ****************/
double **prevalim(double **prlim, int nlstate, double x[], double age, double **oldm, double **savm, double ftolpl, int ij)
{
/* Computes the prevalence limit in each live state at age x by left multiplying the unit
matrix by transitions matrix until convergence is reached */
int i, ii,j,k;
double min, max, maxmin, maxmax,sumnew=0.;
/* double **matprod2(); */ /* test */
double **out, cov[NCOVMAX+1], **pmij();
double **newm;
double agefin, delaymax=50 ; /* Max number of years to converge */
for (ii=1;ii<=nlstate+ndeath;ii++)
for (j=1;j<=nlstate+ndeath;j++){
oldm[ii][j]=(ii==j ? 1.0 : 0.0);
}
cov[1]=1.;
/* Even if hstepm = 1, at least one multiplication by the unit matrix */
for(agefin=age-stepm/YEARM; agefin>=age-delaymax; agefin=agefin-stepm/YEARM){
newm=savm;
/* Covariates have to be included here again */
cov[2]=agefin;
for (k=1; k<=cptcovn;k++) {
cov[2+k]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]];
/*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]]);*/
}
/* for (k=1; k<=cptcovage;k++) cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2]; */
/* for (k=1; k<=cptcovprod;k++) /\* Useless *\/ */
/* cov[2+Tprod[k]]=nbcode[Tvard[k][1]][codtab[ij][Tvard[k][1]]] * nbcode[Tvard[k][2]][codtab[ij][Tvard[k][2]]]; */
/*printf("ij=%d cptcovprod=%d tvar=%d ", ij, cptcovprod, Tvar[1]);*/
/*printf("ij=%d cov[3]=%lf cov[4]=%lf \n",ij, cov[3],cov[4]);*/
/*printf("ij=%d cov[3]=%lf \n",ij, cov[3]);*/
/* savm=pmij(pmmij,cov,ncovmodel,x,nlstate); */
/* out=matprod2(newm, pmij(pmmij,cov,ncovmodel,x,nlstate),1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, oldm); /\* Bug Valgrind *\/ */
out=matprod2(newm, pmij(pmmij,cov,ncovmodel,x,nlstate),1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, oldm); /* Bug Valgrind */
savm=oldm;
oldm=newm;
maxmax=0.;
for(j=1;j<=nlstate;j++){
min=1.;
max=0.;
for(i=1; i<=nlstate; i++) {
sumnew=0;
for(k=1; k<=ndeath; k++) sumnew+=newm[i][nlstate+k];
prlim[i][j]= newm[i][j]/(1-sumnew);
/*printf(" prevalim i=%d, j=%d, prmlim[%d][%d]=%f, agefin=%d \n", i, j, i, j, prlim[i][j],(int)agefin);*/
max=FMAX(max,prlim[i][j]);
min=FMIN(min,prlim[i][j]);
}
maxmin=max-min;
maxmax=FMAX(maxmax,maxmin);
} /* j loop */
if(maxmax < ftolpl){
return prlim;
}
} /* age loop */
return prlim; /* should not reach here */
}
/*************** transition probabilities ***************/
double **pmij(double **ps, double *cov, int ncovmodel, double *x, int nlstate )
{
/* According to parameters values stored in x and the covariate's values stored in cov,
computes the probability to be observed in state j being in state i by appying the
model to the ncovmodel covariates (including constant and age).
lnpijopii=ln(pij/pii)= aij+bij*age+cij*v1+dij*v2+... = sum_nc=1^ncovmodel xij(nc)*cov[nc]
and, according on how parameters are entered, the position of the coefficient xij(nc) of the
ncth covariate in the global vector x is given by the formula:
j=i nc + ((i-1)*(nlstate+ndeath-1)+(j-2))*ncovmodel
Computes ln(pij/pii) (lnpijopii), deduces pij/pii by exponentiation,
sums on j different of i to get 1-pii/pii, deduces pii, and then all pij.
Outputs ps[i][j] the probability to be observed in j being in j according to
the values of the covariates cov[nc] and corresponding parameter values x[nc+shiftij]
*/
double s1, lnpijopii;
/*double t34;*/
int i,j, nc, ii, jj;
for(i=1; i<= nlstate; i++){
for(j=1; ji s1=%.17e, lnpijopii=%.17e %lx %lx\n",s1,lnpijopii,s1,lnpijopii); */
}
ps[i][j]=lnpijopii; /* In fact ln(pij/pii) */
}
}
for(i=1; i<= nlstate; i++){
s1=0;
for(j=1; ji} pij/pii=(1-pii)/pii and thus pii is known from s1 */
ps[i][i]=1./(s1+1.);
/* Computing other pijs */
for(j=1; jfunction)(xt); /* p xt[1]@8 is fine */
/* fret=(*func)(xt); /\* p xt[1]@8 is fine *\/ */
printf("Function = %.12lf ",fret);
for (j=1;j<=n;j++) printf(" %d %.8lf", j, xt[j]);
printf("\n");
free_vector(xt,1,n);
return fret;
}
#endif
/*************** log-likelihood *************/
double func( double *x)
{
int i, ii, j, k, mi, d, kk;
double l, ll[NLSTATEMAX+1], cov[NCOVMAX+1];
double **out;
double sw; /* Sum of weights */
double lli; /* Individual log likelihood */
int s1, s2;
double bbh, survp;
long ipmx;
/*extern weight */
/* We are differentiating ll according to initial status */
/* for (i=1;i<=npar;i++) printf("%f ", x[i]);*/
/*for(i=1;i ");
m=pow(2,cptcoveff);
if (cptcovn < 1) {m=1;ncodemax[1]=1;}
jj1=0;
for(k1=1; k1<=m;k1++){
for(i1=1; i1<=ncodemax[k1];i1++){
jj1++;
if (cptcovn > 0) {
fprintf(fichtm," ");
m=pow(2,cptcoveff);
if (cptcovn < 1) {m=1;ncodemax[1]=1;}
jj1=0;
for(k1=1; k1<=m;k1++){
for(i1=1; i1<=ncodemax[k1];i1++){
jj1++;
if (cptcovn > 0) {
fprintf(fichtm,"
File of contributions to the likelihood: %s
\n",subdirf(fileresilk),subdirf(fileresilk));
fflush(fichtm);
}
return;
}
/*********** Maximum Likelihood Estimation ***************/
void mlikeli(FILE *ficres,double p[], int npar, int ncovmodel, int nlstate, double ftol, double (*func)(double []))
{
int i,j, iter=0;
double **xi;
double fret;
double fretone; /* Only one call to likelihood */
/* char filerespow[FILENAMELENGTH];*/
#ifdef NLOPT
int creturn;
nlopt_opt opt;
/* double lb[9] = { -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL, -HUGE_VAL }; /\* lower bounds *\/ */
double *lb;
double minf; /* the minimum objective value, upon return */
double * p1; /* Shifted parameters from 0 instead of 1 */
myfunc_data dinst, *d = &dinst;
#endif
xi=matrix(1,npar,1,npar);
for (i=1;i<=npar;i++)
for (j=1;j<=npar;j++)
xi[i][j]=(i==j ? 1.0 : 0.0);
printf("Powell\n"); fprintf(ficlog,"Powell\n");
strcpy(filerespow,"pow");
strcat(filerespow,fileres);
if((ficrespow=fopen(filerespow,"w"))==NULL) {
printf("Problem with resultfile: %s\n", filerespow);
fprintf(ficlog,"Problem with resultfile: %s\n", filerespow);
}
fprintf(ficrespow,"# Powell\n# iter -2*LL");
for (i=1;i<=nlstate;i++)
for(j=1;j<=nlstate+ndeath;j++)
if(j!=i)fprintf(ficrespow," p%1d%1d",i,j);
fprintf(ficrespow,"\n");
#ifdef POWELL
powell(p,xi,npar,ftol,&iter,&fret,func);
#endif
#ifdef NLOPT
#ifdef NEWUOA
opt = nlopt_create(NLOPT_LN_NEWUOA,npar);
#else
opt = nlopt_create(NLOPT_LN_BOBYQA,npar);
#endif
lb=vector(0,npar-1);
for (i=0;i Computing probabilities of dying over estepm months as a weighted average (i.e global mortality independent of initial healh state)
%s
\n",digitp);
/* } */
varppt = matrix(nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath);
pstamp(ficresvij);
fprintf(ficresvij,"# Variance and covariance of health expectancies e.j \n# (weighted average of eij where weights are ");
if(popbased==1)
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);
else
fprintf(ficresvij,"the age specific period (stable) prevalences in each health state \n");
fprintf(ficresvij,"# Age");
for(i=1; i<=nlstate;i++)
for(j=1; j<=nlstate;j++)
fprintf(ficresvij," Cov(e.%1d, e.%1d)",i,j);
fprintf(ficresvij,"\n");
xp=vector(1,npar);
dnewm=matrix(1,nlstate,1,npar);
doldm=matrix(1,nlstate,1,nlstate);
dnewmp= matrix(nlstate+1,nlstate+ndeath,1,npar);
doldmp= matrix(nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath);
gradgp=matrix(1,npar,nlstate+1,nlstate+ndeath);
gpp=vector(nlstate+1,nlstate+ndeath);
gmp=vector(nlstate+1,nlstate+ndeath);
trgradgp =matrix(nlstate+1,nlstate+ndeath,1,npar); /* mu or p point j*/
if(estepm < stepm){
printf ("Problem %d lower than %d\n",estepm, stepm);
}
else hstepm=estepm;
/* For example we decided to compute the life expectancy with the smallest unit */
/* hstepm beeing the number of stepms, if hstepm=1 the length of hstepm is stepm.
nhstepm is the number of hstepm from age to agelim
nstepm is the number of stepm from age to agelin.
Look at function hpijx to understand why (it is linked to memory size questions) */
/* We decided (b) to get a life expectancy respecting the most precise curvature of the
survival function given by stepm (the optimization length). Unfortunately it
means that if the survival funtion is printed every two years of age and if
you sum them up and add 1 year (area under the trapezoids) you won't get the same
results. So we changed our mind and took the option of the best precision.
*/
hstepm=hstepm/stepm; /* Typically in stepm units, if stepm=6 & estepm=24 , = 24/6 months = 4 */
agelim = AGESUP;
for (age=bage; age<=fage; age ++){ /* If stepm=6 months */
nstepm=(int) rint((agelim-age)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */
nhstepm = nstepm/hstepm;/* Expressed in hstepm, typically nhstepm=40/4=10 */
p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm);
gradg=ma3x(0,nhstepm,1,npar,1,nlstate);
gp=matrix(0,nhstepm,1,nlstate);
gm=matrix(0,nhstepm,1,nlstate);
for(theta=1; theta <=npar; theta++){
for(i=1; i<=npar; i++){ /* Computes gradient x + delta*/
xp[i] = x[i] + (i==theta ?delti[theta]:0);
}
hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm, ij);
prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij);
if (popbased==1) {
if(mobilav ==0){
for(i=1; i<=nlstate;i++)
prlim[i][i]=probs[(int)age][i][ij];
}else{ /* mobilav */
for(i=1; i<=nlstate;i++)
prlim[i][i]=mobaverage[(int)age][i][ij];
}
}
for(j=1; j<= nlstate; j++){
for(h=0; h<=nhstepm; h++){
for(i=1, gp[h][j]=0.;i<=nlstate;i++)
gp[h][j] += prlim[i][i]*p3mat[i][j][h];
}
}
/* This for computing probability of death (h=1 means
computed over hstepm matrices product = hstepm*stepm months)
as a weighted average of prlim.
*/
for(j=nlstate+1;j<=nlstate+ndeath;j++){
for(i=1,gpp[j]=0.; i<= nlstate; i++)
gpp[j] += prlim[i][i]*p3mat[i][j][1];
}
/* end probability of death */
for(i=1; i<=npar; i++) /* Computes gradient x - delta */
xp[i] = x[i] - (i==theta ?delti[theta]:0);
hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm, ij);
prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij);
if (popbased==1) {
if(mobilav ==0){
for(i=1; i<=nlstate;i++)
prlim[i][i]=probs[(int)age][i][ij];
}else{ /* mobilav */
for(i=1; i<=nlstate;i++)
prlim[i][i]=mobaverage[(int)age][i][ij];
}
}
for(j=1; j<= nlstate; j++){ /* Sum of wi * eij = e.j */
for(h=0; h<=nhstepm; h++){
for(i=1, gm[h][j]=0.;i<=nlstate;i++)
gm[h][j] += prlim[i][i]*p3mat[i][j][h];
}
}
/* This for computing probability of death (h=1 means
computed over hstepm matrices product = hstepm*stepm months)
as a weighted average of prlim.
*/
for(j=nlstate+1;j<=nlstate+ndeath;j++){
for(i=1,gmp[j]=0.; i<= nlstate; i++)
gmp[j] += prlim[i][i]*p3mat[i][j][1];
}
/* end probability of death */
for(j=1; j<= nlstate; j++) /* vareij */
for(h=0; h<=nhstepm; h++){
gradg[h][theta][j]= (gp[h][j]-gm[h][j])/2./delti[theta];
}
for(j=nlstate+1; j<= nlstate+ndeath; j++){ /* var mu */
gradgp[theta][j]= (gpp[j]-gmp[j])/2./delti[theta];
}
} /* End theta */
trgradg =ma3x(0,nhstepm,1,nlstate,1,npar); /* veij */
for(h=0; h<=nhstepm; h++) /* veij */
for(j=1; j<=nlstate;j++)
for(theta=1; theta <=npar; theta++)
trgradg[h][j][theta]=gradg[h][theta][j];
for(j=nlstate+1; j<=nlstate+ndeath;j++) /* mu */
for(theta=1; theta <=npar; theta++)
trgradgp[j][theta]=gradgp[theta][j];
hf=hstepm*stepm/YEARM; /* Duration of hstepm expressed in year unit. */
for(i=1;i<=nlstate;i++)
for(j=1;j<=nlstate;j++)
vareij[i][j][(int)age] =0.;
for(h=0;h<=nhstepm;h++){
for(k=0;k<=nhstepm;k++){
matprod2(dnewm,trgradg[h],1,nlstate,1,npar,1,npar,matcov);
matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg[k]);
for(i=1;i<=nlstate;i++)
for(j=1;j<=nlstate;j++)
vareij[i][j][(int)age] += doldm[i][j]*hf*hf;
}
}
/* pptj */
matprod2(dnewmp,trgradgp,nlstate+1,nlstate+ndeath,1,npar,1,npar,matcov);
matprod2(doldmp,dnewmp,nlstate+1,nlstate+ndeath,1,npar,nlstate+1,nlstate+ndeath,gradgp);
for(j=nlstate+1;j<=nlstate+ndeath;j++)
for(i=nlstate+1;i<=nlstate+ndeath;i++)
varppt[j][i]=doldmp[j][i];
/* end ppptj */
/* x centered again */
hpxij(p3mat,nhstepm,age,hstepm,x,nlstate,stepm,oldm,savm, ij);
prevalim(prlim,nlstate,x,age,oldm,savm,ftolpl,ij);
if (popbased==1) {
if(mobilav ==0){
for(i=1; i<=nlstate;i++)
prlim[i][i]=probs[(int)age][i][ij];
}else{ /* mobilav */
for(i=1; i<=nlstate;i++)
prlim[i][i]=mobaverage[(int)age][i][ij];
}
}
/* This for computing probability of death (h=1 means
computed over hstepm (estepm) matrices product = hstepm*stepm months)
as a weighted average of prlim.
*/
for(j=nlstate+1;j<=nlstate+ndeath;j++){
for(i=1,gmp[j]=0.;i<= nlstate; i++)
gmp[j] += prlim[i][i]*p3mat[i][j][1];
}
/* end probability of death */
fprintf(ficresprobmorprev,"%3d %d ",(int) age, ij);
for(j=nlstate+1; j<=(nlstate+ndeath);j++){
fprintf(ficresprobmorprev," %11.3e %11.3e",gmp[j], sqrt(varppt[j][j]));
for(i=1; i<=nlstate;i++){
fprintf(ficresprobmorprev," %11.3e %11.3e ",prlim[i][i],p3mat[i][j][1]);
}
}
fprintf(ficresprobmorprev,"\n");
fprintf(ficresvij,"%.0f ",age );
for(i=1; i<=nlstate;i++)
for(j=1; j<=nlstate;j++){
fprintf(ficresvij," %.4f", vareij[i][j][(int)age]);
}
fprintf(ficresvij,"\n");
free_matrix(gp,0,nhstepm,1,nlstate);
free_matrix(gm,0,nhstepm,1,nlstate);
free_ma3x(gradg,0,nhstepm,1,npar,1,nlstate);
free_ma3x(trgradg,0,nhstepm,1,nlstate,1,npar);
free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm);
} /* End age */
free_vector(gpp,nlstate+1,nlstate+ndeath);
free_vector(gmp,nlstate+1,nlstate+ndeath);
free_matrix(gradgp,1,npar,nlstate+1,nlstate+ndeath);
free_matrix(trgradgp,nlstate+1,nlstate+ndeath,1,npar); /* mu or p point j*/
fprintf(ficgp,"\nunset parametric;unset label; set ter png small size 320, 240");
/* for(j=nlstate+1; j<= nlstate+ndeath; j++){ *//* Only the first actually */
fprintf(ficgp,"\n set log y; unset log x;set xlabel \"Age\"; set ylabel \"Force of mortality (year-1)\";");
/* fprintf(ficgp,"\n plot \"%s\" u 1:($3*%6.3f) not w l 1 ",fileresprobmorprev,YEARM/estepm); */
/* fprintf(ficgp,"\n replot \"%s\" u 1:(($3+1.96*$4)*%6.3f) t \"95\%% interval\" w l 2 ",fileresprobmorprev,YEARM/estepm); */
/* fprintf(ficgp,"\n replot \"%s\" u 1:(($3-1.96*$4)*%6.3f) not w l 2 ",fileresprobmorprev,YEARM/estepm); */
fprintf(ficgp,"\n plot \"%s\" u 1:($3) not w l lt 1 ",subdirf(fileresprobmorprev));
fprintf(ficgp,"\n replot \"%s\" u 1:(($3+1.96*$4)) t \"95%% interval\" w l lt 2 ",subdirf(fileresprobmorprev));
fprintf(ficgp,"\n replot \"%s\" u 1:(($3-1.96*$4)) not w l lt 2 ",subdirf(fileresprobmorprev));
fprintf(fichtm,"\n
File (multiple files are possible if covariates are present): %s\n",subdirf(fileresprobmorprev),subdirf(fileresprobmorprev));
fprintf(fichtm,"\n
Probability is computed over estepm=%d months.
\n", estepm,subdirf3(optionfilefiname,"varmuptjgr",digitp),digit);
/* 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
\n", stepm,YEARM,digitp,digit);
*/
/* fprintf(ficgp,"\nset out \"varmuptjgr%s%s%s.png\";replot;",digitp,optionfilefiname,digit); */
fprintf(ficgp,"\nset out \"%s%s.png\";replot;\n",subdirf3(optionfilefiname,"varmuptjgr",digitp),digit);
free_vector(xp,1,npar);
free_matrix(doldm,1,nlstate,1,nlstate);
free_matrix(dnewm,1,nlstate,1,npar);
free_matrix(doldmp,nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath);
free_matrix(dnewmp,nlstate+1,nlstate+ndeath,1,npar);
free_matrix(varppt,nlstate+1,nlstate+ndeath,nlstate+1,nlstate+ndeath);
if (mobilav!=0) free_ma3x(mobaverage,1, AGESUP,1,NCOVMAX, 1,NCOVMAX);
fclose(ficresprobmorprev);
fflush(ficgp);
fflush(fichtm);
} /* end varevsij */
/************ Variance of prevlim ******************/
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[])
{
/* Variance of prevalence limit */
/* double **prevalim(double **prlim, int nlstate, double *xp, double age, double **oldm, double **savm,double ftolpl);*/
double **dnewm,**doldm;
int i, j, nhstepm, hstepm;
double *xp;
double *gp, *gm;
double **gradg, **trgradg;
double age,agelim;
int theta;
pstamp(ficresvpl);
fprintf(ficresvpl,"# Standard deviation of period (stable) prevalences \n");
fprintf(ficresvpl,"# Age");
for(i=1; i<=nlstate;i++)
fprintf(ficresvpl," %1d-%1d",i,i);
fprintf(ficresvpl,"\n");
xp=vector(1,npar);
dnewm=matrix(1,nlstate,1,npar);
doldm=matrix(1,nlstate,1,nlstate);
hstepm=1*YEARM; /* Every year of age */
hstepm=hstepm/stepm; /* Typically in stepm units, if j= 2 years, = 2/6 months = 4 */
agelim = AGESUP;
for (age=bage; age<=fage; age ++){ /* If stepm=6 months */
nhstepm=(int) rint((agelim-age)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */
if (stepm >= YEARM) hstepm=1;
nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */
gradg=matrix(1,npar,1,nlstate);
gp=vector(1,nlstate);
gm=vector(1,nlstate);
for(theta=1; theta <=npar; theta++){
for(i=1; i<=npar; i++){ /* Computes gradient */
xp[i] = x[i] + (i==theta ?delti[theta]:0);
}
prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij);
for(i=1;i<=nlstate;i++)
gp[i] = prlim[i][i];
for(i=1; i<=npar; i++) /* Computes gradient */
xp[i] = x[i] - (i==theta ?delti[theta]:0);
prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij);
for(i=1;i<=nlstate;i++)
gm[i] = prlim[i][i];
for(i=1;i<=nlstate;i++)
gradg[theta][i]= (gp[i]-gm[i])/2./delti[theta];
} /* End theta */
trgradg =matrix(1,nlstate,1,npar);
for(j=1; j<=nlstate;j++)
for(theta=1; theta <=npar; theta++)
trgradg[j][theta]=gradg[theta][j];
for(i=1;i<=nlstate;i++)
varpl[i][(int)age] =0.;
matprod2(dnewm,trgradg,1,nlstate,1,npar,1,npar,matcov);
matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg);
for(i=1;i<=nlstate;i++)
varpl[i][(int)age] = doldm[i][i]; /* Covariances are useless */
fprintf(ficresvpl,"%.0f ",age );
for(i=1; i<=nlstate;i++)
fprintf(ficresvpl," %.5f (%.5f)",prlim[i][i],sqrt(varpl[i][(int)age]));
fprintf(ficresvpl,"\n");
free_vector(gp,1,nlstate);
free_vector(gm,1,nlstate);
free_matrix(gradg,1,npar,1,nlstate);
free_matrix(trgradg,1,nlstate,1,npar);
} /* End age */
free_vector(xp,1,npar);
free_matrix(doldm,1,nlstate,1,npar);
free_matrix(dnewm,1,nlstate,1,nlstate);
}
/************ Variance of one-step probabilities ******************/
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[])
{
int i, j=0, k1, l1, tj;
int k2, l2, j1, z1;
int k=0, l;
int first=1, first1, first2;
double cv12, mu1, mu2, lc1, lc2, v12, v21, v11, v22,v1,v2, c12, tnalp;
double **dnewm,**doldm;
double *xp;
double *gp, *gm;
double **gradg, **trgradg;
double **mu;
double age, cov[NCOVMAX+1];
double std=2.0; /* Number of standard deviation wide of confidence ellipsoids */
int theta;
char fileresprob[FILENAMELENGTH];
char fileresprobcov[FILENAMELENGTH];
char fileresprobcor[FILENAMELENGTH];
double ***varpij;
strcpy(fileresprob,"prob");
strcat(fileresprob,fileres);
if((ficresprob=fopen(fileresprob,"w"))==NULL) {
printf("Problem with resultfile: %s\n", fileresprob);
fprintf(ficlog,"Problem with resultfile: %s\n", fileresprob);
}
strcpy(fileresprobcov,"probcov");
strcat(fileresprobcov,fileres);
if((ficresprobcov=fopen(fileresprobcov,"w"))==NULL) {
printf("Problem with resultfile: %s\n", fileresprobcov);
fprintf(ficlog,"Problem with resultfile: %s\n", fileresprobcov);
}
strcpy(fileresprobcor,"probcor");
strcat(fileresprobcor,fileres);
if((ficresprobcor=fopen(fileresprobcor,"w"))==NULL) {
printf("Problem with resultfile: %s\n", fileresprobcor);
fprintf(ficlog,"Problem with resultfile: %s\n", fileresprobcor);
}
printf("Computing standard deviation of one-step probabilities: result on file '%s' \n",fileresprob);
fprintf(ficlog,"Computing standard deviation of one-step probabilities: result on file '%s' \n",fileresprob);
printf("Computing matrix of variance covariance of one-step probabilities: result on file '%s' \n",fileresprobcov);
fprintf(ficlog,"Computing matrix of variance covariance of one-step probabilities: result on file '%s' \n",fileresprobcov);
printf("and correlation matrix of one-step probabilities: result on file '%s' \n",fileresprobcor);
fprintf(ficlog,"and correlation matrix of one-step probabilities: result on file '%s' \n",fileresprobcor);
pstamp(ficresprob);
fprintf(ficresprob,"#One-step probabilities and stand. devi in ()\n");
fprintf(ficresprob,"# Age");
pstamp(ficresprobcov);
fprintf(ficresprobcov,"#One-step probabilities and covariance matrix\n");
fprintf(ficresprobcov,"# Age");
pstamp(ficresprobcor);
fprintf(ficresprobcor,"#One-step probabilities and correlation matrix\n");
fprintf(ficresprobcor,"# Age");
for(i=1; i<=nlstate;i++)
for(j=1; j<=(nlstate+ndeath);j++){
fprintf(ficresprob," p%1d-%1d (SE)",i,j);
fprintf(ficresprobcov," p%1d-%1d ",i,j);
fprintf(ficresprobcor," p%1d-%1d ",i,j);
}
/* fprintf(ficresprob,"\n");
fprintf(ficresprobcov,"\n");
fprintf(ficresprobcor,"\n");
*/
xp=vector(1,npar);
dnewm=matrix(1,(nlstate)*(nlstate+ndeath),1,npar);
doldm=matrix(1,(nlstate)*(nlstate+ndeath),1,(nlstate)*(nlstate+ndeath));
mu=matrix(1,(nlstate)*(nlstate+ndeath), (int) bage, (int)fage);
varpij=ma3x(1,nlstate*(nlstate+ndeath),1,nlstate*(nlstate+ndeath),(int) bage, (int) fage);
first=1;
fprintf(ficgp,"\n# Routine varprob");
fprintf(fichtm,"\n Computing and drawing one step probabilities with their confidence intervals
Matrix of variance-covariance of pairs of step probabilities (drawings)
Matrix of variance-covariance of pairs of step probabilities
\n\
file %s
\n",optionfilehtmcov);
fprintf(fichtmcov,"\nEllipsoids of confidence centered on point (p
\n");
fprintf(fichtmcov,"\n
Contour plot corresponding to x'cov-1x = 4 (where x is the column vector (pij,pkl)) are drawn. \
It can be understood this way: if pij and pkl where uncorrelated the (2x2) matrix of covariance \
would have been (1/(var pij), 0 , 0, 1/(var pkl)), and the confidence interval would be 2 \
standard deviations wide on each axis.
\
Now, if both incidences are correlated (usual case) we diagonalised the inverse of the covariance matrix\
and made the appropriate rotation to look at the uncorrelated principal directions.
\
To be simple, these graphs help to understand the significativity of each parameter in relation to a second other one.
\n");
cov[1]=1;
/* tj=cptcoveff; */
tj = (int) pow(2,cptcoveff);
if (cptcovn<1) {tj=1;ncodemax[1]=1;}
j1=0;
for(j1=1; j1<=tj;j1++){
/*for(i1=1; i1<=ncodemax[t];i1++){ */
/*j1++;*/
if (cptcovn>0) {
fprintf(ficresprob, "\n#********** Variable ");
for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresprob, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]);
fprintf(ficresprob, "**********\n#\n");
fprintf(ficresprobcov, "\n#********** Variable ");
for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresprobcov, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]);
fprintf(ficresprobcov, "**********\n#\n");
fprintf(ficgp, "\n#********** Variable ");
for (z1=1; z1<=cptcoveff; z1++) fprintf(ficgp, " V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]);
fprintf(ficgp, "**********\n#\n");
fprintf(fichtmcov, "\n
********** Variable ");
for (z1=1; z1<=cptcoveff; z1++) fprintf(fichtm, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]);
fprintf(fichtmcov, "**********\n
");
fprintf(ficresprobcor, "\n#********** Variable ");
for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresprobcor, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]);
fprintf(ficresprobcor, "**********\n#");
}
gradg=matrix(1,npar,1,(nlstate)*(nlstate+ndeath));
trgradg=matrix(1,(nlstate)*(nlstate+ndeath),1,npar);
gp=vector(1,(nlstate)*(nlstate+ndeath));
gm=vector(1,(nlstate)*(nlstate+ndeath));
for (age=bage; age<=fage; age ++){
cov[2]=age;
for (k=1; k<=cptcovn;k++) {
cov[2+k]=nbcode[Tvar[k]][codtab[j1][Tvar[k]]];/* j1 1 2 3 4
* 1 1 1 1 1
* 2 2 1 1 1
* 3 1 2 1 1
*/
/* nbcode[1][1]=0 nbcode[1][2]=1;*/
}
for (k=1; k<=cptcovage;k++) cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2];
for (k=1; k<=cptcovprod;k++)
cov[2+Tprod[k]]=nbcode[Tvard[k][1]][codtab[ij][Tvard[k][1]]]*nbcode[Tvard[k][2]][codtab[ij][Tvard[k][2]]];
for(theta=1; theta <=npar; theta++){
for(i=1; i<=npar; i++)
xp[i] = x[i] + (i==theta ?delti[theta]:(double)0);
pmij(pmmij,cov,ncovmodel,xp,nlstate);
k=0;
for(i=1; i<= (nlstate); i++){
for(j=1; j<=(nlstate+ndeath);j++){
k=k+1;
gp[k]=pmmij[i][j];
}
}
for(i=1; i<=npar; i++)
xp[i] = x[i] - (i==theta ?delti[theta]:(double)0);
pmij(pmmij,cov,ncovmodel,xp,nlstate);
k=0;
for(i=1; i<=(nlstate); i++){
for(j=1; j<=(nlstate+ndeath);j++){
k=k+1;
gm[k]=pmmij[i][j];
}
}
for(i=1; i<= (nlstate)*(nlstate+ndeath); i++)
gradg[theta][i]=(gp[i]-gm[i])/(double)2./delti[theta];
}
for(j=1; j<=(nlstate)*(nlstate+ndeath);j++)
for(theta=1; theta <=npar; theta++)
trgradg[j][theta]=gradg[theta][j];
matprod2(dnewm,trgradg,1,(nlstate)*(nlstate+ndeath),1,npar,1,npar,matcov);
matprod2(doldm,dnewm,1,(nlstate)*(nlstate+ndeath),1,npar,1,(nlstate)*(nlstate+ndeath),gradg);
pmij(pmmij,cov,ncovmodel,x,nlstate);
k=0;
for(i=1; i<=(nlstate); i++){
for(j=1; j<=(nlstate+ndeath);j++){
k=k+1;
mu[k][(int) age]=pmmij[i][j];
}
}
for(i=1;i<=(nlstate)*(nlstate+ndeath);i++)
for(j=1;j<=(nlstate)*(nlstate+ndeath);j++)
varpij[i][j][(int)age] = doldm[i][j];
/*printf("\n%d ",(int)age);
for (i=1; i<=(nlstate)*(nlstate+ndeath);i++){
printf("%e [%e ;%e] ",gm[i],gm[i]-2*sqrt(doldm[i][i]),gm[i]+2*sqrt(doldm[i][i]));
fprintf(ficlog,"%e [%e ;%e] ",gm[i],gm[i]-2*sqrt(doldm[i][i]),gm[i]+2*sqrt(doldm[i][i]));
}*/
fprintf(ficresprob,"\n%d ",(int)age);
fprintf(ficresprobcov,"\n%d ",(int)age);
fprintf(ficresprobcor,"\n%d ",(int)age);
for (i=1; i<=(nlstate)*(nlstate+ndeath);i++)
fprintf(ficresprob,"%11.3e (%11.3e) ",mu[i][(int) age],sqrt(varpij[i][i][(int)age]));
for (i=1; i<=(nlstate)*(nlstate+ndeath);i++){
fprintf(ficresprobcov,"%11.3e ",mu[i][(int) age]);
fprintf(ficresprobcor,"%11.3e ",mu[i][(int) age]);
}
i=0;
for (k=1; k<=(nlstate);k++){
for (l=1; l<=(nlstate+ndeath);l++){
i++;
fprintf(ficresprobcov,"\n%d %d-%d",(int)age,k,l);
fprintf(ficresprobcor,"\n%d %d-%d",(int)age,k,l);
for (j=1; j<=i;j++){
/* printf(" k=%d l=%d i=%d j=%d\n",k,l,i,j);fflush(stdout); */
fprintf(ficresprobcov," %11.3e",varpij[i][j][(int)age]);
fprintf(ficresprobcor," %11.3e",varpij[i][j][(int) age]/sqrt(varpij[i][i][(int) age])/sqrt(varpij[j][j][(int)age]));
}
}
}/* end of loop for state */
} /* end of loop for age */
free_vector(gp,1,(nlstate+ndeath)*(nlstate+ndeath));
free_vector(gm,1,(nlstate+ndeath)*(nlstate+ndeath));
free_matrix(trgradg,1,(nlstate+ndeath)*(nlstate+ndeath),1,npar);
free_matrix(gradg,1,(nlstate+ndeath)*(nlstate+ndeath),1,npar);
/* Confidence intervalle of pij */
/*
fprintf(ficgp,"\nunset parametric;unset label");
fprintf(ficgp,"\nset log y;unset log x; set xlabel \"Age\";set ylabel \"probability (year-1)\"");
fprintf(ficgp,"\nset ter png small\nset size 0.65,0.65");
fprintf(fichtm,"\n
Probability with confidence intervals expressed in year-1 :pijgr%s.png, ",optionfilefiname,optionfilefiname);
fprintf(fichtm,"\n
",optionfilefiname);
fprintf(ficgp,"\nset out \"pijgr%s.png\"",optionfilefiname);
fprintf(ficgp,"\nplot \"%s\" every :::%d::%d u 1:2 \"\%%lf",k1,k2,xfilevarprob);
*/
/* Drawing ellipsoids of confidence of two variables p(k1-l1,k2-l2)*/
first1=1;first2=2;
for (k2=1; k2<=(nlstate);k2++){
for (l2=1; l2<=(nlstate+ndeath);l2++){
if(l2==k2) continue;
j=(k2-1)*(nlstate+ndeath)+l2;
for (k1=1; k1<=(nlstate);k1++){
for (l1=1; l1<=(nlstate+ndeath);l1++){
if(l1==k1) continue;
i=(k1-1)*(nlstate+ndeath)+l1;
if(i<=j) continue;
for (age=bage; age<=fage; age ++){
if ((int)age %5==0){
v1=varpij[i][i][(int)age]/stepm*YEARM/stepm*YEARM;
v2=varpij[j][j][(int)age]/stepm*YEARM/stepm*YEARM;
cv12=varpij[i][j][(int)age]/stepm*YEARM/stepm*YEARM;
mu1=mu[i][(int) age]/stepm*YEARM ;
mu2=mu[j][(int) age]/stepm*YEARM;
c12=cv12/sqrt(v1*v2);
/* Computing eigen value of matrix of covariance */
lc1=((v1+v2)+sqrt((v1+v2)*(v1+v2) - 4*(v1*v2-cv12*cv12)))/2.;
lc2=((v1+v2)-sqrt((v1+v2)*(v1+v2) - 4*(v1*v2-cv12*cv12)))/2.;
if ((lc2 <0) || (lc1 <0) ){
if(first2==1){
first1=0;
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);
}
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);
/* lc1=fabs(lc1); */ /* If we want to have them positive */
/* lc2=fabs(lc2); */
}
/* Eigen vectors */
v11=(1./sqrt(1+(v1-lc1)*(v1-lc1)/cv12/cv12));
/*v21=sqrt(1.-v11*v11); *//* error */
v21=(lc1-v1)/cv12*v11;
v12=-v21;
v22=v11;
tnalp=v21/v11;
if(first1==1){
first1=0;
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);
}
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);
/*printf(fignu*/
/* mu1+ v11*lc1*cost + v12*lc2*sin(t) */
/* mu2+ v21*lc1*cost + v22*lc2*sin(t) */
if(first==1){
first=0;
fprintf(ficgp,"\nset parametric;unset label");
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);
fprintf(ficgp,"\nset ter png small size 320, 240");
fprintf(fichtmcov,"\n
Ellipsoids of confidence cov(p%1d%1d,p%1d%1d) expressed in year-1\
:\
%s%d%1d%1d-%1d%1d.png, ",k1,l1,k2,l2,\
subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2,\
subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2);
fprintf(fichtmcov,"\n
",subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2);
fprintf(fichtmcov,"\n
Correlation at age %d (%.3f),",(int) age, c12);
fprintf(ficgp,"\nset out \"%s%d%1d%1d-%1d%1d.png\"",subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2);
fprintf(ficgp,"\nset label \"%d\" at %11.3e,%11.3e center",(int) age, mu1,mu2);
fprintf(ficgp,"\n# Age %d, p%1d%1d - p%1d%1d",(int) age, k1,l1,k2,l2);
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",\
mu1,std,v11,sqrt(lc1),v12,sqrt(lc2),\
mu2,std,v21,sqrt(lc1),v22,sqrt(lc2));
}else{
first=0;
fprintf(fichtmcov," %d (%.3f),",(int) age, c12);
fprintf(ficgp,"\n# Age %d, p%1d%1d - p%1d%1d",(int) age, k1,l1,k2,l2);
fprintf(ficgp,"\nset label \"%d\" at %11.3e,%11.3e center",(int) age, mu1,mu2);
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",\
mu1,std,v11,sqrt(lc1),v12,sqrt(lc2),\
mu2,std,v21,sqrt(lc1),v22,sqrt(lc2));
}/* if first */
} /* age mod 5 */
} /* end loop age */
fprintf(ficgp,"\nset out \"%s%d%1d%1d-%1d%1d.png\";replot;",subdirf2(optionfilefiname,"varpijgr"), j1,k1,l1,k2,l2);
first=1;
} /*l12 */
} /* k12 */
} /*l1 */
}/* k1 */
/* } */ /* loop covariates */
}
free_ma3x(varpij,1,nlstate,1,nlstate+ndeath,(int) bage, (int)fage);
free_matrix(mu,1,(nlstate+ndeath)*(nlstate+ndeath),(int) bage, (int)fage);
free_matrix(doldm,1,(nlstate)*(nlstate+ndeath),1,(nlstate)*(nlstate+ndeath));
free_matrix(dnewm,1,(nlstate)*(nlstate+ndeath),1,npar);
free_vector(xp,1,npar);
fclose(ficresprob);
fclose(ficresprobcov);
fclose(ficresprobcor);
fflush(ficgp);
fflush(fichtmcov);
}
/******************* Printing html file ***********/
void printinghtml(char fileres[], char title[], char datafile[], int firstpass, \
int lastpass, int stepm, int weightopt, char model[],\
int imx,int jmin, int jmax, double jmeanint,char rfileres[],\
int popforecast, int estepm ,\
double jprev1, double mprev1,double anprev1, \
double jprev2, double mprev2,double anprev2){
int jj1, k1, i1, cpt;
fprintf(fichtm,"");
fprintf(fichtm,"Result files (first order: no variance)
\n \
- Observed prevalence in each state (during the period defined between %.lf/%.lf/%.lf and %.lf/%.lf/%.lf): %s
\n ",
jprev1, mprev1,anprev1,jprev2, mprev2,anprev2,subdirf2(fileres,"p"),subdirf2(fileres,"p"));
fprintf(fichtm,"\
- Estimated transition probabilities over %d (stepm) months: %s
\n ",
stepm,subdirf2(fileres,"pij"),subdirf2(fileres,"pij"));
fprintf(fichtm,"\
- Period (stable) prevalence in each health state: %s
\n",
subdirf2(fileres,"pl"),subdirf2(fileres,"pl"));
fprintf(fichtm,"\
- (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): \
%s
\n",
estepm,subdirf2(fileres,"e"),subdirf2(fileres,"e"));
fprintf(fichtm,"\
- Population projections by age and states: \
%s
\n
");
fprintf(fichtm,"\
\n
************ Results for covariates");
for (cpt=1; cpt<=cptcoveff;cpt++)
fprintf(fichtm," V%d=%d ",Tvaraff[cpt],nbcode[Tvaraff[cpt]][codtab[jj1][cpt]]);
fprintf(fichtm," ************\n
");
}
/* Pij */
fprintf(fichtm,"
- Pij or Conditional probabilities to be observed in state j being in state i, %d (stepm) months before: %s%d_1.png
\
",stepm,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1);
/* Quasi-incidences */
fprintf(fichtm,"
- Pij or Conditional probabilities to be observed in state j being in state i %d (stepm) months\
before but expressed in per year i.e. quasi incidences if stepm is small and probabilities too: %s%d_2.png
\
",stepm,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1,subdirf2(optionfilefiname,"pe"),jj1);
/* Period (stable) prevalence in each health state */
for(cpt=1; cpt<=nlstate;cpt++){
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. %s%d_%d.png
\
", cpt, cpt, nlstate, subdirf2(optionfilefiname,"p"),cpt,jj1,subdirf2(optionfilefiname,"p"),cpt,jj1,subdirf2(optionfilefiname,"p"),cpt,jj1);
}
for(cpt=1; cpt<=nlstate;cpt++) {
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) : %s%d%d.png
\
",cpt,nlstate,subdirf2(optionfilefiname,"exp"),cpt,jj1,subdirf2(optionfilefiname,"exp"),cpt,jj1,subdirf2(optionfilefiname,"exp"),cpt,jj1);
}
} /* end i1 */
}/* End k1 */
fprintf(fichtm," Result files (second order: variances)
\n\
- Parameter file with estimated parameters and covariance matrix: %s
\n", rfileres,rfileres);
fprintf(fichtm," - Variance of one-step probabilities: %s
\n",
subdirf2(fileres,"prob"),subdirf2(fileres,"prob"));
fprintf(fichtm,"\
- Variance-covariance of one-step probabilities: %s
\n",
subdirf2(fileres,"probcov"),subdirf2(fileres,"probcov"));
fprintf(fichtm,"\
- Correlation matrix of one-step probabilities: %s
\n",
subdirf2(fileres,"probcor"),subdirf2(fileres,"probcor"));
fprintf(fichtm,"\
- Variances and covariances of health expectancies by age and initial health status (cov(eij,ekl)(estepm=%2d months): \
%s
\n
\n",
estepm,subdirf2(fileres,"stde"),subdirf2(fileres,"stde"));
fprintf(fichtm,"\
- 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): %s
\n",
estepm, subdirf2(fileres,"v"),subdirf2(fileres,"v"));
fprintf(fichtm,"\
- 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): %s
\n",
estepm, subdirf2(fileres,"t"),subdirf2(fileres,"t"));
fprintf(fichtm,"\
- Standard deviation of period (stable) prevalences: %s
\n",\
subdirf2(fileres,"vpl"),subdirf2(fileres,"vpl"));
/* if(popforecast==1) fprintf(fichtm,"\n */
/* - Prevalences forecasting: f%s
\n */
/* - Population forecasting (if popforecast=1): pop%s
\n */
/*
",fileres,fileres,fileres,fileres); */
/* else */
/* fprintf(fichtm,"\n No population forecast: popforecast = %d (instead of 1) or stepm = %d (instead of 1) or model=%s (instead of .)
\n",popforecast, stepm, model); */
fflush(fichtm);
fprintf(fichtm,"
");
fflush(fichtm);
}
/******************* Gnuplot file **************/
void printinggnuplot(char fileres[], char optionfilefiname[], double ageminpar, double agemaxpar, double fage , char pathc[], double p[]){
char dirfileres[132],optfileres[132];
int cpt=0,k1=0,i=0,k=0,j=0,jk=0,k2=0,k3=0,ij=0,l=0;
int ng=0;
/* if((ficgp=fopen(optionfilegnuplot,"a"))==NULL) { */
/* printf("Problem with file %s",optionfilegnuplot); */
/* fprintf(ficlog,"Problem with file %s",optionfilegnuplot); */
/* } */
/*#ifdef windows */
fprintf(ficgp,"cd \"%s\" \n",pathc);
/*#endif */
m=pow(2,cptcoveff);
strcpy(dirfileres,optionfilefiname);
strcpy(optfileres,"vpl");
/* 1eme*/
fprintf(ficgp,"\n# 1st: Period (stable) prevalence with CI: 'vpl' files\n");
for (cpt=1; cpt<= nlstate ; cpt ++) {
for (k1=1; k1<= m ; k1 ++) { /* plot [100000000000000000000:-100000000000000000000] "mysbiaspar/vplrmysbiaspar.txt to check */
fprintf(ficgp,"\nset out \"%s%d_%d.png\" \n",subdirf2(optionfilefiname,"v"),cpt,k1);
fprintf(ficgp,"\n#set out \"v%s%d_%d.png\" \n",optionfilefiname,cpt,k1);
fprintf(ficgp,"set xlabel \"Age\" \n\
set ylabel \"Probability\" \n\
set ter png small size 320, 240\n\
plot [%.f:%.f] \"%s\" every :::%d::%d u 1:2 \"%%lf",ageminpar,fage,subdirf2(fileres,"vpl"),k1-1,k1-1);
for (i=1; i<= nlstate ; i ++) {
if (i==cpt) fprintf(ficgp," %%lf (%%lf)");
else fprintf(ficgp," %%*lf (%%*lf)");
}
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);
for (i=1; i<= nlstate ; i ++) {
if (i==cpt) fprintf(ficgp," %%lf (%%lf)");
else fprintf(ficgp," %%*lf (%%*lf)");
}
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);
for (i=1; i<= nlstate ; i ++) {
if (i==cpt) fprintf(ficgp," %%lf (%%lf)");
else fprintf(ficgp," %%*lf (%%*lf)");
}
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));
}
}
/*2 eme*/
fprintf(ficgp,"\n# 2nd: Total life expectancy with CI: 't' files\n");
for (k1=1; k1<= m ; k1 ++) {
fprintf(ficgp,"\nset out \"%s%d.png\" \n",subdirf2(optionfilefiname,"e"),k1);
fprintf(ficgp,"set ylabel \"Years\" \nset ter png small size 320, 240\nplot [%.f:%.f] ",ageminpar,fage);
for (i=1; i<= nlstate+1 ; i ++) {
k=2*i;
fprintf(ficgp,"\"%s\" every :::%d::%d u 1:2 \"%%lf",subdirf2(fileres,"t"),k1-1,k1-1);
for (j=1; j<= nlstate+1 ; j ++) {
if (j==i) fprintf(ficgp," %%lf (%%lf)");
else fprintf(ficgp," %%*lf (%%*lf)");
}
if (i== 1) fprintf(ficgp,"\" t\"TLE\" w l ,");
else fprintf(ficgp,"\" t\"LE in state (%d)\" w l ,",i-1);
fprintf(ficgp,"\"%s\" every :::%d::%d u 1:($2-$3*2) \"%%lf",subdirf2(fileres,"t"),k1-1,k1-1);
for (j=1; j<= nlstate+1 ; j ++) {
if (j==i) fprintf(ficgp," %%lf (%%lf)");
else fprintf(ficgp," %%*lf (%%*lf)");
}
fprintf(ficgp,"\" t\"\" w l lt 0,");
fprintf(ficgp,"\"%s\" every :::%d::%d u 1:($2+$3*2) \"%%lf",subdirf2(fileres,"t"),k1-1,k1-1);
for (j=1; j<= nlstate+1 ; j ++) {
if (j==i) fprintf(ficgp," %%lf (%%lf)");
else fprintf(ficgp," %%*lf (%%*lf)");
}
if (i== (nlstate+1)) fprintf(ficgp,"\" t\"\" w l lt 0");
else fprintf(ficgp,"\" t\"\" w l lt 0,");
}
}
/*3eme*/
for (k1=1; k1<= m ; k1 ++) {
for (cpt=1; cpt<= nlstate ; cpt ++) {
/* k=2+nlstate*(2*cpt-2); */
k=2+(nlstate+1)*(cpt-1);
fprintf(ficgp,"\nset out \"%s%d%d.png\" \n",subdirf2(optionfilefiname,"exp"),cpt,k1);
fprintf(ficgp,"set ter png small size 320, 240\n\
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);
/*fprintf(ficgp,",\"e%s\" every :::%d::%d u 1:($%d-2*$%d) \"\%%lf ",fileres,k1-1,k1-1,k,k+1);
for (i=1; i<= nlstate*2 ; i ++) fprintf(ficgp,"\%%lf (\%%lf) ");
fprintf(ficgp,"\" t \"e%d1\" w l",cpt);
fprintf(ficgp,",\"e%s\" every :::%d::%d u 1:($%d+2*$%d) \"\%%lf ",fileres,k1-1,k1-1,k,k+1);
for (i=1; i<= nlstate*2 ; i ++) fprintf(ficgp,"\%%lf (\%%lf) ");
fprintf(ficgp,"\" t \"e%d1\" w l",cpt);
*/
for (i=1; i< nlstate ; i ++) {
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);
/* 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);*/
}
fprintf(ficgp," ,\"%s\" every :::%d::%d u 1:%d t \"e%d.\" w l",subdirf2(fileres,"e"),k1-1,k1-1,k+nlstate,cpt);
}
}
/* CV preval stable (period) */
for (k1=1; k1<= m ; k1 ++) { /* For each multivariate if any */
for (cpt=1; cpt<=nlstate ; cpt ++) { /* For each life state */
k=3;
fprintf(ficgp,"\n#\n#\n#CV preval stable (period): 'pij' files, cov=%d state=%d",k1, cpt);
fprintf(ficgp,"\nset out \"%s%d_%d.png\" \n",subdirf2(optionfilefiname,"p"),cpt,k1);
fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \n\
set ter png small size 320, 240\n\
unset log y\n\
plot [%.f:%.f] ", ageminpar, agemaxpar);
for (i=1; i<= nlstate ; i ++){
if(i==1)
fprintf(ficgp,"\"%s\"",subdirf2(fileres,"pij"));
else
fprintf(ficgp,", '' ");
l=(nlstate+ndeath)*(i-1)+1;
fprintf(ficgp," u ($1==%d ? ($3):1/0):($%d/($%d",k1,k+l+(cpt-1),k+l);
for (j=1; j<= (nlstate-1) ; j ++)
fprintf(ficgp,"+$%d",k+l+j);
fprintf(ficgp,")) t \"prev(%d,%d)\" w l",i,cpt);
} /* nlstate */
fprintf(ficgp,"\n");
} /* end cpt state*/
} /* end covariate */
/* proba elementaires */
for(i=1,jk=1; i <=nlstate; i++){
for(k=1; k <=(nlstate+ndeath); k++){
if (k != i) {
for(j=1; j <=ncovmodel; j++){
fprintf(ficgp,"p%d=%f ",jk,p[jk]);
jk++;
fprintf(ficgp,"\n");
}
}
}
}
/*goto avoid;*/
for(ng=1; ng<=2;ng++){ /* Number of graphics: first is probabilities second is incidence per year*/
for(jk=1; jk <=m; jk++) {
fprintf(ficgp,"\nset out \"%s%d_%d.png\" \n",subdirf2(optionfilefiname,"pe"),jk,ng);
if (ng==2)
fprintf(ficgp,"\nset ylabel \"Quasi-incidence per year\"\n");
else
fprintf(ficgp,"\nset title \"Probability\"\n");
fprintf(ficgp,"\nset ter png small size 320, 240\nset log y\nplot [%.f:%.f] ",ageminpar,agemaxpar);
i=1;
for(k2=1; k2<=nlstate; k2++) {
k3=i;
for(k=1; k<=(nlstate+ndeath); k++) {
if (k != k2){
if(ng==2)
fprintf(ficgp," %f*exp(p%d+p%d*x",YEARM/stepm,i,i+1);
else
fprintf(ficgp," exp(p%d+p%d*x",i,i+1);
ij=1;/* To be checked else nbcode[0][0] wrong */
for(j=3; j <=ncovmodel; j++) {
/* if(((j-2)==Tage[ij]) &&(ij <=cptcovage)) { /\* Bug valgrind *\/ */
/* /\*fprintf(ficgp,"+p%d*%d*x",i+j-1,nbcode[Tvar[j-2]][codtab[jk][Tvar[j-2]]]);*\/ */
/* ij++; */
/* } */
/* else */
fprintf(ficgp,"+p%d*%d",i+j-1,nbcode[Tvar[j-2]][codtab[jk][j-2]]);
}
fprintf(ficgp,")/(1");
for(k1=1; k1 <=nlstate; k1++){
fprintf(ficgp,"+exp(p%d+p%d*x",k3+(k1-1)*ncovmodel,k3+(k1-1)*ncovmodel+1);
ij=1;
for(j=3; j <=ncovmodel; j++){
/* if(((j-2)==Tage[ij]) &&(ij <=cptcovage)) { */
/* fprintf(ficgp,"+p%d*%d*x",k3+(k1-1)*ncovmodel+1+j-2,nbcode[Tvar[j-2]][codtab[jk][Tvar[j-2]]]); */
/* ij++; */
/* } */
/* else */
fprintf(ficgp,"+p%d*%d",k3+(k1-1)*ncovmodel+1+j-2,nbcode[Tvar[j-2]][codtab[jk][j-2]]);
}
fprintf(ficgp,")");
}
fprintf(ficgp,") t \"p%d%d\" ", k2,k);
if ((k+k2)!= (nlstate*2+ndeath)) fprintf(ficgp,",");
i=i+ncovmodel;
}
} /* end k */
} /* end k2 */
} /* end jk */
} /* end ng */
/* avoid: */
fflush(ficgp);
} /* end gnuplot */
/*************** Moving average **************/
int movingaverage(double ***probs, double bage,double fage, double ***mobaverage, int mobilav){
int i, cpt, cptcod;
int modcovmax =1;
int mobilavrange, mob;
double age;
modcovmax=2*cptcoveff;/* Max number of modalities. We suppose
a covariate has 2 modalities */
if (cptcovn<1) modcovmax=1; /* At least 1 pass */
if(mobilav==1||mobilav ==3 ||mobilav==5 ||mobilav== 7){
if(mobilav==1) mobilavrange=5; /* default */
else mobilavrange=mobilav;
for (age=bage; age<=fage; age++)
for (i=1; i<=nlstate;i++)
for (cptcod=1;cptcod<=modcovmax;cptcod++)
mobaverage[(int)age][i][cptcod]=probs[(int)age][i][cptcod];
/* We keep the original values on the extreme ages bage, fage and for
fage+1 and bage-1 we use a 3 terms moving average; for fage+2 bage+2
we use a 5 terms etc. until the borders are no more concerned.
*/
for (mob=3;mob <=mobilavrange;mob=mob+2){
for (age=bage+(mob-1)/2; age<=fage-(mob-1)/2; age++){
for (i=1; i<=nlstate;i++){
for (cptcod=1;cptcod<=modcovmax;cptcod++){
mobaverage[(int)age][i][cptcod] =probs[(int)age][i][cptcod];
for (cpt=1;cpt<=(mob-1)/2;cpt++){
mobaverage[(int)age][i][cptcod] +=probs[(int)age-cpt][i][cptcod];
mobaverage[(int)age][i][cptcod] +=probs[(int)age+cpt][i][cptcod];
}
mobaverage[(int)age][i][cptcod]=mobaverage[(int)age][i][cptcod]/mob;
}
}
}/* end age */
}/* end mob */
}else return -1;
return 0;
}/* End movingaverage */
/************** Forecasting ******************/
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){
/* proj1, year, month, day of starting projection
agemin, agemax range of age
dateprev1 dateprev2 range of dates during which prevalence is computed
anproj2 year of en of projection (same day and month as proj1).
*/
int yearp, stepsize, hstepm, nhstepm, j, k, cptcod, i, h, i1;
double agec; /* generic age */
double agelim, ppij, yp,yp1,yp2,jprojmean,mprojmean,anprojmean;
double *popeffectif,*popcount;
double ***p3mat;
double ***mobaverage;
char fileresf[FILENAMELENGTH];
agelim=AGESUP;
prevalence(probs, ageminpar, agemax, s, agev, nlstate, imx, Tvar, nbcode, ncodemax, mint, anint, dateprev1, dateprev2, firstpass, lastpass);
strcpy(fileresf,"f");
strcat(fileresf,fileres);
if((ficresf=fopen(fileresf,"w"))==NULL) {
printf("Problem with forecast resultfile: %s\n", fileresf);
fprintf(ficlog,"Problem with forecast resultfile: %s\n", fileresf);
}
printf("Computing forecasting: result on file '%s' \n", fileresf);
fprintf(ficlog,"Computing forecasting: result on file '%s' \n", fileresf);
if (cptcoveff==0) ncodemax[cptcoveff]=1;
if (mobilav!=0) {
mobaverage= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX);
if (movingaverage(probs, ageminpar, fage, mobaverage,mobilav)!=0){
fprintf(ficlog," Error in movingaverage mobilav=%d\n",mobilav);
printf(" Error in movingaverage mobilav=%d\n",mobilav);
}
}
stepsize=(int) (stepm+YEARM-1)/YEARM;
if (stepm<=12) stepsize=1;
if(estepm < stepm){
printf ("Problem %d lower than %d\n",estepm, stepm);
}
else hstepm=estepm;
hstepm=hstepm/stepm;
yp1=modf(dateintmean,&yp);/* extracts integral of datemean in yp and
fractional in yp1 */
anprojmean=yp;
yp2=modf((yp1*12),&yp);
mprojmean=yp;
yp1=modf((yp2*30.5),&yp);
jprojmean=yp;
if(jprojmean==0) jprojmean=1;
if(mprojmean==0) jprojmean=1;
i1=cptcoveff;
if (cptcovn < 1){i1=1;}
fprintf(ficresf,"# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jprojmean,mprojmean,anprojmean,dateintmean,dateprev1,dateprev2);
fprintf(ficresf,"#****** Routine prevforecast **\n");
/* if (h==(int)(YEARM*yearp)){ */
for(cptcov=1, k=0;cptcov<=i1;cptcov++){
for(cptcod=1;cptcod<=ncodemax[cptcoveff];cptcod++){
k=k+1;
fprintf(ficresf,"\n#******");
for(j=1;j<=cptcoveff;j++) {
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]]);
}
fprintf(ficresf,"******\n");
fprintf(ficresf,"# Covariate valuofcovar yearproj age");
for(j=1; j<=nlstate+ndeath;j++){
for(i=1; i<=nlstate;i++)
fprintf(ficresf," p%d%d",i,j);
fprintf(ficresf," p.%d",j);
}
for (yearp=0; yearp<=(anproj2-anproj1);yearp +=stepsize) {
fprintf(ficresf,"\n");
fprintf(ficresf,"\n# Forecasting at date %.lf/%.lf/%.lf ",jproj1,mproj1,anproj1+yearp);
for (agec=fage; agec>=(ageminpar-1); agec--){
nhstepm=(int) rint((agelim-agec)*YEARM/stepm);
nhstepm = nhstepm/hstepm;
p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm);
oldm=oldms;savm=savms;
hpxij(p3mat,nhstepm,agec,hstepm,p,nlstate,stepm,oldm,savm, k);
for (h=0; h<=nhstepm; h++){
if (h*hstepm/YEARM*stepm ==yearp) {
fprintf(ficresf,"\n");
for(j=1;j<=cptcoveff;j++)
fprintf(ficresf,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]);
fprintf(ficresf,"%.f %.f ",anproj1+yearp,agec+h*hstepm/YEARM*stepm);
}
for(j=1; j<=nlstate+ndeath;j++) {
ppij=0.;
for(i=1; i<=nlstate;i++) {
if (mobilav==1)
ppij=ppij+p3mat[i][j][h]*mobaverage[(int)agec][i][cptcod];
else {
ppij=ppij+p3mat[i][j][h]*probs[(int)(agec)][i][cptcod];
}
if (h*hstepm/YEARM*stepm== yearp) {
fprintf(ficresf," %.3f", p3mat[i][j][h]);
}
} /* end i */
if (h*hstepm/YEARM*stepm==yearp) {
fprintf(ficresf," %.3f", ppij);
}
}/* end j */
} /* end h */
free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm);
} /* end agec */
} /* end yearp */
} /* end cptcod */
} /* end cptcov */
if (mobilav!=0) free_ma3x(mobaverage,1, AGESUP,1,NCOVMAX, 1,NCOVMAX);
fclose(ficresf);
}
/************** Forecasting *****not tested NB*************/
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){
int cpt, stepsize, hstepm, nhstepm, j,k,c, cptcod, i,h;
int *popage;
double calagedatem, agelim, kk1, kk2;
double *popeffectif,*popcount;
double ***p3mat,***tabpop,***tabpopprev;
double ***mobaverage;
char filerespop[FILENAMELENGTH];
tabpop= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX);
tabpopprev= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX);
agelim=AGESUP;
calagedatem=(anpyram+mpyram/12.+jpyram/365.-dateintmean)*YEARM;
prevalence(probs, ageminpar, agemax, s, agev, nlstate, imx, Tvar, nbcode, ncodemax, mint, anint, dateprev1, dateprev2, firstpass, lastpass);
strcpy(filerespop,"pop");
strcat(filerespop,fileres);
if((ficrespop=fopen(filerespop,"w"))==NULL) {
printf("Problem with forecast resultfile: %s\n", filerespop);
fprintf(ficlog,"Problem with forecast resultfile: %s\n", filerespop);
}
printf("Computing forecasting: result on file '%s' \n", filerespop);
fprintf(ficlog,"Computing forecasting: result on file '%s' \n", filerespop);
if (cptcoveff==0) ncodemax[cptcoveff]=1;
if (mobilav!=0) {
mobaverage= ma3x(1, AGESUP,1,NCOVMAX, 1,NCOVMAX);
if (movingaverage(probs, ageminpar, fage, mobaverage,mobilav)!=0){
fprintf(ficlog," Error in movingaverage mobilav=%d\n",mobilav);
printf(" Error in movingaverage mobilav=%d\n",mobilav);
}
}
stepsize=(int) (stepm+YEARM-1)/YEARM;
if (stepm<=12) stepsize=1;
agelim=AGESUP;
hstepm=1;
hstepm=hstepm/stepm;
if (popforecast==1) {
if((ficpop=fopen(popfile,"r"))==NULL) {
printf("Problem with population file : %s\n",popfile);exit(0);
fprintf(ficlog,"Problem with population file : %s\n",popfile);exit(0);
}
popage=ivector(0,AGESUP);
popeffectif=vector(0,AGESUP);
popcount=vector(0,AGESUP);
i=1;
while ((c=fscanf(ficpop,"%d %lf\n",&popage[i],&popcount[i])) != EOF) i=i+1;
imx=i;
for (i=1; i
************ Results for covariates");
for (cpt=1; cpt<=cptcoveff;cpt++)
fprintf(fichtm," V%d=%d ",Tvaraff[cpt],nbcode[Tvaraff[cpt]][codtab[jj1][cpt]]);
fprintf(fichtm," ************\n
");
}
for(cpt=1; cpt<=nlstate;cpt++) {
fprintf(fichtm,"
- Observed (cross-sectional) and period (incidence based) \
prevalence (with 95%% confidence interval) in state (%d): %s%d_%d.png
\
",cpt,subdirf2(optionfilefiname,"v"),cpt,jj1,subdirf2(optionfilefiname,"v"),cpt,jj1);
}
fprintf(fichtm,"\n
- Total life expectancy by age and \
health expectancies in states (1) and (2). If popbased=1 the smooth (due to the model) \
true period expectancies (those weighted with period prevalences are also\
drawn in addition to the population based expectancies computed using\
observed and cahotic prevalences: %s%d.png
\
",subdirf2(optionfilefiname,"e"),jj1,subdirf2(optionfilefiname,"e"),jj1);
} /* end i1 */
}/* End k1 */
fprintf(fichtm,"
");
fprintf(fichtm,"Result files
\n Force of mortality. Parameters of the Gompertz fit (with confidence interval in brackets):
");
fprintf(fichtm," mu(age) =%lf*exp(%lf*(age-%d)) per year
",p[1],p[2],agegomp);
for (i=1;i<=2;i++)
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]));
fprintf(fichtm,"
");
fprintf(fichtm,"Life table
\n
");
fprintf(fichtm,"\nAge l
");
for (k=agegomp;k<(agemortsup-2);k++)
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]);
fflush(fichtm);
}
/******************* Gnuplot file **************/
void printinggnuplotmort(char fileres[], char optionfilefiname[], double ageminpar, double agemaxpar, double fage , char pathc[], double p[]){
char dirfileres[132],optfileres[132];
int ng;
/*#ifdef windows */
fprintf(ficgp,"cd \"%s\" \n",pathc);
/*#endif */
strcpy(dirfileres,optionfilefiname);
strcpy(optfileres,"vpl");
fprintf(ficgp,"set out \"graphmort.png\"\n ");
fprintf(ficgp,"set xlabel \"Age\"\n set ylabel \"Force of mortality (per year)\" \n ");
fprintf(ficgp, "set ter png small size 320, 240\n set log y\n");
/* fprintf(ficgp, "set size 0.65,0.65\n"); */
fprintf(ficgp,"plot [%d:100] %lf*exp(%lf*(x-%d))",agegomp,p[1],p[2],agegomp);
}
int readdata(char datafile[], int firstobs, int lastobs, int *imax)
{
/*-------- data file ----------*/
FILE *fic;
char dummy[]=" ";
int i=0, j=0, n=0;
int linei, month, year,iout;
char line[MAXLINE], linetmp[MAXLINE];
char stra[MAXLINE], strb[MAXLINE];
char *stratrunc;
int lstra;
if((fic=fopen(datafile,"r"))==NULL) {
printf("Problem while opening datafile: %s\n", datafile);return 1;
fprintf(ficlog,"Problem while opening datafile: %s\n", datafile);return 1;
}
i=1;
linei=0;
while ((fgets(line, MAXLINE, fic) != NULL) &&((i >= firstobs) && (i <=lastobs))) {
linei=linei+1;
for(j=strlen(line); j>=0;j--){ /* Untabifies line */
if(line[j] == '\t')
line[j] = ' ';
}
for(j=strlen(line)-1; (line[j]==' ')||(line[j]==10)||(line[j]==13);j--){
;
};
line[j+1]=0; /* Trims blanks at end of line */
if(line[0]=='#'){
fprintf(ficlog,"Comment line\n%s\n",line);
printf("Comment line\n%s\n",line);
continue;
}
trimbb(linetmp,line); /* Trims multiple blanks in line */
strcpy(line, linetmp);
for (j=maxwav;j>=1;j--){
cutv(stra, strb, line, ' ');
if(strb[0]=='.') { /* Missing status */
lval=-1;
}else{
errno=0;
lval=strtol(strb,&endptr,10);
/* if (errno == ERANGE && (lval == LONG_MAX || lval == LONG_MIN))*/
if( strb[0]=='\0' || (*endptr != '\0')){
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);
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);
return 1;
}
}
s[j][i]=lval;
strcpy(line,stra);
cutv(stra, strb,line,' ');
if( (iout=sscanf(strb,"%d/%d",&month, &year)) != 0){
}
else if( (iout=sscanf(strb,"%s.",dummy)) != 0){
month=99;
year=9999;
}else{
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);
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);
return 1;
}
anint[j][i]= (double) year;
mint[j][i]= (double)month;
strcpy(line,stra);
} /* ENd Waves */
cutv(stra, strb,line,' ');
if( (iout=sscanf(strb,"%d/%d",&month, &year)) != 0){
}
else if( (iout=sscanf(strb,"%s.",dummy)) != 0){
month=99;
year=9999;
}else{
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);
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);
return 1;
}
andc[i]=(double) year;
moisdc[i]=(double) month;
strcpy(line,stra);
cutv(stra, strb,line,' ');
if( (iout=sscanf(strb,"%d/%d",&month, &year)) != 0){
}
else if( (iout=sscanf(strb,"%s.", dummy)) != 0){
month=99;
year=9999;
}else{
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);
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);
return 1;
}
if (year==9999) {
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);
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);
return 1;
}
annais[i]=(double)(year);
moisnais[i]=(double)(month);
strcpy(line,stra);
cutv(stra, strb,line,' ');
errno=0;
dval=strtod(strb,&endptr);
if( strb[0]=='\0' || (*endptr != '\0')){
printf("Error reading data around '%f' at line number %d, \"%s\" for individual %d\nShould be a weight. Exiting.\n",dval, i,line,linei);
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);
fflush(ficlog);
return 1;
}
weight[i]=dval;
strcpy(line,stra);
for (j=ncovcol;j>=1;j--){
cutv(stra, strb,line,' ');
if(strb[0]=='.') { /* Missing status */
lval=-1;
}else{
errno=0;
lval=strtol(strb,&endptr,10);
if( strb[0]=='\0' || (*endptr != '\0')){
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);
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);
return 1;
}
}
if(lval <-1 || lval >1){
printf("Error reading data around '%ld' at line number %d for individual %d, '%s'\n \
Should be a value of %d(nth) covariate (0 should be the value for the reference and 1\n \
for the alternative. IMaCh does not build design variables automatically, do it yourself.\n \
For example, for multinomial values like 1, 2 and 3,\n \
build V1=0 V2=0 for the reference value (1),\n \
V1=1 V2=0 for (2) \n \
and V1=0 V2=1 for (3). V1=1 V2=1 should not exist and the corresponding\n \
output of IMaCh is often meaningless.\n \
Exiting.\n",lval,linei, i,line,j);
fprintf(ficlog,"Error reading data around '%ld' at line number %d for individual %d, '%s'\n \
Should be a value of %d(nth) covariate (0 should be the value for the reference and 1\n \
for the alternative. IMaCh does not build design variables automatically, do it yourself.\n \
For example, for multinomial values like 1, 2 and 3,\n \
build V1=0 V2=0 for the reference value (1),\n \
V1=1 V2=0 for (2) \n \
and V1=0 V2=1 for (3). V1=1 V2=1 should not exist and the corresponding\n \
output of IMaCh is often meaningless.\n \
Exiting.\n",lval,linei, i,line,j);fflush(ficlog);
return 1;
}
covar[j][i]=(double)(lval);
strcpy(line,stra);
}
lstra=strlen(stra);
if(lstra > 9){ /* More than 2**32 or max of what printf can write with %ld */
stratrunc = &(stra[lstra-9]);
num[i]=atol(stratrunc);
}
else
num[i]=atol(stra);
/*if((s[2][i]==2) && (s[3][i]==-1)&&(s[4][i]==9)){
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;}*/
i=i+1;
} /* End loop reading data */
*imax=i-1; /* Number of individuals */
fclose(fic);
return (0);
/* endread: */
printf("Exiting readdata: ");
fclose(fic);
return (1);
}
void removespace(char *str) {
char *p1 = str, *p2 = str;
do
while (*p2 == ' ')
p2++;
while (*p1++ == *p2++);
}
int decodemodel ( char model[], int lastobs) /**< This routine decode the model and returns:
* Model V1+V2+V3+V8+V7*V8+V5*V6+V8*age+V3*age
* - cptcovt total number of covariates of the model nbocc(+)+1 = 8
* - cptcovn or number of covariates k of the models excluding age*products =6
* - cptcovage number of covariates with age*products =2
* - cptcovs number of simple covariates
* - 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
* which is a new column after the 9 (ncovcol) variables.
* - if k is a product Vn*Vm covar[k][i] is filled with correct values for each individual
* - Tprod[l] gives the kth covariates of the product Vn*Vm l=1 to cptcovprod-cptcovage
* Tprod[1]@2 {5, 6}: position of first product V7*V8 is 5, and second V5*V6 is 6.
* - Tvard[k] p Tvard[1][1]@4 {7, 8, 5, 6} for V7*V8 and V5*V6 .
*/
{
int i, j, k, ks;
int j1, k1, k2;
char modelsav[80];
char stra[80], strb[80], strc[80], strd[80],stre[80];
/*removespace(model);*/
if (strlen(model) >1){ /* If there is at least 1 covariate */
j=0, j1=0, k1=0, k2=-1, ks=0, cptcovn=0;
j=nbocc(model,'+'); /**< j=Number of '+' */
j1=nbocc(model,'*'); /**< j1=Number of '*' */
cptcovs=j+1-j1; /**< Number of simple covariates V1+V2*age+V3 +V3*V4=> V1 + V3 =2 */
cptcovt= j+1; /* Number of total covariates in the model V1 + V2*age+ V3 + V3*V4=> 4*/
/* including age products which are counted in cptcovage.
* but the covariates which are products must be treated separately: ncovn=4- 2=2 (V1+V3). */
cptcovprod=j1; /**< Number of products V1*V2 +v3*age = 2 */
cptcovprodnoage=0; /**< Number of covariate products without age: V3*V4 =1 */
strcpy(modelsav,model);
if (strstr(model,"AGE") !=0){
printf("Error. AGE must be in lower case 'age' model=%s ",model);
fprintf(ficlog,"Error. AGE must be in lower case model=%s ",model);fflush(ficlog);
return 1;
}
if (strstr(model,"v") !=0){
printf("Error. 'v' must be in upper case 'V' model=%s ",model);
fprintf(ficlog,"Error. 'v' must be in upper case model=%s ",model);fflush(ficlog);
return 1;
}
/* Design
* V1 V2 V3 V4 V5 V6 V7 V8 V9 Weight
* < ncovcol=8 >
* Model V2 + V1 + V3*age + V3 + V5*V6 + V7*V8 + V8*age + V8
* k= 1 2 3 4 5 6 7 8
* cptcovn number of covariates (not including constant and age ) = # of + plus 1 = 7+1=8
* covar[k,i], value of kth covariate if not including age for individual i:
* covar[1][i]= (V2), covar[4][i]=(V3), covar[8][i]=(V8)
* Tvar[k] # of the kth covariate: Tvar[1]=2 Tvar[4]=3 Tvar[8]=8
* if multiplied by age: V3*age Tvar[3=V3*age]=3 (V3) Tvar[7]=8 and
* Tage[++cptcovage]=k
* if products, new covar are created after ncovcol with k1
* Tvar[k]=ncovcol+k1; # of the kth covariate product: Tvar[5]=ncovcol+1=10 Tvar[6]=ncovcol+1=11
* Tprod[k1]=k; Tprod[1]=5 Tprod[2]= 6; gives the position of the k1th product
* 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
* Tvar[cptcovn+k2]=Tvard[k1][1];Tvar[cptcovn+k2+1]=Tvard[k1][2];
* Tvar[8+1]=5;Tvar[8+2]=6;Tvar[8+3]=7;Tvar[8+4]=8 inverted
* V1 V2 V3 V4 V5 V6 V7 V8 V9 V10 V11
* < ncovcol=8 >
* Model V2 + V1 + V3*age + V3 + V5*V6 + V7*V8 + V8*age + V8 d1 d1 d2 d2
* k= 1 2 3 4 5 6 7 8 9 10 11 12
* Tvar[k]= 2 1 3 3 10 11 8 8 5 6 7 8
* p Tvar[1]@12={2, 1, 3, 3, 11, 10, 8, 8, 7, 8, 5, 6}
* p Tprod[1]@2={ 6, 5}
*p Tvard[1][1]@4= {7, 8, 5, 6}
* covar[k][i]= V2 V1 ? V3 V5*V6? V7*V8? ? V8
* cov[Tage[kk]+2]=covar[Tvar[Tage[kk]]][i]*cov[2];
*How to reorganize?
* Model V1 + V2 + V3 + V8 + V5*V6 + V7*V8 + V3*age + V8*age
* Tvars {2, 1, 3, 3, 11, 10, 8, 8, 7, 8, 5, 6}
* {2, 1, 4, 8, 5, 6, 3, 7}
* Struct []
*/
/* This loop fills the array Tvar from the string 'model'.*/
/* j is the number of + signs in the model V1+V2+V3 j=2 i=3 to 1 */
/* modelsav=V2+V1+V4+age*V3 strb=age*V3 stra=V2+V1+V4 */
/* k=4 (age*V3) Tvar[k=4]= 3 (from V3) Tage[cptcovage=1]=4 */
/* k=3 V4 Tvar[k=3]= 4 (from V4) */
/* k=2 V1 Tvar[k=2]= 1 (from V1) */
/* k=1 Tvar[1]=2 (from V2) */
/* k=5 Tvar[5] */
/* for (k=1; k<=cptcovn;k++) { */
/* cov[2+k]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]]; */
/* } */
/* for (k=1; k<=cptcovage;k++) cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2]; */
/*
* Treating invertedly V2+V1+V3*age+V2*V4 is as if written V2*V4 +V3*age + V1 + V2 */
for(k=cptcovt; k>=1;k--) /**< Number of covariates */
Tvar[k]=0;
cptcovage=0;
for(k=1; k<=cptcovt;k++){ /* Loop on total covariates of the model */
cutl(stra,strb,modelsav,'+'); /* keeps in strb after the first '+'
modelsav==V2+V1+V4+V3*age strb=V3*age stra=V2+V1+V4 */
if (nbocc(modelsav,'+')==0) strcpy(strb,modelsav); /* and analyzes it */
/* printf("i=%d a=%s b=%s sav=%s\n",i, stra,strb,modelsav);*/
/*scanf("%d",i);*/
if (strchr(strb,'*')) { /**< Model includes a product V2+V1+V4+V3*age strb=V3*age */
cutl(strc,strd,strb,'*'); /**< strd*strc Vm*Vn: strb=V3*age(input) strc=age strd=V3 ; V3*V2 strc=V2, strd=V3 */
if (strcmp(strc,"age")==0) { /**< Model includes age: Vn*age */
/* covar is not filled and then is empty */
cptcovprod--;
cutl(stre,strb,strd,'V'); /* strd=V3(input): stre="3" */
Tvar[k]=atoi(stre); /* V2+V1+V4+V3*age Tvar[4]=3 ; V1+V2*age Tvar[2]=2 */
cptcovage++; /* Sums the number of covariates which include age as a product */
Tage[cptcovage]=k; /* Tage[1] = 4 */
/*printf("stre=%s ", stre);*/
} else if (strcmp(strd,"age")==0) { /* or age*Vn */
cptcovprod--;
cutl(stre,strb,strc,'V');
Tvar[k]=atoi(stre);
cptcovage++;
Tage[cptcovage]=k;
} else { /* Age is not in the model product V2+V1+V1*V4+V3*age+V3*V2 strb=V3*V2*/
/* loops on k1=1 (V3*V2) and k1=2 V4*V3 */
cptcovn++;
cptcovprodnoage++;k1++;
cutl(stre,strb,strc,'V'); /* strc= Vn, stre is n; strb=V3*V2 stre=3 strc=*/
Tvar[k]=ncovcol+k1; /* For model-covariate k tells which data-covariate to use but
because this model-covariate is a construction we invent a new column
ncovcol + k1
If already ncovcol=4 and model=V2+V1+V1*V4+age*V3+V3*V2
Tvar[3=V1*V4]=4+1 Tvar[5=V3*V2]=4 + 2= 6, etc */
cutl(strc,strb,strd,'V'); /* strd was Vm, strc is m */
Tprod[k1]=k; /* Tprod[1]=3(=V1*V4) for V2+V1+V1*V4+age*V3+V3*V2 */
Tvard[k1][1] =atoi(strc); /* m 1 for V1*/
Tvard[k1][2] =atoi(stre); /* n 4 for V4*/
k2=k2+2;
Tvar[cptcovt+k2]=Tvard[k1][1]; /* Tvar[(cptcovt=4+k2=1)=5]= 1 (V1) */
Tvar[cptcovt+k2+1]=Tvard[k1][2]; /* Tvar[(cptcovt=4+(k2=1)+1)=6]= 4 (V4) */
for (i=1; i<=lastobs;i++){
/* Computes the new covariate which is a product of
covar[n][i]* covar[m][i] and stores it at ncovol+k1 May not be defined */
covar[ncovcol+k1][i]=covar[atoi(stre)][i]*covar[atoi(strc)][i];
}
} /* End age is not in the model */
} /* End if model includes a product */
else { /* no more sum */
/*printf("d=%s c=%s b=%s\n", strd,strc,strb);*/
/* scanf("%d",i);*/
cutl(strd,strc,strb,'V');
ks++; /**< Number of simple covariates */
cptcovn++;
Tvar[k]=atoi(strd);
}
strcpy(modelsav,stra); /* modelsav=V2+V1+V4 stra=V2+V1+V4 */
/*printf("a=%s b=%s sav=%s\n", stra,strb,modelsav);
scanf("%d",i);*/
} /* end of loop + */
} /* end model */
/*The number n of Vn is stored in Tvar. cptcovage =number of age covariate. Tage gives the position of age. cptcovprod= number of products.
If model=V1+V1*age then Tvar[1]=1 Tvar[2]=1 cptcovage=1 Tage[1]=2 cptcovprod=0*/
/* printf("tvar1=%d tvar2=%d tvar3=%d cptcovage=%d Tage=%d",Tvar[1],Tvar[2],Tvar[3],cptcovage,Tage[1]);
printf("cptcovprod=%d ", cptcovprod);
fprintf(ficlog,"cptcovprod=%d ", cptcovprod);
scanf("%d ",i);*/
return (0); /* with covar[new additional covariate if product] and Tage if age */
/*endread:*/
printf("Exiting decodemodel: ");
return (1);
}
int calandcheckages(int imx, int maxwav, double *agemin, double *agemax, int *nberr, int *nbwarn )
{
int i, m;
for (i=1; i<=imx; i++) {
for(m=2; (m<= maxwav); m++) {
if (((int)mint[m][i]== 99) && (s[m][i] <= nlstate)){
anint[m][i]=9999;
s[m][i]=-1;
}
if((int)moisdc[i]==99 && (int)andc[i]==9999 && s[m][i]>nlstate){
*nberr = *nberr + 1;
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);
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);
s[m][i]=-1;
}
if((int)moisdc[i]==99 && (int)andc[i]!=9999 && s[m][i]>nlstate){
(*nberr)++;
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]);
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]);
s[m][i]=-1; /* We prefer to skip it (and to skip it in version 0.8a1 too */
}
}
}
for (i=1; i<=imx; i++) {
agedc[i]=(moisdc[i]/12.+andc[i])-(moisnais[i]/12.+annais[i]);
for(m=firstpass; (m<= lastpass); m++){
if(s[m][i] >0 || s[m][i]==-2 || s[m][i]==-4 || s[m][i]==-5){
if (s[m][i] >= nlstate+1) {
if(agedc[i]>0){
if((int)moisdc[i]!=99 && (int)andc[i]!=9999){
agev[m][i]=agedc[i];
/*if(moisdc[i]==99 && andc[i]==9999) s[m][i]=-1;*/
}else {
if ((int)andc[i]!=9999){
nbwarn++;
printf("Warning negative age at death: %ld line:%d\n",num[i],i);
fprintf(ficlog,"Warning negative age at death: %ld line:%d\n",num[i],i);
agev[m][i]=-1;
}
}
} /* agedc > 0 */
}
else if(s[m][i] !=9){ /* Standard case, age in fractional
years but with the precision of a month */
agev[m][i]=(mint[m][i]/12.+1./24.+anint[m][i])-(moisnais[i]/12.+1./24.+annais[i]);
if((int)mint[m][i]==99 || (int)anint[m][i]==9999)
agev[m][i]=1;
else if(agev[m][i] < *agemin){
*agemin=agev[m][i];
printf(" Min anint[%d][%d]=%.2f annais[%d]=%.2f, agemin=%.2f\n",m,i,anint[m][i], i,annais[i], *agemin);
}
else if(agev[m][i] >*agemax){
*agemax=agev[m][i];
/* printf(" Max anint[%d][%d]=%.0f annais[%d]=%.0f, agemax=%.2f\n",m,i,anint[m][i], i,annais[i], *agemax);*/
}
/*agev[m][i]=anint[m][i]-annais[i];*/
/* agev[m][i] = age[i]+2*m;*/
}
else { /* =9 */
agev[m][i]=1;
s[m][i]=-1;
}
}
else /*= 0 Unknown */
agev[m][i]=1;
}
}
for (i=1; i<=imx; i++) {
for(m=firstpass; (m<=lastpass); m++){
if (s[m][i] > (nlstate+ndeath)) {
(*nberr)++;
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);
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);
return 1;
}
}
}
/*for (i=1; i<=imx; i++){
for (m=firstpass; (m
%s \
\n\
Title=%s
Datafile=%s Firstpass=%d Lastpass=%d Stepm=%d Weight=%d Model=%s
\n",\
optionfilehtmcov,version,fullversion,title,datafile,firstpass,lastpass,stepm, weightopt, model);
}
fprintf(fichtm,"\n
%s \
\n\
Title=%s
Datafile=%s Firstpass=%d Lastpass=%d Stepm=%d Weight=%d Model=%s
\n\
\n\
\
\n",\
optionfilehtm,version,fullversion,title,datafile,firstpass,lastpass,stepm, weightopt, model,\
optionfilefiname,optionfilext,optionfilefiname,optionfilext,\
fileres,fileres,\
filelog,filelog,optionfilegnuplot,optionfilegnuplot,strstart);
fflush(fichtm);
strcpy(pathr,path);
strcat(pathr,optionfilefiname);
chdir(optionfilefiname); /* Move to directory named optionfile */
/* Calculates basic frequencies. Computes observed prevalence at single age
and prints on file fileres'p'. */
freqsummary(fileres, agemin, agemax, s, agev, nlstate, imx,Tvaraff,nbcode, ncodemax,mint,anint,strstart);
fprintf(fichtm,"\n");
fprintf(fichtm,"Parameter files
\n\
- Parameter file: %s.%s
\n\
- Copy of the parameter file: o%s
\n\
- Log file of the run: %s
\n\
- Gnuplot file name: %s
\n\
- Date and time at start: %s
Total number of observations=%d
\n\
Youngest age at first (selected) pass %.2f, oldest age %.2f
\n\
Interval (in months) between two waves: Min=%d Max=%d Mean=%.2lf
\n",\
imx,agemin,agemax,jmin,jmax,jmean);
pmmij= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */
oldms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */
newms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */
savms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */
oldm=oldms; newm=newms; savm=savms; /* Keeps fixed addresses to free */
/* For Powell, parameters are in a vector p[] starting at p[1]
so we point p on param[1][1] so that p[1] maps on param[1][1][1] */
p=param[1][1]; /* *(*(*(param +1)+1)+0) */
globpr=0; /* To get the number ipmx of contributions and the sum of weights*/
if (mle==-3){
ximort=matrix(1,NDIM,1,NDIM);
/* ximort=gsl_matrix_alloc(1,NDIM,1,NDIM); */
cens=ivector(1,n);
ageexmed=vector(1,n);
agecens=vector(1,n);
dcwave=ivector(1,n);
for (i=1; i<=imx; i++){
dcwave[i]=-1;
for (m=firstpass; m<=lastpass; m++)
if (s[m][i]>nlstate) {
dcwave[i]=m;
/* printf("i=%d j=%d s=%d dcwave=%d\n",i,j, s[j][i],dcwave[i]);*/
break;
}
}
for (i=1; i<=imx; i++) {
if (wav[i]>0){
ageexmed[i]=agev[mw[1][i]][i];
j=wav[i];
agecens[i]=1.;
if (ageexmed[i]> 1 && wav[i] > 0){
agecens[i]=agev[mw[j][i]][i];
cens[i]= 1;
}else if (ageexmed[i]< 1)
cens[i]= -1;
if (agedc[i]< AGESUP && agedc[i]>1 && dcwave[i]>firstpass && dcwave[i]<=lastpass)
cens[i]=0 ;
}
else cens[i]=-1;
}
for (i=1;i<=NDIM;i++) {
for (j=1;j<=NDIM;j++)
ximort[i][j]=(i == j ? 1.0 : 0.0);
}
/*p[1]=0.0268; p[NDIM]=0.083;*/
/*printf("%lf %lf", p[1], p[2]);*/
#ifdef GSL
printf("GSL optimization\n"); fprintf(ficlog,"Powell\n");
#else
printf("Powell\n"); fprintf(ficlog,"Powell\n");
#endif
strcpy(filerespow,"pow-mort");
strcat(filerespow,fileres);
if((ficrespow=fopen(filerespow,"w"))==NULL) {
printf("Problem with resultfile: %s\n", filerespow);
fprintf(ficlog,"Problem with resultfile: %s\n", filerespow);
}
#ifdef GSL
fprintf(ficrespow,"# GSL optimization\n# iter -2*LL");
#else
fprintf(ficrespow,"# Powell\n# iter -2*LL");
#endif
/* for (i=1;i<=nlstate;i++)
for(j=1;j<=nlstate+ndeath;j++)
if(j!=i)fprintf(ficrespow," p%1d%1d",i,j);
*/
fprintf(ficrespow,"\n");
#ifdef GSL
/* gsl starts here */
T = gsl_multimin_fminimizer_nmsimplex;
gsl_multimin_fminimizer *sfm = NULL;
gsl_vector *ss, *x;
gsl_multimin_function minex_func;
/* Initial vertex size vector */
ss = gsl_vector_alloc (NDIM);
if (ss == NULL){
GSL_ERROR_VAL ("failed to allocate space for ss", GSL_ENOMEM, 0);
}
/* Set all step sizes to 1 */
gsl_vector_set_all (ss, 0.001);
/* Starting point */
x = gsl_vector_alloc (NDIM);
if (x == NULL){
gsl_vector_free(ss);
GSL_ERROR_VAL ("failed to allocate space for x", GSL_ENOMEM, 0);
}
/* Initialize method and iterate */
/* p[1]=0.0268; p[NDIM]=0.083; */
/* gsl_vector_set(x, 0, 0.0268); */
/* gsl_vector_set(x, 1, 0.083); */
gsl_vector_set(x, 0, p[1]);
gsl_vector_set(x, 1, p[2]);
minex_func.f = &gompertz_f;
minex_func.n = NDIM;
minex_func.params = (void *)&p; /* ??? */
sfm = gsl_multimin_fminimizer_alloc (T, NDIM);
gsl_multimin_fminimizer_set (sfm, &minex_func, x, ss);
printf("Iterations beginning .....\n\n");
printf("Iter. # Intercept Slope -Log Likelihood Simplex size\n");
iteri=0;
while (rval == GSL_CONTINUE){
iteri++;
status = gsl_multimin_fminimizer_iterate(sfm);
if (status) printf("error: %s\n", gsl_strerror (status));
fflush(0);
if (status)
break;
rval = gsl_multimin_test_size (gsl_multimin_fminimizer_size (sfm), 1e-6);
ssval = gsl_multimin_fminimizer_size (sfm);
if (rval == GSL_SUCCESS)
printf ("converged to a local maximum at\n");
printf("%5d ", iteri);
for (it = 0; it < NDIM; it++){
printf ("%10.5f ", gsl_vector_get (sfm->x, it));
}
printf("f() = %-10.5f ssize = %.7f\n", sfm->fval, ssval);
}
printf("\n\n Please note: Program should be run many times with varying starting points to detemine global maximum\n\n");
gsl_vector_free(x); /* initial values */
gsl_vector_free(ss); /* inital step size */
for (it=0; it
Local time at start %s
Local time at end %s
\n",strstart, strtend);
fclose(fichtm);
fprintf(fichtmcov,"
Local time at start %s
Local time at end %s
\n",strstart, strtend);
fclose(fichtmcov);
fclose(ficgp);
fclose(ficlog);
/*------ End -----------*/
printf("Before Current directory %s!\n",pathcd);
if(chdir(pathcd) != 0)
printf("Can't move to directory %s!\n",path);
if(getcwd(pathcd,MAXLINE) > 0)
printf("Current directory %s!\n",pathcd);
/*strcat(plotcmd,CHARSEPARATOR);*/
sprintf(plotcmd,"gnuplot");
#ifdef _WIN32
sprintf(plotcmd,"\"%sgnuplot.exe\"",pathimach);
#endif
if(!stat(plotcmd,&info)){
printf("Error or gnuplot program not found: '%s'\n",plotcmd);fflush(stdout);
if(!stat(getenv("GNUPLOTBIN"),&info)){
printf("Error or gnuplot program not found: '%s' Environment GNUPLOTBIN not set.\n",plotcmd);fflush(stdout);
}else
strcpy(pplotcmd,plotcmd);
#ifdef __unix
strcpy(plotcmd,GNUPLOTPROGRAM);
if(!stat(plotcmd,&info)){
printf("Error gnuplot program not found: '%s'\n",plotcmd);fflush(stdout);
}else
strcpy(pplotcmd,plotcmd);
#endif
}else
strcpy(pplotcmd,plotcmd);
sprintf(plotcmd,"%s %s",pplotcmd, optionfilegnuplot);
printf("Starting graphs with: '%s'\n",plotcmd);fflush(stdout);
if((outcmd=system(plotcmd)) != 0){
printf("gnuplot command might not be in your path: '%s', err=%d\n", plotcmd, outcmd);
printf("\n Trying if gnuplot resides on the same directory that IMaCh\n");
sprintf(plotcmd,"%sgnuplot %s", pathimach, optionfilegnuplot);
if((outcmd=system(plotcmd)) != 0)
printf("\n Still a problem with gnuplot command %s, err=%d\n", plotcmd, outcmd);
}
printf(" Successful, please wait...");
while (z[0] != 'q') {
/* chdir(path); */
printf("\nType e to edit results with your browser, g to graph again and q for exit: ");
scanf("%s",z);
/* if (z[0] == 'c') system("./imach"); */
if (z[0] == 'e') {
#ifdef __APPLE__
sprintf(pplotcmd, "open %s", optionfilehtm);
#elif __linux
sprintf(pplotcmd, "xdg-open %s", optionfilehtm);
#else
sprintf(pplotcmd, "%s", optionfilehtm);
#endif
printf("Starting browser with: %s",pplotcmd);fflush(stdout);
system(pplotcmd);
}
else if (z[0] == 'g') system(plotcmd);
else if (z[0] == 'q') exit(0);
}
end:
while (z[0] != 'q') {
printf("\nType q for exiting: ");
scanf("%s",z);
}
}