|
|
| version 1.1, 2000/12/28 18:49:56 | version 1.7, 2001/05/02 17:50:24 |
|---|---|
| Line 1 | Line 1 |
| /*********************** Imach ************************************** | /*********************** Imach ************************************** |
| This program computes Healthy Life Expectancies from cross-longitudinal | This program computes Healthy Life Expectancies from cross-longitudinal |
| data. Cross-longitudinal consist in a first survey ("cross") where | data. Cross-longitudinal consist in a first survey ("cross") where |
| individuals from different ages are interviewed on their health status | individuals from different ages are interviewed on their health status |
| or degree of disability. At least a second wave of interviews | or degree of disability. At least a second wave of interviews |
| ("longitudinal") should measure each new individual health status. | ("longitudinal") should measure each new individual health status. |
| Health expectancies are computed from the transistions observed between | Health expectancies are computed from the transistions observed between |
| waves and are computed for each degree of severity of disability (number | waves and are computed for each degree of severity of disability (number |
| of life states). More degrees you consider, more time is necessary to | of life states). More degrees you consider, more time is necessary to |
| reach the Maximum Likekilhood of the parameters involved in the model. | reach the Maximum Likelihood of the parameters involved in the model. |
| The simplest model is the multinomial logistic model where pij is | The simplest model is the multinomial logistic model where pij is |
| the probabibility to be observed in state j at the second wave conditional | the probabibility to be observed in state j at the second wave conditional |
| to be observed in state i at the first wave. Therefore the model is: | to be observed in state i at the first wave. Therefore the model is: |
| log(pij/pii)= aij + bij*age+ cij*sex + etc , where 'age' is age and 'sex' | log(pij/pii)= aij + bij*age+ cij*sex + etc , where 'age' is age and 'sex' |
| is a covariate. If you want to have a more complex model than "constant and | is a covariate. If you want to have a more complex model than "constant and |
| age", you should modify the program where the markup | age", you should modify the program where the markup |
| *Covariates have to be included here again* invites you to do it. | *Covariates have to be included here again* invites you to do it. |
| More covariates you add, less is the speed of the convergence. | More covariates you add, less is the speed of the convergence. |
| The advantage that this computer programme claims, comes from that if the | The advantage that this computer programme claims, comes from that if the |
| delay between waves is not identical for each individual, or if some | delay between waves is not identical for each individual, or if some |
| individual missed an interview, the information is not rounded or lost, but | individual missed an interview, the information is not rounded or lost, but |
| taken into account using an interpolation or extrapolation. | taken into account using an interpolation or extrapolation. |
| hPijx is the probability to be | hPijx is the probability to be |
| observed in state i at age x+h conditional to the observed state i at age | observed in state i at age x+h conditional to the observed state i at age |
| x. The delay 'h' can be split into an exact number (nh*stepm) of | x. The delay 'h' can be split into an exact number (nh*stepm) of |
| unobserved intermediate states. This elementary transition (by month or | unobserved intermediate states. This elementary transition (by month or |
| quarter trimester, semester or year) is model as a multinomial logistic. | quarter trimester, semester or year) is model as a multinomial logistic. |
| The hPx matrix is simply the matrix product of nh*stepm elementary matrices | The hPx matrix is simply the matrix product of nh*stepm elementary matrices |
| and the contribution of each individual to the likelihood is simply hPijx. | and the contribution of each individual to the likelihood is simply hPijx. |
| Also this programme outputs the covariance matrix of the parameters but also | Also this programme outputs the covariance matrix of the parameters but also |
| of the life expectancies. It also computes the prevalence limits. | of the life expectancies. It also computes the prevalence limits. |
| Authors: Nicolas Brouard (brouard@ined.fr) and Agnès Lièvre (lievre@ined.fr). | Authors: Nicolas Brouard (brouard@ined.fr) and Agnès Lièvre (lievre@ined.fr). |
| Institut national d'études démographiques, Paris. | Institut national d'études démographiques, Paris. |
| This software have been partly granted by Euro-REVES, a concerted action | This software have been partly granted by Euro-REVES, a concerted action |
| from the European Union. | from the European Union. |
| It is copyrighted identically to a GNU software product, ie programme and | It is copyrighted identically to a GNU software product, ie programme and |
| software can be distributed freely for non commercial use. Latest version | software can be distributed freely for non commercial use. Latest version |
| can be accessed at http://euroreves.ined.fr/imach . | can be accessed at http://euroreves.ined.fr/imach . |
| **********************************************************************/ | **********************************************************************/ |
| #include <math.h> | #include <math.h> |
| #include <stdio.h> | #include <stdio.h> |
| #include <stdlib.h> | #include <stdlib.h> |
| #include <unistd.h> | #include <unistd.h> |
| #define MAXLINE 256 | #define MAXLINE 256 |
| #define FILENAMELENGTH 80 | #define FILENAMELENGTH 80 |
| /*#define DEBUG*/ | /*#define DEBUG*/ |
| /*#define win*/ | #define windows |
| #define GLOCK_ERROR_NOPATH -1 /* empty path */ | |
| #define MAXPARM 30 /* Maximum number of parameters for the optimization */ | #define GLOCK_ERROR_GETCWD -2 /* cannot get cwd */ |
| #define NPARMAX 64 /* (nlstate+ndeath-1)*nlstate*ncov */ | |
| #define MAXPARM 30 /* Maximum number of parameters for the optimization */ | |
| #define NINTERVMAX 8 | #define NPARMAX 64 /* (nlstate+ndeath-1)*nlstate*ncovmodel */ |
| #define NLSTATEMAX 8 /* Maximum number of live states (for func) */ | |
| #define NDEATHMAX 8 /* Maximum number of dead states (for func) */ | #define NINTERVMAX 8 |
| #define NCOVMAX 8 /* Maximum number of covariates */ | #define NLSTATEMAX 8 /* Maximum number of live states (for func) */ |
| #define MAXN 20000 | #define NDEATHMAX 8 /* Maximum number of dead states (for func) */ |
| #define YEARM 12. /* Number of months per year */ | #define NCOVMAX 8 /* Maximum number of covariates */ |
| #define AGESUP 130 | #define MAXN 20000 |
| #define AGEBASE 40 | #define YEARM 12. /* Number of months per year */ |
| #define AGESUP 130 | |
| #define AGEBASE 40 | |
| int nvar; | |
| int npar=NPARMAX; | int nvar; |
| int nlstate=2; /* Number of live states */ | static int cptcov; |
| int ndeath=1; /* Number of dead states */ | int cptcovn, cptcovage=0, cptcoveff=0; |
| int ncov; /* Total number of covariables including constant a12*1 +b12*x ncov=2 */ | int npar=NPARMAX; |
| int nlstate=2; /* Number of live states */ | |
| int *wav; /* Number of waves for this individuual 0 is possible */ | int ndeath=1; /* Number of dead states */ |
| int maxwav; /* Maxim number of waves */ | int ncovmodel, ncov; /* Total number of covariables including constant a12*1 +b12*x ncovmodel=2 */ |
| int mle, weightopt; | |
| int **mw; /* mw[mi][i] is number of the mi wave for this individual */ | int *wav; /* Number of waves for this individuual 0 is possible */ |
| int **dh; /* dh[mi][i] is number of steps between mi,mi+1 for this individual */ | int maxwav; /* Maxim number of waves */ |
| double **oldm, **newm, **savm; /* Working pointers to matrices */ | int mle, weightopt; |
| double **oldms, **newms, **savms; /* Fixed working pointers to matrices */ | int **mw; /* mw[mi][i] is number of the mi wave for this individual */ |
| FILE *fic,*ficpar, *ficparo,*ficres, *ficrespl, *ficrespij, *ficrest; | int **dh; /* dh[mi][i] is number of steps between mi,mi+1 for this individual */ |
| FILE *ficgp, *fichtm; | double **oldm, **newm, **savm; /* Working pointers to matrices */ |
| double **oldms, **newms, **savms; /* Fixed working pointers to matrices */ | |
| #define NR_END 1 | FILE *fic,*ficpar, *ficparo,*ficres, *ficrespl, *ficrespij, *ficrest; |
| #define FREE_ARG char* | FILE *ficgp, *fichtm; |
| #define FTOL 1.0e-10 | FILE *ficreseij; |
| char filerese[FILENAMELENGTH]; | |
| #define NRANSI | FILE *ficresvij; |
| #define ITMAX 200 | char fileresv[FILENAMELENGTH]; |
| FILE *ficresvpl; | |
| #define TOL 2.0e-4 | char fileresvpl[FILENAMELENGTH]; |
| #define CGOLD 0.3819660 | #define NR_END 1 |
| #define ZEPS 1.0e-10 | #define FREE_ARG char* |
| #define SHFT(a,b,c,d) (a)=(b);(b)=(c);(c)=(d); | #define FTOL 1.0e-10 |
| #define GOLD 1.618034 | #define NRANSI |
| #define GLIMIT 100.0 | #define ITMAX 200 |
| #define TINY 1.0e-20 | |
| #define TOL 2.0e-4 | |
| static double maxarg1,maxarg2; | |
| #define FMAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1)>(maxarg2)? (maxarg1):(maxarg2)) | #define CGOLD 0.3819660 |
| #define FMIN(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1)<(maxarg2)? (maxarg1):(maxarg2)) | #define ZEPS 1.0e-10 |
| #define SHFT(a,b,c,d) (a)=(b);(b)=(c);(c)=(d); | |
| #define SIGN(a,b) ((b)>0.0 ? fabs(a) : -fabs(a)) | |
| #define rint(a) floor(a+0.5) | #define GOLD 1.618034 |
| #define GLIMIT 100.0 | |
| static double sqrarg; | #define TINY 1.0e-20 |
| #define SQR(a) ((sqrarg=(a)) == 0.0 ? 0.0 :sqrarg*sqrarg) | |
| #define SWAP(a,b) {temp=(a);(a)=(b);(b)=temp;} | static double maxarg1,maxarg2; |
| #define FMAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1)>(maxarg2)? (maxarg1):(maxarg2)) | |
| int imx; | #define FMIN(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1)<(maxarg2)? (maxarg1):(maxarg2)) |
| int stepm; | |
| /* Stepm, step in month: minimum step interpolation*/ | #define SIGN(a,b) ((b)>0.0 ? fabs(a) : -fabs(a)) |
| #define rint(a) floor(a+0.5) | |
| int m,nb; | |
| int *num, firstpass=0, lastpass=2,*cod; | static double sqrarg; |
| double **agev,*moisnais, *annais, *moisdc, *andc,**mint, **anint; | #define SQR(a) ((sqrarg=(a)) == 0.0 ? 0.0 :sqrarg*sqrarg) |
| double **pmmij; | #define SWAP(a,b) {temp=(a);(a)=(b);(b)=temp;} |
| double *weight; | int imx; |
| int **s; /* Status */ | int stepm; |
| double *agedc, **covar, idx; | /* Stepm, step in month: minimum step interpolation*/ |
| int m,nb; | |
| double ftol=FTOL; /* Tolerance for computing Max Likelihood */ | int *num, firstpass=0, lastpass=4,*cod, *ncodemax, *Tage; |
| double ftolhess; /* Tolerance for computing hessian */ | double **agev,*moisnais, *annais, *moisdc, *andc,**mint, **anint; |
| double **pmmij; | |
| /******************************************/ | double *weight; |
| int **s; /* Status */ | |
| void replace(char *s, char*t) | double *agedc, **covar, idx; |
| { | int **nbcode, *Tcode, *Tvar, **codtab, **Tvard, *Tprod, cptcovprod, *Tvaraff; |
| int i; | |
| int lg=20; | double ftol=FTOL; /* Tolerance for computing Max Likelihood */ |
| i=0; | double ftolhess; /* Tolerance for computing hessian */ |
| lg=strlen(t); | |
| for(i=0; i<= lg; i++) { | /**************** split *************************/ |
| (s[i] = t[i]); | static int split( char *path, char *dirc, char *name ) |
| if (t[i]== '\\') s[i]='/'; | { |
| } | char *s; /* pointer */ |
| } | int l1, l2; /* length counters */ |
| void cut(char *u,char *v, char*t) | |
| { | l1 = strlen( path ); /* length of path */ |
| int i,lg,j,p; | if ( l1 == 0 ) return( GLOCK_ERROR_NOPATH ); |
| i=0; | s = strrchr( path, '\\' ); /* find last / */ |
| for(j=0; j<=strlen(t); j++) { | if ( s == NULL ) { /* no directory, so use current */ |
| if(t[j]=='\\') p=j; | #if defined(__bsd__) /* get current working directory */ |
| } | extern char *getwd( ); |
| lg=strlen(t); | if ( getwd( dirc ) == NULL ) { |
| for(j=0; j<p; j++) { | #else |
| (u[j] = t[j]); | extern char *getcwd( ); |
| u[p]='\0'; | |
| } | if ( getcwd( dirc, FILENAME_MAX ) == NULL ) { |
| #endif | |
| for(j=0; j<= lg; j++) { | return( GLOCK_ERROR_GETCWD ); |
| if (j>=(p+1))(v[j-p-1] = t[j]); | } |
| } | strcpy( name, path ); /* we've got it */ |
| } | } else { /* strip direcotry from path */ |
| s++; /* after this, the filename */ | |
| /********************** nrerror ********************/ | l2 = strlen( s ); /* length of filename */ |
| if ( l2 == 0 ) return( GLOCK_ERROR_NOPATH ); | |
| void nrerror(char error_text[]) | strcpy( name, s ); /* save file name */ |
| { | strncpy( dirc, path, l1 - l2 ); /* now the directory */ |
| fprintf(stderr,"ERREUR ...\n"); | dirc[l1-l2] = 0; /* add zero */ |
| fprintf(stderr,"%s\n",error_text); | } |
| exit(1); | l1 = strlen( dirc ); /* length of directory */ |
| } | if ( dirc[l1-1] != '\\' ) { dirc[l1] = '\\'; dirc[l1+1] = 0; } |
| /*********************** vector *******************/ | return( 0 ); /* we're done */ |
| 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; | void replace(char *s, char*t) |
| } | { |
| int i; | |
| /************************ free vector ******************/ | int lg=20; |
| void free_vector(double*v, int nl, int nh) | i=0; |
| { | lg=strlen(t); |
| free((FREE_ARG)(v+nl-NR_END)); | for(i=0; i<= lg; i++) { |
| } | (s[i] = t[i]); |
| if (t[i]== '\\') s[i]='/'; | |
| /************************ivector *******************************/ | } |
| int *ivector(long nl,long nh) | } |
| { | |
| int *v; | int nbocc(char *s, char occ) |
| v=(int *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(int))); | { |
| if (!v) nrerror("allocation failure in ivector"); | int i,j=0; |
| return v-nl+NR_END; | int lg=20; |
| } | i=0; |
| lg=strlen(s); | |
| /******************free ivector **************************/ | for(i=0; i<= lg; i++) { |
| void free_ivector(int *v, long nl, long nh) | if (s[i] == occ ) j++; |
| { | } |
| free((FREE_ARG)(v+nl-NR_END)); | return j; |
| } | } |
| /******************* imatrix *******************************/ | void cutv(char *u,char *v, char*t, char occ) |
| int **imatrix(long nrl, long nrh, long ncl, long nch) | { |
| /* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */ | int i,lg,j,p=0; |
| { | i=0; |
| long i, nrow=nrh-nrl+1,ncol=nch-ncl+1; | for(j=0; j<=strlen(t)-1; j++) { |
| int **m; | if((t[j]!= occ) && (t[j+1]== occ)) p=j+1; |
| } | |
| /* allocate pointers to rows */ | |
| m=(int **) malloc((size_t)((nrow+NR_END)*sizeof(int*))); | lg=strlen(t); |
| if (!m) nrerror("allocation failure 1 in matrix()"); | for(j=0; j<p; j++) { |
| m += NR_END; | (u[j] = t[j]); |
| m -= nrl; | } |
| u[p]='\0'; | |
| /* allocate rows and set pointers to them */ | for(j=0; j<= lg; j++) { |
| m[nrl]=(int *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(int))); | if (j>=(p+1))(v[j-p-1] = t[j]); |
| if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); | } |
| m[nrl] += NR_END; | } |
| m[nrl] -= ncl; | |
| /********************** nrerror ********************/ | |
| for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol; | |
| void nrerror(char error_text[]) | |
| /* return pointer to array of pointers to rows */ | { |
| return m; | fprintf(stderr,"ERREUR ...\n"); |
| } | fprintf(stderr,"%s\n",error_text); |
| exit(1); | |
| /****************** free_imatrix *************************/ | } |
| void free_imatrix(m,nrl,nrh,ncl,nch) | /*********************** vector *******************/ |
| int **m; | double *vector(int nl, int nh) |
| long nch,ncl,nrh,nrl; | { |
| /* free an int matrix allocated by imatrix() */ | double *v; |
| { | v=(double *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(double))); |
| free((FREE_ARG) (m[nrl]+ncl-NR_END)); | if (!v) nrerror("allocation failure in vector"); |
| free((FREE_ARG) (m+nrl-NR_END)); | return v-nl+NR_END; |
| } | } |
| /******************* matrix *******************************/ | /************************ free vector ******************/ |
| double **matrix(long nrl, long nrh, long ncl, long nch) | void free_vector(double*v, int nl, int nh) |
| { | { |
| long i, nrow=nrh-nrl+1, ncol=nch-ncl+1; | free((FREE_ARG)(v+nl-NR_END)); |
| double **m; | } |
| m=(double **) malloc((size_t)((nrow+NR_END)*sizeof(double*))); | /************************ivector *******************************/ |
| if (!m) nrerror("allocation failure 1 in matrix()"); | int *ivector(long nl,long nh) |
| m += NR_END; | { |
| m -= nrl; | int *v; |
| v=(int *) malloc((size_t)((nh-nl+1+NR_END)*sizeof(int))); | |
| m[nrl]=(double *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double))); | if (!v) nrerror("allocation failure in ivector"); |
| if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); | return v-nl+NR_END; |
| m[nrl] += NR_END; | } |
| m[nrl] -= ncl; | |
| /******************free ivector **************************/ | |
| for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol; | void free_ivector(int *v, long nl, long nh) |
| return m; | { |
| } | free((FREE_ARG)(v+nl-NR_END)); |
| } | |
| /*************************free matrix ************************/ | |
| void free_matrix(double **m, long nrl, long nrh, long ncl, long nch) | /******************* imatrix *******************************/ |
| { | int **imatrix(long nrl, long nrh, long ncl, long nch) |
| free((FREE_ARG)(m[nrl]+ncl-NR_END)); | /* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */ |
| free((FREE_ARG)(m+nrl-NR_END)); | { |
| } | long i, nrow=nrh-nrl+1,ncol=nch-ncl+1; |
| int **m; | |
| /******************* ma3x *******************************/ | |
| double ***ma3x(long nrl, long nrh, long ncl, long nch, long nll, long nlh) | /* allocate pointers to rows */ |
| { | m=(int **) malloc((size_t)((nrow+NR_END)*sizeof(int*))); |
| long i, j, nrow=nrh-nrl+1, ncol=nch-ncl+1, nlay=nlh-nll+1; | if (!m) nrerror("allocation failure 1 in matrix()"); |
| double ***m; | m += NR_END; |
| m -= nrl; | |
| m=(double ***) malloc((size_t)((nrow+NR_END)*sizeof(double*))); | |
| if (!m) nrerror("allocation failure 1 in matrix()"); | |
| m += NR_END; | /* allocate rows and set pointers to them */ |
| m -= nrl; | m[nrl]=(int *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(int))); |
| if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); | |
| m[nrl]=(double **) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double))); | m[nrl] += NR_END; |
| if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); | m[nrl] -= ncl; |
| m[nrl] += NR_END; | |
| m[nrl] -= ncl; | for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol; |
| for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol; | /* return pointer to array of pointers to rows */ |
| return m; | |
| 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; | /****************** free_imatrix *************************/ |
| m[nrl][ncl] -= nll; | void free_imatrix(m,nrl,nrh,ncl,nch) |
| for (j=ncl+1; j<=nch; j++) | int **m; |
| m[nrl][j]=m[nrl][j-1]+nlay; | long nch,ncl,nrh,nrl; |
| /* free an int matrix allocated by imatrix() */ | |
| for (i=nrl+1; i<=nrh; i++) { | { |
| m[i][ncl]=m[i-1l][ncl]+ncol*nlay; | free((FREE_ARG) (m[nrl]+ncl-NR_END)); |
| for (j=ncl+1; j<=nch; j++) | free((FREE_ARG) (m+nrl-NR_END)); |
| m[i][j]=m[i][j-1]+nlay; | } |
| } | |
| return m; | /******************* matrix *******************************/ |
| } | double **matrix(long nrl, long nrh, long ncl, long nch) |
| { | |
| /*************************free ma3x ************************/ | long i, nrow=nrh-nrl+1, ncol=nch-ncl+1; |
| void free_ma3x(double ***m, long nrl, long nrh, long ncl, long nch,long nll, long nlh) | double **m; |
| { | |
| free((FREE_ARG)(m[nrl][ncl]+ nll-NR_END)); | m=(double **) malloc((size_t)((nrow+NR_END)*sizeof(double*))); |
| free((FREE_ARG)(m[nrl]+ncl-NR_END)); | if (!m) nrerror("allocation failure 1 in matrix()"); |
| free((FREE_ARG)(m+nrl-NR_END)); | m += NR_END; |
| } | m -= nrl; |
| /***************** f1dim *************************/ | m[nrl]=(double *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double))); |
| extern int ncom; | if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); |
| extern double *pcom,*xicom; | m[nrl] += NR_END; |
| extern double (*nrfunc)(double []); | m[nrl] -= ncl; |
| double f1dim(double x) | for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol; |
| { | return m; |
| int j; | } |
| double f; | |
| double *xt; | /*************************free matrix ************************/ |
| void free_matrix(double **m, long nrl, long nrh, long ncl, long nch) | |
| xt=vector(1,ncom); | { |
| for (j=1;j<=ncom;j++) xt[j]=pcom[j]+x*xicom[j]; | free((FREE_ARG)(m[nrl]+ncl-NR_END)); |
| f=(*nrfunc)(xt); | free((FREE_ARG)(m+nrl-NR_END)); |
| free_vector(xt,1,ncom); | } |
| return f; | |
| } | /******************* ma3x *******************************/ |
| double ***ma3x(long nrl, long nrh, long ncl, long nch, long nll, long nlh) | |
| /*****************brent *************************/ | { |
| double brent(double ax, double bx, double cx, double (*f)(double), double tol, double *xmin) | long i, j, nrow=nrh-nrl+1, ncol=nch-ncl+1, nlay=nlh-nll+1; |
| { | double ***m; |
| int iter; | |
| double a,b,d,etemp; | m=(double ***) malloc((size_t)((nrow+NR_END)*sizeof(double*))); |
| double fu,fv,fw,fx; | if (!m) nrerror("allocation failure 1 in matrix()"); |
| double ftemp; | m += NR_END; |
| double p,q,r,tol1,tol2,u,v,w,x,xm; | m -= nrl; |
| double e=0.0; | |
| m[nrl]=(double **) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double))); | |
| a=(ax < cx ? ax : cx); | if (!m[nrl]) nrerror("allocation failure 2 in matrix()"); |
| b=(ax > cx ? ax : cx); | m[nrl] += NR_END; |
| x=w=v=bx; | m[nrl] -= ncl; |
| fw=fv=fx=(*f)(x); | |
| for (iter=1;iter<=ITMAX;iter++) { | for (i=nrl+1; i<=nrh; i++) m[i]=m[i-1]+ncol; |
| xm=0.5*(a+b); | |
| tol2=2.0*(tol1=tol*fabs(x)+ZEPS); | m[nrl][ncl]=(double *) malloc((size_t)((nrow*ncol*nlay+NR_END)*sizeof(double))); |
| /* if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret)))*/ | if (!m[nrl][ncl]) nrerror("allocation failure 3 in matrix()"); |
| printf(".");fflush(stdout); | m[nrl][ncl] += NR_END; |
| #ifdef DEBUG | m[nrl][ncl] -= nll; |
| 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); | for (j=ncl+1; j<=nch; j++) |
| /* if ((fabs(x-xm) <= (tol2-0.5*(b-a)))||(2.0*fabs(fu-ftemp) <= ftol*1.e-2*(fabs(fu)+fabs(ftemp)))) { */ | m[nrl][j]=m[nrl][j-1]+nlay; |
| #endif | |
| if (fabs(x-xm) <= (tol2-0.5*(b-a))){ | for (i=nrl+1; i<=nrh; i++) { |
| *xmin=x; | m[i][ncl]=m[i-1l][ncl]+ncol*nlay; |
| return fx; | for (j=ncl+1; j<=nch; j++) |
| } | m[i][j]=m[i][j-1]+nlay; |
| ftemp=fu; | } |
| if (fabs(e) > tol1) { | return m; |
| r=(x-w)*(fx-fv); | } |
| q=(x-v)*(fx-fw); | |
| p=(x-v)*q-(x-w)*r; | /*************************free ma3x ************************/ |
| q=2.0*(q-r); | void free_ma3x(double ***m, long nrl, long nrh, long ncl, long nch,long nll, long nlh) |
| if (q > 0.0) p = -p; | { |
| q=fabs(q); | free((FREE_ARG)(m[nrl][ncl]+ nll-NR_END)); |
| etemp=e; | free((FREE_ARG)(m[nrl]+ncl-NR_END)); |
| e=d; | free((FREE_ARG)(m+nrl-NR_END)); |
| 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 { | /***************** f1dim *************************/ |
| d=p/q; | extern int ncom; |
| u=x+d; | extern double *pcom,*xicom; |
| if (u-a < tol2 || b-u < tol2) | extern double (*nrfunc)(double []); |
| d=SIGN(tol1,xm-x); | |
| } | double f1dim(double x) |
| } else { | { |
| d=CGOLD*(e=(x >= xm ? a-x : b-x)); | int j; |
| } | double f; |
| u=(fabs(d) >= tol1 ? x+d : x+SIGN(tol1,d)); | double *xt; |
| fu=(*f)(u); | |
| if (fu <= fx) { | xt=vector(1,ncom); |
| if (u >= x) a=x; else b=x; | for (j=1;j<=ncom;j++) xt[j]=pcom[j]+x*xicom[j]; |
| SHFT(v,w,x,u) | f=(*nrfunc)(xt); |
| SHFT(fv,fw,fx,fu) | free_vector(xt,1,ncom); |
| } else { | return f; |
| if (u < x) a=u; else b=u; | } |
| if (fu <= fw || w == x) { | |
| v=w; | /*****************brent *************************/ |
| w=u; | double brent(double ax, double bx, double cx, double (*f)(double), double tol, double *xmin) |
| fv=fw; | { |
| fw=fu; | int iter; |
| } else if (fu <= fv || v == x || v == w) { | double a,b,d,etemp; |
| v=u; | double fu,fv,fw,fx; |
| fv=fu; | double ftemp; |
| } | double p,q,r,tol1,tol2,u,v,w,x,xm; |
| } | double e=0.0; |
| } | |
| nrerror("Too many iterations in brent"); | a=(ax < cx ? ax : cx); |
| *xmin=x; | b=(ax > cx ? ax : cx); |
| return fx; | x=w=v=bx; |
| } | fw=fv=fx=(*f)(x); |
| for (iter=1;iter<=ITMAX;iter++) { | |
| /****************** mnbrak ***********************/ | xm=0.5*(a+b); |
| tol2=2.0*(tol1=tol*fabs(x)+ZEPS); | |
| void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, double *fc, | /* if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret)))*/ |
| double (*func)(double)) | printf(".");fflush(stdout); |
| { | #ifdef DEBUG |
| double ulim,u,r,q, dum; | 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); |
| double fu; | /* if ((fabs(x-xm) <= (tol2-0.5*(b-a)))||(2.0*fabs(fu-ftemp) <= ftol*1.e-2*(fabs(fu)+fabs(ftemp)))) { */ |
| #endif | |
| *fa=(*func)(*ax); | if (fabs(x-xm) <= (tol2-0.5*(b-a))){ |
| *fb=(*func)(*bx); | *xmin=x; |
| if (*fb > *fa) { | return fx; |
| SHFT(dum,*ax,*bx,dum) | } |
| SHFT(dum,*fb,*fa,dum) | ftemp=fu; |
| } | if (fabs(e) > tol1) { |
| *cx=(*bx)+GOLD*(*bx-*ax); | r=(x-w)*(fx-fv); |
| *fc=(*func)(*cx); | q=(x-v)*(fx-fw); |
| while (*fb > *fc) { | p=(x-v)*q-(x-w)*r; |
| r=(*bx-*ax)*(*fb-*fc); | q=2.0*(q-r); |
| q=(*bx-*cx)*(*fb-*fa); | if (q > 0.0) p = -p; |
| u=(*bx)-((*bx-*cx)*q-(*bx-*ax)*r)/ | q=fabs(q); |
| (2.0*SIGN(FMAX(fabs(q-r),TINY),q-r)); | etemp=e; |
| ulim=(*bx)+GLIMIT*(*cx-*bx); | e=d; |
| if ((*bx-u)*(u-*cx) > 0.0) { | if (fabs(p) >= fabs(0.5*q*etemp) || p <= q*(a-x) || p >= q*(b-x)) |
| fu=(*func)(u); | d=CGOLD*(e=(x >= xm ? a-x : b-x)); |
| } else if ((*cx-u)*(u-ulim) > 0.0) { | else { |
| fu=(*func)(u); | d=p/q; |
| if (fu < *fc) { | u=x+d; |
| SHFT(*bx,*cx,u,*cx+GOLD*(*cx-*bx)) | if (u-a < tol2 || b-u < tol2) |
| SHFT(*fb,*fc,fu,(*func)(u)) | d=SIGN(tol1,xm-x); |
| } | } |
| } else if ((u-ulim)*(ulim-*cx) >= 0.0) { | } else { |
| u=ulim; | d=CGOLD*(e=(x >= xm ? a-x : b-x)); |
| fu=(*func)(u); | } |
| } else { | u=(fabs(d) >= tol1 ? x+d : x+SIGN(tol1,d)); |
| u=(*cx)+GOLD*(*cx-*bx); | fu=(*f)(u); |
| fu=(*func)(u); | if (fu <= fx) { |
| } | if (u >= x) a=x; else b=x; |
| SHFT(*ax,*bx,*cx,u) | SHFT(v,w,x,u) |
| SHFT(*fa,*fb,*fc,fu) | SHFT(fv,fw,fx,fu) |
| } | } else { |
| } | if (u < x) a=u; else b=u; |
| if (fu <= fw || w == x) { | |
| /*************** linmin ************************/ | v=w; |
| w=u; | |
| int ncom; | fv=fw; |
| double *pcom,*xicom; | fw=fu; |
| double (*nrfunc)(double []); | } else if (fu <= fv || v == x || v == w) { |
| v=u; | |
| void linmin(double p[], double xi[], int n, double *fret,double (*func)(double [])) | fv=fu; |
| { | } |
| double brent(double ax, double bx, double cx, | } |
| double (*f)(double), double tol, double *xmin); | } |
| double f1dim(double x); | nrerror("Too many iterations in brent"); |
| void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, | *xmin=x; |
| double *fc, double (*func)(double)); | return fx; |
| int j; | } |
| double xx,xmin,bx,ax; | |
| double fx,fb,fa; | /****************** mnbrak ***********************/ |
| ncom=n; | void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, double *fc, |
| pcom=vector(1,n); | double (*func)(double)) |
| xicom=vector(1,n); | { |
| nrfunc=func; | double ulim,u,r,q, dum; |
| for (j=1;j<=n;j++) { | double fu; |
| pcom[j]=p[j]; | |
| xicom[j]=xi[j]; | *fa=(*func)(*ax); |
| } | *fb=(*func)(*bx); |
| ax=0.0; | if (*fb > *fa) { |
| xx=1.0; | SHFT(dum,*ax,*bx,dum) |
| mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,f1dim); | SHFT(dum,*fb,*fa,dum) |
| *fret=brent(ax,xx,bx,f1dim,TOL,&xmin); | } |
| #ifdef DEBUG | *cx=(*bx)+GOLD*(*bx-*ax); |
| printf("retour brent fret=%.12e xmin=%.12e\n",*fret,xmin); | *fc=(*func)(*cx); |
| #endif | while (*fb > *fc) { |
| for (j=1;j<=n;j++) { | r=(*bx-*ax)*(*fb-*fc); |
| xi[j] *= xmin; | q=(*bx-*cx)*(*fb-*fa); |
| p[j] += xi[j]; | u=(*bx)-((*bx-*cx)*q-(*bx-*ax)*r)/ |
| } | (2.0*SIGN(FMAX(fabs(q-r),TINY),q-r)); |
| free_vector(xicom,1,n); | ulim=(*bx)+GLIMIT*(*cx-*bx); |
| free_vector(pcom,1,n); | if ((*bx-u)*(u-*cx) > 0.0) { |
| } | fu=(*func)(u); |
| } else if ((*cx-u)*(u-ulim) > 0.0) { | |
| /*************** powell ************************/ | fu=(*func)(u); |
| void powell(double p[], double **xi, int n, double ftol, int *iter, double *fret, | if (fu < *fc) { |
| double (*func)(double [])) | SHFT(*bx,*cx,u,*cx+GOLD*(*cx-*bx)) |
| SHFT(*fb,*fc,fu,(*func)(u)) | |
| { | } |
| } else if ((u-ulim)*(ulim-*cx) >= 0.0) { | |
| u=ulim; | |
| void linmin(double p[], double xi[], int n, double *fret, | fu=(*func)(u); |
| double (*func)(double [])); | } else { |
| int i,ibig,j; | u=(*cx)+GOLD*(*cx-*bx); |
| double del,t,*pt,*ptt,*xit; | fu=(*func)(u); |
| double fp,fptt; | } |
| double *xits; | SHFT(*ax,*bx,*cx,u) |
| pt=vector(1,n); | SHFT(*fa,*fb,*fc,fu) |
| ptt=vector(1,n); | } |
| xit=vector(1,n); | } |
| xits=vector(1,n); | |
| *fret=(*func)(p); | /*************** linmin ************************/ |
| for (j=1;j<=n;j++) pt[j]=p[j]; | |
| for (*iter=1;;++(*iter)) { | int ncom; |
| fp=(*fret); | double *pcom,*xicom; |
| ibig=0; | double (*nrfunc)(double []); |
| del=0.0; | |
| printf("\nPowell iter=%d -2*LL=%.12f",*iter,*fret); | void linmin(double p[], double xi[], int n, double *fret,double (*func)(double [])) |
| for (i=1;i<=n;i++) | { |
| printf(" %d %.12f",i, p[i]); | double brent(double ax, double bx, double cx, |
| printf("\n"); | double (*f)(double), double tol, double *xmin); |
| for (i=1;i<=n;i++) { | double f1dim(double x); |
| for (j=1;j<=n;j++) xit[j]=xi[j][i]; | void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, |
| fptt=(*fret); | double *fc, double (*func)(double)); |
| #ifdef DEBUG | int j; |
| printf("fret=%lf \n",*fret); | double xx,xmin,bx,ax; |
| #endif | double fx,fb,fa; |
| printf("%d",i);fflush(stdout); | |
| linmin(p,xit,n,fret,func); | ncom=n; |
| if (fabs(fptt-(*fret)) > del) { | pcom=vector(1,n); |
| del=fabs(fptt-(*fret)); | xicom=vector(1,n); |
| ibig=i; | nrfunc=func; |
| } | for (j=1;j<=n;j++) { |
| #ifdef DEBUG | pcom[j]=p[j]; |
| printf("%d %.12e",i,(*fret)); | xicom[j]=xi[j]; |
| for (j=1;j<=n;j++) { | } |
| xits[j]=FMAX(fabs(p[j]-pt[j]),1.e-5); | ax=0.0; |
| printf(" x(%d)=%.12e",j,xit[j]); | xx=1.0; |
| } | mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,f1dim); |
| for(j=1;j<=n;j++) | *fret=brent(ax,xx,bx,f1dim,TOL,&xmin); |
| printf(" p=%.12e",p[j]); | #ifdef DEBUG |
| printf("\n"); | printf("retour brent fret=%.12e xmin=%.12e\n",*fret,xmin); |
| #endif | #endif |
| } | for (j=1;j<=n;j++) { |
| if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret))) { | xi[j] *= xmin; |
| #ifdef DEBUG | p[j] += xi[j]; |
| int k[2],l; | } |
| k[0]=1; | free_vector(xicom,1,n); |
| k[1]=-1; | free_vector(pcom,1,n); |
| printf("Max: %.12e",(*func)(p)); | } |
| for (j=1;j<=n;j++) | |
| printf(" %.12e",p[j]); | /*************** powell ************************/ |
| printf("\n"); | void powell(double p[], double **xi, int n, double ftol, int *iter, double *fret, |
| for(l=0;l<=1;l++) { | double (*func)(double [])) |
| for (j=1;j<=n;j++) { | { |
| ptt[j]=p[j]+(p[j]-pt[j])*k[l]; | void linmin(double p[], double xi[], int n, double *fret, |
| printf("l=%d j=%d ptt=%.12e, xits=%.12e, p=%.12e, xit=%.12e", l,j,ptt[j],xits[j],p[j],xit[j]); | double (*func)(double [])); |
| } | int i,ibig,j; |
| printf("func(ptt)=%.12e, deriv=%.12e\n",(*func)(ptt),(ptt[j]-p[j])/((*func)(ptt)-(*func)(p))); | double del,t,*pt,*ptt,*xit; |
| } | double fp,fptt; |
| #endif | double *xits; |
| pt=vector(1,n); | |
| ptt=vector(1,n); | |
| free_vector(xit,1,n); | xit=vector(1,n); |
| free_vector(xits,1,n); | xits=vector(1,n); |
| free_vector(ptt,1,n); | *fret=(*func)(p); |
| free_vector(pt,1,n); | for (j=1;j<=n;j++) pt[j]=p[j]; |
| return; | for (*iter=1;;++(*iter)) { |
| } | fp=(*fret); |
| if (*iter == ITMAX) nrerror("powell exceeding maximum iterations."); | ibig=0; |
| for (j=1;j<=n;j++) { | del=0.0; |
| ptt[j]=2.0*p[j]-pt[j]; | printf("\nPowell iter=%d -2*LL=%.12f",*iter,*fret); |
| xit[j]=p[j]-pt[j]; | for (i=1;i<=n;i++) |
| pt[j]=p[j]; | printf(" %d %.12f",i, p[i]); |
| } | printf("\n"); |
| fptt=(*func)(ptt); | for (i=1;i<=n;i++) { |
| if (fptt < fp) { | for (j=1;j<=n;j++) xit[j]=xi[j][i]; |
| t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)-del*SQR(fp-fptt); | fptt=(*fret); |
| if (t < 0.0) { | #ifdef DEBUG |
| linmin(p,xit,n,fret,func); | printf("fret=%lf \n",*fret); |
| for (j=1;j<=n;j++) { | #endif |
| xi[j][ibig]=xi[j][n]; | printf("%d",i);fflush(stdout); |
| xi[j][n]=xit[j]; | linmin(p,xit,n,fret,func); |
| } | if (fabs(fptt-(*fret)) > del) { |
| #ifdef DEBUG | del=fabs(fptt-(*fret)); |
| printf("Direction changed last moved %d in place of ibig=%d, new last is the average:\n",n,ibig); | ibig=i; |
| for(j=1;j<=n;j++) | } |
| printf(" %.12e",xit[j]); | #ifdef DEBUG |
| printf("\n"); | printf("%d %.12e",i,(*fret)); |
| #endif | for (j=1;j<=n;j++) { |
| } | xits[j]=FMAX(fabs(p[j]-pt[j]),1.e-5); |
| } | printf(" x(%d)=%.12e",j,xit[j]); |
| } | } |
| } | for(j=1;j<=n;j++) |
| printf(" p=%.12e",p[j]); | |
| /**** Prevalence limit ****************/ | printf("\n"); |
| #endif | |
| double **prevalim(double **prlim, int nlstate, double x[], double age, double **oldm, double **savm, double ftolpl) | } |
| { | if (2.0*fabs(fp-(*fret)) <= ftol*(fabs(fp)+fabs(*fret))) { |
| /* Computes the prevalence limit in each live state at age x by left multiplying the unit | #ifdef DEBUG |
| matrix by transitions matrix until convergence is reached */ | int k[2],l; |
| k[0]=1; | |
| int i, ii,j,k; | k[1]=-1; |
| double min, max, maxmin, maxmax,sumnew=0.; | printf("Max: %.12e",(*func)(p)); |
| double **matprod2(); | for (j=1;j<=n;j++) |
| double **out, cov[NCOVMAX], **pmij(); | printf(" %.12e",p[j]); |
| double **newm; | printf("\n"); |
| double agefin, delaymax=50 ; /* Max number of years to converge */ | for(l=0;l<=1;l++) { |
| for (j=1;j<=n;j++) { | |
| for (ii=1;ii<=nlstate+ndeath;ii++) | ptt[j]=p[j]+(p[j]-pt[j])*k[l]; |
| for (j=1;j<=nlstate+ndeath;j++){ | printf("l=%d j=%d ptt=%.12e, xits=%.12e, p=%.12e, xit=%.12e", l,j,ptt[j],xits[j],p[j],xit[j]); |
| oldm[ii][j]=(ii==j ? 1.0 : 0.0); | } |
| } | printf("func(ptt)=%.12e, deriv=%.12e\n",(*func)(ptt),(ptt[j]-p[j])/((*func)(ptt)-(*func)(p))); |
| /* Even if hstepm = 1, at least one multiplication by the unit matrix */ | } |
| for(agefin=age-stepm/YEARM; agefin>=age-delaymax; agefin=agefin-stepm/YEARM){ | #endif |
| newm=savm; | |
| /* Covariates have to be included here again */ | |
| cov[1]=1.; | free_vector(xit,1,n); |
| cov[2]=agefin; | free_vector(xits,1,n); |
| out=matprod2(newm, pmij(pmmij,cov,ncov,x,nlstate),1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, oldm); | free_vector(ptt,1,n); |
| /* printf("age=%f agefin=%f po=%f pn=%f\n",age,agefin,oldm[1][1],newm[1][1]);*/ | free_vector(pt,1,n); |
| return; | |
| savm=oldm; | } |
| oldm=newm; | if (*iter == ITMAX) nrerror("powell exceeding maximum iterations."); |
| maxmax=0.; | for (j=1;j<=n;j++) { |
| for(j=1;j<=nlstate;j++){ | ptt[j]=2.0*p[j]-pt[j]; |
| min=1.; | xit[j]=p[j]-pt[j]; |
| max=0.; | pt[j]=p[j]; |
| for(i=1; i<=nlstate; i++) { | } |
| sumnew=0; | fptt=(*func)(ptt); |
| for(k=1; k<=ndeath; k++) sumnew+=newm[i][nlstate+k]; | if (fptt < fp) { |
| prlim[i][j]= newm[i][j]/(1-sumnew); | t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)-del*SQR(fp-fptt); |
| max=FMAX(max,prlim[i][j]); | if (t < 0.0) { |
| min=FMIN(min,prlim[i][j]); | linmin(p,xit,n,fret,func); |
| } | for (j=1;j<=n;j++) { |
| maxmin=max-min; | xi[j][ibig]=xi[j][n]; |
| maxmax=FMAX(maxmax,maxmin); | xi[j][n]=xit[j]; |
| } | } |
| if(maxmax < ftolpl){ | #ifdef DEBUG |
| return prlim; | printf("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]); |
| } | printf("\n"); |
| #endif | |
| /*************** transition probabilities **********/ | } |
| } | |
| double **pmij(double **ps, double *cov, int ncov, double *x, int nlstate ) | } |
| { | } |
| double s1, s2; | |
| /*double t34;*/ | /**** Prevalence limit ****************/ |
| int i,j,j1, nc, ii, jj; | |
| double **prevalim(double **prlim, int nlstate, double x[], double age, double **oldm, double **savm, double ftolpl, int ij) | |
| for(i=1; i<= nlstate; i++){ | { |
| for(j=1; j<i;j++){ | /* Computes the prevalence limit in each live state at age x by left multiplying the unit |
| for (nc=1, s2=0.;nc <=ncov; nc++){ | matrix by transitions matrix until convergence is reached */ |
| /*s2 += param[i][j][nc]*cov[nc];*/ | |
| s2 += x[(i-1)*nlstate*ncov+(j-1)*ncov+nc+(i-1)*(ndeath-1)*ncov]*cov[nc]; | int i, ii,j,k; |
| /*printf("Int j<i s1=%.17e, s2=%.17e\n",s1,s2);*/ | double min, max, maxmin, maxmax,sumnew=0.; |
| } | double **matprod2(); |
| ps[i][j]=s2; | double **out, cov[NCOVMAX], **pmij(); |
| /*printf("s1=%.17e, s2=%.17e\n",s1,s2);*/ | double **newm; |
| } | double agefin, delaymax=50 ; /* Max number of years to converge */ |
| for(j=i+1; j<=nlstate+ndeath;j++){ | |
| for (nc=1, s2=0.;nc <=ncov; nc++){ | for (ii=1;ii<=nlstate+ndeath;ii++) |
| s2 += x[(i-1)*nlstate*ncov+(j-2)*ncov+nc+(i-1)*(ndeath-1)*ncov]*cov[nc]; | for (j=1;j<=nlstate+ndeath;j++){ |
| /*printf("Int j>i s1=%.17e, s2=%.17e %lx %lx\n",s1,s2,s1,s2);*/ | oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
| } | } |
| ps[i][j]=s2; | |
| } | cov[1]=1.; |
| } | |
| for(i=1; i<= nlstate; i++){ | /* Even if hstepm = 1, at least one multiplication by the unit matrix */ |
| s1=0; | for(agefin=age-stepm/YEARM; agefin>=age-delaymax; agefin=agefin-stepm/YEARM){ |
| for(j=1; j<i; j++) | newm=savm; |
| s1+=exp(ps[i][j]); | /* Covariates have to be included here again */ |
| for(j=i+1; j<=nlstate+ndeath; j++) | cov[2]=agefin; |
| s1+=exp(ps[i][j]); | |
| ps[i][i]=1./(s1+1.); | for (k=1; k<=cptcovn;k++) { |
| for(j=1; j<i; j++) | cov[2+k]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]]; |
| ps[i][j]= exp(ps[i][j])*ps[i][i]; | /*printf("ij=%d Tvar[k]=%d nbcode=%d cov=%lf\n",ij, Tvar[k],nbcode[Tvar[k]][codtab[ij][Tvar[k]]],cov[2+k]);*/ |
| for(j=i+1; j<=nlstate+ndeath; j++) | } |
| ps[i][j]= exp(ps[i][j])*ps[i][i]; | for (k=1; k<=cptcovage;k++) |
| /* ps[i][nlstate+1]=1.-s1- ps[i][i];*/ /* Sum should be 1 */ | cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2]; |
| } /* end i */ | for (k=1; k<=cptcovprod;k++) |
| cov[2+Tprod[k]]=nbcode[Tvard[k][1]][codtab[ij][Tvard[k][1]]]*nbcode[Tvard[k][2]][codtab[ij][Tvard[k][2]]]; | |
| for(ii=nlstate+1; ii<= nlstate+ndeath; ii++){ | |
| for(jj=1; jj<= nlstate+ndeath; jj++){ | /*printf("ij=%d cptcovprod=%d tvar=%d ", ij, cptcovprod, Tvar[1]);*/ |
| ps[ii][jj]=0; | |
| ps[ii][ii]=1; | /*printf("ij=%d cov[3]=%lf cov[4]=%lf \n",ij, cov[3],cov[4]);*/ |
| } | |
| } | out=matprod2(newm, pmij(pmmij,cov,ncovmodel,x,nlstate),1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, oldm); |
| /* for(ii=1; ii<= nlstate+ndeath; ii++){ | savm=oldm; |
| for(jj=1; jj<= nlstate+ndeath; jj++){ | oldm=newm; |
| printf("%lf ",ps[ii][jj]); | maxmax=0.; |
| } | for(j=1;j<=nlstate;j++){ |
| printf("\n "); | min=1.; |
| } | max=0.; |
| printf("\n ");printf("%lf ",cov[2]);*/ | for(i=1; i<=nlstate; i++) { |
| /* | sumnew=0; |
| for(i=1; i<= npar; i++) printf("%f ",x[i]); | for(k=1; k<=ndeath; k++) sumnew+=newm[i][nlstate+k]; |
| goto end;*/ | prlim[i][j]= newm[i][j]/(1-sumnew); |
| return ps; | max=FMAX(max,prlim[i][j]); |
| } | min=FMIN(min,prlim[i][j]); |
| } | |
| /**************** Product of 2 matrices ******************/ | maxmin=max-min; |
| maxmax=FMAX(maxmax,maxmin); | |
| double **matprod2(double **out, double **in,long nrl, long nrh, long ncl, long nch, long ncolol, long ncoloh, double **b) | } |
| { | if(maxmax < ftolpl){ |
| /* Computes the matric product of in(1,nrh-nrl+1)(1,nch-ncl+1) times | return prlim; |
| b(1,nch-ncl+1)(1,ncoloh-ncolol+1) into out(...) */ | } |
| /* in, b, out are matrice of pointers which should have been initialized | } |
| before: only the contents of out is modified. The function returns | } |
| a pointer to pointers identical to out */ | |
| long i, j, k; | /*************** transition probabilities **********/ |
| for(i=nrl; i<= nrh; i++) | |
| for(k=ncolol; k<=ncoloh; k++) | double **pmij(double **ps, double *cov, int ncovmodel, double *x, int nlstate ) |
| for(j=ncl,out[i][k]=0.; j<=nch; j++) | { |
| out[i][k] +=in[i][j]*b[j][k]; | double s1, s2; |
| /*double t34;*/ | |
| return out; | int i,j,j1, nc, ii, jj; |
| } | |
| for(i=1; i<= nlstate; i++){ | |
| for(j=1; j<i;j++){ | |
| /************* Higher Matrix Product ***************/ | for (nc=1, s2=0.;nc <=ncovmodel; nc++){ |
| /*s2 += param[i][j][nc]*cov[nc];*/ | |
| double ***hpxij(double ***po, int nhstepm, double age, int hstepm, double *x, int nlstate, int stepm, double **oldm, double **savm ) | s2 += x[(i-1)*nlstate*ncovmodel+(j-1)*ncovmodel+nc+(i-1)*(ndeath-1)*ncovmodel]*cov[nc]; |
| { | /*printf("Int j<i s1=%.17e, s2=%.17e\n",s1,s2);*/ |
| /* Computes the transition matrix starting at age 'age' over 'nhstepm*hstepm*stepm' month | } |
| duration (i.e. until | ps[i][j]=s2; |
| age (in years) age+nhstepm*stepm/12) by multiplying nhstepm*hstepm matrices. | /*printf("s1=%.17e, s2=%.17e\n",s1,s2);*/ |
| Output is stored in matrix po[i][j][h] for h every 'hstepm' step | } |
| (typically every 2 years instead of every month which is too big). | for(j=i+1; j<=nlstate+ndeath;j++){ |
| Model is determined by parameters x and covariates have to be | for (nc=1, s2=0.;nc <=ncovmodel; nc++){ |
| included manually here. | s2 += x[(i-1)*nlstate*ncovmodel+(j-2)*ncovmodel+nc+(i-1)*(ndeath-1)*ncovmodel]*cov[nc]; |
| /*printf("Int j>i s1=%.17e, s2=%.17e %lx %lx\n",s1,s2,s1,s2);*/ | |
| */ | } |
| ps[i][j]=s2; | |
| int i, j, d, h; | } |
| double **out, cov[NCOVMAX]; | } |
| double **newm; | for(i=1; i<= nlstate; i++){ |
| s1=0; | |
| /* Hstepm could be zero and should return the unit matrix */ | for(j=1; j<i; j++) |
| for (i=1;i<=nlstate+ndeath;i++) | s1+=exp(ps[i][j]); |
| for (j=1;j<=nlstate+ndeath;j++){ | for(j=i+1; j<=nlstate+ndeath; j++) |
| oldm[i][j]=(i==j ? 1.0 : 0.0); | s1+=exp(ps[i][j]); |
| po[i][j][0]=(i==j ? 1.0 : 0.0); | ps[i][i]=1./(s1+1.); |
| } | for(j=1; j<i; j++) |
| /* Even if hstepm = 1, at least one multiplication by the unit matrix */ | ps[i][j]= exp(ps[i][j])*ps[i][i]; |
| for(h=1; h <=nhstepm; h++){ | for(j=i+1; j<=nlstate+ndeath; j++) |
| for(d=1; d <=hstepm; d++){ | ps[i][j]= exp(ps[i][j])*ps[i][i]; |
| newm=savm; | /* ps[i][nlstate+1]=1.-s1- ps[i][i];*/ /* Sum should be 1 */ |
| /* Covariates have to be included here again */ | } /* end i */ |
| cov[1]=1.; | |
| cov[2]=age+((h-1)*hstepm + (d-1))*stepm/YEARM; | for(ii=nlstate+1; ii<= nlstate+ndeath; ii++){ |
| /*printf("h=%d d=%d age=%f cov=%f\n",h,d,age,cov[2]);*/ | for(jj=1; jj<= nlstate+ndeath; jj++){ |
| out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, | ps[ii][jj]=0; |
| pmij(pmmij,cov,ncov,x,nlstate)); | ps[ii][ii]=1; |
| savm=oldm; | } |
| oldm=newm; | } |
| } | |
| for(i=1; i<=nlstate+ndeath; i++) | /* for(ii=1; ii<= nlstate+ndeath; ii++){ |
| for(j=1;j<=nlstate+ndeath;j++) { | for(jj=1; jj<= nlstate+ndeath; jj++){ |
| po[i][j][h]=newm[i][j]; | printf("%lf ",ps[ii][jj]); |
| /*printf("i=%d j=%d h=%d po[i][j][h]=%f ",i,j,h,po[i][j][h]); | } |
| */ | printf("\n "); |
| } | } |
| } /* end h */ | printf("\n ");printf("%lf ",cov[2]);*/ |
| return po; | /* |
| } | for(i=1; i<= npar; i++) printf("%f ",x[i]); |
| goto end;*/ | |
| return ps; | |
| /*************** log-likelihood *************/ | } |
| double func( double *x) | |
| { | /**************** Product of 2 matrices ******************/ |
| int i, ii, j, k, mi, d; | |
| double l, ll[NLSTATEMAX], cov[NCOVMAX]; | double **matprod2(double **out, double **in,long nrl, long nrh, long ncl, long nch, long ncolol, long ncoloh, double **b) |
| double **out; | { |
| double sw; /* Sum of weights */ | /* Computes the matric product of in(1,nrh-nrl+1)(1,nch-ncl+1) times |
| double lli; /* Individual log likelihood */ | b(1,nch-ncl+1)(1,ncoloh-ncolol+1) into out(...) */ |
| long ipmx; | /* in, b, out are matrice of pointers which should have been initialized |
| /*extern weight */ | before: only the contents of out is modified. The function returns |
| /* We are differentiating ll according to initial status */ | a pointer to pointers identical to out */ |
| /* for (i=1;i<=npar;i++) printf("%f ", x[i]);*/ | long i, j, k; |
| /*for(i=1;i<imx;i++) | for(i=nrl; i<= nrh; i++) |
| printf(" %d\n",s[4][i]); | for(k=ncolol; k<=ncoloh; k++) |
| */ | for(j=ncl,out[i][k]=0.; j<=nch; j++) |
| out[i][k] +=in[i][j]*b[j][k]; | |
| for(k=1; k<=nlstate; k++) ll[k]=0.; | |
| for (i=1,ipmx=0, sw=0.; i<=imx; i++){ | return out; |
| 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); | |
| for(d=0; d<dh[mi][i]; d++){ | /************* Higher Matrix Product ***************/ |
| newm=savm; | |
| cov[1]=1.; | double ***hpxij(double ***po, int nhstepm, double age, int hstepm, double *x, int nlstate, int stepm, double **oldm, double **savm, int ij ) |
| cov[2]=agev[mw[mi][i]][i]+d*stepm/YEARM; | { |
| out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, | /* Computes the transition matrix starting at age 'age' over 'nhstepm*hstepm*stepm' month |
| 1,nlstate+ndeath,pmij(pmmij,cov,ncov,x,nlstate)); | duration (i.e. until |
| savm=oldm; | age (in years) age+nhstepm*stepm/12) by multiplying nhstepm*hstepm matrices. |
| oldm=newm; | Output is stored in matrix po[i][j][h] for h every 'hstepm' step |
| (typically every 2 years instead of every month which is too big). | |
| Model is determined by parameters x and covariates have to be | |
| } /* end mult */ | included manually here. |
| lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]); | */ |
| /* printf(" %f ",out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]);*/ | |
| ipmx +=1; | int i, j, d, h, k; |
| sw += weight[i]; | double **out, cov[NCOVMAX]; |
| ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; | double **newm; |
| } /* end of wave */ | |
| } /* end of individual */ | /* Hstepm could be zero and should return the unit matrix */ |
| for (i=1;i<=nlstate+ndeath;i++) | |
| for(k=1,l=0.; k<=nlstate; k++) l += ll[k]; | for (j=1;j<=nlstate+ndeath;j++){ |
| /* printf("l1=%f l2=%f ",ll[1],ll[2]); */ | oldm[i][j]=(i==j ? 1.0 : 0.0); |
| l= l*ipmx/sw; /* To get the same order of magnitude as if weight=1 for every body */ | po[i][j][0]=(i==j ? 1.0 : 0.0); |
| return -l; | } |
| } | /* Even if hstepm = 1, at least one multiplication by the unit matrix */ |
| for(h=1; h <=nhstepm; h++){ | |
| for(d=1; d <=hstepm; d++){ | |
| /*********** Maximum Likelihood Estimation ***************/ | newm=savm; |
| /* Covariates have to be included here again */ | |
| void mlikeli(FILE *ficres,double p[], int npar, int ncov, int nlstate, double ftol, double (*func)(double [])) | cov[1]=1.; |
| { | cov[2]=age+((h-1)*hstepm + (d-1))*stepm/YEARM; |
| int i,j, iter; | for (k=1; k<=cptcovn;k++) cov[2+k]=nbcode[Tvar[k]][codtab[ij][Tvar[k]]]; |
| double **xi,*delti; | for (k=1; k<=cptcovage;k++) |
| double fret; | cov[2+Tage[k]]=cov[2+Tage[k]]*cov[2]; |
| xi=matrix(1,npar,1,npar); | for (k=1; k<=cptcovprod;k++) |
| for (i=1;i<=npar;i++) | cov[2+Tprod[k]]=nbcode[Tvard[k][1]][codtab[ij][Tvard[k][1]]]*nbcode[Tvard[k][2]][codtab[ij][Tvard[k][2]]]; |
| for (j=1;j<=npar;j++) | |
| xi[i][j]=(i==j ? 1.0 : 0.0); | |
| printf("Powell\n"); | /*printf("hxi cptcov=%d cptcode=%d\n",cptcov,cptcode);*/ |
| powell(p,xi,npar,ftol,&iter,&fret,func); | /*printf("h=%d d=%d age=%f cov=%f\n",h,d,age,cov[2]);*/ |
| out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath,1,nlstate+ndeath, | |
| printf("\n#Number of iterations = %d, -2 Log likelihood = %.12f\n",iter,func(p)); | pmij(pmmij,cov,ncovmodel,x,nlstate)); |
| fprintf(ficres,"#Number of iterations = %d, -2 Log likelihood = %.12f ",iter,func(p)); | savm=oldm; |
| oldm=newm; | |
| } | } |
| for(i=1; i<=nlstate+ndeath; i++) | |
| /**** Computes Hessian and covariance matrix ***/ | for(j=1;j<=nlstate+ndeath;j++) { |
| void hesscov(double **matcov, double p[], int npar, double delti[], double ftolhess, double (*func)(double [])) | po[i][j][h]=newm[i][j]; |
| { | /*printf("i=%d j=%d h=%d po[i][j][h]=%f ",i,j,h,po[i][j][h]); |
| double **a,**y,*x,pd; | */ |
| double **hess; | } |
| int i, j,jk; | } /* end h */ |
| int *indx; | return po; |
| } | |
| double hessii(double p[], double delta, int theta, double delti[]); | |
| double hessij(double p[], double delti[], int i, int j); | |
| void lubksb(double **a, int npar, int *indx, double b[]) ; | /*************** log-likelihood *************/ |
| void ludcmp(double **a, int npar, int *indx, double *d) ; | double func( double *x) |
| { | |
| int i, ii, j, k, mi, d, kk; | |
| hess=matrix(1,npar,1,npar); | double l, ll[NLSTATEMAX], cov[NCOVMAX]; |
| double **out; | |
| printf("\nCalculation of the hessian matrix. Wait...\n"); | double sw; /* Sum of weights */ |
| for (i=1;i<=npar;i++){ | double lli; /* Individual log likelihood */ |
| printf("%d",i);fflush(stdout); | long ipmx; |
| hess[i][i]=hessii(p,ftolhess,i,delti); | /*extern weight */ |
| /*printf(" %f ",p[i]);*/ | /* We are differentiating ll according to initial status */ |
| } | /* for (i=1;i<=npar;i++) printf("%f ", x[i]);*/ |
| /*for(i=1;i<imx;i++) | |
| for (i=1;i<=npar;i++) { | printf(" %d\n",s[4][i]); |
| for (j=1;j<=npar;j++) { | */ |
| if (j>i) { | cov[1]=1.; |
| printf(".%d%d",i,j);fflush(stdout); | |
| hess[i][j]=hessij(p,delti,i,j); | for(k=1; k<=nlstate; k++) ll[k]=0.; |
| hess[j][i]=hess[i][j]; | 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++) |
| printf("\n"); | for (j=1;j<=nlstate+ndeath;j++) oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
| for(d=0; d<dh[mi][i]; d++){ | |
| printf("\nInverting the hessian to get the covariance matrix. Wait...\n"); | newm=savm; |
| cov[2]=agev[mw[mi][i]][i]+d*stepm/YEARM; | |
| a=matrix(1,npar,1,npar); | for (kk=1; kk<=cptcovage;kk++) { |
| y=matrix(1,npar,1,npar); | cov[Tage[kk]+2]=covar[Tvar[Tage[kk]]][i]*cov[2]; |
| x=vector(1,npar); | /*printf("%d %d",kk,Tage[kk]);*/ |
| indx=ivector(1,npar); | } |
| for (i=1;i<=npar;i++) | /*cov[4]=covar[1][i]*cov[2];scanf("%d", i);*/ |
| for (j=1;j<=npar;j++) a[i][j]=hess[i][j]; | /*cov[3]=pow(cov[2],2)/1000.;*/ |
| ludcmp(a,npar,indx,&pd); | |
| out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, | |
| for (j=1;j<=npar;j++) { | 1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
| for (i=1;i<=npar;i++) x[i]=0; | savm=oldm; |
| x[j]=1; | oldm=newm; |
| lubksb(a,npar,indx,x); | |
| for (i=1;i<=npar;i++){ | |
| matcov[i][j]=x[i]; | } /* end mult */ |
| } | |
| } | lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]); |
| /* printf(" %f ",out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]);*/ | |
| printf("\n#Hessian matrix#\n"); | ipmx +=1; |
| for (i=1;i<=npar;i++) { | sw += weight[i]; |
| for (j=1;j<=npar;j++) { | ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; |
| printf("%.3e ",hess[i][j]); | } /* end of wave */ |
| } | } /* end of individual */ |
| printf("\n"); | |
| } | for(k=1,l=0.; k<=nlstate; k++) l += ll[k]; |
| /* printf("l1=%f l2=%f ",ll[1],ll[2]); */ | |
| /* Recompute Inverse */ | l= l*ipmx/sw; /* To get the same order of magnitude as if weight=1 for every body */ |
| for (i=1;i<=npar;i++) | return -l; |
| for (j=1;j<=npar;j++) a[i][j]=matcov[i][j]; | } |
| ludcmp(a,npar,indx,&pd); | |
| /* printf("\n#Hessian matrix recomputed#\n"); | /*********** Maximum Likelihood Estimation ***************/ |
| for (j=1;j<=npar;j++) { | void mlikeli(FILE *ficres,double p[], int npar, int ncovmodel, int nlstate, double ftol, double (*func)(double [])) |
| for (i=1;i<=npar;i++) x[i]=0; | { |
| x[j]=1; | int i,j, iter; |
| lubksb(a,npar,indx,x); | double **xi,*delti; |
| for (i=1;i<=npar;i++){ | double fret; |
| y[i][j]=x[i]; | xi=matrix(1,npar,1,npar); |
| printf("%.3e ",y[i][j]); | for (i=1;i<=npar;i++) |
| } | for (j=1;j<=npar;j++) |
| printf("\n"); | xi[i][j]=(i==j ? 1.0 : 0.0); |
| } | printf("Powell\n"); |
| */ | powell(p,xi,npar,ftol,&iter,&fret,func); |
| free_matrix(a,1,npar,1,npar); | printf("\n#Number of iterations = %d, -2 Log likelihood = %.12f\n",iter,func(p)); |
| free_matrix(y,1,npar,1,npar); | fprintf(ficres,"#Number of iterations = %d, -2 Log likelihood = %.12f ",iter,func(p)); |
| free_vector(x,1,npar); | |
| free_ivector(indx,1,npar); | } |
| free_matrix(hess,1,npar,1,npar); | |
| /**** 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; | |
| /*************** hessian matrix ****************/ | double **hess; |
| double hessii( double x[], double delta, int theta, double delti[]) | int i, j,jk; |
| { | int *indx; |
| int i; | |
| int l=1, lmax=20; | double hessii(double p[], double delta, int theta, double delti[]); |
| double k1,k2; | double hessij(double p[], double delti[], int i, int j); |
| double p2[NPARMAX+1]; | void lubksb(double **a, int npar, int *indx, double b[]) ; |
| double res; | void ludcmp(double **a, int npar, int *indx, double *d) ; |
| double delt, delts, nkhi=10.,nkhif=1., khi=1.e-4; | |
| double fx; | |
| int k=0,kmax=10; | hess=matrix(1,npar,1,npar); |
| double l1; | |
| printf("\nCalculation of the hessian matrix. Wait...\n"); | |
| fx=func(x); | for (i=1;i<=npar;i++){ |
| for (i=1;i<=npar;i++) p2[i]=x[i]; | printf("%d",i);fflush(stdout); |
| for(l=0 ; l <=lmax; l++){ | hess[i][i]=hessii(p,ftolhess,i,delti); |
| l1=pow(10,l); | /*printf(" %f ",p[i]);*/ |
| delts=delt; | } |
| for(k=1 ; k <kmax; k=k+1){ | |
| delt = delta*(l1*k); | for (i=1;i<=npar;i++) { |
| p2[theta]=x[theta] +delt; | for (j=1;j<=npar;j++) { |
| k1=func(p2)-fx; | if (j>i) { |
| p2[theta]=x[theta]-delt; | printf(".%d%d",i,j);fflush(stdout); |
| k2=func(p2)-fx; | hess[i][j]=hessij(p,delti,i,j); |
| /*res= (k1-2.0*fx+k2)/delt/delt; */ | hess[j][i]=hess[i][j]; |
| res= (k1+k2)/delt/delt/2.; /* Divided by because L and not 2*L */ | } |
| } | |
| #ifdef DEBUG | } |
| printf("%d %d k1=%.12e k2=%.12e xk1=%.12e xk2=%.12e delt=%.12e res=%.12e l=%d k=%d,fx=%.12e\n",theta,theta,k1,k2,x[theta]+delt,x[theta]-delt,delt,res, l, k,fx); | printf("\n"); |
| #endif | |
| /*if(fabs(k1-2.0*fx+k2) <1.e-13){ */ | printf("\nInverting the hessian to get the covariance matrix. Wait...\n"); |
| if((k1 <khi/nkhi/2.) || (k2 <khi/nkhi/2.)){ | |
| k=kmax; | a=matrix(1,npar,1,npar); |
| } | y=matrix(1,npar,1,npar); |
| else if((k1 >khi/nkhif) || (k2 >khi/nkhif)){ /* Keeps lastvalue before 3.84/2 KHI2 5% 1d.f. */ | x=vector(1,npar); |
| k=kmax; l=lmax*10.; | indx=ivector(1,npar); |
| } | for (i=1;i<=npar;i++) |
| else if((k1 >khi/nkhi) || (k2 >khi/nkhi)){ | for (j=1;j<=npar;j++) a[i][j]=hess[i][j]; |
| delts=delt; | ludcmp(a,npar,indx,&pd); |
| } | |
| } | for (j=1;j<=npar;j++) { |
| } | for (i=1;i<=npar;i++) x[i]=0; |
| delti[theta]=delts; | x[j]=1; |
| return res; | lubksb(a,npar,indx,x); |
| for (i=1;i<=npar;i++){ | |
| } | matcov[i][j]=x[i]; |
| } | |
| double hessij( double x[], double delti[], int thetai,int thetaj) | } |
| { | |
| int i; | printf("\n#Hessian matrix#\n"); |
| int l=1, l1, lmax=20; | for (i=1;i<=npar;i++) { |
| double k1,k2,k3,k4,res,fx; | for (j=1;j<=npar;j++) { |
| double p2[NPARMAX+1]; | printf("%.3e ",hess[i][j]); |
| int k; | } |
| printf("\n"); | |
| fx=func(x); | } |
| for (k=1; k<=2; k++) { | |
| for (i=1;i<=npar;i++) p2[i]=x[i]; | /* Recompute Inverse */ |
| p2[thetai]=x[thetai]+delti[thetai]/k; | for (i=1;i<=npar;i++) |
| p2[thetaj]=x[thetaj]+delti[thetaj]/k; | for (j=1;j<=npar;j++) a[i][j]=matcov[i][j]; |
| k1=func(p2)-fx; | ludcmp(a,npar,indx,&pd); |
| p2[thetai]=x[thetai]+delti[thetai]/k; | /* printf("\n#Hessian matrix recomputed#\n"); |
| p2[thetaj]=x[thetaj]-delti[thetaj]/k; | |
| k2=func(p2)-fx; | for (j=1;j<=npar;j++) { |
| for (i=1;i<=npar;i++) x[i]=0; | |
| p2[thetai]=x[thetai]-delti[thetai]/k; | x[j]=1; |
| p2[thetaj]=x[thetaj]+delti[thetaj]/k; | lubksb(a,npar,indx,x); |
| k3=func(p2)-fx; | for (i=1;i<=npar;i++){ |
| y[i][j]=x[i]; | |
| p2[thetai]=x[thetai]-delti[thetai]/k; | printf("%.3e ",y[i][j]); |
| p2[thetaj]=x[thetaj]-delti[thetaj]/k; | } |
| k4=func(p2)-fx; | printf("\n"); |
| res=(k1-k2-k3+k4)/4.0/delti[thetai]*k/delti[thetaj]*k/2.; /* Because of L not 2*L */ | } |
| #ifdef DEBUG | */ |
| printf("%d %d k=%d, k1=%.12e k2=%.12e k3=%.12e k4=%.12e delti/k=%.12e deltj/k=%.12e, xi-de/k=%.12e xj-de/k=%.12e res=%.12e k1234=%.12e,k1-2=%.12e,k3-4=%.12e\n",thetai,thetaj,k,k1,k2,k3,k4,delti[thetai]/k,delti[thetaj]/k,x[thetai]-delti[thetai]/k,x[thetaj]-delti[thetaj]/k, res,k1-k2-k3+k4,k1-k2,k3-k4); | |
| #endif | free_matrix(a,1,npar,1,npar); |
| } | free_matrix(y,1,npar,1,npar); |
| return res; | free_vector(x,1,npar); |
| } | free_ivector(indx,1,npar); |
| free_matrix(hess,1,npar,1,npar); | |
| /************** Inverse of matrix **************/ | |
| void ludcmp(double **a, int n, int *indx, double *d) | |
| { | } |
| int i,imax,j,k; | |
| double big,dum,sum,temp; | /*************** hessian matrix ****************/ |
| double *vv; | double hessii( double x[], double delta, int theta, double delti[]) |
| { | |
| vv=vector(1,n); | int i; |
| *d=1.0; | int l=1, lmax=20; |
| for (i=1;i<=n;i++) { | double k1,k2; |
| big=0.0; | double p2[NPARMAX+1]; |
| for (j=1;j<=n;j++) | double res; |
| if ((temp=fabs(a[i][j])) > big) big=temp; | double delt, delts, nkhi=10.,nkhif=1., khi=1.e-4; |
| if (big == 0.0) nrerror("Singular matrix in routine ludcmp"); | double fx; |
| vv[i]=1.0/big; | int k=0,kmax=10; |
| } | double l1; |
| for (j=1;j<=n;j++) { | |
| for (i=1;i<j;i++) { | fx=func(x); |
| sum=a[i][j]; | for (i=1;i<=npar;i++) p2[i]=x[i]; |
| for (k=1;k<i;k++) sum -= a[i][k]*a[k][j]; | for(l=0 ; l <=lmax; l++){ |
| a[i][j]=sum; | l1=pow(10,l); |
| } | delts=delt; |
| big=0.0; | for(k=1 ; k <kmax; k=k+1){ |
| for (i=j;i<=n;i++) { | delt = delta*(l1*k); |
| sum=a[i][j]; | p2[theta]=x[theta] +delt; |
| for (k=1;k<j;k++) | k1=func(p2)-fx; |
| sum -= a[i][k]*a[k][j]; | p2[theta]=x[theta]-delt; |
| a[i][j]=sum; | k2=func(p2)-fx; |
| if ( (dum=vv[i]*fabs(sum)) >= big) { | /*res= (k1-2.0*fx+k2)/delt/delt; */ |
| big=dum; | res= (k1+k2)/delt/delt/2.; /* Divided by because L and not 2*L */ |
| imax=i; | |
| } | #ifdef DEBUG |
| } | printf("%d %d k1=%.12e k2=%.12e xk1=%.12e xk2=%.12e delt=%.12e res=%.12e l=%d k=%d,fx=%.12e\n",theta,theta,k1,k2,x[theta]+delt,x[theta]-delt,delt,res, l, k,fx); |
| if (j != imax) { | #endif |
| for (k=1;k<=n;k++) { | /*if(fabs(k1-2.0*fx+k2) <1.e-13){ */ |
| dum=a[imax][k]; | if((k1 <khi/nkhi/2.) || (k2 <khi/nkhi/2.)){ |
| a[imax][k]=a[j][k]; | k=kmax; |
| a[j][k]=dum; | } |
| } | else if((k1 >khi/nkhif) || (k2 >khi/nkhif)){ /* Keeps lastvalue before 3.84/2 KHI2 5% 1d.f. */ |
| *d = -(*d); | k=kmax; l=lmax*10.; |
| vv[imax]=vv[j]; | } |
| } | else if((k1 >khi/nkhi) || (k2 >khi/nkhi)){ |
| indx[j]=imax; | delts=delt; |
| if (a[j][j] == 0.0) a[j][j]=TINY; | } |
| if (j != n) { | } |
| dum=1.0/(a[j][j]); | } |
| for (i=j+1;i<=n;i++) a[i][j] *= dum; | delti[theta]=delts; |
| } | return res; |
| } | |
| free_vector(vv,1,n); /* Doesn't work */ | } |
| ; | |
| } | double hessij( double x[], double delti[], int thetai,int thetaj) |
| { | |
| void lubksb(double **a, int n, int *indx, double b[]) | int i; |
| { | int l=1, l1, lmax=20; |
| int i,ii=0,ip,j; | double k1,k2,k3,k4,res,fx; |
| double sum; | double p2[NPARMAX+1]; |
| int k; | |
| for (i=1;i<=n;i++) { | |
| ip=indx[i]; | fx=func(x); |
| sum=b[ip]; | for (k=1; k<=2; k++) { |
| b[ip]=b[i]; | for (i=1;i<=npar;i++) p2[i]=x[i]; |
| if (ii) | p2[thetai]=x[thetai]+delti[thetai]/k; |
| for (j=ii;j<=i-1;j++) sum -= a[i][j]*b[j]; | p2[thetaj]=x[thetaj]+delti[thetaj]/k; |
| else if (sum) ii=i; | k1=func(p2)-fx; |
| b[i]=sum; | |
| } | p2[thetai]=x[thetai]+delti[thetai]/k; |
| for (i=n;i>=1;i--) { | p2[thetaj]=x[thetaj]-delti[thetaj]/k; |
| sum=b[i]; | k2=func(p2)-fx; |
| for (j=i+1;j<=n;j++) sum -= a[i][j]*b[j]; | |
| b[i]=sum/a[i][i]; | p2[thetai]=x[thetai]-delti[thetai]/k; |
| } | p2[thetaj]=x[thetaj]+delti[thetaj]/k; |
| } | k3=func(p2)-fx; |
| /************ Frequencies ********************/ | p2[thetai]=x[thetai]-delti[thetai]/k; |
| void freqsummary(char fileres[], int agemin, int agemax, int **s, double **agev, int nlstate, int imx) | p2[thetaj]=x[thetaj]-delti[thetaj]/k; |
| { /* Some frequencies */ | k4=func(p2)-fx; |
| res=(k1-k2-k3+k4)/4.0/delti[thetai]*k/delti[thetaj]*k/2.; /* Because of L not 2*L */ | |
| int i, m, jk; | #ifdef DEBUG |
| double ***freq; /* Frequencies */ | printf("%d %d k=%d, k1=%.12e k2=%.12e k3=%.12e k4=%.12e delti/k=%.12e deltj/k=%.12e, xi-de/k=%.12e xj-de/k=%.12e res=%.12e k1234=%.12e,k1-2=%.12e,k3-4=%.12e\n",thetai,thetaj,k,k1,k2,k3,k4,delti[thetai]/k,delti[thetaj]/k,x[thetai]-delti[thetai]/k,x[thetaj]-delti[thetaj]/k, res,k1-k2-k3+k4,k1-k2,k3-k4); |
| double *pp; | #endif |
| double pos; | } |
| FILE *ficresp; | return res; |
| char fileresp[FILENAMELENGTH]; | } |
| pp=vector(1,nlstate); | /************** Inverse of matrix **************/ |
| void ludcmp(double **a, int n, int *indx, double *d) | |
| strcpy(fileresp,"p"); | { |
| strcat(fileresp,fileres); | int i,imax,j,k; |
| if((ficresp=fopen(fileresp,"w"))==NULL) { | double big,dum,sum,temp; |
| printf("Problem with prevalence resultfile: %s\n", fileresp); | double *vv; |
| exit(0); | |
| } | vv=vector(1,n); |
| *d=1.0; | |
| freq= ma3x(-1,nlstate+ndeath,-1,nlstate+ndeath,agemin,agemax+3); | for (i=1;i<=n;i++) { |
| for (i=-1; i<=nlstate+ndeath; i++) | big=0.0; |
| for (jk=-1; jk<=nlstate+ndeath; jk++) | for (j=1;j<=n;j++) |
| for(m=agemin; m <= agemax+3; m++) | if ((temp=fabs(a[i][j])) > big) big=temp; |
| freq[i][jk][m]=0; | if (big == 0.0) nrerror("Singular matrix in routine ludcmp"); |
| vv[i]=1.0/big; | |
| for (i=1; i<=imx; i++) { | } |
| for(m=firstpass; m<= lastpass-1; m++){ | for (j=1;j<=n;j++) { |
| if(agev[m][i]==0) agev[m][i]=agemax+1; | for (i=1;i<j;i++) { |
| if(agev[m][i]==1) agev[m][i]=agemax+2; | sum=a[i][j]; |
| freq[s[m][i]][s[m+1][i]][(int)agev[m][i]] += weight[i]; | for (k=1;k<i;k++) sum -= a[i][k]*a[k][j]; |
| freq[s[m][i]][s[m+1][i]][(int) agemax+3] += weight[i]; | a[i][j]=sum; |
| } | } |
| } | big=0.0; |
| for (i=j;i<=n;i++) { | |
| fprintf(ficresp, "#"); | sum=a[i][j]; |
| for(i=1; i<=nlstate;i++) | for (k=1;k<j;k++) |
| fprintf(ficresp, " Age Prev(%d) N(%d) N",i,i); | sum -= a[i][k]*a[k][j]; |
| fprintf(ficresp, "\n"); | a[i][j]=sum; |
| if ( (dum=vv[i]*fabs(sum)) >= big) { | |
| for(i=(int)agemin; i <= (int)agemax+3; i++){ | big=dum; |
| if(i==(int)agemax+3) | imax=i; |
| printf("Total"); | } |
| else | } |
| printf("Age %d", i); | if (j != imax) { |
| for(jk=1; jk <=nlstate ; jk++){ | for (k=1;k<=n;k++) { |
| for(m=-1, pp[jk]=0; m <=nlstate+ndeath ; m++) | dum=a[imax][k]; |
| pp[jk] += freq[jk][m][i]; | a[imax][k]=a[j][k]; |
| } | a[j][k]=dum; |
| for(jk=1; jk <=nlstate ; jk++){ | } |
| for(m=-1, pos=0; m <=0 ; m++) | *d = -(*d); |
| pos += freq[jk][m][i]; | vv[imax]=vv[j]; |
| if(pp[jk]>=1.e-10) | } |
| printf(" %d.=%.0f loss[%d]=%.1f%%",jk,pp[jk],jk,100*pos/pp[jk]); | indx[j]=imax; |
| else | if (a[j][j] == 0.0) a[j][j]=TINY; |
| printf(" %d.=%.0f loss[%d]=NaNQ%%",jk,pp[jk],jk); | if (j != n) { |
| } | dum=1.0/(a[j][j]); |
| for(jk=1; jk <=nlstate ; jk++){ | for (i=j+1;i<=n;i++) a[i][j] *= dum; |
| for(m=1, pp[jk]=0; m <=nlstate+ndeath; m++) | } |
| pp[jk] += freq[jk][m][i]; | } |
| } | free_vector(vv,1,n); /* Doesn't work */ |
| for(jk=1,pos=0; jk <=nlstate ; jk++) | ; |
| pos += pp[jk]; | } |
| for(jk=1; jk <=nlstate ; jk++){ | |
| if(pos>=1.e-5) | void lubksb(double **a, int n, int *indx, double b[]) |
| printf(" %d.=%.0f prev[%d]=%.1f%%",jk,pp[jk],jk,100*pp[jk]/pos); | { |
| else | int i,ii=0,ip,j; |
| printf(" %d.=%.0f prev[%d]=NaNQ%%",jk,pp[jk],jk); | double sum; |
| if( i <= (int) agemax){ | |
| if(pos>=1.e-5) | for (i=1;i<=n;i++) { |
| fprintf(ficresp," %d %.5f %.0f %.0f",i,pp[jk]/pos, pp[jk],pos); | ip=indx[i]; |
| else | sum=b[ip]; |
| fprintf(ficresp," %d NaNq %.0f %.0f",i,pp[jk],pos); | b[ip]=b[i]; |
| } | if (ii) |
| } | for (j=ii;j<=i-1;j++) sum -= a[i][j]*b[j]; |
| for(jk=-1; jk <=nlstate+ndeath; jk++) | else if (sum) ii=i; |
| for(m=-1; m <=nlstate+ndeath; m++) | b[i]=sum; |
| if(freq[jk][m][i] !=0 ) printf(" %d%d=%.0f",jk,m,freq[jk][m][i]); | } |
| if(i <= (int) agemax) | for (i=n;i>=1;i--) { |
| fprintf(ficresp,"\n"); | sum=b[i]; |
| printf("\n"); | for (j=i+1;j<=n;j++) sum -= a[i][j]*b[j]; |
| } | b[i]=sum/a[i][i]; |
| } | |
| fclose(ficresp); | } |
| free_ma3x(freq,-1,nlstate+ndeath,-1,nlstate+ndeath,(int) agemin,(int) agemax+3); | |
| free_vector(pp,1,nlstate); | /************ Frequencies ********************/ |
| void freqsummary(char fileres[], int agemin, int agemax, int **s, double **agev, int nlstate, int imx, int *Tvar, int **nbcode, int *ncodemax) | |
| } /* End of Freq */ | { /* Some frequencies */ |
| /************* Waves Concatenation ***************/ | int i, m, jk, k1, i1, j1, bool, z1,z2,j; |
| double ***freq; /* Frequencies */ | |
| void concatwav(int wav[], int **dh, int **mw, int **s, double *agedc, double **agev, int firstpass, int lastpass, int imx, int nlstate, int stepm) | double *pp; |
| { | double pos; |
| /* Concatenates waves: wav[i] is the number of effective (useful waves) of individual i. | FILE *ficresp; |
| Death is a valid wave (if date is known). | char fileresp[FILENAMELENGTH]; |
| mw[mi][i] is the mi (mi=1 to wav[i]) effective wave of individual i | |
| dh[m][i] of dh[mw[mi][i][i] is the delay between two effective waves m=mw[mi][i] | pp=vector(1,nlstate); |
| and mw[mi+1][i]. dh depends on stepm. | |
| */ | strcpy(fileresp,"p"); |
| strcat(fileresp,fileres); | |
| int i, mi, m; | if((ficresp=fopen(fileresp,"w"))==NULL) { |
| int j, k=0,jk, ju, jl,jmin=1e+5, jmax=-1; | printf("Problem with prevalence resultfile: %s\n", fileresp); |
| float sum=0.; | exit(0); |
| } | |
| for(i=1; i<=imx; i++){ | freq= ma3x(-1,nlstate+ndeath,-1,nlstate+ndeath,agemin,agemax+3); |
| mi=0; | j1=0; |
| m=firstpass; | |
| while(s[m][i] <= nlstate){ | j=cptcoveff; |
| if(s[m][i]>=1) | if (cptcovn<1) {j=1;ncodemax[1]=1;} |
| mw[++mi][i]=m; | |
| if(m >=lastpass) | for(k1=1; k1<=j;k1++){ |
| break; | for(i1=1; i1<=ncodemax[k1];i1++){ |
| else | j1++; |
| m++; | |
| }/* end while */ | for (i=-1; i<=nlstate+ndeath; i++) |
| if (s[m][i] > nlstate){ | for (jk=-1; jk<=nlstate+ndeath; jk++) |
| mi++; /* Death is another wave */ | for(m=agemin; m <= agemax+3; m++) |
| /* if(mi==0) never been interviewed correctly before death */ | freq[i][jk][m]=0; |
| /* Only death is a correct wave */ | |
| mw[mi][i]=m; | for (i=1; i<=imx; i++) { |
| } | bool=1; |
| if (cptcovn>0) { | |
| wav[i]=mi; | for (z1=1; z1<=cptcoveff; z1++) |
| if(mi==0) | if (covar[Tvaraff[z1]][i]!= nbcode[Tvaraff[z1]][codtab[j1][z1]]) bool=0; |
| printf("Warning, no any valid information for:%d line=%d\n",num[i],i); | } |
| } | if (bool==1) { |
| for(m=firstpass; m<=lastpass-1; m++){ | |
| for(i=1; i<=imx; i++){ | if(agev[m][i]==0) agev[m][i]=agemax+1; |
| for(mi=1; mi<wav[i];mi++){ | if(agev[m][i]==1) agev[m][i]=agemax+2; |
| if (stepm <=0) | freq[s[m][i]][s[m+1][i]][(int)agev[m][i]] += weight[i]; |
| dh[mi][i]=1; | freq[s[m][i]][s[m+1][i]][(int) agemax+3] += weight[i]; |
| else{ | } |
| if (s[mw[mi+1][i]][i] > nlstate) { | } |
| j= rint(agedc[i]*12-agev[mw[mi][i]][i]*12); | } |
| if(j=0) j=1; /* Survives at least one month after exam */ | if (cptcovn>0) { |
| } | fprintf(ficresp, "\n#********** Variable "); |
| else{ | for (z1=1; z1<=cptcoveff; z1++) fprintf(ficresp, "V%d=%d ",Tvaraff[z1],nbcode[Tvaraff[z1]][codtab[j1][z1]]); |
| j= rint( (agev[mw[mi+1][i]][i]*12 - agev[mw[mi][i]][i]*12)); | } |
| k=k+1; | fprintf(ficresp, "**********\n#"); |
| if (j >= jmax) jmax=j; | for(i=1; i<=nlstate;i++) |
| else if (j <= jmin)jmin=j; | fprintf(ficresp, " Age Prev(%d) N(%d) N",i,i); |
| sum=sum+j; | fprintf(ficresp, "\n"); |
| } | |
| jk= j/stepm; | for(i=(int)agemin; i <= (int)agemax+3; i++){ |
| jl= j -jk*stepm; | if(i==(int)agemax+3) |
| ju= j -(jk+1)*stepm; | printf("Total"); |
| if(jl <= -ju) | else |
| dh[mi][i]=jk; | printf("Age %d", i); |
| else | for(jk=1; jk <=nlstate ; jk++){ |
| dh[mi][i]=jk+1; | for(m=-1, pp[jk]=0; m <=nlstate+ndeath ; m++) |
| if(dh[mi][i]==0) | pp[jk] += freq[jk][m][i]; |
| dh[mi][i]=1; /* At least one step */ | } |
| } | for(jk=1; jk <=nlstate ; jk++){ |
| } | for(m=-1, pos=0; m <=0 ; m++) |
| } | pos += freq[jk][m][i]; |
| printf("Delay (in months) between two waves Min=%d Max=%d Mean=%f\n\n ",jmin, jmax,sum/k); | if(pp[jk]>=1.e-10) |
| } | printf(" %d.=%.0f loss[%d]=%.1f%%",jk,pp[jk],jk,100*pos/pp[jk]); |
| else | |
| /*********** Health Expectancies ****************/ | printf(" %d.=%.0f loss[%d]=NaNQ%%",jk,pp[jk],jk); |
| } | |
| void evsij(char fileres[], double ***eij, double x[], int nlstate, int stepm, int bage, int fage, double **oldm, double **savm) | for(jk=1; jk <=nlstate ; jk++){ |
| { | for(m=1, pp[jk]=0; m <=nlstate+ndeath; m++) |
| /* Health expectancies */ | pp[jk] += freq[jk][m][i]; |
| int i, j, nhstepm, hstepm, h; | } |
| double age, agelim,hf; | for(jk=1,pos=0; jk <=nlstate ; jk++) |
| double ***p3mat; | pos += pp[jk]; |
| for(jk=1; jk <=nlstate ; jk++){ | |
| FILE *ficreseij; | if(pos>=1.e-5) |
| char filerese[FILENAMELENGTH]; | printf(" %d.=%.0f prev[%d]=%.1f%%",jk,pp[jk],jk,100*pp[jk]/pos); |
| else | |
| strcpy(filerese,"e"); | printf(" %d.=%.0f prev[%d]=NaNQ%%",jk,pp[jk],jk); |
| strcat(filerese,fileres); | if( i <= (int) agemax){ |
| if((ficreseij=fopen(filerese,"w"))==NULL) { | if(pos>=1.e-5) |
| printf("Problem with Health Exp. resultfile: %s\n", filerese); exit(0); | fprintf(ficresp," %d %.5f %.0f %.0f",i,pp[jk]/pos, pp[jk],pos); |
| } | else |
| printf("Computing Health Expectancies: result on file '%s' \n", filerese); | fprintf(ficresp," %d NaNq %.0f %.0f",i,pp[jk],pos); |
| } | |
| fprintf(ficreseij,"# Health expectancies\n"); | } |
| fprintf(ficreseij,"# Age"); | for(jk=-1; jk <=nlstate+ndeath; jk++) |
| for(i=1; i<=nlstate;i++) | for(m=-1; m <=nlstate+ndeath; m++) |
| for(j=1; j<=nlstate;j++) | if(freq[jk][m][i] !=0 ) printf(" %d%d=%.0f",jk,m,freq[jk][m][i]); |
| fprintf(ficreseij," %1d-%1d",i,j); | if(i <= (int) agemax) |
| fprintf(ficreseij,"\n"); | fprintf(ficresp,"\n"); |
| printf("\n"); | |
| hstepm=1*YEARM; /* Every j years of age (in month) */ | } |
| 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 */ | fclose(ficresp); |
| /* nhstepm age range expressed in number of stepm */ | free_ma3x(freq,-1,nlstate+ndeath,-1,nlstate+ndeath,(int) agemin,(int) agemax+3); |
| nhstepm=(int) rint((agelim-age)*YEARM/stepm); | free_vector(pp,1,nlstate); |
| /* Typically if 20 years = 20*12/6=40 stepm */ | |
| if (stepm >= YEARM) hstepm=1; | } /* End of Freq */ |
| nhstepm = nhstepm/hstepm;/* Expressed in hstepm, typically 40/4=10 */ | |
| p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | /************* Waves Concatenation ***************/ |
| /* Computed by stepm unit matrices, product of hstepm matrices, stored | |
| in an array of nhstepm length: nhstepm=10, hstepm=4, stepm=6 months */ | void concatwav(int wav[], int **dh, int **mw, int **s, double *agedc, double **agev, int firstpass, int lastpass, int imx, int nlstate, int stepm) |
| hpxij(p3mat,nhstepm,age,hstepm,x,nlstate,stepm,oldm, savm); | { |
| /* Concatenates waves: wav[i] is the number of effective (useful waves) of individual i. | |
| Death is a valid wave (if date is known). | |
| for(i=1; i<=nlstate;i++) | mw[mi][i] is the mi (mi=1 to wav[i]) effective wave of individual i |
| for(j=1; j<=nlstate;j++) | dh[m][i] of dh[mw[mi][i][i] is the delay between two effective waves m=mw[mi][i] |
| for (h=0, eij[i][j][(int)age]=0; h<=nhstepm; h++){ | and mw[mi+1][i]. dh depends on stepm. |
| eij[i][j][(int)age] +=p3mat[i][j][h]; | */ |
| } | |
| int i, mi, m; | |
| hf=1; | int j, k=0,jk, ju, jl,jmin=1e+5, jmax=-1; |
| if (stepm >= YEARM) hf=stepm/YEARM; | float sum=0.; |
| fprintf(ficreseij,"%.0f",age ); | |
| for(i=1; i<=nlstate;i++) | for(i=1; i<=imx; i++){ |
| for(j=1; j<=nlstate;j++){ | mi=0; |
| fprintf(ficreseij," %.4f", hf*eij[i][j][(int)age]); | m=firstpass; |
| } | while(s[m][i] <= nlstate){ |
| fprintf(ficreseij,"\n"); | if(s[m][i]>=1) |
| free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | mw[++mi][i]=m; |
| } | if(m >=lastpass) |
| fclose(ficreseij); | break; |
| } | else |
| m++; | |
| /************ Variance ******************/ | }/* end while */ |
| void varevsij(char fileres[], double ***vareij, double **matcov, double x[], double delti[], int nlstate, int stepm, double bage, double fage, double **oldm, double **savm, double **prlim, double ftolpl) | if (s[m][i] > nlstate){ |
| { | mi++; /* Death is another wave */ |
| /* Variance of health expectancies */ | /* if(mi==0) never been interviewed correctly before death */ |
| /* double **prevalim(double **prlim, int nlstate, double *xp, double age, double **oldm, double ** savm,double ftolpl);*/ | /* Only death is a correct wave */ |
| double **newm; | mw[mi][i]=m; |
| double **dnewm,**doldm; | } |
| int i, j, nhstepm, hstepm, h; | |
| int k; | wav[i]=mi; |
| FILE *ficresvij; | if(mi==0) |
| char fileresv[FILENAMELENGTH]; | printf("Warning, no any valid information for:%d line=%d\n",num[i],i); |
| double *xp; | } |
| double **gp, **gm; | |
| double ***gradg, ***trgradg; | for(i=1; i<=imx; i++){ |
| double ***p3mat; | for(mi=1; mi<wav[i];mi++){ |
| double age,agelim; | if (stepm <=0) |
| int theta; | dh[mi][i]=1; |
| else{ | |
| strcpy(fileresv,"v"); | if (s[mw[mi+1][i]][i] > nlstate) { |
| strcat(fileresv,fileres); | j= rint(agedc[i]*12-agev[mw[mi][i]][i]*12); |
| if((ficresvij=fopen(fileresv,"w"))==NULL) { | if(j=0) j=1; /* Survives at least one month after exam */ |
| printf("Problem with variance resultfile: %s\n", fileresv);exit(0); | } |
| } | else{ |
| printf("Computing Variance-covariance of DFLEs: file '%s' \n", fileresv); | j= rint( (agev[mw[mi+1][i]][i]*12 - agev[mw[mi][i]][i]*12)); |
| k=k+1; | |
| if (j >= jmax) jmax=j; | |
| fprintf(ficresvij,"# Covariances of life expectancies\n"); | else if (j <= jmin)jmin=j; |
| fprintf(ficresvij,"# Age"); | sum=sum+j; |
| for(i=1; i<=nlstate;i++) | } |
| for(j=1; j<=nlstate;j++) | jk= j/stepm; |
| fprintf(ficresvij," Cov(e%1d, e%1d)",i,j); | jl= j -jk*stepm; |
| fprintf(ficresvij,"\n"); | ju= j -(jk+1)*stepm; |
| if(jl <= -ju) | |
| xp=vector(1,npar); | dh[mi][i]=jk; |
| dnewm=matrix(1,nlstate,1,npar); | else |
| doldm=matrix(1,nlstate,1,nlstate); | dh[mi][i]=jk+1; |
| if(dh[mi][i]==0) | |
| hstepm=1*YEARM; /* Every year of age */ | dh[mi][i]=1; /* At least one step */ |
| 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 */ | printf("Delay (in months) between two waves Min=%d Max=%d Mean=%f\n\n ",jmin, jmax,sum/k); |
| if (stepm >= YEARM) hstepm=1; | } |
| nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ | /*********** Tricode ****************************/ |
| p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | void tricode(int *Tvar, int **nbcode, int imx) |
| gradg=ma3x(0,nhstepm,1,npar,1,nlstate); | { |
| gp=matrix(0,nhstepm,1,nlstate); | int Ndum[20],ij=1, k, j, i; |
| gm=matrix(0,nhstepm,1,nlstate); | int cptcode=0; |
| cptcoveff=0; | |
| for(theta=1; theta <=npar; theta++){ | |
| for(i=1; i<=npar; i++){ /* Computes gradient */ | for (k=0; k<19; k++) Ndum[k]=0; |
| xp[i] = x[i] + (i==theta ?delti[theta]:0); | for (k=1; k<=7; k++) ncodemax[k]=0; |
| } | |
| hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm); | for (j=1; j<=(cptcovn+2*cptcovprod); j++) { |
| prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl); | for (i=1; i<=imx; i++) { |
| for(j=1; j<= nlstate; j++){ | ij=(int)(covar[Tvar[j]][i]); |
| for(h=0; h<=nhstepm; h++){ | Ndum[ij]++; |
| for(i=1, gp[h][j]=0.;i<=nlstate;i++) | if (ij > cptcode) cptcode=ij; |
| gp[h][j] += prlim[i][i]*p3mat[i][j][h]; | } |
| } | |
| } | /*printf("cptcode=%d cptcovn=%d ",cptcode,cptcovn);*/ |
| for (i=0; i<=cptcode; i++) { | |
| for(i=1; i<=npar; i++) /* Computes gradient */ | if(Ndum[i]!=0) ncodemax[j]++; |
| xp[i] = x[i] - (i==theta ?delti[theta]:0); | } |
| hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm); | ij=1; |
| prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl); | |
| for(j=1; j<= nlstate; j++){ | for (i=1; i<=ncodemax[j]; i++) { |
| for(h=0; h<=nhstepm; h++){ | for (k=0; k<=19; k++) { |
| for(i=1, gm[h][j]=0.;i<=nlstate;i++) | if (Ndum[k] != 0) { |
| gm[h][j] += prlim[i][i]*p3mat[i][j][h]; | nbcode[Tvar[j]][ij]=k; |
| } | /* printf("ij=%d ",nbcode[Tvar[2]][1]);*/ |
| } | ij++; |
| for(j=1; j<= nlstate; j++) | } |
| for(h=0; h<=nhstepm; h++){ | if (ij > ncodemax[j]) break; |
| gradg[h][theta][j]= (gp[h][j]-gm[h][j])/2./delti[theta]; | } |
| } | } |
| } /* End theta */ | } |
| for (i=1; i<=10; i++) { | |
| trgradg =ma3x(0,nhstepm,1,nlstate,1,npar); | ij=Tvar[i]; |
| Ndum[ij]++; | |
| for(h=0; h<=nhstepm; h++) | } |
| for(j=1; j<=nlstate;j++) | ij=1; |
| for(theta=1; theta <=npar; theta++) | for (i=1; i<=cptcovn; i++) { |
| trgradg[h][j][theta]=gradg[h][theta][j]; | if((Ndum[i]!=0) && (i<=ncov)){ |
| Tvaraff[i]=ij; | |
| for(i=1;i<=nlstate;i++) | ij++; |
| for(j=1;j<=nlstate;j++) | } |
| vareij[i][j][(int)age] =0.; | } |
| for(h=0;h<=nhstepm;h++){ | |
| for(k=0;k<=nhstepm;k++){ | for (j=1; j<=(cptcovn+2*cptcovprod); j++) { |
| matprod2(dnewm,trgradg[h],1,nlstate,1,npar,1,npar,matcov); | if ((Tvar[j]>= cptcoveff) && (Tvar[j] <=ncov)) cptcoveff=Tvar[j]; |
| matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg[k]); | /*printf("j=%d %d\n",j,Tvar[j]);*/ |
| for(i=1;i<=nlstate;i++) | } |
| for(j=1;j<=nlstate;j++) | |
| vareij[i][j][(int)age] += doldm[i][j]; | /* printf("cptcoveff=%d Tvaraff=%d %d\n",cptcoveff, Tvaraff[1],Tvaraff[2]); |
| } | scanf("%d",i);*/ |
| } | } |
| h=1; | |
| if (stepm >= YEARM) h=stepm/YEARM; | /*********** Health Expectancies ****************/ |
| fprintf(ficresvij,"%.0f ",age ); | |
| for(i=1; i<=nlstate;i++) | void evsij(char fileres[], double ***eij, double x[], int nlstate, int stepm, int bage, int fage, double **oldm, double **savm, int ij) |
| for(j=1; j<=nlstate;j++){ | { |
| fprintf(ficresvij," %.4f", h*vareij[i][j][(int)age]); | /* Health expectancies */ |
| } | int i, j, nhstepm, hstepm, h; |
| fprintf(ficresvij,"\n"); | double age, agelim,hf; |
| free_matrix(gp,0,nhstepm,1,nlstate); | double ***p3mat; |
| free_matrix(gm,0,nhstepm,1,nlstate); | |
| free_ma3x(gradg,0,nhstepm,1,npar,1,nlstate); | fprintf(ficreseij,"# Health expectancies\n"); |
| free_ma3x(trgradg,0,nhstepm,1,nlstate,1,npar); | fprintf(ficreseij,"# Age"); |
| free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | for(i=1; i<=nlstate;i++) |
| } /* End age */ | for(j=1; j<=nlstate;j++) |
| fclose(ficresvij); | fprintf(ficreseij," %1d-%1d",i,j); |
| free_vector(xp,1,npar); | fprintf(ficreseij,"\n"); |
| free_matrix(doldm,1,nlstate,1,npar); | |
| free_matrix(dnewm,1,nlstate,1,nlstate); | hstepm=1*YEARM; /* Every j years of age (in month) */ |
| hstepm=hstepm/stepm; /* Typically in stepm units, if j= 2 years, = 2/6 months = 4 */ | |
| } | |
| agelim=AGESUP; | |
| /************ Variance of prevlim ******************/ | for (age=bage; age<=fage; age ++){ /* If stepm=6 months */ |
| 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) | /* nhstepm age range expressed in number of stepm */ |
| { | nhstepm=(int) rint((agelim-age)*YEARM/stepm); |
| /* Variance of health expectancies */ | /* Typically if 20 years = 20*12/6=40 stepm */ |
| /* double **prevalim(double **prlim, int nlstate, double *xp, double age, double **oldm, double ** savm,double ftolpl);*/ | if (stepm >= YEARM) hstepm=1; |
| double **newm; | nhstepm = nhstepm/hstepm;/* Expressed in hstepm, typically 40/4=10 */ |
| double **dnewm,**doldm; | p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); |
| int i, j, nhstepm, hstepm; | /* Computed by stepm unit matrices, product of hstepm matrices, stored |
| int k; | in an array of nhstepm length: nhstepm=10, hstepm=4, stepm=6 months */ |
| FILE *ficresvpl; | hpxij(p3mat,nhstepm,age,hstepm,x,nlstate,stepm,oldm, savm, ij); |
| char fileresvpl[FILENAMELENGTH]; | |
| double *xp; | |
| double *gp, *gm; | for(i=1; i<=nlstate;i++) |
| double **gradg, **trgradg; | for(j=1; j<=nlstate;j++) |
| double age,agelim; | for (h=0, eij[i][j][(int)age]=0; h<=nhstepm; h++){ |
| int theta; | eij[i][j][(int)age] +=p3mat[i][j][h]; |
| } | |
| strcpy(fileresvpl,"vpl"); | |
| strcat(fileresvpl,fileres); | hf=1; |
| if((ficresvpl=fopen(fileresvpl,"w"))==NULL) { | if (stepm >= YEARM) hf=stepm/YEARM; |
| printf("Problem with variance prev lim resultfile: %s\n", fileresvpl); | fprintf(ficreseij,"%.0f",age ); |
| exit(0); | for(i=1; i<=nlstate;i++) |
| } | for(j=1; j<=nlstate;j++){ |
| printf("Computing Variance-covariance of Prevalence limit: file '%s' \n", fileresvpl); | fprintf(ficreseij," %.4f", hf*eij[i][j][(int)age]); |
| } | |
| fprintf(ficreseij,"\n"); | |
| fprintf(ficresvpl,"# Standard deviation of prevalences limit\n"); | free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); |
| fprintf(ficresvpl,"# Age"); | } |
| for(i=1; i<=nlstate;i++) | } |
| fprintf(ficresvpl," %1d-%1d",i,i); | |
| fprintf(ficresvpl,"\n"); | /************ Variance ******************/ |
| void varevsij(char fileres[], double ***vareij, double **matcov, double x[], double delti[], int nlstate, int stepm, double bage, double fage, double **oldm, double **savm, double **prlim, double ftolpl, int ij) | |
| xp=vector(1,npar); | { |
| dnewm=matrix(1,nlstate,1,npar); | /* Variance of health expectancies */ |
| doldm=matrix(1,nlstate,1,nlstate); | /* double **prevalim(double **prlim, int nlstate, double *xp, double age, double **oldm, double ** savm,double ftolpl);*/ |
| double **newm; | |
| hstepm=1*YEARM; /* Every year of age */ | double **dnewm,**doldm; |
| hstepm=hstepm/stepm; /* Typically in stepm units, if j= 2 years, = 2/6 months = 4 */ | int i, j, nhstepm, hstepm, h; |
| agelim = AGESUP; | int k, cptcode; |
| for (age=bage; age<=fage; age ++){ /* If stepm=6 months */ | double *xp; |
| nhstepm=(int) rint((agelim-age)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ | double **gp, **gm; |
| if (stepm >= YEARM) hstepm=1; | double ***gradg, ***trgradg; |
| nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ | double ***p3mat; |
| gradg=matrix(1,npar,1,nlstate); | double age,agelim; |
| gp=vector(1,nlstate); | int theta; |
| gm=vector(1,nlstate); | |
| fprintf(ficresvij,"# Covariances of life expectancies\n"); | |
| for(theta=1; theta <=npar; theta++){ | fprintf(ficresvij,"# Age"); |
| for(i=1; i<=npar; i++){ /* Computes gradient */ | for(i=1; i<=nlstate;i++) |
| xp[i] = x[i] + (i==theta ?delti[theta]:0); | for(j=1; j<=nlstate;j++) |
| } | fprintf(ficresvij," Cov(e%1d, e%1d)",i,j); |
| prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl); | fprintf(ficresvij,"\n"); |
| for(i=1;i<=nlstate;i++) | |
| gp[i] = prlim[i][i]; | xp=vector(1,npar); |
| dnewm=matrix(1,nlstate,1,npar); | |
| for(i=1; i<=npar; i++) /* Computes gradient */ | doldm=matrix(1,nlstate,1,nlstate); |
| xp[i] = x[i] - (i==theta ?delti[theta]:0); | |
| prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl); | hstepm=1*YEARM; /* Every year of age */ |
| for(i=1;i<=nlstate;i++) | hstepm=hstepm/stepm; /* Typically in stepm units, if j= 2 years, = 2/6 months = 4 */ |
| gm[i] = prlim[i][i]; | agelim = AGESUP; |
| for (age=bage; age<=fage; age ++){ /* If stepm=6 months */ | |
| for(i=1;i<=nlstate;i++) | nhstepm=(int) rint((agelim-age)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ |
| gradg[theta][i]= (gp[i]-gm[i])/2./delti[theta]; | if (stepm >= YEARM) hstepm=1; |
| } /* End theta */ | nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ |
| p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | |
| trgradg =matrix(1,nlstate,1,npar); | gradg=ma3x(0,nhstepm,1,npar,1,nlstate); |
| gp=matrix(0,nhstepm,1,nlstate); | |
| for(j=1; j<=nlstate;j++) | gm=matrix(0,nhstepm,1,nlstate); |
| for(theta=1; theta <=npar; theta++) | |
| trgradg[j][theta]=gradg[theta][j]; | for(theta=1; theta <=npar; theta++){ |
| for(i=1; i<=npar; i++){ /* Computes gradient */ | |
| for(i=1;i<=nlstate;i++) | xp[i] = x[i] + (i==theta ?delti[theta]:0); |
| varpl[i][(int)age] =0.; | } |
| matprod2(dnewm,trgradg,1,nlstate,1,npar,1,npar,matcov); | hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm, ij); |
| matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg); | prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij); |
| for(i=1;i<=nlstate;i++) | for(j=1; j<= nlstate; j++){ |
| varpl[i][(int)age] = doldm[i][i]; /* Covariances are useless */ | for(h=0; h<=nhstepm; h++){ |
| for(i=1, gp[h][j]=0.;i<=nlstate;i++) | |
| fprintf(ficresvpl,"%.0f ",age ); | gp[h][j] += prlim[i][i]*p3mat[i][j][h]; |
| 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); | for(i=1; i<=npar; i++) /* Computes gradient */ |
| free_vector(gm,1,nlstate); | xp[i] = x[i] - (i==theta ?delti[theta]:0); |
| free_matrix(gradg,1,npar,1,nlstate); | hpxij(p3mat,nhstepm,age,hstepm,xp,nlstate,stepm,oldm,savm, ij); |
| free_matrix(trgradg,1,nlstate,1,npar); | prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij); |
| } /* End age */ | for(j=1; j<= nlstate; j++){ |
| fclose(ficresvpl); | for(h=0; h<=nhstepm; h++){ |
| free_vector(xp,1,npar); | for(i=1, gm[h][j]=0.;i<=nlstate;i++) |
| free_matrix(doldm,1,nlstate,1,npar); | gm[h][j] += prlim[i][i]*p3mat[i][j][h]; |
| free_matrix(dnewm,1,nlstate,1,nlstate); | } |
| } | |
| } | for(j=1; j<= nlstate; j++) |
| for(h=0; h<=nhstepm; h++){ | |
| gradg[h][theta][j]= (gp[h][j]-gm[h][j])/2./delti[theta]; | |
| } | |
| /***********************************************/ | } /* End theta */ |
| /**************** Main Program *****************/ | |
| /***********************************************/ | trgradg =ma3x(0,nhstepm,1,nlstate,1,npar); |
| /*int main(int argc, char *argv[])*/ | for(h=0; h<=nhstepm; h++) |
| int main() | for(j=1; j<=nlstate;j++) |
| { | for(theta=1; theta <=npar; theta++) |
| trgradg[h][j][theta]=gradg[h][theta][j]; | |
| int i,j, k, n=MAXN,iter,m,size; | |
| double agedeb, agefin,hf; | for(i=1;i<=nlstate;i++) |
| double agemin=1.e20, agemax=-1.e20; | for(j=1;j<=nlstate;j++) |
| vareij[i][j][(int)age] =0.; | |
| double fret; | for(h=0;h<=nhstepm;h++){ |
| double **xi,tmp,delta; | for(k=0;k<=nhstepm;k++){ |
| matprod2(dnewm,trgradg[h],1,nlstate,1,npar,1,npar,matcov); | |
| double dum; /* Dummy variable */ | matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg[k]); |
| double ***p3mat; | for(i=1;i<=nlstate;i++) |
| int *indx; | for(j=1;j<=nlstate;j++) |
| char line[MAXLINE], linepar[MAXLINE]; | vareij[i][j][(int)age] += doldm[i][j]; |
| char title[MAXLINE]; | } |
| char optionfile[FILENAMELENGTH], datafile[FILENAMELENGTH], filerespl[FILENAMELENGTH]; | } |
| char fileres[FILENAMELENGTH], filerespij[FILENAMELENGTH], filereso[FILENAMELENGTH]; | h=1; |
| char filerest[FILENAMELENGTH]; | if (stepm >= YEARM) h=stepm/YEARM; |
| char fileregp[FILENAMELENGTH]; | fprintf(ficresvij,"%.0f ",age ); |
| char path[80],pathc[80],pathcd[80],pathtot[80]; | for(i=1; i<=nlstate;i++) |
| int firstobs=1, lastobs=10; | for(j=1; j<=nlstate;j++){ |
| int sdeb, sfin; /* Status at beginning and end */ | fprintf(ficresvij," %.4f", h*vareij[i][j][(int)age]); |
| int c, h , cpt,l; | } |
| int ju,jl, mi; | fprintf(ficresvij,"\n"); |
| int i1,j1, k1,jk,aa,bb, stepsize; | free_matrix(gp,0,nhstepm,1,nlstate); |
| int jnais,jdc,jint4,jint1,jint2,jint3,**outcome,**adl,*tab; | free_matrix(gm,0,nhstepm,1,nlstate); |
| free_ma3x(gradg,0,nhstepm,1,npar,1,nlstate); | |
| int hstepm, nhstepm; | free_ma3x(trgradg,0,nhstepm,1,nlstate,1,npar); |
| double bage, fage, age, agelim, agebase; | free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); |
| double ftolpl=FTOL; | } /* End age */ |
| double **prlim; | |
| double *severity; | free_vector(xp,1,npar); |
| double ***param; /* Matrix of parameters */ | free_matrix(doldm,1,nlstate,1,npar); |
| double *p; | free_matrix(dnewm,1,nlstate,1,nlstate); |
| double **matcov; /* Matrix of covariance */ | |
| double ***delti3; /* Scale */ | } |
| double *delti; /* Scale */ | |
| double ***eij, ***vareij; | /************ Variance of prevlim ******************/ |
| double **varpl; /* Variances of prevalence limits by age */ | 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) |
| double *epj, vepp; | { |
| char version[80]="Imach version 0.64, May 2000, INED-EUROREVES "; | /* Variance of prevalence limit */ |
| char *alph[]={"a","a","b","c","d","e"}, str[4]; | /* double **prevalim(double **prlim, int nlstate, double *xp, double age, double **oldm, double ** savm,double ftolpl);*/ |
| char z[1]="c"; | double **newm; |
| #include <sys/time.h> | double **dnewm,**doldm; |
| #include <time.h> | int i, j, nhstepm, hstepm; |
| int k, cptcode; | |
| /* long total_usecs; | double *xp; |
| struct timeval start_time, end_time; | double *gp, *gm; |
| double **gradg, **trgradg; | |
| gettimeofday(&start_time, (struct timezone*)0); */ /* at first time */ | double age,agelim; |
| int theta; | |
| printf("\nIMACH, Version 0.64"); | fprintf(ficresvpl,"# Standard deviation of prevalences limit\n"); |
| printf("\nEnter the parameter file name: "); | fprintf(ficresvpl,"# Age"); |
| #define windows 1 | for(i=1; i<=nlstate;i++) |
| #ifdef windows | fprintf(ficresvpl," %1d-%1d",i,i); |
| scanf("%s",pathtot); | fprintf(ficresvpl,"\n"); |
| getcwd(pathcd, size); | |
| cut(path,optionfile,pathtot); | xp=vector(1,npar); |
| chdir(path); | dnewm=matrix(1,nlstate,1,npar); |
| replace(pathc,path); | doldm=matrix(1,nlstate,1,nlstate); |
| #endif | |
| #ifdef unix | hstepm=1*YEARM; /* Every year of age */ |
| scanf("%s",optionfile); | hstepm=hstepm/stepm; /* Typically in stepm units, if j= 2 years, = 2/6 months = 4 */ |
| #endif | agelim = AGESUP; |
| for (age=bage; age<=fage; age ++){ /* If stepm=6 months */ | |
| /*-------- arguments in the command line --------*/ | nhstepm=(int) rint((agelim-age)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ |
| if (stepm >= YEARM) hstepm=1; | |
| strcpy(fileres,"r"); | nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ |
| strcat(fileres, optionfile); | gradg=matrix(1,npar,1,nlstate); |
| gp=vector(1,nlstate); | |
| /*---------arguments file --------*/ | gm=vector(1,nlstate); |
| if((ficpar=fopen(optionfile,"r"))==NULL) { | for(theta=1; theta <=npar; theta++){ |
| printf("Problem with optionfile %s\n",optionfile); | for(i=1; i<=npar; i++){ /* Computes gradient */ |
| goto end; | xp[i] = x[i] + (i==theta ?delti[theta]:0); |
| } | } |
| prevalim(prlim,nlstate,xp,age,oldm,savm,ftolpl,ij); | |
| strcpy(filereso,"o"); | for(i=1;i<=nlstate;i++) |
| strcat(filereso,fileres); | gp[i] = prlim[i][i]; |
| if((ficparo=fopen(filereso,"w"))==NULL) { | |
| printf("Problem with Output resultfile: %s\n", filereso);goto end; | 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); | |
| /*--------- index.htm --------*/ | for(i=1;i<=nlstate;i++) |
| gm[i] = prlim[i][i]; | |
| if((fichtm=fopen("index.htm","w"))==NULL) { | |
| printf("Problem with index.htm \n");goto end; | for(i=1;i<=nlstate;i++) |
| } | gradg[theta][i]= (gp[i]-gm[i])/2./delti[theta]; |
| } /* End theta */ | |
| fprintf(fichtm,"<body><ul><li>Outputs files<br><br>\n | |
| - Observed prevalence in each state: <a href=\"p%s\">p%s</a> <br>\n | trgradg =matrix(1,nlstate,1,npar); |
| - Estimated parameters and the covariance matrix: <a href=\"%s\">%s</a> <br> | |
| - Stationary prevalence in each state: <a href=\"pl%s\">pl%s</a> <br> | for(j=1; j<=nlstate;j++) |
| - Transition probabilities: <a href=\"pij%s\">pij%s</a><br> | for(theta=1; theta <=npar; theta++) |
| - Copy of the parameter file: <a href=\"o%s\">o%s</a><br> | trgradg[j][theta]=gradg[theta][j]; |
| - Life expectancies by age and initial health status: <a href=\"e%s\">e%s</a> <br> | |
| - Variances of life expectancies by age and initial health status: <a href=\"v%s\">v%s</a><br> | for(i=1;i<=nlstate;i++) |
| - Health expectancies with their variances: <a href=\"t%s\">t%s</a> <br> | varpl[i][(int)age] =0.; |
| - Standard deviation of stationary prevalences: <a href=\"vpl%s\">vpl%s</a> <br><br>",fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres); | matprod2(dnewm,trgradg,1,nlstate,1,npar,1,npar,matcov); |
| matprod2(doldm,dnewm,1,nlstate,1,npar,1,nlstate,gradg); | |
| fprintf(fichtm," <li>Graphs<br> <br>"); | for(i=1;i<=nlstate;i++) |
| varpl[i][(int)age] = doldm[i][i]; /* Covariances are useless */ | |
| for(cpt=1; cpt<nlstate;cpt++) | |
| fprintf(fichtm,"- Prevalence of disability: p%s1.gif<br> | fprintf(ficresvpl,"%.0f ",age ); |
| <img src=\"p%s1.gif\"><br>",strtok(optionfile, "."),strtok(optionfile, "."),cpt); | for(i=1; i<=nlstate;i++) |
| for(cpt=1; cpt<=nlstate;cpt++) | fprintf(ficresvpl," %.5f (%.5f)",prlim[i][i],sqrt(varpl[i][(int)age])); |
| fprintf(fichtm,"- Observed and stationary prevalence (with confident | fprintf(ficresvpl,"\n"); |
| interval) in state (%d): v%s%d.gif <br> | free_vector(gp,1,nlstate); |
| <img src=\"v%s%d.gif\"><br>",cpt,strtok(optionfile, "."),cpt,strtok(optionfile, "."),cpt); | free_vector(gm,1,nlstate); |
| free_matrix(gradg,1,npar,1,nlstate); | |
| for(cpt=1; cpt<=nlstate;cpt++) | free_matrix(trgradg,1,nlstate,1,npar); |
| fprintf(fichtm,"- Health life expectancies by age and initial health state (%d): exp%s%d.gif <br> | } /* End age */ |
| <img src=\"ex%s%d.gif\"><br>",cpt,strtok(optionfile, "."),cpt,strtok(optionfile, "."),cpt); | |
| free_vector(xp,1,npar); | |
| fprintf(fichtm,"- Total life expectancy by age and | free_matrix(doldm,1,nlstate,1,npar); |
| health expectancies in states (1) and (2): e%s.gif<br> | free_matrix(dnewm,1,nlstate,1,nlstate); |
| <img src=\"e%s.gif\"></li> </ul></body>",strtok(optionfile, "."),strtok(optionfile, ".")); | |
| } | |
| fclose(fichtm); | |
| /* Reads comments: lines beginning with '#' */ | /***********************************************/ |
| while((c=getc(ficpar))=='#' && c!= EOF){ | /**************** Main Program *****************/ |
| ungetc(c,ficpar); | /***********************************************/ |
| fgets(line, MAXLINE, ficpar); | |
| puts(line); | /*int main(int argc, char *argv[])*/ |
| fputs(line,ficparo); | int main() |
| } | { |
| ungetc(c,ficpar); | |
| int i,j, k, n=MAXN,iter,m,size,cptcode, aaa, cptcod; | |
| fscanf(ficpar,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%lf stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\n",title, datafile, &lastobs, &firstpass,&lastpass,&ftol, &stepm, &ncov, &nlstate,&ndeath, &maxwav, &mle, &weightopt); | double agedeb, agefin,hf; |
| printf("title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\n", title, datafile, lastobs, firstpass,lastpass,ftol, stepm, ncov, nlstate,ndeath, maxwav, mle, weightopt); | double agemin=1.e20, agemax=-1.e20; |
| fprintf(ficparo,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\n", title, datafile, lastobs, firstpass,lastpass,ftol,stepm,ncov,nlstate,ndeath,maxwav, mle, weightopt); | |
| double fret; | |
| nvar=ncov-1; /* Suppressing age as a basic covariate */ | double **xi,tmp,delta; |
| /* Read guess parameters */ | double dum; /* Dummy variable */ |
| /* Reads comments: lines beginning with '#' */ | double ***p3mat; |
| while((c=getc(ficpar))=='#' && c!= EOF){ | int *indx; |
| ungetc(c,ficpar); | char line[MAXLINE], linepar[MAXLINE]; |
| fgets(line, MAXLINE, ficpar); | char title[MAXLINE]; |
| puts(line); | char optionfile[FILENAMELENGTH], datafile[FILENAMELENGTH], filerespl[FILENAMELENGTH]; |
| fputs(line,ficparo); | char fileres[FILENAMELENGTH], filerespij[FILENAMELENGTH], filereso[FILENAMELENGTH]; |
| } | char filerest[FILENAMELENGTH]; |
| ungetc(c,ficpar); | char fileregp[FILENAMELENGTH]; |
| char path[80],pathc[80],pathcd[80],pathtot[80],model[20]; | |
| param= ma3x(1,nlstate,1,nlstate+ndeath-1,1,ncov); | int firstobs=1, lastobs=10; |
| for(i=1; i <=nlstate; i++) | int sdeb, sfin; /* Status at beginning and end */ |
| for(j=1; j <=nlstate+ndeath-1; j++){ | int c, h , cpt,l; |
| fscanf(ficpar,"%1d%1d",&i1,&j1); | int ju,jl, mi; |
| fprintf(ficparo,"%1d%1d",i1,j1); | int i1,j1, k1,k2,k3,jk,aa,bb, stepsize, ij; |
| printf("%1d%1d",i,j); | int jnais,jdc,jint4,jint1,jint2,jint3,**outcome,**adl,*tab; |
| for(k=1; k<=ncov;k++){ | |
| fscanf(ficpar," %lf",¶m[i][j][k]); | int hstepm, nhstepm; |
| printf(" %lf",param[i][j][k]); | double bage, fage, age, agelim, agebase; |
| fprintf(ficparo," %lf",param[i][j][k]); | double ftolpl=FTOL; |
| } | double **prlim; |
| fscanf(ficpar,"\n"); | double *severity; |
| printf("\n"); | double ***param; /* Matrix of parameters */ |
| fprintf(ficparo,"\n"); | double *p; |
| } | double **matcov; /* Matrix of covariance */ |
| double ***delti3; /* Scale */ | |
| npar= (nlstate+ndeath-1)*nlstate*ncov; | double *delti; /* Scale */ |
| p=param[1][1]; | double ***eij, ***vareij; |
| double **varpl; /* Variances of prevalence limits by age */ | |
| /* Reads comments: lines beginning with '#' */ | double *epj, vepp; |
| while((c=getc(ficpar))=='#' && c!= EOF){ | char version[80]="Imach version 62c, May 1999, INED-EUROREVES "; |
| ungetc(c,ficpar); | char *alph[]={"a","a","b","c","d","e"}, str[4]; |
| fgets(line, MAXLINE, ficpar); | |
| puts(line); | char z[1]="c", occ; |
| fputs(line,ficparo); | #include <sys/time.h> |
| } | #include <time.h> |
| ungetc(c,ficpar); | char stra[80], strb[80], strc[80], strd[80],stre[80],modelsav[80]; |
| /* long total_usecs; | |
| delti3= ma3x(1,nlstate,1,nlstate+ndeath-1,1,ncov); | struct timeval start_time, end_time; |
| delti=vector(1,npar); /* Scale of each paramater (output from hesscov) */ | |
| for(i=1; i <=nlstate; i++){ | gettimeofday(&start_time, (struct timezone*)0); */ /* at first time */ |
| for(j=1; j <=nlstate+ndeath-1; j++){ | |
| fscanf(ficpar,"%1d%1d",&i1,&j1); | |
| printf("%1d%1d",i,j); | printf("\nIMACH, Version 0.64a"); |
| fprintf(ficparo,"%1d%1d",i1,j1); | printf("\nEnter the parameter file name: "); |
| for(k=1; k<=ncov;k++){ | |
| fscanf(ficpar,"%le",&delti3[i][j][k]); | #ifdef windows |
| printf(" %le",delti3[i][j][k]); | scanf("%s",pathtot); |
| fprintf(ficparo," %le",delti3[i][j][k]); | getcwd(pathcd, size); |
| } | /*cygwin_split_path(pathtot,path,optionfile); |
| fscanf(ficpar,"\n"); | printf("pathtot=%s, path=%s, optionfile=%s\n",pathtot,path,optionfile);*/ |
| printf("\n"); | /* cutv(path,optionfile,pathtot,'\\');*/ |
| fprintf(ficparo,"\n"); | |
| } | split(pathtot, path,optionfile); |
| } | chdir(path); |
| delti=delti3[1][1]; | replace(pathc,path); |
| #endif | |
| /* Reads comments: lines beginning with '#' */ | #ifdef unix |
| while((c=getc(ficpar))=='#' && c!= EOF){ | scanf("%s",optionfile); |
| ungetc(c,ficpar); | #endif |
| fgets(line, MAXLINE, ficpar); | |
| puts(line); | /*-------- arguments in the command line --------*/ |
| fputs(line,ficparo); | |
| } | strcpy(fileres,"r"); |
| ungetc(c,ficpar); | strcat(fileres, optionfile); |
| matcov=matrix(1,npar,1,npar); | /*---------arguments file --------*/ |
| for(i=1; i <=npar; i++){ | |
| fscanf(ficpar,"%s",&str); | if((ficpar=fopen(optionfile,"r"))==NULL) { |
| printf("%s",str); | printf("Problem with optionfile %s\n",optionfile); |
| fprintf(ficparo,"%s",str); | goto end; |
| for(j=1; j <=i; j++){ | } |
| fscanf(ficpar," %le",&matcov[i][j]); | |
| printf(" %.5le",matcov[i][j]); | strcpy(filereso,"o"); |
| fprintf(ficparo," %.5le",matcov[i][j]); | strcat(filereso,fileres); |
| } | if((ficparo=fopen(filereso,"w"))==NULL) { |
| fscanf(ficpar,"\n"); | printf("Problem with Output resultfile: %s\n", filereso);goto end; |
| printf("\n"); | } |
| fprintf(ficparo,"\n"); | |
| } | /* Reads comments: lines beginning with '#' */ |
| for(i=1; i <=npar; i++) | while((c=getc(ficpar))=='#' && c!= EOF){ |
| for(j=i+1;j<=npar;j++) | ungetc(c,ficpar); |
| matcov[i][j]=matcov[j][i]; | fgets(line, MAXLINE, ficpar); |
| puts(line); | |
| printf("\n"); | fputs(line,ficparo); |
| } | |
| ungetc(c,ficpar); | |
| if(mle==1){ | |
| /*-------- data file ----------*/ | fscanf(ficpar,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%lf stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\nmodel=%s\n",title, datafile, &lastobs, &firstpass,&lastpass,&ftol, &stepm, &ncov, &nlstate,&ndeath, &maxwav, &mle, &weightopt,model); |
| if((ficres =fopen(fileres,"w"))==NULL) { | printf("title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\nmodel=%s\n", title, datafile, lastobs, firstpass,lastpass,ftol, stepm, ncov, nlstate,ndeath, maxwav, mle, weightopt,model); |
| printf("Problem with resultfile: %s\n", fileres);goto end; | fprintf(ficparo,"title=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\nmodel=%s\n", title, datafile, lastobs, firstpass,lastpass,ftol,stepm,ncov,nlstate,ndeath,maxwav, mle, weightopt,model); |
| } | |
| fprintf(ficres,"#%s\n",version); | covar=matrix(0,NCOVMAX,1,n); |
| if (strlen(model)<=1) cptcovn=0; | |
| if((fic=fopen(datafile,"r"))==NULL) { | else { |
| printf("Problem with datafile: %s\n", datafile);goto end; | j=0; |
| } | j=nbocc(model,'+'); |
| cptcovn=j+1; | |
| n= lastobs; | } |
| severity = vector(1,maxwav); | |
| outcome=imatrix(1,maxwav+1,1,n); | ncovmodel=2+cptcovn; |
| num=ivector(1,n); | nvar=ncovmodel-1; /* Suppressing age as a basic covariate */ |
| moisnais=vector(1,n); | |
| annais=vector(1,n); | /* Read guess parameters */ |
| moisdc=vector(1,n); | /* Reads comments: lines beginning with '#' */ |
| andc=vector(1,n); | while((c=getc(ficpar))=='#' && c!= EOF){ |
| agedc=vector(1,n); | ungetc(c,ficpar); |
| cod=ivector(1,n); | fgets(line, MAXLINE, ficpar); |
| weight=vector(1,n); | puts(line); |
| for(i=1;i<=n;i++) weight[i]=1.0; /* Equal weights, 1 by default */ | fputs(line,ficparo); |
| mint=matrix(1,maxwav,1,n); | } |
| anint=matrix(1,maxwav,1,n); | ungetc(c,ficpar); |
| covar=matrix(1,NCOVMAX,1,n); | |
| s=imatrix(1,maxwav+1,1,n); | param= ma3x(1,nlstate,1,nlstate+ndeath-1,1,ncovmodel); |
| adl=imatrix(1,maxwav+1,1,n); | for(i=1; i <=nlstate; i++) |
| tab=ivector(1,NCOVMAX); | for(j=1; j <=nlstate+ndeath-1; j++){ |
| i=1; | fscanf(ficpar,"%1d%1d",&i1,&j1); |
| while (fgets(line, MAXLINE, fic) != NULL) { | fprintf(ficparo,"%1d%1d",i1,j1); |
| if ((i >= firstobs) && (i <lastobs)) { | printf("%1d%1d",i,j); |
| sscanf(line,"%d %lf %lf %lf %lf/%lf %lf/%lf %lf/%lf %d %lf/%lf %d %lf/%lf %d %lf/%lf %d", &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]); | for(k=1; k<=ncovmodel;k++){ |
| i=i+1; | fscanf(ficpar," %lf",¶m[i][j][k]); |
| } | printf(" %lf",param[i][j][k]); |
| } | fprintf(ficparo," %lf",param[i][j][k]); |
| imx=i-1; /* Number of individuals */ | } |
| fscanf(ficpar,"\n"); | |
| fclose(fic); | printf("\n"); |
| fprintf(ficparo,"\n"); | |
| if (weightopt != 1) { /* Maximisation without weights*/ | } |
| for(i=1;i<=n;i++) weight[i]=1.0; | |
| } | npar= (nlstate+ndeath-1)*nlstate*ncovmodel; |
| /*-calculation of age at interview from date of interview and age at death -*/ | p=param[1][1]; |
| agev=matrix(1,maxwav,1,imx); | |
| /* Reads comments: lines beginning with '#' */ | |
| for (i=1; i<=imx; i++) { | while((c=getc(ficpar))=='#' && c!= EOF){ |
| agedc[i]=(moisdc[i]/12.+andc[i])-(moisnais[i]/12.+annais[i]); | ungetc(c,ficpar); |
| for(m=1; (m<= maxwav); m++){ | fgets(line, MAXLINE, ficpar); |
| if(s[m][i] >0){ | puts(line); |
| if (s[m][i] == nlstate+1) { | fputs(line,ficparo); |
| if(agedc[i]>0) | } |
| agev[m][i]=agedc[i]; | ungetc(c,ficpar); |
| else{ | |
| printf("Warning negative age at death: %d line:%d\n",num[i],i); | delti3= ma3x(1,nlstate,1,nlstate+ndeath-1,1,ncovmodel); |
| agev[m][i]=-1; | delti=vector(1,npar); /* Scale of each paramater (output from hesscov) */ |
| } | for(i=1; i <=nlstate; i++){ |
| } | for(j=1; j <=nlstate+ndeath-1; j++){ |
| else if(s[m][i] !=9){ /* Should no more exist */ | fscanf(ficpar,"%1d%1d",&i1,&j1); |
| agev[m][i]=(mint[m][i]/12.+1./24.+anint[m][i])-(moisnais[i]/12.+1./24.+annais[i]); | printf("%1d%1d",i,j); |
| if(mint[m][i]==99 || anint[m][i]==9999) | fprintf(ficparo,"%1d%1d",i1,j1); |
| agev[m][i]=1; | for(k=1; k<=ncovmodel;k++){ |
| else if(agev[m][i] <agemin){ | fscanf(ficpar,"%le",&delti3[i][j][k]); |
| agemin=agev[m][i]; | printf(" %le",delti3[i][j][k]); |
| /*printf(" Min anint[%d][%d]=%.2f annais[%d]=%.2f, agemin=%.2f\n",m,i,anint[m][i], i,annais[i], agemin);*/ | fprintf(ficparo," %le",delti3[i][j][k]); |
| } | } |
| else if(agev[m][i] >agemax){ | fscanf(ficpar,"\n"); |
| agemax=agev[m][i]; | printf("\n"); |
| /* printf(" anint[%d][%d]=%.0f annais[%d]=%.0f, agemax=%.0f\n",m,i,anint[m][i], i,annais[i], agemax);*/ | fprintf(ficparo,"\n"); |
| } | } |
| /*agev[m][i]=anint[m][i]-annais[i];*/ | } |
| /* agev[m][i] = age[i]+2*m;*/ | delti=delti3[1][1]; |
| } | |
| else { /* =9 */ | /* Reads comments: lines beginning with '#' */ |
| agev[m][i]=1; | while((c=getc(ficpar))=='#' && c!= EOF){ |
| s[m][i]=-1; | ungetc(c,ficpar); |
| } | fgets(line, MAXLINE, ficpar); |
| } | puts(line); |
| else /*= 0 Unknown */ | fputs(line,ficparo); |
| agev[m][i]=1; | } |
| } | ungetc(c,ficpar); |
| } | matcov=matrix(1,npar,1,npar); |
| for (i=1; i<=imx; i++) { | for(i=1; i <=npar; i++){ |
| for(m=1; (m<= maxwav); m++){ | fscanf(ficpar,"%s",&str); |
| if (s[m][i] > (nlstate+ndeath)) { | printf("%s",str); |
| printf("Error: Wrong value in nlstate or ndeath\n"); | fprintf(ficparo,"%s",str); |
| goto end; | for(j=1; j <=i; j++){ |
| } | fscanf(ficpar," %le",&matcov[i][j]); |
| } | printf(" %.5le",matcov[i][j]); |
| } | fprintf(ficparo," %.5le",matcov[i][j]); |
| } | |
| printf("Total number of individuals= %d, Agemin = %.2f, Agemax= %.2f\n\n", imx, agemin, agemax); | fscanf(ficpar,"\n"); |
| printf("\n"); | |
| free_vector(severity,1,maxwav); | fprintf(ficparo,"\n"); |
| free_imatrix(outcome,1,maxwav+1,1,n); | } |
| free_vector(moisnais,1,n); | for(i=1; i <=npar; i++) |
| free_vector(annais,1,n); | for(j=i+1;j<=npar;j++) |
| free_matrix(mint,1,maxwav,1,n); | matcov[i][j]=matcov[j][i]; |
| free_matrix(anint,1,maxwav,1,n); | |
| free_vector(moisdc,1,n); | printf("\n"); |
| free_vector(andc,1,n); | |
| /*-------- data file ----------*/ | |
| wav=ivector(1,imx); | if((ficres =fopen(fileres,"w"))==NULL) { |
| dh=imatrix(1,lastpass-firstpass+1,1,imx); | printf("Problem with resultfile: %s\n", fileres);goto end; |
| mw=imatrix(1,lastpass-firstpass+1,1,imx); | } |
| fprintf(ficres,"#%s\n",version); | |
| /* Concatenates waves */ | |
| concatwav(wav, dh, mw, s, agedc, agev, firstpass, lastpass, imx, nlstate, stepm); | if((fic=fopen(datafile,"r"))==NULL) { |
| printf("Problem with datafile: %s\n", datafile);goto end; | |
| /* Calculates basic frequencies. Computes observed prevalence at single age | } |
| and prints on file fileres'p'. */ | |
| freqsummary(fileres, agemin, agemax, s, agev, nlstate, imx); | n= lastobs; |
| severity = vector(1,maxwav); | |
| pmmij= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | outcome=imatrix(1,maxwav+1,1,n); |
| oldms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | num=ivector(1,n); |
| newms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | moisnais=vector(1,n); |
| savms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | annais=vector(1,n); |
| oldm=oldms; newm=newms; savm=savms; /* Keeps fixed addresses to free */ | moisdc=vector(1,n); |
| andc=vector(1,n); | |
| /* For Powell, parameters are in a vector p[] starting at p[1] | agedc=vector(1,n); |
| so we point p on param[1][1] so that p[1] maps on param[1][1][1] */ | cod=ivector(1,n); |
| p=param[1][1]; /* *(*(*(param +1)+1)+0) */ | weight=vector(1,n); |
| for(i=1;i<=n;i++) weight[i]=1.0; /* Equal weights, 1 by default */ | |
| mlikeli(ficres,p, npar, ncov, nlstate, ftol, func); | mint=matrix(1,maxwav,1,n); |
| anint=matrix(1,maxwav,1,n); | |
| s=imatrix(1,maxwav+1,1,n); | |
| /*--------- results files --------------*/ | adl=imatrix(1,maxwav+1,1,n); |
| fprintf(ficres,"\ntitle=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\n", title, datafile, lastobs, firstpass,lastpass,ftol, stepm, ncov, nlstate, ndeath, maxwav, mle,weightopt); | tab=ivector(1,NCOVMAX); |
| ncodemax=ivector(1,8); | |
| jk=1; | |
| fprintf(ficres,"# Parameters\n"); | i=1; |
| printf("# Parameters\n"); | while (fgets(line, MAXLINE, fic) != NULL) { |
| for(i=1,jk=1; i <=nlstate; i++){ | if ((i >= firstobs) && (i <=lastobs)) { |
| for(k=1; k <=(nlstate+ndeath); k++){ | |
| if (k != i) | for (j=maxwav;j>=1;j--){ |
| { | cutv(stra, strb,line,' '); s[j][i]=atoi(strb); |
| printf("%d%d ",i,k); | strcpy(line,stra); |
| fprintf(ficres,"%1d%1d ",i,k); | cutv(stra, strb,line,'/'); anint[j][i]=(double)(atoi(strb)); strcpy(line,stra); |
| for(j=1; j <=ncov; j++){ | cutv(stra, strb,line,' '); mint[j][i]=(double)(atoi(strb)); strcpy(line,stra); |
| printf("%f ",p[jk]); | } |
| fprintf(ficres,"%f ",p[jk]); | |
| jk++; | cutv(stra, strb,line,'/'); andc[i]=(double)(atoi(strb)); strcpy(line,stra); |
| } | cutv(stra, strb,line,' '); moisdc[i]=(double)(atoi(strb)); strcpy(line,stra); |
| printf("\n"); | |
| fprintf(ficres,"\n"); | cutv(stra, strb,line,'/'); annais[i]=(double)(atoi(strb)); strcpy(line,stra); |
| } | cutv(stra, strb,line,' '); moisnais[i]=(double)(atoi(strb)); strcpy(line,stra); |
| } | |
| } | cutv(stra, strb,line,' '); weight[i]=(double)(atoi(strb)); strcpy(line,stra); |
| for (j=ncov;j>=1;j--){ | |
| /* Computing hessian and covariance matrix */ | cutv(stra, strb,line,' '); covar[j][i]=(double)(atoi(strb)); strcpy(line,stra); |
| ftolhess=ftol; /* Usually correct */ | } |
| hesscov(matcov, p, npar, delti, ftolhess, func); | num[i]=atol(stra); |
| fprintf(ficres,"# Scales\n"); | |
| printf("# Scales\n"); | /*printf("%d %.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]));*/ |
| for(i=1,jk=1; i <=nlstate; i++){ | |
| for(j=1; j <=nlstate+ndeath; j++){ | i=i+1; |
| if (j!=i) { | } |
| fprintf(ficres,"%1d%1d",i,j); | } |
| printf("%1d%1d",i,j); | |
| for(k=1; k<=ncov;k++){ | /*scanf("%d",i);*/ |
| printf(" %.5e",delti[jk]); | imx=i-1; /* Number of individuals */ |
| fprintf(ficres," %.5e",delti[jk]); | |
| jk++; | /* Calculation of the number of parameter from char model*/ |
| } | Tvar=ivector(1,15); |
| printf("\n"); | Tprod=ivector(1,15); |
| fprintf(ficres,"\n"); | Tvaraff=ivector(1,15); |
| } | Tvard=imatrix(1,15,1,2); |
| } | Tage=ivector(1,15); |
| } | |
| if (strlen(model) >1){ | |
| k=1; | j=0, j1=0, k1=1, k2=1; |
| fprintf(ficres,"# Covariance\n"); | j=nbocc(model,'+'); |
| printf("# Covariance\n"); | j1=nbocc(model,'*'); |
| for(i=1;i<=npar;i++){ | cptcovn=j+1; |
| /* if (k>nlstate) k=1; | cptcovprod=j1; |
| i1=(i-1)/(ncov*nlstate)+1; | |
| fprintf(ficres,"%s%d%d",alph[k],i1,tab[i]); | strcpy(modelsav,model); |
| printf("%s%d%d",alph[k],i1,tab[i]);*/ | if (j==0) { |
| fprintf(ficres,"%3d",i); | if (j1==0){ |
| printf("%3d",i); | cutv(stra,strb,modelsav,'V'); |
| for(j=1; j<=i;j++){ | Tvar[1]=atoi(strb); |
| fprintf(ficres," %.5e",matcov[i][j]); | } |
| printf(" %.5e",matcov[i][j]); | else if (j1==1) { |
| } | cutv(stra,strb,modelsav,'*'); |
| fprintf(ficres,"\n"); | Tage[1]=1; cptcovage++; |
| printf("\n"); | if (strcmp(stra,"age")==0) { |
| k++; | cptcovprod--; |
| } | cutv(strd,strc,strb,'V'); |
| Tvar[1]=atoi(strc); | |
| while((c=getc(ficpar))=='#' && c!= EOF){ | } |
| ungetc(c,ficpar); | else if (strcmp(strb,"age")==0) { |
| fgets(line, MAXLINE, ficpar); | cptcovprod--; |
| puts(line); | cutv(strd,strc,stra,'V'); |
| fputs(line,ficparo); | Tvar[1]=atoi(strc); |
| } | } |
| ungetc(c,ficpar); | else { |
| cutv(strd,strc,strb,'V'); | |
| fscanf(ficpar,"agemin=%lf agemax=%lf bage=%lf fage=%lf\n",&agemin,&agemax, &bage, &fage); | cutv(stre,strd,stra,'V'); |
| Tvar[1]=ncov+1; | |
| if (fage <= 2) { | for (k=1; k<=lastobs;k++) |
| bage = agemin; | covar[ncov+1][k]=covar[atoi(strc)][k]*covar[atoi(strd)][k]; |
| fage = agemax; | } |
| } | /*printf("%s %s %s\n", stra,strb,modelsav); |
| printf("%d ",Tvar[1]); | |
| fprintf(ficres,"# agemin agemax for life expectancy, bage fage (if mle==0 ie no data nor Max likelihood).\n"); | scanf("%d",i);*/ |
| fprintf(ficres,"agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f\n",agemin,agemax,bage,fage); | } |
| /*------------ gnuplot -------------*/ | } |
| chdir(pathcd); | else { |
| if((ficgp=fopen("graph.gp","w"))==NULL) { | for(i=j; i>=1;i--){ |
| printf("Problem with file graph.gp");goto end; | cutv(stra,strb,modelsav,'+'); |
| } | /*printf("%s %s %s\n", stra,strb,modelsav); |
| #ifdef windows | scanf("%d",i);*/ |
| fprintf(ficgp,"cd \"%s\" \n",pathc); | if (strchr(strb,'*')) { |
| #endif | cutv(strd,strc,strb,'*'); |
| /* 1eme*/ | if (strcmp(strc,"age")==0) { |
| cptcovprod--; | |
| for (cpt=1; cpt<= nlstate ; cpt ++) { | cutv(strb,stre,strd,'V'); |
| #ifdef windows | Tvar[i+1]=atoi(stre); |
| fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \nset ter gif small size 400,300\nplot [%.f:%.f] \"vpl%s\" u 1:%d \"\%%lf",agemin,fage,fileres,cpt*2); | cptcovage++; |
| #endif | Tage[cptcovage]=i+1; |
| #ifdef unix | printf("stre=%s ", stre); |
| fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \nplot [%.f:%.f] \"vpl%s\" u 1:%d \"\%%lf",agemin,fage,fileres,cpt*2); | } |
| #endif | else if (strcmp(strd,"age")==0) { |
| for (i=1; i<= nlstate ; i ++) fprintf(ficgp," \%%lf (\%%lf)"); | cptcovprod--; |
| fprintf(ficgp,"\" t\"Stationary prevalence\" w l 0,\"vpl%s\" u 1:($%d+2*$%d) \"\%%lf",fileres,2*cpt,cpt*2+1); | cutv(strb,stre,strc,'V'); |
| for (i=1; i<= nlstate ; i ++) fprintf(ficgp," \%%lf (\%%lf)"); | Tvar[i+1]=atoi(stre); |
| fprintf(ficgp,"\" t\"95\%% CI\" w l 1,\"vpl%s\" u 1:($%d-2*$%d) \"\%%lf",fileres,2*cpt,2*cpt+1); | cptcovage++; |
| for (i=1; i<= nlstate ; i ++) fprintf(ficgp," \%%lf (\%%lf)"); | Tage[cptcovage]=i+1; |
| fprintf(ficgp,"\" t\"\" w l 1,\"p%s\" u 1:($%d) t\"Observed prevalence \" w l 2",fileres,2+4*(cpt-1)); | } |
| #ifdef unix | else { |
| fprintf(ficgp,"\nset ter gif small size 400,300"); | cutv(strb,stre,strc,'V'); |
| #endif | Tvar[i+1]=ncov+k1; |
| fprintf(ficgp,"\nset out \"v%s%d.gif\" \nreplot\n\n",strtok(optionfile, "."),cpt); | cutv(strb,strc,strd,'V'); |
| Tprod[k1]=i+1; | |
| } | Tvard[k1][1]=atoi(strc); |
| /*2 eme*/ | Tvard[k1][2]=atoi(stre); |
| Tvar[cptcovn+k2]=Tvard[k1][1]; | |
| fprintf(ficgp,"set ylabel \"Years\" \nset ter gif small size 400,300\nplot [%.f:%.f] ",agemin,fage); | Tvar[cptcovn+k2+1]=Tvard[k1][2]; |
| for (i=1; i<= nlstate+1 ; i ++) { | for (k=1; k<=lastobs;k++) |
| k=2*i; | covar[ncov+k1][k]=covar[atoi(stre)][k]*covar[atoi(strc)][k]; |
| fprintf(ficgp,"\"t%s\" u 1:%d \"\%%lf \%%lf (\%%lf) \%%lf (\%%lf)",fileres,k); | k1++; |
| for (j=1; j< nlstate ; j ++) fprintf(ficgp," \%%lf (\%%lf)"); | k2=k2+2; |
| if (i== 1) fprintf(ficgp,"\" t\"TLE\" w l ,"); | } |
| else fprintf(ficgp,"\" t\"LE in state (%d)\" w l ,",i-1); | } |
| fprintf(ficgp,"\"t%s\" u 1:($%d-2*$%d) \"\%%lf \%%lf (\%%lf) \%%lf (\%%lf)",fileres,k,k+1); | else { |
| for (j=1; j< nlstate ; j ++) fprintf(ficgp," \%%lf (\%%lf)"); | cutv(strd,strc,strb,'V'); |
| fprintf(ficgp,"\" t\"\" w l 0,"); | /* printf("%s %s %s", strd,strc,strb);*/ |
| fprintf(ficgp,"\"t%s\" u 1:($%d+2*$%d) \"\%%lf \%%lf (\%%lf) \%%lf (\%%lf)",fileres,k,k+1); | Tvar[i+1]=atoi(strc); |
| for (j=1; j< nlstate ; j ++) fprintf(ficgp," \%%lf (\%%lf)"); | } |
| if (i== (nlstate+1)) fprintf(ficgp,"\" t\"\" w l 0"); | strcpy(modelsav,stra); |
| else fprintf(ficgp,"\" t\"\" w l 0,"); | } |
| } | cutv(strd,strc,stra,'V'); |
| fprintf(ficgp,"\nset out \"e%s.gif\" \nreplot\n\n",strtok(optionfile, ".")); | Tvar[1]=atoi(strc); |
| } | |
| /*3eme*/ | } |
| for (cpt=1; cpt<= nlstate ; cpt ++) { | /* for (i=1; i<=5; i++) |
| k=2+nlstate*(cpt-1); | printf("i=%d %d ",i,Tvar[i]);*/ |
| fprintf(ficgp,"set ter gif small size 400,300\nplot [%.f:%.f] \"e%s\" u 1:%d t \"e%d1\" w l",agemin,fage,fileres,k,cpt); | /* printf("tvar=%d %d cptcovage=%d %d",Tvar[1],Tvar[2],cptcovage,Tage[1]);*/ |
| for (i=1; i< nlstate ; i ++) { | /*printf("cptcovprod=%d ", cptcovprod);*/ |
| fprintf(ficgp,",\"e%s\" u 1:%d t \"e%d%d\" w l",fileres,k+1,cpt,i+1); | /* scanf("%d ",i);*/ |
| } | fclose(fic); |
| fprintf(ficgp,"\nset out \"ex%s%d.gif\" \nreplot\n\n",strtok(optionfile, "."),cpt); | |
| } | /* if(mle==1){*/ |
| if (weightopt != 1) { /* Maximisation without weights*/ | |
| /* CV preval stat */ | for(i=1;i<=n;i++) weight[i]=1.0; |
| for (cpt=1; cpt<nlstate ; cpt ++) { | } |
| k=3; | /*-calculation of age at interview from date of interview and age at death -*/ |
| fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \nset ter gif small size 400,300\nplot [%.f:%.f] \"pij%s\" u 2:($%d/($%d",agemin,agemax,fileres,k+cpt,k); | agev=matrix(1,maxwav,1,imx); |
| for (i=1; i< nlstate ; i ++) | |
| fprintf(ficgp,"+$%d",k+i); | for (i=1; i<=imx; i++) { |
| fprintf(ficgp,")) t\"prev(%d,%d)\" w l",cpt,cpt+1); | agedc[i]=(moisdc[i]/12.+andc[i])-(moisnais[i]/12.+annais[i]); |
| for(m=1; (m<= maxwav); m++){ | |
| l=3+(nlstate+ndeath)*cpt; | if(s[m][i] >0){ |
| fprintf(ficgp,",\"pij%s\" u 2:($%d/($%d",fileres,l+cpt,l); | if (s[m][i] == nlstate+1) { |
| if(agedc[i]>0) | |
| for (i=1; i< nlstate ; i ++) { | if(moisdc[i]!=99 && andc[i]!=9999) |
| l=3+(nlstate+ndeath)*cpt; | agev[m][i]=agedc[i]; |
| fprintf(ficgp,"+$%d",l+i); | else{ |
| } | printf("Warning negative age at death: %d line:%d\n",num[i],i); |
| fprintf(ficgp,")) t\"prev(%d,%d)\" w l\n",cpt+1,cpt+1); | agev[m][i]=-1; |
| } | |
| } | |
| fprintf(ficgp,"set out \"p%s%d.gif\" \nreplot\n\n",strtok(optionfile, "."),cpt); | else if(s[m][i] !=9){ /* Should no more exist */ |
| } | agev[m][i]=(mint[m][i]/12.+1./24.+anint[m][i])-(moisnais[i]/12.+1./24.+annais[i]); |
| if(mint[m][i]==99 || anint[m][i]==9999) | |
| agev[m][i]=1; | |
| fclose(ficgp); | else if(agev[m][i] <agemin){ |
| agemin=agev[m][i]; | |
| chdir(path); | /*printf(" Min anint[%d][%d]=%.2f annais[%d]=%.2f, agemin=%.2f\n",m,i,anint[m][i], i,annais[i], agemin);*/ |
| free_matrix(agev,1,maxwav,1,imx); | } |
| free_ivector(wav,1,imx); | else if(agev[m][i] >agemax){ |
| free_imatrix(dh,1,lastpass-firstpass+1,1,imx); | agemax=agev[m][i]; |
| free_imatrix(mw,1,lastpass-firstpass+1,1,imx); | /* printf(" anint[%d][%d]=%.0f annais[%d]=%.0f, agemax=%.0f\n",m,i,anint[m][i], i,annais[i], agemax);*/ |
| } | |
| free_imatrix(s,1,maxwav+1,1,n); | /*agev[m][i]=anint[m][i]-annais[i];*/ |
| /* agev[m][i] = age[i]+2*m;*/ | |
| } | |
| free_ivector(num,1,n); | else { /* =9 */ |
| free_vector(agedc,1,n); | agev[m][i]=1; |
| free_vector(weight,1,n); | s[m][i]=-1; |
| free_matrix(covar,1,NCOVMAX,1,n); | } |
| fclose(ficparo); | } |
| fclose(ficres); | else /*= 0 Unknown */ |
| } | agev[m][i]=1; |
| } | |
| /*________fin mle=1_________*/ | |
| } | |
| for (i=1; i<=imx; i++) { | |
| for(m=1; (m<= maxwav); m++){ | |
| /* No more information from the sample is required now */ | if (s[m][i] > (nlstate+ndeath)) { |
| /* Reads comments: lines beginning with '#' */ | printf("Error: Wrong value in nlstate or ndeath\n"); |
| while((c=getc(ficpar))=='#' && c!= EOF){ | goto end; |
| ungetc(c,ficpar); | } |
| fgets(line, MAXLINE, ficpar); | } |
| puts(line); | } |
| fputs(line,ficparo); | |
| } | printf("Total number of individuals= %d, Agemin = %.2f, Agemax= %.2f\n\n", imx, agemin, agemax); |
| ungetc(c,ficpar); | |
| free_vector(severity,1,maxwav); | |
| fscanf(ficpar,"agemin=%lf agemax=%lf bage=%lf fage=%lf\n",&agemin,&agemax, &bage, &fage); | free_imatrix(outcome,1,maxwav+1,1,n); |
| printf("agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f\n",agemin,agemax, bage, fage); | free_vector(moisnais,1,n); |
| fprintf(ficparo,"agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f\n",agemin,agemax,bage,fage); | free_vector(annais,1,n); |
| free_matrix(mint,1,maxwav,1,n); | |
| /*--------------- Prevalence limit --------------*/ | free_matrix(anint,1,maxwav,1,n); |
| free_vector(moisdc,1,n); | |
| strcpy(filerespl,"pl"); | free_vector(andc,1,n); |
| strcat(filerespl,fileres); | |
| if((ficrespl=fopen(filerespl,"w"))==NULL) { | |
| printf("Problem with Prev limit resultfile: %s\n", filerespl);goto end; | wav=ivector(1,imx); |
| } | dh=imatrix(1,lastpass-firstpass+1,1,imx); |
| printf("Computing prevalence limit: result on file '%s' \n", filerespl); | mw=imatrix(1,lastpass-firstpass+1,1,imx); |
| fprintf(ficrespl,"#Prevalence limit\n"); | |
| fprintf(ficrespl,"#Age "); | /* Concatenates waves */ |
| for(i=1; i<=nlstate;i++) fprintf(ficrespl,"%d-%d ",i,i); | concatwav(wav, dh, mw, s, agedc, agev, firstpass, lastpass, imx, nlstate, stepm); |
| fprintf(ficrespl,"\n"); | |
| prlim=matrix(1,nlstate,1,nlstate); | Tcode=ivector(1,100); |
| pmmij= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | nbcode=imatrix(1,nvar,1,8); |
| oldms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | ncodemax[1]=1; |
| newms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | if (cptcovn > 0) tricode(Tvar,nbcode,imx); |
| savms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ | |
| oldm=oldms; newm=newms; savm=savms; /* Keeps fixed addresses to free */ | codtab=imatrix(1,100,1,10); |
| h=0; | |
| agebase=agemin; | m=pow(2,cptcoveff); |
| agelim=agemax; | |
| ftolpl=1.e-10; | for(k=1;k<=cptcoveff; k++){ |
| for (age=agebase; age<=agelim; age++){ | for(i=1; i <=(m/pow(2,k));i++){ |
| prevalim(prlim, nlstate, p, age, oldm, savm,ftolpl); | for(j=1; j <= ncodemax[k]; j++){ |
| fprintf(ficrespl,"%.0f",age ); | for(cpt=1; cpt <=(m/pow(2,cptcoveff+1-k)); cpt++){ |
| for(i=1; i<=nlstate;i++) | h++; |
| fprintf(ficrespl," %.5f", prlim[i][i]); | if (h>m) h=1;codtab[h][k]=j; |
| fprintf(ficrespl,"\n"); | } |
| } | } |
| fclose(ficrespl); | } |
| } | |
| /*------------- h Pij x at various ages ------------*/ | |
| strcpy(filerespij,"pij"); strcat(filerespij,fileres); | /*for(i=1; i <=m ;i++){ |
| if((ficrespij=fopen(filerespij,"w"))==NULL) { | for(k=1; k <=cptcovn; k++){ |
| printf("Problem with Pij resultfile: %s\n", filerespij);goto end; | printf("i=%d k=%d %d %d",i,k,codtab[i][k], cptcoveff); |
| } | } |
| printf("Computing pij: result on file '%s' \n", filerespij); | printf("\n"); |
| stepsize=(int) (stepm+YEARM-1)/YEARM; | } |
| if (stepm<=24) stepsize=2; | scanf("%d",i);*/ |
| agelim=AGESUP; | /* Calculates basic frequencies. Computes observed prevalence at single age |
| hstepm=stepsize*YEARM; /* Every year of age */ | and prints on file fileres'p'. */ |
| hstepm=hstepm/stepm; /* Typically 2 years, = 2/6 months = 4 */ | freqsummary(fileres, agemin, agemax, s, agev, nlstate, imx,Tvar,nbcode, ncodemax); |
| for (agedeb=fage; agedeb>=bage; agedeb--){ /* If stepm=6 months */ | |
| nhstepm=(int) rint((agelim-agedeb)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ | pmmij= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ |
| nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ | oldms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ |
| p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | newms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ |
| oldm=oldms;savm=savms; | savms= matrix(1,nlstate+ndeath,1,nlstate+ndeath); /* creation */ |
| hpxij(p3mat,nhstepm,agedeb,hstepm,p,nlstate,stepm,oldm,savm); | oldm=oldms; newm=newms; savm=savms; /* Keeps fixed addresses to free */ |
| fprintf(ficrespij,"# Age"); | |
| for(i=1; i<=nlstate;i++) | /* For Powell, parameters are in a vector p[] starting at p[1] |
| for(j=1; j<=nlstate+ndeath;j++) | so we point p on param[1][1] so that p[1] maps on param[1][1][1] */ |
| fprintf(ficrespij," %1d-%1d",i,j); | p=param[1][1]; /* *(*(*(param +1)+1)+0) */ |
| fprintf(ficrespij,"\n"); | |
| for (h=0; h<=nhstepm; h++){ | if(mle==1){ |
| fprintf(ficrespij,"%.0f %.0f",agedeb, agedeb+ h*hstepm/YEARM*stepm ); | mlikeli(ficres,p, npar, ncovmodel, nlstate, ftol, func); |
| for(i=1; i<=nlstate;i++) | } |
| for(j=1; j<=nlstate+ndeath;j++) | |
| fprintf(ficrespij," %.5f", p3mat[i][j][h]); | /*--------- results files --------------*/ |
| fprintf(ficrespij,"\n"); | fprintf(ficres,"\ntitle=%s datafile=%s lastobs=%d firstpass=%d lastpass=%d\nftol=%e stepm=%d ncov=%d nlstate=%d ndeath=%d maxwav=%d mle=%d weight=%d\nmodel=%s\n", title, datafile, lastobs, firstpass,lastpass,ftol, stepm, ncov, nlstate, ndeath, maxwav, mle,weightopt,model); |
| } | |
| free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | jk=1; |
| fprintf(ficrespij,"\n"); | fprintf(ficres,"# Parameters\n"); |
| } | printf("# Parameters\n"); |
| fclose(ficrespij); | for(i=1,jk=1; i <=nlstate; i++){ |
| for(k=1; k <=(nlstate+ndeath); k++){ | |
| /*---------- Health expectancies and variances ------------*/ | if (k != i) |
| { | |
| eij=ma3x(1,nlstate,1,nlstate,(int) bage, (int) fage); | printf("%d%d ",i,k); |
| oldm=oldms;savm=savms; | fprintf(ficres,"%1d%1d ",i,k); |
| evsij(fileres, eij, p, nlstate, stepm, (int) bage, (int)fage, oldm, savm); | for(j=1; j <=ncovmodel; j++){ |
| printf("%f ",p[jk]); | |
| vareij=ma3x(1,nlstate,1,nlstate,(int) bage, (int) fage); | fprintf(ficres,"%f ",p[jk]); |
| oldm=oldms;savm=savms; | jk++; |
| varevsij(fileres, vareij, matcov, p, delti, nlstate, stepm, (int) bage, (int) fage, oldm, savm, prlim, ftolpl); | } |
| printf("\n"); | |
| strcpy(filerest,"t"); | fprintf(ficres,"\n"); |
| strcat(filerest,fileres); | } |
| if((ficrest=fopen(filerest,"w"))==NULL) { | } |
| printf("Problem with total LE resultfile: %s\n", filerest);goto end; | } |
| } | if(mle==1){ |
| printf("Computing Total LEs with variances: file '%s' \n", filerest); | /* Computing hessian and covariance matrix */ |
| fprintf(ficrest,"#Total LEs with variances: e.. (std) "); | ftolhess=ftol; /* Usually correct */ |
| for (i=1;i<=nlstate;i++) fprintf(ficrest,"e.%d (std) ",i); | hesscov(matcov, p, npar, delti, ftolhess, func); |
| fprintf(ficrest,"\n"); | } |
| fprintf(ficres,"# Scales\n"); | |
| hf=1; | printf("# Scales\n"); |
| if (stepm >= YEARM) hf=stepm/YEARM; | for(i=1,jk=1; i <=nlstate; i++){ |
| epj=vector(1,nlstate+1); | for(j=1; j <=nlstate+ndeath; j++){ |
| for(age=bage; age <=fage ;age++){ | if (j!=i) { |
| prevalim(prlim, nlstate, p, age, oldm, savm,ftolpl); | fprintf(ficres,"%1d%1d",i,j); |
| fprintf(ficrest," %.0f",age); | printf("%1d%1d",i,j); |
| for(j=1, epj[nlstate+1]=0.;j <=nlstate;j++){ | for(k=1; k<=ncovmodel;k++){ |
| for(i=1, epj[j]=0.;i <=nlstate;i++) { | printf(" %.5e",delti[jk]); |
| epj[j] += prlim[i][i]*hf*eij[i][j][(int)age]; | fprintf(ficres," %.5e",delti[jk]); |
| } | jk++; |
| epj[nlstate+1] +=epj[j]; | } |
| } | printf("\n"); |
| for(i=1, vepp=0.;i <=nlstate;i++) | fprintf(ficres,"\n"); |
| for(j=1;j <=nlstate;j++) | } |
| vepp += vareij[i][j][(int)age]; | } |
| fprintf(ficrest," %.2f (%.2f)", epj[nlstate+1],hf*sqrt(vepp)); | } |
| for(j=1;j <=nlstate;j++){ | |
| fprintf(ficrest," %.2f (%.2f)", epj[j],hf*sqrt(vareij[j][j][(int)age])); | k=1; |
| } | fprintf(ficres,"# Covariance\n"); |
| fprintf(ficrest,"\n"); | printf("# Covariance\n"); |
| } | for(i=1;i<=npar;i++){ |
| fclose(ficrest); | /* if (k>nlstate) k=1; |
| fclose(ficpar); | i1=(i-1)/(ncovmodel*nlstate)+1; |
| free_vector(epj,1,nlstate+1); | fprintf(ficres,"%s%d%d",alph[k],i1,tab[i]); |
| printf("%s%d%d",alph[k],i1,tab[i]);*/ | |
| /*------- Variance limit prevalence------*/ | fprintf(ficres,"%3d",i); |
| printf("%3d",i); | |
| varpl=matrix(1,nlstate,(int) bage, (int) fage); | for(j=1; j<=i;j++){ |
| oldm=oldms;savm=savms; | fprintf(ficres," %.5e",matcov[i][j]); |
| varprevlim(fileres, varpl, matcov, p, delti, nlstate, stepm, (int) bage, (int) fage, oldm, savm, prlim, ftolpl); | printf(" %.5e",matcov[i][j]); |
| } | |
| fprintf(ficres,"\n"); | |
| free_matrix(varpl,1,nlstate,(int) bage, (int)fage); | printf("\n"); |
| k++; | |
| free_ma3x(vareij,1,nlstate,1,nlstate,(int) bage, (int)fage); | } |
| free_ma3x(eij,1,nlstate,1,nlstate,(int) bage, (int)fage); | |
| while((c=getc(ficpar))=='#' && c!= EOF){ | |
| ungetc(c,ficpar); | |
| free_matrix(pmmij,1,nlstate+ndeath,1,nlstate+ndeath); | fgets(line, MAXLINE, ficpar); |
| free_matrix(oldms, 1,nlstate+ndeath,1,nlstate+ndeath); | puts(line); |
| free_matrix(newms, 1,nlstate+ndeath,1,nlstate+ndeath); | fputs(line,ficparo); |
| free_matrix(savms, 1,nlstate+ndeath,1,nlstate+ndeath); | } |
| ungetc(c,ficpar); | |
| free_matrix(matcov,1,npar,1,npar); | |
| free_vector(delti,1,npar); | fscanf(ficpar,"agemin=%lf agemax=%lf bage=%lf fage=%lf\n",&agemin,&agemax, &bage, &fage); |
| free_ma3x(param,1,nlstate,1, nlstate+ndeath-1,1,ncov); | if (fage <= 2) { |
| bage = agemin; | |
| printf("End of Imach\n"); | fage = agemax; |
| /* gettimeofday(&end_time, (struct timezone*)0);*/ /* after time */ | } |
| /* printf("Total time was %d Sec. %d uSec.\n", end_time.tv_sec -start_time.tv_sec, end_time.tv_usec -start_time.tv_usec);*/ | fprintf(ficres,"# agemin agemax for life expectancy, bage fage (if mle==0 ie no data nor Max likelihood).\n"); |
| /*printf("Total time was %d uSec.\n", total_usecs);*/ | fprintf(ficres,"agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f\n",agemin,agemax,bage,fage); |
| /*------ End -----------*/ | |
| end: | /*------------ gnuplot -------------*/ |
| #ifdef windows | chdir(pathcd); |
| chdir(pathcd); | if((ficgp=fopen("graph.plt","w"))==NULL) { |
| #endif | printf("Problem with file graph.gp");goto end; |
| system("gnuplot graph.gp"); | } |
| #ifdef windows | |
| #ifdef windows | fprintf(ficgp,"cd \"%s\" \n",pathc); |
| while (z[0] != 'q') { | #endif |
| chdir(pathcd); | m=pow(2,cptcoveff); |
| printf("\nType e to edit output files, c to start again, and q for exiting: "); | |
| scanf("%s",z); | /* 1eme*/ |
| if (z[0] == 'c') system("./imach"); | for (cpt=1; cpt<= nlstate ; cpt ++) { |
| else if (z[0] == 'e') { | for (k1=1; k1<= m ; k1 ++) { |
| chdir(path); | |
| system("index.htm"); | #ifdef windows |
| } | fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \nset ter gif small size 400,300\nplot [%.f:%.f] \"vpl%s\" every :::%d::%d u 1:2 \"\%%lf",agemin,fage,fileres,k1-1,k1-1); |
| else if (z[0] == 'q') exit(0); | #endif |
| } | #ifdef unix |
| #endif | fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \nplot [%.f:%.f] \"vpl%s\" u 1:2 \"\%%lf",agemin,fage,fileres); |
| } | #endif |
| for (i=1; i<= nlstate ; i ++) { | |
| if (i==cpt) fprintf(ficgp," \%%lf (\%%lf)"); | |
| else fprintf(ficgp," \%%*lf (\%%*lf)"); | |
| } | |
| fprintf(ficgp,"\" t\"Stationary prevalence\" w l 0,\"vpl%s\" every :::%d::%d u 1:($2+2*$3) \"\%%lf",fileres,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,\"vpl%s\" every :::%d::%d u 1:($2-2*$3) \"\%%lf",fileres,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,\"p%s\" every :::%d::%d u 1:($%d) t\"Observed prevalence \" w l 2",fileres,k1-1,k1-1,2+4*(cpt-1)); | |
| #ifdef unix | |
| fprintf(ficgp,"\nset ter gif small size 400,300"); | |
| #endif | |
| fprintf(ficgp,"\nset out \"v%s%d%d.gif\" \nreplot\n\n",strtok(optionfile, "."),cpt,k1); | |
| } | |
| } | |
| /*2 eme*/ | |
| for (k1=1; k1<= m ; k1 ++) { | |
| fprintf(ficgp,"set ylabel \"Years\" \nset ter gif small size 400,300\nplot [%.f:%.f] ",agemin,fage); | |
| for (i=1; i<= nlstate+1 ; i ++) { | |
| k=2*i; | |
| fprintf(ficgp,"\"t%s\" every :::%d::%d u 1:2 \"\%%lf",fileres,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,"\"t%s\" every :::%d::%d u 1:($2-$3*2) \"\%%lf",fileres,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,"\"t%s\" every :::%d::%d u 1:($2+$3*2) \"\%%lf",fileres,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,"); | |
| } | |
| fprintf(ficgp,"\nset out \"e%s%d.gif\" \nreplot\n\n",strtok(optionfile, "."),k1); | |
| } | |
| /*3eme*/ | |
| for (k1=1; k1<= m ; k1 ++) { | |
| for (cpt=1; cpt<= nlstate ; cpt ++) { | |
| k=2+nlstate*(cpt-1); | |
| fprintf(ficgp,"set ter gif small size 400,300\nplot [%.f:%.f] \"e%s\" every :::%d::%d u 1:%d t \"e%d1\" w l",agemin,fage,fileres,k1-1,k1-1,k,cpt); | |
| for (i=1; i< nlstate ; i ++) { | |
| fprintf(ficgp,",\"e%s\" every :::%d::%d u 1:%d t \"e%d%d\" w l",fileres,k1-1,k1-1,k+i,cpt,i+1); | |
| } | |
| fprintf(ficgp,"\nset out \"exp%s%d%d.gif\" \nreplot\n\n",strtok(optionfile, "."),cpt,k1); | |
| } | |
| } | |
| /* CV preval stat */ | |
| for (k1=1; k1<= m ; k1 ++) { | |
| for (cpt=1; cpt<nlstate ; cpt ++) { | |
| k=3; | |
| fprintf(ficgp,"set xlabel \"Age\" \nset ylabel \"Probability\" \nset ter gif small size 400,300\nplot [%.f:%.f] \"pij%s\" u ($1==%d ? ($3):1/0):($%d/($%d",agemin,agemax,fileres,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,",\"pij%s\" u ($1==%d ? ($3):1/0):($%d/($%d",fileres,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); | |
| fprintf(ficgp,"set out \"p%s%d%d.gif\" \nreplot\n\n",strtok(optionfile, "."),cpt,k1); | |
| } | |
| } | |
| /* 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,"%s%1d%1d=%f ",alph[j],i,k,p[jk]);*/ | |
| /*fprintf(ficgp,"%s",alph[1]);*/ | |
| fprintf(ficgp,"p%d=%f ",jk,p[jk]); | |
| jk++; | |
| fprintf(ficgp,"\n"); | |
| } | |
| } | |
| } | |
| } | |
| for(jk=1; jk <=m; jk++) { | |
| fprintf(ficgp,"\nset ter gif small size 400,300\nset log y\nplot [%.f:%.f] ",agemin,agemax); | |
| i=1; | |
| for(k2=1; k2<=nlstate; k2++) { | |
| k3=i; | |
| for(k=1; k<=(nlstate+ndeath); k++) { | |
| if (k != k2){ | |
| 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; | |
| } | |
| } | |
| } | |
| fprintf(ficgp,"\nset out \"pe%s%d.gif\" \nreplot\n\n",strtok(optionfile, "."),jk); | |
| } | |
| fclose(ficgp); | |
| chdir(path); | |
| free_matrix(agev,1,maxwav,1,imx); | |
| free_ivector(wav,1,imx); | |
| free_imatrix(dh,1,lastpass-firstpass+1,1,imx); | |
| free_imatrix(mw,1,lastpass-firstpass+1,1,imx); | |
| free_imatrix(s,1,maxwav+1,1,n); | |
| free_ivector(num,1,n); | |
| free_vector(agedc,1,n); | |
| free_vector(weight,1,n); | |
| /*free_matrix(covar,1,NCOVMAX,1,n);*/ | |
| fclose(ficparo); | |
| fclose(ficres); | |
| /* }*/ | |
| /*________fin mle=1_________*/ | |
| /* No more information from the sample is required now */ | |
| /* Reads comments: lines beginning with '#' */ | |
| while((c=getc(ficpar))=='#' && c!= EOF){ | |
| ungetc(c,ficpar); | |
| fgets(line, MAXLINE, ficpar); | |
| puts(line); | |
| fputs(line,ficparo); | |
| } | |
| ungetc(c,ficpar); | |
| fscanf(ficpar,"agemin=%lf agemax=%lf bage=%lf fage=%lf\n",&agemin,&agemax, &bage, &fage); | |
| printf("agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f\n",agemin,agemax, bage, fage); | |
| fprintf(ficparo,"agemin=%.0f agemax=%.0f bage=%.0f fage=%.0f\n",agemin,agemax,bage,fage); | |
| /*--------- index.htm --------*/ | |
| if((fichtm=fopen("index.htm","w"))==NULL) { | |
| printf("Problem with index.htm \n");goto end; | |
| } | |
| fprintf(fichtm,"<body><ul> Imach, Version 0.64a<hr> <li>Outputs files<br><br>\n | |
| - Observed prevalence in each state: <a href=\"p%s\">p%s</a> <br>\n | |
| - Estimated parameters and the covariance matrix: <a href=\"%s\">%s</a> <br> | |
| - Stationary prevalence in each state: <a href=\"pl%s\">pl%s</a> <br> | |
| - Transition probabilities: <a href=\"pij%s\">pij%s</a><br> | |
| - Copy of the parameter file: <a href=\"o%s\">o%s</a><br> | |
| - Life expectancies by age and initial health status: <a href=\"e%s\">e%s</a> <br> | |
| - Variances of life expectancies by age and initial health status: <a href=\"v%s\">v%s</a><br> | |
| - Health expectancies with their variances: <a href=\"t%s\">t%s</a> <br> | |
| - Standard deviation of stationary prevalences: <a href=\"vpl%s\">vpl%s</a> <br><br>",fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres,fileres); | |
| fprintf(fichtm," <li>Graphs</li>\n<p>"); | |
| m=cptcoveff; | |
| if (cptcovn < 1) {m=1;ncodemax[1]=1;} | |
| j1=0; | |
| for(k1=1; k1<=m;k1++){ | |
| for(i1=1; i1<=ncodemax[k1];i1++){ | |
| j1++; | |
| if (cptcovn > 0) { | |
| fprintf(fichtm,"<hr>************ Results for covariates"); | |
| for (cpt=1; cpt<=cptcoveff;cpt++) | |
| fprintf(fichtm," V%d=%d ",Tvaraff[cpt],nbcode[Tvaraff[cpt]][codtab[j1][cpt]]); | |
| fprintf(fichtm," ************\n<hr>"); | |
| } | |
| fprintf(fichtm,"<br>- Probabilities: pe%s%d.gif<br> | |
| <img src=\"pe%s%d.gif\">",strtok(optionfile, "."),j1,strtok(optionfile, "."),j1); | |
| for(cpt=1; cpt<nlstate;cpt++){ | |
| fprintf(fichtm,"<br>- Prevalence of disability : p%s%d%d.gif<br> | |
| <img src=\"p%s%d%d.gif\">",strtok(optionfile, "."),cpt,j1,strtok(optionfile, "."),cpt,j1); | |
| } | |
| for(cpt=1; cpt<=nlstate;cpt++) { | |
| fprintf(fichtm,"<br>- Observed and stationary prevalence (with confident | |
| interval) in state (%d): v%s%d%d.gif <br> | |
| <img src=\"v%s%d%d.gif\">",cpt,strtok(optionfile, "."),cpt,j1,strtok(optionfile, "."),cpt,j1); | |
| } | |
| for(cpt=1; cpt<=nlstate;cpt++) { | |
| fprintf(fichtm,"\n<br>- Health life expectancies by age and initial health state (%d): exp%s%d%d.gif <br> | |
| <img src=\"exp%s%d%d.gif\">",cpt,strtok(optionfile, "."),cpt,j1,strtok(optionfile, "."),cpt,j1); | |
| } | |
| fprintf(fichtm,"\n<br>- Total life expectancy by age and | |
| health expectancies in states (1) and (2): e%s%d.gif<br> | |
| <img src=\"e%s%d.gif\">",strtok(optionfile, "."),j1,strtok(optionfile, "."),j1); | |
| fprintf(fichtm,"\n</body>"); | |
| } | |
| } | |
| fclose(fichtm); | |
| /*--------------- Prevalence limit --------------*/ | |
| strcpy(filerespl,"pl"); | |
| strcat(filerespl,fileres); | |
| if((ficrespl=fopen(filerespl,"w"))==NULL) { | |
| printf("Problem with Prev limit resultfile: %s\n", filerespl);goto end; | |
| } | |
| printf("Computing prevalence limit: result on file '%s' \n", filerespl); | |
| fprintf(ficrespl,"#Prevalence limit\n"); | |
| fprintf(ficrespl,"#Age "); | |
| for(i=1; i<=nlstate;i++) fprintf(ficrespl,"%d-%d ",i,i); | |
| fprintf(ficrespl,"\n"); | |
| prlim=matrix(1,nlstate,1,nlstate); | |
| 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 */ | |
| k=0; | |
| agebase=agemin; | |
| agelim=agemax; | |
| ftolpl=1.e-10; | |
| i1=cptcoveff; | |
| if (cptcovn < 1){i1=1;} | |
| for(cptcov=1;cptcov<=i1;cptcov++){ | |
| for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){ | |
| k=k+1; | |
| /*printf("cptcov=%d cptcod=%d codtab=%d nbcode=%d\n",cptcov, cptcod,Tcode[cptcode],codtab[cptcod][cptcov]);*/ | |
| fprintf(ficrespl,"\n#******"); | |
| for(j=1;j<=cptcoveff;j++) | |
| fprintf(ficrespl," V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); | |
| fprintf(ficrespl,"******\n"); | |
| for (age=agebase; age<=agelim; age++){ | |
| prevalim(prlim, nlstate, p, age, oldm, savm,ftolpl,k); | |
| fprintf(ficrespl,"%.0f",age ); | |
| for(i=1; i<=nlstate;i++) | |
| fprintf(ficrespl," %.5f", prlim[i][i]); | |
| fprintf(ficrespl,"\n"); | |
| } | |
| } | |
| } | |
| fclose(ficrespl); | |
| /*------------- h Pij x at various ages ------------*/ | |
| strcpy(filerespij,"pij"); strcat(filerespij,fileres); | |
| if((ficrespij=fopen(filerespij,"w"))==NULL) { | |
| printf("Problem with Pij resultfile: %s\n", filerespij);goto end; | |
| } | |
| printf("Computing pij: result on file '%s' \n", filerespij); | |
| stepsize=(int) (stepm+YEARM-1)/YEARM; | |
| if (stepm<=24) stepsize=2; | |
| agelim=AGESUP; | |
| hstepm=stepsize*YEARM; /* Every year of age */ | |
| hstepm=hstepm/stepm; /* Typically 2 years, = 2/6 months = 4 */ | |
| k=0; | |
| for(cptcov=1;cptcov<=i1;cptcov++){ | |
| for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){ | |
| k=k+1; | |
| fprintf(ficrespij,"\n#****** "); | |
| for(j=1;j<=cptcoveff;j++) | |
| fprintf(ficrespij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); | |
| fprintf(ficrespij,"******\n"); | |
| for (agedeb=fage; agedeb>=bage; agedeb--){ /* If stepm=6 months */ | |
| nhstepm=(int) rint((agelim-agedeb)*YEARM/stepm); /* Typically 20 years = 20*12/6=40 */ | |
| nhstepm = nhstepm/hstepm; /* Typically 40/4=10 */ | |
| p3mat=ma3x(1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | |
| oldm=oldms;savm=savms; | |
| hpxij(p3mat,nhstepm,agedeb,hstepm,p,nlstate,stepm,oldm,savm, k); | |
| fprintf(ficrespij,"# Age"); | |
| for(i=1; i<=nlstate;i++) | |
| for(j=1; j<=nlstate+ndeath;j++) | |
| fprintf(ficrespij," %1d-%1d",i,j); | |
| fprintf(ficrespij,"\n"); | |
| for (h=0; h<=nhstepm; h++){ | |
| fprintf(ficrespij,"%d %.0f %.0f",k,agedeb, agedeb+ h*hstepm/YEARM*stepm ); | |
| for(i=1; i<=nlstate;i++) | |
| for(j=1; j<=nlstate+ndeath;j++) | |
| fprintf(ficrespij," %.5f", p3mat[i][j][h]); | |
| fprintf(ficrespij,"\n"); | |
| } | |
| free_ma3x(p3mat,1,nlstate+ndeath,1, nlstate+ndeath, 0,nhstepm); | |
| fprintf(ficrespij,"\n"); | |
| } | |
| } | |
| } | |
| fclose(ficrespij); | |
| /*---------- Health expectancies and variances ------------*/ | |
| strcpy(filerest,"t"); | |
| strcat(filerest,fileres); | |
| if((ficrest=fopen(filerest,"w"))==NULL) { | |
| printf("Problem with total LE resultfile: %s\n", filerest);goto end; | |
| } | |
| printf("Computing Total LEs with variances: file '%s' \n", filerest); | |
| strcpy(filerese,"e"); | |
| strcat(filerese,fileres); | |
| if((ficreseij=fopen(filerese,"w"))==NULL) { | |
| printf("Problem with Health Exp. resultfile: %s\n", filerese); exit(0); | |
| } | |
| printf("Computing Health Expectancies: result on file '%s' \n", filerese); | |
| strcpy(fileresv,"v"); | |
| strcat(fileresv,fileres); | |
| if((ficresvij=fopen(fileresv,"w"))==NULL) { | |
| printf("Problem with variance resultfile: %s\n", fileresv);exit(0); | |
| } | |
| printf("Computing Variance-covariance of DFLEs: file '%s' \n", fileresv); | |
| k=0; | |
| for(cptcov=1;cptcov<=i1;cptcov++){ | |
| for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){ | |
| k=k+1; | |
| fprintf(ficrest,"\n#****** "); | |
| for(j=1;j<=cptcoveff;j++) | |
| fprintf(ficrest,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); | |
| fprintf(ficrest,"******\n"); | |
| fprintf(ficreseij,"\n#****** "); | |
| for(j=1;j<=cptcoveff;j++) | |
| fprintf(ficreseij,"V%d=%d ",j,nbcode[j][codtab[k][j]]); | |
| fprintf(ficreseij,"******\n"); | |
| fprintf(ficresvij,"\n#****** "); | |
| for(j=1;j<=cptcoveff;j++) | |
| fprintf(ficresvij,"V%d=%d ",j,nbcode[j][codtab[k][j]]); | |
| fprintf(ficresvij,"******\n"); | |
| eij=ma3x(1,nlstate,1,nlstate,(int) bage, (int) fage); | |
| oldm=oldms;savm=savms; | |
| evsij(fileres, eij, p, nlstate, stepm, (int) bage, (int)fage, oldm, savm, k); | |
| vareij=ma3x(1,nlstate,1,nlstate,(int) bage, (int) fage); | |
| oldm=oldms;savm=savms; | |
| varevsij(fileres, vareij, matcov, p, delti, nlstate, stepm, (int) bage, (int) fage, oldm, savm, prlim, ftolpl,k); | |
| fprintf(ficrest,"#Total LEs with variances: e.. (std) "); | |
| for (i=1;i<=nlstate;i++) fprintf(ficrest,"e.%d (std) ",i); | |
| fprintf(ficrest,"\n"); | |
| hf=1; | |
| if (stepm >= YEARM) hf=stepm/YEARM; | |
| epj=vector(1,nlstate+1); | |
| for(age=bage; age <=fage ;age++){ | |
| prevalim(prlim, nlstate, p, age, oldm, savm,ftolpl,k); | |
| fprintf(ficrest," %.0f",age); | |
| for(j=1, epj[nlstate+1]=0.;j <=nlstate;j++){ | |
| for(i=1, epj[j]=0.;i <=nlstate;i++) { | |
| epj[j] += prlim[i][i]*hf*eij[i][j][(int)age]; | |
| } | |
| epj[nlstate+1] +=epj[j]; | |
| } | |
| for(i=1, vepp=0.;i <=nlstate;i++) | |
| for(j=1;j <=nlstate;j++) | |
| vepp += vareij[i][j][(int)age]; | |
| fprintf(ficrest," %.2f (%.2f)", epj[nlstate+1],hf*sqrt(vepp)); | |
| for(j=1;j <=nlstate;j++){ | |
| fprintf(ficrest," %.2f (%.2f)", epj[j],hf*sqrt(vareij[j][j][(int)age])); | |
| } | |
| fprintf(ficrest,"\n"); | |
| } | |
| } | |
| } | |
| fclose(ficreseij); | |
| fclose(ficresvij); | |
| fclose(ficrest); | |
| fclose(ficpar); | |
| free_vector(epj,1,nlstate+1); | |
| /* scanf("%d ",i); */ | |
| /*------- Variance limit prevalence------*/ | |
| strcpy(fileresvpl,"vpl"); | |
| strcat(fileresvpl,fileres); | |
| if((ficresvpl=fopen(fileresvpl,"w"))==NULL) { | |
| printf("Problem with variance prev lim resultfile: %s\n", fileresvpl); | |
| exit(0); | |
| } | |
| printf("Computing Variance-covariance of Prevalence limit: file '%s' \n", fileresvpl); | |
| k=0; | |
| for(cptcov=1;cptcov<=i1;cptcov++){ | |
| for(cptcod=1;cptcod<=ncodemax[cptcov];cptcod++){ | |
| k=k+1; | |
| fprintf(ficresvpl,"\n#****** "); | |
| for(j=1;j<=cptcoveff;j++) | |
| fprintf(ficresvpl,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtab[k][j]]); | |
| fprintf(ficresvpl,"******\n"); | |
| varpl=matrix(1,nlstate,(int) bage, (int) fage); | |
| oldm=oldms;savm=savms; | |
| varprevlim(fileres, varpl, matcov, p, delti, nlstate, stepm, (int) bage, (int) fage, oldm, savm, prlim, ftolpl,k); | |
| } | |
| } | |
| fclose(ficresvpl); | |
| /*---------- End : free ----------------*/ | |
| free_matrix(varpl,1,nlstate,(int) bage, (int)fage); | |
| free_ma3x(vareij,1,nlstate,1,nlstate,(int) bage, (int)fage); | |
| free_ma3x(eij,1,nlstate,1,nlstate,(int) bage, (int)fage); | |
| free_matrix(pmmij,1,nlstate+ndeath,1,nlstate+ndeath); | |
| free_matrix(oldms, 1,nlstate+ndeath,1,nlstate+ndeath); | |
| free_matrix(newms, 1,nlstate+ndeath,1,nlstate+ndeath); | |
| free_matrix(savms, 1,nlstate+ndeath,1,nlstate+ndeath); | |
| free_matrix(matcov,1,npar,1,npar); | |
| free_vector(delti,1,npar); | |
| free_ma3x(param,1,nlstate,1, nlstate+ndeath-1,1,ncovmodel); | |
| printf("End of Imach\n"); | |
| /* gettimeofday(&end_time, (struct timezone*)0);*/ /* after time */ | |
| /* printf("Total time was %d Sec. %d uSec.\n", end_time.tv_sec -start_time.tv_sec, end_time.tv_usec -start_time.tv_usec);*/ | |
| /*printf("Total time was %d uSec.\n", total_usecs);*/ | |
| /*------ End -----------*/ | |
| end: | |
| #ifdef windows | |
| chdir(pathcd); | |
| #endif | |
| system("wgnuplot graph.plt"); | |
| #ifdef windows | |
| while (z[0] != 'q') { | |
| chdir(pathcd); | |
| printf("\nType e to edit output files, c to start again, and q for exiting: "); | |
| scanf("%s",z); | |
| if (z[0] == 'c') system("./imach"); | |
| else if (z[0] == 'e') { | |
| chdir(path); | |
| system("index.htm"); | |
| } | |
| else if (z[0] == 'q') exit(0); | |
| } | |
| #endif | |
| } | |