/* $Id: imach.c,v 1.138 2010/04/30 18:19:40 brouard Exp $ $State: Exp $ $Log: imach.c,v $ 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]); */
/* } */
/* } */
/********************** 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])
*/
}
/*************************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;
}
/***************** 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,fv,fw,fx;
double ftemp;
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 DEBUG
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) {
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));
ulim=(*bx)+GLIMIT*(*cx-*bx);
if ((*bx-u)*(u-*cx) > 0.0) {
fu=(*func)(u);
} else if ((*cx-u)*(u-ulim) > 0.0) {
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=ulim;
fu=(*func)(u);
} else {
u=(*cx)+GOLD*(*cx-*bx);
fu=(*func)(u);
}
SHFT(*ax,*bx,*cx,u)
SHFT(*fa,*fb,*fc,fu)
}
}
/*************** linmin ************************/
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);
*fret=brent(ax,xx,bx,f1dim,TOL,&xmin);
#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);
}
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,"%d day(s) %d hour(s) %d minute(s) %d second(s)",days, hours, minutes, sec_left);
return ascdiff;
}
/*************** powell ************************/
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];
for (*iter=1;;++(*iter)) {
fp=(*fret);
ibig=0;
del=0.0;
last_time=curr_time;
(void) gettimeofday(&curr_time,&tzp);
printf("\nPowell iter=%d -2*LL=%.12f %ld sec. %ld sec.",*iter,*fret, curr_time.tv_sec-last_time.tv_sec, curr_time.tv_sec-start_time.tv_sec);fflush(stdout);
fprintf(ficlog,"\nPowell iter=%d -2*LL=%.12f %ld sec. %ld sec.",*iter,*fret, curr_time.tv_sec-last_time.tv_sec, curr_time.tv_sec-start_time.tv_sec); fflush(ficlog);
/* fprintf(ficrespow,"%d %.12f %ld",*iter,*fret,curr_time.tv_sec-start_time.tv_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){
tm = *localtime(&curr_time.tv_sec);
strcpy(strcurr,asctime(&tm));
/* asctime_r(&tm,strcurr); */
forecast_time=curr_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 this last iteration #%d: %ld seconds,\n",*iter,curr_time.tv_sec-last_time.tv_sec);
fprintf(ficlog,"\nConsidering the time needed for this last iteration #%d: %ld seconds,\n",*iter,curr_time.tv_sec-last_time.tv_sec);
for(niterf=10;niterf<=30;niterf+=10){
forecast_time.tv_sec=curr_time.tv_sec+(niterf-*iter)*(curr_time.tv_sec-last_time.tv_sec);
tmf = *localtime(&forecast_time.tv_sec);
/* asctime_r(&tmf,strfor); */
strcpy(strfor,asctime(&tmf));
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(forecast_time.tv_sec-curr_time.tv_sec,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(forecast_time.tv_sec-curr_time.tv_sec,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 \n",*fret);
fprintf(ficlog,"fret=%lf \n",*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=%.12e",p[j]);
fprintf(ficlog," p=%.12e",p[j]);
}
printf("\n");
fprintf(ficlog,"\n");
#endif
}
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++) {
ptt[j]=2.0*p[j]-pt[j];
xit[j]=p[j]-pt[j];
pt[j]=p[j];
}
fptt=(*func)(ptt);
if (fptt < fp) {
t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)-del*SQR(fp-fptt);
if (t < 0.0) {
linmin(p,xit,n,fret,func);
for (j=1;j<=n;j++) {
xi[j][ibig]=xi[j][n];
xi[j][n]=xit[j];
}
#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
}
}
}
}
/**** 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();
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("ij=%d k=%d Tvar[k]=%d nbcode=%d cov=%lf codtab[ij][Tvar[k]]=%d \n",ij,k, Tvar[k],nbcode[Tvar[k]][codtab[ij][Tvar[k]]],cov[2+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++)
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]);*/
out=matprod2(newm, pmij(pmmij,cov,ncovmodel,x,nlstate),1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, oldm);
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);
max=FMAX(max,prlim[i][j]);
min=FMIN(min,prlim[i][j]);
}
maxmin=max-min;
maxmax=FMAX(maxmax,maxmin);
}
if(maxmax < ftolpl){
return prlim;
}
}
}
/*************** 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,j1, 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; j 1 the results are less biased than in previous versions.
*/
s1=s[mw[mi][i]][i];
s2=s[mw[mi+1][i]][i];
bbh=(double)bh[mi][i]/(double)stepm;
/* bias bh is positive if real duration
* is higher than the multiple of stepm and negative otherwise.
*/
/* lli= (savm[s1][s2]>1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2]));*/
if( s2 > nlstate){
/* i.e. if s2 is a death state and if the date of death is known
then the contribution to the likelihood is the probability to
die between last step unit time and current step unit time,
which is also equal to probability to die before dh
minus probability to die before dh-stepm .
In version up to 0.92 likelihood was computed
as if date of death was unknown. Death was treated as any other
health state: the date of the interview describes the actual state
and not the date of a change in health state. The former idea was
to consider that at each interview the state was recorded
(healthy, disable or death) and IMaCh was corrected; but when we
introduced the exact date of death then we should have modified
the contribution of an exact death to the likelihood. This new
contribution is smaller and very dependent of the step unit
stepm. It is no more the probability to die between last interview
and month of death but the probability to survive from last
interview up to one month before death multiplied by the
probability to die within a month. Thanks to Chris
Jackson for correcting this bug. Former versions increased
mortality artificially. The bad side is that we add another loop
which slows down the processing. The difference can be up to 10%
lower mortality.
*/
lli=log(out[s1][s2] - savm[s1][s2]);
} else if (s2==-2) {
for (j=1,survp=0. ; j<=nlstate; j++)
survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j];
/*survp += out[s1][j]; */
lli= log(survp);
}
else if (s2==-4) {
for (j=3,survp=0. ; j<=nlstate; j++)
survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j];
lli= log(survp);
}
else if (s2==-5) {
for (j=1,survp=0. ; j<=2; j++)
survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j];
lli= log(survp);
}
else{
lli= log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]); /* linear interpolation */
/* lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*(savm[s1][s2])):log((1.+bbh)*out[s1][s2]));*/ /* linear interpolation */
}
/*lli=(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]);*/
/*if(lli ==000.0)*/
/*printf("bbh= %f lli=%f savm=%f out=%f %d\n",bbh,lli,savm[s1][s2], out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]],i); */
ipmx +=1;
sw += weight[i];
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli;
} /* end of wave */
} /* end of individual */
} else if(mle==2){
for (i=1,ipmx=0, sw=0.; i<=imx; i++){
for (k=1; k<=cptcovn;k++) cov[2+k]=covar[Tvar[k]][i];
for(mi=1; mi<= wav[i]-1; mi++){
for (ii=1;ii<=nlstate+ndeath;ii++)
for (j=1;j<=nlstate+ndeath;j++){
oldm[ii][j]=(ii==j ? 1.0 : 0.0);
savm[ii][j]=(ii==j ? 1.0 : 0.0);
}
for(d=0; d<=dh[mi][i]; d++){
newm=savm;
cov[2]=agev[mw[mi][i]][i]+d*stepm/YEARM;
for (kk=1; kk<=cptcovage;kk++) {
cov[Tage[kk]+2]=covar[Tvar[Tage[kk]]][i]*cov[2];
}
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath,
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate));
savm=oldm;
oldm=newm;
} /* end mult */
s1=s[mw[mi][i]][i];
s2=s[mw[mi+1][i]][i];
bbh=(double)bh[mi][i]/(double)stepm;
lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*(savm[s1][s2])):log((1.+bbh)*out[s1][s2])); /* linear interpolation */
ipmx +=1;
sw += weight[i];
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli;
} /* end of wave */
} /* end of individual */
} else if(mle==3){ /* exponential inter-extrapolation */
for (i=1,ipmx=0, sw=0.; i<=imx; i++){
for (k=1; k<=cptcovn;k++) cov[2+k]=covar[Tvar[k]][i];
for(mi=1; mi<= wav[i]-1; mi++){
for (ii=1;ii<=nlstate+ndeath;ii++)
for (j=1;j<=nlstate+ndeath;j++){
oldm[ii][j]=(ii==j ? 1.0 : 0.0);
savm[ii][j]=(ii==j ? 1.0 : 0.0);
}
for(d=0; d ");
m=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=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;
double **xi;
double fret;
double fretone; /* Only one call to likelihood */
/* char filerespow[FILENAMELENGTH];*/
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");
powell(p,xi,npar,ftol,&iter,&fret,func);
free_matrix(xi,1,npar,1,npar);
fclose(ficrespow);
printf("\n#Number of iterations = %d, -2 Log likelihood = %.12f\n",iter,func(p));
fprintf(ficlog,"\n#Number of iterations = %d, -2 Log likelihood = %.12f \n",iter,func(p));
fprintf(ficres,"#Number of iterations = %d, -2 Log likelihood = %.12f \n",iter,func(p));
}
/**** Computes Hessian and covariance matrix ***/
void hesscov(double **matcov, double p[], int npar, double delti[], double ftolhess, double (*func)(double []))
{
double **a,**y,*x,pd;
double **hess;
int i, j,jk;
int *indx;
double hessii(double p[], double delta, int theta, double delti[],double (*func)(double []),int npar);
double hessij(double p[], double delti[], int i, int j,double (*func)(double []),int npar);
void lubksb(double **a, int npar, int *indx, double b[]) ;
void ludcmp(double **a, int npar, int *indx, double *d) ;
double gompertz(double p[]);
hess=matrix(1,npar,1,npar);
printf("\nCalculation of the hessian matrix. Wait...\n");
fprintf(ficlog,"\nCalculation of the hessian matrix. Wait...\n");
for (i=1;i<=npar;i++){
printf("%d",i);fflush(stdout);
fprintf(ficlog,"%d",i);fflush(ficlog);
hess[i][i]=hessii(p,ftolhess,i,delti,func,npar);
/* printf(" %f ",p[i]);
printf(" %lf %lf %lf",hess[i][i],ftolhess,delti[i]);*/
}
for (i=1;i<=npar;i++) {
for (j=1;j<=npar;j++) {
if (j>i) {
printf(".%d%d",i,j);fflush(stdout);
fprintf(ficlog,".%d%d",i,j);fflush(ficlog);
hess[i][j]=hessij(p,delti,i,j,func,npar);
hess[j][i]=hess[i][j];
/*printf(" %lf ",hess[i][j]);*/
}
}
}
printf("\n");
fprintf(ficlog,"\n");
printf("\nInverting the hessian to get the covariance matrix. Wait...\n");
fprintf(ficlog,"\nInverting the hessian to get the covariance matrix. Wait...\n");
a=matrix(1,npar,1,npar);
y=matrix(1,npar,1,npar);
x=vector(1,npar);
indx=ivector(1,npar);
for (i=1;i<=npar;i++)
for (j=1;j<=npar;j++) a[i][j]=hess[i][j];
ludcmp(a,npar,indx,&pd);
for (j=1;j<=npar;j++) {
for (i=1;i<=npar;i++) x[i]=0;
x[j]=1;
lubksb(a,npar,indx,x);
for (i=1;i<=npar;i++){
matcov[i][j]=x[i];
}
}
printf("\n#Hessian matrix#\n");
fprintf(ficlog,"\n#Hessian matrix#\n");
for (i=1;i<=npar;i++) {
for (j=1;j<=npar;j++) {
printf("%.3e ",hess[i][j]);
fprintf(ficlog,"%.3e ",hess[i][j]);
}
printf("\n");
fprintf(ficlog,"\n");
}
/* Recompute Inverse */
for (i=1;i<=npar;i++)
for (j=1;j<=npar;j++) a[i][j]=matcov[i][j];
ludcmp(a,npar,indx,&pd);
/* printf("\n#Hessian matrix recomputed#\n");
for (j=1;j<=npar;j++) {
for (i=1;i<=npar;i++) x[i]=0;
x[j]=1;
lubksb(a,npar,indx,x);
for (i=1;i<=npar;i++){
y[i][j]=x[i];
printf("%.3e ",y[i][j]);
fprintf(ficlog,"%.3e ",y[i][j]);
}
printf("\n");
fprintf(ficlog,"\n");
}
*/
free_matrix(a,1,npar,1,npar);
free_matrix(y,1,npar,1,npar);
free_vector(x,1,npar);
free_ivector(indx,1,npar);
free_matrix(hess,1,npar,1,npar);
}
/*************** hessian matrix ****************/
double hessii(double x[], double delta, int theta, double delti[], double (*func)(double []), int npar)
{
int i;
int l=1, lmax=20;
double k1,k2;
double p2[MAXPARM+1]; /* identical to x */
double res;
double delt=0.0001, delts, nkhi=10.,nkhif=1., khi=1.e-4;
double fx;
int k=0,kmax=10;
double l1;
fx=func(x);
for (i=1;i<=npar;i++) p2[i]=x[i];
for(l=0 ; l <=lmax; l++){
l1=pow(10,l);
delts=delt;
for(k=1 ; k 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;set size 0.65, 0.65");
/* 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 1 ",subdirf(fileresprobmorprev));
fprintf(ficgp,"\n replot \"%s\" u 1:(($3+1.96*$4)) t \"95\%% interval\" w l 2 ",subdirf(fileresprobmorprev));
fprintf(ficgp,"\n replot \"%s\" u 1:(($3-1.96*$4)) not w l 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 **newm;
double **dnewm,**doldm;
int i, j, nhstepm, hstepm;
int k, cptcode;
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, i1, k1, l1, t, tj;
int k2, l2, j1, z1;
int k=0,l, cptcode;
int first=1, first1;
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,agelim, cov[NCOVMAX];
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;
if (cptcovn<1) {tj=1;ncodemax[1]=1;}
j1=0;
for(t=1; t<=tj;t++){
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#");
}
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]]];
}
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]]];
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(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);
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);
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=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++){
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 */
/* 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;
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) ){
printf("Error: 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. Continuing by making them positive: WRONG RESULTS.\n", lc1, lc2, v1, v2, cv12, i, j, (int)age,fileresprobcov, fileresprobcor);
fprintf(ficlog,"Error: 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", lc1, lc2, v1, v2, cv12);fflush(ficlog);
lc1=fabs(lc1);
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\nset size 0.65,0.65");
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%d1.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%d2.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
\
",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 : %s%d%d.png
\
",cpt,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 m0,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*/
for (cpt=1; cpt<= nlstate ; cpt ++) {
for (k1=1; k1<= m ; k1 ++) {
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\n\
set size 0.65,0.65\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 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 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 1,\"%s\" every :::%d::%d u 1:($%d) t\"Observed prevalence \" w l 2",subdirf2(fileres,"p"),k1-1,k1-1,2+4*(cpt-1));
}
}
/*2 eme*/
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\nset size 0.65,0.65\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 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 0");
else fprintf(ficgp,"\" t\"\" w l 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\n\
set size 0.65,0.65\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 (cpt=1; cpt<=nlstate ; cpt ++) {
k=3;
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\nset size 0.65,0.65\n\
unset log y\n\
plot [%.f:%.f] \"%s\" u ($1==%d ? ($3):1/0):($%d/($%d",ageminpar,agemaxpar,subdirf2(fileres,"pij"),k1,k+cpt+1,k+1);
for (i=1; i< nlstate ; i ++)
fprintf(ficgp,"+$%d",k+i+1);
fprintf(ficgp,")) t\"prev(%d,%d)\" w l",cpt,cpt+1);
l=3+(nlstate+ndeath)*cpt;
fprintf(ficgp,",\"%s\" u ($1==%d ? ($3):1/0):($%d/($%d",subdirf2(fileres,"pij"),k1,l+cpt+1,l+1);
for (i=1; i< nlstate ; i ++) {
l=3+(nlstate+ndeath)*cpt;
fprintf(ficgp,"+$%d",l+i+1);
}
fprintf(ficgp,")) t\"prev(%d,%d)\" w l\n",cpt+1,cpt+1);
}
}
/* 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");
}
}
}
}
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\nset size 0.65,0.65\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;
for(j=3; j <=ncovmodel; j++) {
if(((j-2)==Tage[ij]) &&(ij <=cptcovage)) {
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 */
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 ******************/
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, c, cptcod, i, h, i1;
int *popage;
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*************/
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 m,cpt,k1,i,k,j,jk,k2,k3,ij,l;
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\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, j, n;
int linei, month, year,iout;
char line[MAXLINE], linetmp[MAXLINE];
char stra[80], strb[80];
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 */
for (j=0; line[j]!='\0';j++){
line[j]=linetmp[j];
}
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 %ld 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 %ld 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.") != 0){
month=99;
year=9999;
}else{
printf("Error reading data around '%s' at line number %ld 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 %ld 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 %ld 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 %ld 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.") != 0){
month=99;
year=9999;
}else{
printf("Error reading data around '%s' at line number %ld 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 %ld 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 %ld 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 %ld 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 %ld, \"%s\" for individual %d\nShould be a weight. Exiting.\n",dval, i,line,linei);
fprintf(ficlog,"Error reading data around '%f' at line number %ld, \"%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 '%d' at line number %ld 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 '%d' at line number %ld 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 '%d' at line number %ld 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 '%d' at line number %ld 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);
}
int decodemodel ( char model[], int lastobs)
{
int i, j, k;
int i1, j1, k1, k2;
char modelsav[80];
char stra[80], strb[80], strc[80], strd[80],stre[80];
if (strlen(model) >1){ /* If there is at least 1 covariate */
j=0, j1=0, k1=1, k2=1;
j=nbocc(model,'+'); /* j=Number of '+' */
j1=nbocc(model,'*'); /* j1=Number of '*' */
cptcovn=j+1; /* Number of covariates V1+V2*age+V3 =>(2 plus signs) + 1=3
but the covariates which are product must be computed and stored. */
cptcovprod=j1; /*Number of products V1*V2 +v3*age = 2 */
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;
}
/* 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]; */
for(k=cptcovn; k>=1;k--){
cutv(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 */
cutv(strd,strc,strb,'*'); /* strd*strc Vm*Vn: strb=V3*age strc=age strd=V3 ; V3*V2 strc=V2, strd=V3 */
if (strcmp(strc,"age")==0) { /* Vn*age */
cptcovprod--;
cutv(strb,stre,strd,'V'); /* stre="V3" */
Tvar[k]=atoi(stre); /* V2+V1+V4+V3*age Tvar[4]=2 ; 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--;
cutv(strb,stre,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 */
cutv(strb,stre,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 */
cutv(strb,strc,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*/
Tvar[cptcovn+k2]=Tvard[k1][1]; /* Tvar[(cptcovn=4+k2=1)=5]= 1 (V1) */
Tvar[cptcovn+k2+1]=Tvard[k1][2]; /* Tvar[(cptcovn=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 */
covar[ncovcol+k1][i]=covar[atoi(stre)][i]*covar[atoi(strc)][i];
}
k1++;
k2=k2+2;
} /* 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);*/
cutv(strd,strc,strb,'V');
Tvar[k]=atoi(strc);
}
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);
}
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++;
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\n",(int)moisdc[i],(int)andc[i],num[i],i);
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\n",(int)moisdc[i],(int)andc[i],num[i],i);
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;
}
}
}
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(" anint[%d][%d]=%.0f annais[%d]=%.0f, agemax=%.0f\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");
#elsedef
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");
#elsedef
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");
#ifndef UNIX
sprintf(plotcmd,"\"%sgnuplot.exe\"",pathimach);
#endif
if(!stat(plotcmd,&info)){
printf("Error gnuplot program not found: %s\n",plotcmd);fflush(stdout);
if(!stat(getenv("GNUPLOTBIN"),&info)){
printf("Error 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("\n Problem with gnuplot\n");
}
printf(" Wait...");
while (z[0] != 'q') {
/* chdir(path); */
printf("\nType e to edit output files, g to graph again and q for exiting: ");
scanf("%s",z);
/* if (z[0] == 'c') system("./imach"); */
if (z[0] == 'e') {
printf("Starting browser with: %s",optionfilehtm);fflush(stdout);
system(optionfilehtm);
}
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);
}
}