/* Empirical application to welfare duration model 
*******************************************************************
*******************************************************************

            Estimation of Measurement Error Models 
                   Using Marginal Information

                         Yingyao Hu                               
                    Department of Economics                    
                  The Johns Hopkins University                      
                          June 2002                             
*******************************************************************

CONTENT:

PART 1: Introduction

1	Objective
2	Model
3	Input & output
4	Definition of variables
5	Definition of subscripts in variables
6	List of functions and procedures

PART 2: The executive program code

Step 0: creating the data
Step 1: loading the data
Step 2: 
Step 3: 
Step 4: 
Appendix: functions and procedures  

*******************************************************************
*******************************************************************


**********************  PART 1: Introduction  *********************

1 Objective:

2 Model:



3 Input & output:

Input		: 
Output		: 

4 Definition of variables:

5 Definition of subscripts in variables:

6 List of functions and procedures:


***************   PART 2: The executive program code  ************* 

*/ 



/* step 0: setting */
    new; 
    library pgraph; 

    @ setting output file and output format @
    #define output_file c:\temp\dur_para_realdata.txt
    #define probit_data "c:\\temp\\simul_data.xls"
    output file = output_file reset;  
    format /mat /on /mb1 /ros 12,5;

    @ global variables @
    declare y,d,cpi,w,x,u,e,z;        @ data x: nominal benefit, cpi: log CPI@
    declare ys,ds,zs,cpis,ws,xs,kks;    @ an observation, ws is a column vector @;
    declare K;                  @ dimension of z~w @
    declare beta,theta,d_beta,d_theta,ss,tt;@ unknown paramter and its dimension, indexes @
    declare M,M_K;              @ cutoff point of the series estimator @
    declare lnL_hat, DlnL_hat, D2lnL_hat, lnL, DlnL, D2lnL; 
                                @log likelihood and its derivative @   
    declare bigK1,bigK2,bigT1,bigT2,ptTe,ptTzw,pdf_t1,pdf_t2,sequ_Tzw,tt1,tt2, eps;
    
    @ define i @
    i = complex(0,1); 
    
    @ random seed @
    seed = 352676456;
    rndseed seed;

    @ initial time @
    start_time = time;
    print "starting time:" start_time';

/* step 1: the model and data generation */

 simu_N = 1;
 simu=0;do until simu==simu_N; simu=simu+1;
 print "simulation: " simu;

  @ the model @
    K       = 9 @3 9 6@;            @ number of independent variables (z,w), no constant   @
    d_beta  = K;            @ dimension of beta, not necessarily equal to K@   

    w_scale = 24~1000~1~1~100~ones(1,6);      @ 1*(K-1) vector: scale of w, used in line 130 @
	w_scale = w_scale[.,1:(K-1)];

  @ simulation parameters @
    n1 = 520; 		@ number of observations in sample 1 @
    n2 = 3318;		@ number of observations in sample 2 @

    @ likelihood function of the latent model: fstar(y|z,w;beta)   @    
    @ function fstar(y,z,w,beta) is given in the Appendix: A3      @    

    tolerence = 1e-10; @ tolerence controls how close the denominator is to zero @    

/* step 1: the model and data import */

    "importing data ...";
  @ real data: SIPP @
    open dt1= c:\temp\SIPP;
    orgdata = readr(dt1,n1);
    dt1      = close(dt1);

    orgdata = orgdata[.,1:13]; @ 16 variables: y~d~x~w~spl_sequ @
    y       = orgdata[.,1];
    d       = orgdata[.,2];
    cpi     = orgdata[.,3];     @ CPI @
    x       = orgdata[.,4];     @ mismeasured nominal benefit, for deconvolution @
    w       = orgdata[.,5:13];

    @ select civariates @ 
    w       =   w[.,1:rows(w_scale')];
    w       = w./w_scale; @ rescale @

    T_period= maxc(y); @ maximum spell length @
/*
    qut = 3;

    transfer=                   ones(1,qut)~zeros(1,T_period-1*qut)
               |zeros(1,qut)  ~ ones(1,qut)~zeros(1,T_period-2*qut)
               |zeros(1,2*qut)~ ones(1,qut)~zeros(1,T_period-3*qut)
               |zeros(1,3*qut)~ ones(1,qut)~zeros(1,T_period-4*qut)
               |zeros(1,4*qut)~ ones(1,T_period-4*qut);

    transfer=                   ones(1,qut)~zeros(1,T_period-1*qut)
               |zeros(1,qut)  ~ ones(1,qut)~zeros(1,T_period-2*qut)
               |zeros(1,2*qut)~ ones(1,qut)~zeros(1,T_period-3*qut)
               |zeros(1,3*qut)~ ones(1,qut)~zeros(1,T_period-4*qut)
               |zeros(1,4*qut)~ ones(1,2*qut)~zeros(1,T_period-6*qut)
               |zeros(1,6*qut)~ ones(1,T_period-6*qut);
*/
    qut = 1;
    transfer=                   ones(1,qut)~zeros(1,T_period-1*qut)
               |zeros(1,qut)  ~ ones(1,qut)~zeros(1,T_period-2*qut)
               |zeros(1,2*qut)~ ones(1,qut)~zeros(1,T_period-3*qut)
               |zeros(1,3*qut)~ ones(1,qut)~zeros(1,T_period-4*qut)
               |zeros(1,4*qut)~ ones(1,qut)~zeros(1,T_period-5*qut)
               |zeros(1,5*qut)~ ones(1,qut)~zeros(1,T_period-6*qut)
               |zeros(1,6*qut)~ ones(1,qut)~zeros(1,T_period-7*qut)
               |zeros(1,7*qut)~ ones(1,qut)~zeros(1,T_period-8*qut)
               |zeros(1,8*qut)~ ones(1,qut)~zeros(1,T_period-9*qut)
               |zeros(1,9*qut)~ ones(1,qut)~zeros(1,T_period-10*qut)
               |zeros(1,10*qut)~ ones(1,qut)~zeros(1,T_period-11*qut)
               |zeros(1,11*qut)~ ones(1,qut)~zeros(1,T_period-12*qut)
               |zeros(1,12*qut)~ ones(1,2*qut)~zeros(1,T_period-14*qut)
               |zeros(1,14*qut)~ ones(1,2*qut)~zeros(1,T_period-16*qut)
               |zeros(1,16*qut)~ ones(1,2*qut)~zeros(1,T_period-18*qut)
               |zeros(1,18*qut)~ ones(1,2*qut)~zeros(1,T_period-20*qut)
               |zeros(1,20*qut)~ ones(1,T_period-20*qut);    
    
    d_lambda= 17@ 16 6 5@;
    d_theta = d_beta + d_lambda;    

    @ first period data for deconvolution @

  @ real data: AFDC QC @
    open dt2= c:\temp\QC;
    z        = readr(dt2,n2);  @ nominal benefit @
    dt2      = close(dt2);

  @ g(ln e) g(ln x) g(ln z) estimated by deconvolution and direct Hermite@   

    x   = ln(x);
    z   = ln(z);    
    cpi = ln(cpi); 


    fn demean(ix) = ix  - (meanc(ix)')  ;
    x       = demean( x );
    z       = demean( z );
    cpi     = demean( cpi );    
    w       = demean( w );

    zmax    = maxc(z);
    zmin    = minc(z);    
        
  @ estimation parameters @
  
    bigT1 = 0.7 @ 0.8 0.85@ @0.6 0.7@;    @ cutoff of the integral of the coefficients: coeff_e of g(e) @
    bigT2 = 0.875~(0.9.* ones(1,K-1)) @0.875~0.6 0.9~0.9 0.9~1 0.6~1 1~1@;    @ 1*K vector: cutoff of the integral of the coefficients: coeff_zw of g(z,w) @
    priorun = 1;    @ 0: a new test ; 1: has been run before @    
    
	@ simulation points for integration in g(z,w) @
    ptTzw        = 500; @100 1000 4000@
    tt2          = (rndu(ptTzw,K)-0.5)./0.5;
    tt2          = bigT2.*tt2;        
    pdf_t2       = 1/prodc(2.*bigT2');

/* graph of g(e) */  
    pt = 100;              @number of testing points of x or z@
    tx = seqa(-1.5,4/pt,pt) @  seqa(-0.5,1.5/pt,pt) testing point @ ; 	

    @ display the density @
    ytics(-0.2,1.4,0.4,0);
    xtics(minc(tx),maxc(tx),0.5,0);
    title("ln(x)=ln(z)+ln(e)");
    tge = g_e_hat(tx @- (meanc(x) - meanc(z)) @);

	tge = tge@.*(tge.>0)@;

    xy(tx,tge);
stop;

/* step 2: deconvolution of the density g(z|x,w) */

	"estimating g(z|x,w)...";
/* Gauss Quardratures in integration w.r.t. z in likelihood function L */

declare matrix _intq12[6,2] = 0.125233408511469 0.249147045813403
                               0.367831498998180 0.233492536538355
                               0.587317954286617 0.203167426723066
                               0.769902674194305 0.160078328543346
                               0.904117256370475 0.106939325995318
                               0.981560634246719 0.047175336386512;
declare _xq _wq g_zxw;

    _e = _intq12[.,1];
    _w = _intq12[.,2];
    _e = (-rev(_e)|_e);
    _w = rev(_w)|_w;


    diff = zmax - zmin;
    _xq = 0.5*( (zmax + zmin)+(diff .* _e));
    _wq = (diff/2).*_w;

    
    /*   
    @ export simulation data @
    fname   =probit_data;
    let names   = y z_latent w u;
    call export(y~z_latent~w~u,fname,names);
    */   
 
    @corrx(z_latent~e);@

  if priorun == 0; @ have been run before ? @    

    _g_ezx = zeros(n1,rows(_xq));
    jz=0;do until jz==rows(_xq); jz=jz+1;
        _g_ezx[.,jz]     = g_e_hat((x-_xq[jz,.]));
    endo;   

    _g_zw = zeros(n1,rows(_xq));
    jz=0;do until jz==rows(_xq); jz=jz+1;

	"quadrature" jz;

        jw=0;do until jw==n1; jw=jw+1;
        _g_zw[jw,jz] = g_zw_hat(_xq[jz,.],(w[jw,.]'));
        endo;   
    endo;	

	_g_ezx = _g_ezx.*(_g_ezx.>0);
	_g_zw  = _g_zw .*(_g_zw.>0);



    g_zxw = real( _g_ezx) .* real(_g_zw);
/*    clear _g_ezx _g_zw;
	
	
	sumc(sumc((g_zxw.<0)));

	@ lower bound for a density @
	density_l=1E-6;
	dd_l = (g_zxw.<density_l);
	sumc(sumc(dd_l));
	g_zxw = g_zxw.*(1-dd_l) + density_l.*dd_l;

    clear dd_l;
	*/	

    save path = "c://temp//" g_zxw;
  else;
    load path = "c://temp//" g_zxw; 
  endif;
   
	print "found g(z|x,w)";



 
/* step 3: evaluation of the likelihood function */

	/*

    print "evaluating likelihood function and its derivative at theta0 ...";

    beta0   = rndn(d_beta,1);
    lambda0 = ones(d_lambda,1);  
    theta0  = beta0|lambda0;

    lnL_hat             = lnL_hat_   (theta0);
    {DlnL_hat,D2lnL_hat}= D12lnL_hat_(theta0);
    lnL                 = lnL_       (theta0);
    {DlnL,D2lnL}        = D12lnL_    (theta0);     

    print "beta0  "     beta0';
    print "lnL_hat(theta0)  "     lnL_hat;
    print "lnL(theta0)      "     lnL; 

    print "DlnL_hat(theta0)/n1 "   (DlnL_hat)'./n1; 
    print "DlnL(theta0)/n1     "   (DlnL)'./n1; 

    print "det(D2lnL_hat) "   det(D2lnL_hat); 
    print "det(D2lnL)     "   det(D2lnL); 

	*/

    Newton_tol = 1E-4;      @ 1E-3 tolerence of Newton's method @
    


/* step 4.4: MLE4: fstar(y|x,w) */

    print "searching for MLE with fstar(y|x,w)"; 

    @ pick a random initial point @
    picking:
    beta_ini    = (-1|1|1|-1|-1|1|1|1|-1).*0.5 @  rndn(d_beta,1)@;
    lambda_ini  = 0.03*ones(d_lambda,1)@  0.07*rndu(d_lambda,1)@; 
      
    theta_hat = beta_ini|lambda_ini;

    @ loop of searching MLE @
    lnL_opt = -1e10;
    j = 0;	         		@ "j" is iteration times of searching MLE @
    A = 0; do until A > 1;	@ "A" is indicator of end of search @
  	    
   	lnL     = 0;
    DlnL    = zeros(d_theta,1); 
    D2lnL   = zeros(d_theta,d_theta);

    lnL = lnL_(theta_hat);    
    print " Iteration" j ":"  theta_hat[1:d_beta,.]' " lnL^: " lnL;

    @ calculating 1st and 2nd derivative of log likelihood function at theta_hat@
    {DlnL,D2lnL}    = D12lnL_(theta_hat);

        if (ismiss(DlnL)==1) @ or (abs(det(D2lnL))<=1E-6)@; goto picking; endif;

/*        
        @ mthod 2 @
        if  lnL>lnL_opt; 
            @ find the optimal value @
            theta_opt   = theta_hat;
            var_opt     = -inv(D2lnL);
            lnL_opt = lnL ;
    	endif;

        @ update estimate for next round @
        theta_hat = theta_hat-inv(D2lnL)*DlnL; 
        
        j = j+1; 
        if j>30; A=2; endif;             
*/


        @ update estimate for next round @
        step = -inv(D2lnL)*DlnL;
        theta_hat = theta_hat + step;        
        if  maxc( abs(step) ) < Newton_tol ; @ whether score is close enough to 0 @
            @ find the optimal value @
            {DlnL,D2lnL}= D12lnL_(theta_hat);
            theta_opt   = theta_hat;
            var_opt     = -inv(D2lnL);
            A = 2; @ end of search @
    	else;
            j = j+1;              
        endif;

    endo;

    theta_opt4 = theta_opt;
    theta_sd4  = sqrt(diag(var_opt));

    beta_opt4  = theta_opt4[1:d_beta,.];
    beta_sd4   =  theta_sd4[1:d_beta,.];

    lambda_opt4  = theta_opt4[(d_beta+1):d_theta,.];
    lambda_sd4   =  theta_sd4[(d_beta+1):d_theta,.];


/* step 4.1: MLE1 : f_hat(y|x,w) */
    
    print "searching for MLE with f_hat(y|x,w)"; 

    @ take the initial value of theta_hat @   
    theta_hat =  @beta_ini|lambda_ini @theta_opt4  .* (1|ones(rows(theta_opt4)-1,1) ); 

    
    @ loop of searching MLE @
    lnL_hat_opt = -1e10;
    j = 0;	         		@ "j" is iteration times of searching MLE @
    A = 0; do until A > 1;	@ "A" is indicator of end of search @

        lnL_hat = lnL_hat_(theta_hat);    
   	    print " Iteration" j ":" theta_hat[1:d_beta,.]' " lnL^: " lnL_hat;

        @ calculating 1st and 2nd derivative of log likelihood function at theta_hat@
        {DlnL_hat,D2lnL_hat}    = D12lnL_hat_(theta_hat);

        @ if (ismiss(DlnL_hat)==1) or (abs(det(D2lnL_hat))<=1E-6); goto picking; endif;@

        @method 1@ 
        @ update estimate for next round @
        step = -inv(D2lnL_hat)*DlnL_hat;
        theta_hat = theta_hat + step;        
        if  maxc( abs(step) ) < Newton_tol ; @ whether score is close enough to 0 @
            @ find the optimal value @
            {DlnL_hat,D2lnL_hat}    = D12lnL_hat_(theta_hat);
            theta_opt   = theta_hat;
            var_opt     = -inv(D2lnL_hat);
            A = 2; @ end of search @
    	else;
            j = j+1;              
        endif;
        
/*
        if  lnL_hat>lnL_hat_opt; 
            @ find the optimal value @
            theta_opt   = theta_hat;
            var_opt     = -inv(D2lnL_hat);
            lnL_hat_opt = lnL_hat ;
    	endif;

        @ update estimate for next round @
        theta_hat = theta_hat-inv(D2lnL_hat)*DlnL_hat; 
        j = j+1; 
        if j>30; A=2; endif;             
              


        if   maxc(abs(DlnL_hat)./n1) < Newton_tol ; @ whether score is close enough to 0 @
            @ find the optimal value @
            theta_opt   = theta_hat;
            var_opt     = -inv(D2lnL_hat);
            A = 2; @ end of search @
    	else;
            @ update estimate for next round @
            theta_hat = theta_hat-inv(D2lnL_hat)*DlnL_hat; 
            j = j+1;              
        endif;
*/    
    	
    endo;

	"found optimal theta for lnL_hat";

    /*  correction terms in asymptotic variance */

	"computing asymptotic variance...";

	itheta = theta_opt;
	cumpT2 = cumprodc(2*bigT2');  cumpT2=cumpT2[rows(bigT2'),1];

	tol_f = 1e-5@0.01@; @tolerence of f_hat in denominator @

@ calculating elements @

		n_ii = 100;

		ts = 2*(rndu(n_ii,1)-0.5)*bigT1;	
		uv = bigT2.* ( 2*(rndu(n_ii,rows(bigT2'))-0.5)  );	
		us = uv[.,1];
		vs = uv[.,2:rows(bigT2')];

		echfz_t  = zeros(1,n_ii);
		echfz_u  = zeros(1,n_ii);
		echfx_t  = zeros(1,n_ii);
		echfx_u  = zeros(1,n_ii);
		echfxw   = zeros(1,n_ii);

		Lii=0;do until Lii==n_ii; Lii=Lii+1; 
			echfz_t[1,Lii] = meanc(exp(i*2*pi*ts[Lii,.].*z))';
			echfz_u[1,Lii] = meanc(exp(i*2*pi*us[Lii,.].*z))';
			echfx_t[1,Lii] = meanc(exp(i*2*pi*ts[Lii,.].*x))';
			echfx_u[1,Lii] = meanc(exp(i*2*pi*us[Lii,.].*x))';
			echfxw[1,Lii]  = meanc(exp(  i*2*pi*(  us[Lii,.].*x+w*(vs[Lii,.]')  )))';
 	    endo;

		_f_hat  = zeros(n1,1);
		_Df_hat = zeros(n1,rows(theta_opt));
		_fstar = zeros(n1,n_ii);
		_g_zw  = zeros(n1,n_ii);
		_g_e   = zeros(n1,n_ii);

		zss = rndu(n_ii,1)*(zmax-zmin)+zmin; 

		
		fst = zeros(n1,rows(_xq));
	   	Ljj=0;do until Ljj==n1; Ljj=Ljj+1;
"_f_hat" Ljj;
        	ys = y[Ljj,.]; ds = d[Ljj,.]; cpis = cpi[Ljj,.]; ws = w[Ljj,.]'; 
        	fst[Ljj,.]    = fstar(ys,ds,_xq-cpis,ws,itheta)';
    	endo;
    	_f_hat = (fst.*g_zxw)*_wq;

		
		Dfst = zeros(n1,rows(_xq));
	    ss=0;do until ss==d_theta; ss=ss+1;
"_Df_hat" ss;
	   	Ljj=0;do until Ljj==n1; Ljj=Ljj+1;
        	ys = y[Ljj,.]; ds = d[Ljj,.]; cpis = cpi[Ljj,.]; ws = w[Ljj,.]'; 
        	Dfst[Ljj,.]    = Dfstar(ss,ys,ds,_xq-cpis,ws,itheta)';
	   	endo;
		_Df_hat[.,ss] = (Dfst.*g_zxw)*_wq;
		endo;


	    Lkk=0;do until Lkk==n1; Lkk=Lkk+1; 
"_g( )" Lkk;
	        yss = y[Lkk,.]; dss = d[Lkk,.]; cpiss = cpi[Lkk,.]; xss = x[Lkk,.]; wss = w[Lkk,.]';    
			Lii=0;do until Lii==n_ii; Lii=Lii+1; 
				_fstar[Lkk,Lii] = fstar(yss,dss,zss[Lii,.]-cpiss,wss,itheta);
				_g_zw[Lkk,Lii] = g_zw_hat(zss[Lii,.],wss);
				_g_e[Lkk,Lii]  = g_e_hat(xss-zss[Lii,.]);
	 	    endo;
		endo;
		
		d_f = _f_hat.>tol_f;


@ delta_1 : correction terms from sample 1 @
	delta_1 = zeros(rows(itheta),rows(itheta));	
    Ljj=0;do until Ljj==n1; Ljj=Ljj+1; 
	x_tilt = x[Ljj,.];
	w_tilt = w[Ljj,.]';
"delta_1" Ljj;
	_delta = zeros(rows(theta_opt),1);
    Lgg=0;do until Lgg==rows(theta_opt); Lgg=Lgg+1; 

	buff_x1 = _fstar .* _Df_hat[.,Lgg] .* (_f_hat.^-2) .* _g_zw
			.* exp(-i*2*pi.*(ts').*(x-(zss')-x_tilt))./echfz_t;
	buff_x1	= meanc(buff_x1')./(zmax-zmin)./(2*bigT1) ;
		
	buff_x2 = _fstar .* _Df_hat[.,Lgg] .* (_f_hat.^-2)	.* _g_e
			.* (-exp(-i*2*pi.*( (us').*((zss')-x_tilt)+w*(vs') )).*echfxw.*echfz_u.*(echfx_u^-2) );
	buff_x2	= meanc(buff_x2')./ (zmax-zmin)./ (cumpT2) ;

	buff_xw = _fstar .* _Df_hat[.,Lgg] .* (_f_hat.^-2)	.* _g_e
			.* ( exp(-i*2*pi.*( (us').*((zss')-x_tilt)+(w-(w_tilt'))*(vs') )).*echfz_u.*(echfx_u^-1) );
	buff_xw	= meanc(buff_xw')./ (zmax-zmin)./ (cumpT2);

	buff_x1 = real(buff_x1 + buff_x2 + buff_xw);
	_delta[Lgg,.] = meanc( selif(buff_x1,d_f) );
    endo;

	delta_1 = delta_1 + real(_delta*_delta'); @not divided by n1 @	
    endo;

	delta_1 = var_opt * delta_1 * var_opt;

@ delta_2 : correction terms from sample 2 @
	delta_2 = zeros(rows(itheta),rows(itheta));	
    Ljj=0;do until Ljj==n2; Ljj=Ljj+1; 
	z_tilt = z[Ljj,.];
"delta_2" Ljj;
	_delta = zeros(rows(theta_opt),1);
    Lgg=0;do until Lgg==rows(theta_opt); Lgg=Lgg+1; 

	buff_z1 = _fstar .* _Df_hat[.,Lgg] .* (_f_hat.^-2)	.* _g_zw
			.* (-exp(-i*2*pi.*(ts').*(x-(zss')-z_tilt)).*echfx_t.*(echfz_t^-2) );
	buff_z1	= meanc(buff_z1')./ (zmax-zmin)./ (2*bigT1) ;

	buff_z2 = _fstar .* _Df_hat[.,Lgg] .*(_f_hat.^-2)	.* _g_e
			.* ( exp(-i*2*pi.*( (us').*( (zss')-z_tilt)+w*(vs') )).*echfxw.*(echfx_u^-1) );
	buff_z2	= meanc(buff_z2')./ (zmax-zmin)./ (cumpT2) ;

	buff_z1 = real(buff_z1 + buff_z2);
	_delta[Lgg,.] = meanc( selif(buff_z1,d_f) );
    endo;

	delta_2 = delta_2 + real(_delta*_delta'); @not divided by n2 @	
    endo;

	delta_2 = var_opt * delta_2 * var_opt;

	"var_opt:" var_opt;
	"delta_1:" delta_1;
	"delta_2:" delta_2;

	var_opt = var_opt + delta_1 + (n1/n2)*delta_2;


/*  end of correction terms in asymptotic variance */
    
    
    theta_opt1 = theta_opt;
    theta_sd1  = sqrt(diag(var_opt));

    beta_opt1  = theta_opt1[1:d_beta,.];
    beta_sd1   =  theta_sd1[1:d_beta,.];

    lambda_opt1  = theta_opt1[(d_beta+1):d_theta,.];
    lambda_sd1   =  theta_sd1[(d_beta+1):d_theta,.];

/* step **: display the paramters and results */

    print " ******* parameters *******";  
    print "  Date:" datestring(0);      
    print "1 simulation parameters :"; 
    print "  sample 1: n1=" n1; 
    print "  sample 2: n2=" n2; 	
    print "  dimension of beta   = " d_beta;
    print "  dimension of lambda = " d_lambda;
    print "  cutoff point of coefficient integral: 1-dim case" bigT1;
    print "  cutoff point of coefficient integral: K-dim case" bigT2;
    print "  tolerence ="  tolerence;

    print "3 estimation results ";

    print "  MLE1 : f_hat(y|x,w):";       
    print "   beta     " theta_opt1';
    print "   beta s.d."  theta_sd1'; 

    print "  MLE4 : fstar(y|x,w):";
    print "   beta     " theta_opt4';
    print "   beta s.d."  theta_sd4'; 


endo; @ simulation @
    
    Elp_time = time-start_time; 
    print "4 Elapsed time : " Elp_time[1,1] " hr " Elp_time[2,1] " min " Elp_time[3,1] " sec";

    @ end of the program @ 
    output off;
    end;


/****************************************************************************/
/**************** Appendix : procedures and functions ***********************/
/****************************************************************************/
/* A0 procedures of estimated log likelihood function and its derivatives   */
/*         lnL_hat_(), D12lnL_hat_(), lnL_(), D12lnL_()                     */
/* A1 procedures of estimated likelihood function and its derivatives       */
/*         f_hat(), Df_hat(), D2f_hat()                                     */
/* A2 procedures of estimated nuisance density                              */ 
/*         g_e_hat(), g_zw_hat(), g_hat()                                   */
/* A3 procedures of given likelihood function and its derivatives           */
/*         fstar(), Dfstar(), D2fstar()                                     */
/* A4 procedures of ture densities and likelihood function and derivatives  */
/*         g_e(), g_zw(), f(), Df(), D2f()                                  */
/* A5 procedures of Hremite related functions and other functions           */
/*         kesi(), kesiV(), kkk(), hermite()                                */
/****************************************************************************/


/* A0 procedures of estimated log likelihood function and its derivatives   */
/* procedures   : lnL_hat_(), D12lnL_hat_(), lnL_(), D12lnL_()              */
/* lnL_hat_()   : observed likelihood function, i.e. f_hat(y,x,w,theta)     */
/* D12lnL_hat_(): score vector and information matrix                       */

/* estimated log likelihood */
    proc(1) = lnL_hat_(itheta);
    local Ljj,buff,fstar_j;
    buff = 0;

    fstar_j = zeros(n1,rows(_xq));	
    Ljj=0;do until Ljj==n1; Ljj=Ljj+1;
        ys = y[Ljj,.]; ds = d[Ljj,.]; cpis = cpi[Ljj,.]; ws = w[Ljj,.]'; 
        fstar_j[Ljj,.]    = fstar(ys,ds,_xq-cpis,ws,itheta)';
    endo;
    buff = (fstar_j.*g_zxw)*_wq;
    buff = sumc(real(ln(buff)));

    retp(buff); 
    endp;    
    
/* derivatives of estimated log likelihood */
    proc(2) = D12lnL_hat_(itheta);
    local Ljj,buff1,buff2,score,fstar_j,Dfstar_j,Dfstar_ss,Dfstar_tt,D2fstar_j,scorej;
    
    @ initialize the variables @
    buff1   =zeros(d_theta,1); 
    buff2   =zeros(d_theta,d_theta);

	fstar_j = zeros(n1,rows(_xq));	
	Ljj=0;do until Ljj==n1; Ljj=Ljj+1;
        ys = y[Ljj,.]; ds = d[Ljj,.]; cpis = cpi[Ljj,.]; ws = w[Ljj,.]'; 
        fstar_j[Ljj,.]    = fstar(ys,ds,_xq-cpis,ws,itheta)';
	endo;
	fstar_j = (fstar_j.*g_zxw)*(_wq);

    Dfstar_ss = zeros(n1,d_theta);
    ss=0;do until ss==d_theta; ss=ss+1;

  	Dfstar_j = zeros(n1,rows(_xq));	
	Ljj=0;do until Ljj==n1; Ljj=Ljj+1;
        ys = y[Ljj,.]; ds = d[Ljj,.]; cpis = cpi[Ljj,.]; ws = w[Ljj,.]'; 
        Dfstar_j[Ljj,.] = Dfstar(ss,ys,ds,_xq-cpis,ws,itheta)';
	endo;
    Dfstar_ss[.,ss] = (Dfstar_j.*g_zxw)*(_wq);
    
    buff1[ss,.] = sumc(Dfstar_ss[.,ss]./fstar_j);

    endo;


    ss = 1;
    do until ss > d_theta;
        tt = ss;
        do until tt > d_theta;

  	D2fstar_j = zeros(n1,rows(_xq));
	Ljj=0;do until Ljj==n1; Ljj=Ljj+1;
        ys = y[Ljj,.]; ds = d[Ljj,.]; cpis = cpi[Ljj,.]; ws = w[Ljj,.]';
        D2fstar_j[Ljj,.] = D2fstar(ss,tt,ys,ds,_xq-cpis,ws,itheta)';
	endo;
    D2fstar_j = (D2fstar_j.*g_zxw)*(_wq);

        buff2[ss,tt] = sumc( (D2fstar_j.*fstar_j - Dfstar_ss[.,ss].*Dfstar_ss[.,tt])./(fstar_j.^2)  );

            if tt /= ss;
                buff2[tt,ss] =buff2[ss,tt];
            endif;
            tt = tt+1;
        endo;
        ss = ss+1;
    endo;

    retp(real(buff1),real(buff2)); 
    endp;    

/* ture log likelihood */
    proc(1) = lnL_(itheta);
    local Ljj,buff,f_hat_j,_ys,_ds,_cpis,_xs,_ws,_delta_x;
    
    buff = 0;
    Ljj=0;do until Ljj==n1; Ljj = Ljj + 1;
        _ys = y[Ljj,.]; _ds = d[Ljj,.]; _cpis = cpi[Ljj,.];_xs = x[Ljj,.]; _ws = w[Ljj,.]';  
        f_hat_j = fstar(_ys,_ds,_xs-_cpis,_ws,itheta);
if abs(f_hat_j)>0; 
        buff = buff + real( ln(f_hat_j) ); @ same as take abs(f_hat_j) @
endif;
    endo;
    retp(buff);     
    
    endp;    
    
/* derivatives of true log likelihood */

    proc(2) = D12lnL_(itheta);
    local Ljj,buff1,buff2,f_hat_j,Df_hat_j,D2f_hat_j,scorej,_ys,_ds,_cpis,_xs,_ws,_delta_x;
    
    @ initialize the variables @
    buff1   =zeros(d_theta,1); 
    buff2   =zeros(d_theta,d_theta);
  
    Ljj=0;do until Ljj==n1; Ljj = Ljj+1;
        _ys = y[Ljj,.]; _ds = d[Ljj,.];  _cpis = cpi[Ljj,.]; _xs = x[Ljj,.]; _ws = w[Ljj,.]'; 

        f_hat_j     = fstar(_ys,_ds,_xs-_cpis,_ws,itheta);
        
        @ if ismiss(f_hat_j); _ys _ds _xs _ws itheta; endif;@
        
        Df_hat_j = zeros(d_theta,1);
        ss=0;do until ss==d_theta; ss=ss+1;
        Df_hat_j[ss,.]  = Dfstar(ss,_ys,_ds,_xs-_cpis,_ws,itheta);
        endo;
        
      @ _ys "##" f_hat_j "$$" Df_hat_j';  @    

        /*
            
        D2f_hat_j = zeros(d_theta,d_theta);    
        ss = 1;
        do until ss > d_theta;
            tt = ss;
            do until tt > d_theta;
                D2f_hat_j[ss,tt] = D2fstar(ss,tt,_ys,_ds,_xs-_cpis,_ws,itheta);
                if tt /= ss;
                    D2f_hat_j[tt,ss] =D2f_hat_j[ss,tt];
                endif;
                tt = tt+1;
            endo;
            ss = ss+1;
        endo;
    
        buff1   =buff1    + Df_hat_j./f_hat_j; 
        buff2   =buff2    + (D2f_hat_j.*f_hat_j-Df_hat_j*(Df_hat_j') )./(f_hat_j.^2);
        */    

        @ BHHH method @
        scorej  = Df_hat_j./f_hat_j;
        buff1   = buff1    + scorej; 
        buff2   = buff2    - scorej*(scorej');
     
    endo;
    
    retp(real(buff1),real(buff2)); 
    endp;    
    

/* A1 procedures of estimated likelihood function and its derivatives   */
/* procedures   : f_hat(), Df_hat(), D2f_hat()                          */
/* f_hat()      : observed likelihood function, i.e. f_hat(y,x,w,theta) */
/* Df_hat()     : score vector, i.e. Df_hat/Dtheta(y,x,w,theta)         */
/* D2f_hat()    : information matrix, i.e. D2f_hat/D2theta              */
/* intermetiate procedures: f_hat_(), Df_hat_(), D2f_hat_(),integrands*/

/* f_hat() : observed likelihood function */
    proc(1) = f_hat(iy,id,icpi,ix,iw,itheta);
    @ iy,id,ix: scalar @
    @ iw: (K-1)*1 @
    ys = iy; ds = id; cpis = icpi; xs = ix; ws = iw; theta = itheta;
    retp(intquad1(&f_hat_,zmax|zmin));
    endp;
    
    /* f_hat_() : integrand of f_hat */
    proc(1) = f_hat_(iz); 
    retp(fstar(ys,ds,iz-cpis,ws,theta).*g_e_hat(xs-iz).*g_zw_hat(iz,ws)); 
    endp;

/* Df_hat() : Df_hat/Dtheta, observed score vector */
    proc(1) = Df_hat(iy,id,icpi,ix,iw,itheta);
    local buff;
    buff = zeros(d_theta,1);
    ys = iy; ds = id;  cpis = icpi; xs = ix; ws = iw; theta = itheta;
    ss=0;do until ss==d_theta; ss=ss+1;
        buff[ss,.] = intquad1(&Df_hat_,zmax|zmin);
    endo;
    retp(buff);
    endp;
    
    /* Df_hat_() : integrand of Df_hat/Dtheta, scalar */
    proc(1) = Df_hat_(iz); 
    local buff;
    buff = Dfstar(ss,ys,ds,iz-cpis,ws,theta).*g_e_hat(xs-iz).*g_zw_hat(iz,ws);
    retp(buff);     
    endp;
    
/* D2f_hat() : D2f_hat/D2theta, observed information matrix */
    proc(1) = D2f_hat(iy,id,icpi,ix,iw,itheta); 
    local buff;
    buff = zeros(d_theta,d_theta);
    ys = iy; ds = id;  cpis = icpi; xs = ix; ws = iw; theta = itheta;
    
    ss = 1;
    do until ss > d_theta;
        tt = ss;
        do until tt > d_theta;
            buff[ss,tt] = intquad1(&D2f_hat_,zmax|zmin);
            if tt /= ss;
                buff[tt,ss] =buff[ss,tt];
            endif;
            tt = tt+1;
        endo;
        ss = ss+1;
    endo;
 
    retp(buff);
    endp;
    
    /* Df_hat_() : integrand of D2f_hat/D2theta, scalar */
    proc(1) = D2f_hat_(iz); 
    retp( D2fstar(ss,tt,ys,ds,iz-cpis,ws,theta).*g_e_hat(xs-iz).*g_zw_hat(iz,ws) );     
    endp;

/* A2 procedures of estimated nuisance density  */        
/* procedures   : g_e_hat(), g_zw_hat(),g_hat() */
/* g_e_hat()    : nuisance density, g(e)        */
/* g_zw_hat()   : nuisance density, g(z,w)      */
/* g_hat()      : 1-dim density esitmated by H-series  */  
/* additional procedures: g_hat() estimates g(e), g(x), g(z), g(w) for comparison */

/* g_e_hat() : g(e) estimated by deconvolution */
   

    proc(1) = g_e_hat(_x); 
    eps =   _x;
	_intord = 12;
    retp( real( intquad1(&g_e_,bigT1|-bigT1) ) ); 
    endp;
    
    
    proc(1) = g_e_(_tt1); 
    @ _x is the testing points @
    local Ljj,temp,h0,h1,h2,xx;
    local echfx,echfz;
    echfx       = meanc(exp(i*2*pi*_tt1.*x))' ;
    echfz       = meanc(exp(i*2*pi*_tt1.*z))' ;
    retp(exp(-2.*pi.*i.*_tt1.*eps).*echfx./echfz); 
    endp;

    
  
/* g_zw_hat() : g(z,w) estimated by deconvolution */
    @ g_zw_hat() : for display only @
    proc(1) = g_zw_hat(_z,_w); 
    @ _x is the testing points @
  
    local buff,kk,jj,c_x,c_z,c_xw,fou,c_;

    fou  = exp(-i.*2.*pi.*(tt2*(_z|_w)));

    c_x  = meanc(exp(i.*2.*pi.*(tt2[.,1]').*x));
    c_z  = meanc(exp(i.*2.*pi.*(tt2[.,1]').*z));

     
    c_xw = zeros(rows(tt2),1);
    jj=0;do until jj==rows(tt2); jj=jj+1;
        c_xw[jj,1] = meanc(exp(i.*2.*pi.*( (x~w)*(tt2[jj,.]') )));
    endo;
    
    c_ = meanc(fou.*c_xw.*c_z./c_x./pdf_t2);
    retp(real(c_)); 
    endp;    

/* g_hat() : g(xx) estimated directly by Hermite series: for comparison */
    proc(1) = g_hat(ix,coeff_H);  
    @ ix is the testing points @
    @ smpl is the sample @
    retp( real( coeff_H'*kesiV(rows(coeff_H)-1,ix) )); 
    endp;

    proc(1) = coeff_H(smpl,_k);  
    local kk,buff,constant;
    buff = zeros(_k+1,1);
    kk=-1;do until kk==_k; kk=kk+1;
    constant    = sqrt(2)/( exp(lnfact(kk)) * (2^kk) );
    buff[kk+1,1] = constant.*meanc(kesi(kk,smpl));
    endo;
    retp(buff); 
    endp;
   

/* A3 procedures of given likelihood function and its derivatives       */
/* fun and proc : fstar(), Dfstar(), D2fstar()                          */
/* fstar()      : Given likelihood function, i.e. fstar(y|z,w;theta)    */
/* Dfstar()     : score vector, i.e. Dfstar/Dtheta(y|z,w;theta)         */
/* D2fstar()    : information matrix, i.e. D2fstar/D2theta(y|z,w;theta) */
/* these functions are part of the inputs: fstar(),Dfstar() are required*/


    @ building brick @
 proc(1) = f_cens(iy,iz,iw,itheta);
    local ibeta,ilambda,indx,tran,f;

    if iy==0; f= 1;
    else;
    
    tran    = transfer[.,1:iy];
    ibeta   = itheta[1:d_beta,.];
    ilambda = itheta[(d_beta+1):d_theta,.]; 
    ilambda = (ilambda'*tran)'; 
    indx    = iz.*ibeta[1,1] + sumc(iw.*ibeta[2:d_beta,1]);
    f       = exp(-sumc(ilambda).*exp(indx));
    endif; @ iy!=0 @  
    retp( f );    
    endp;

 proc(1) = Df_cens(is,iy,iz,iw,itheta);
    local ibeta,ilambda,tran,indx,D1f;

    if iy==0; D1f= 0;
    else;
    
    tran    = transfer[.,1:iy];
    ibeta   = itheta[1:d_beta,.];
    ilambda = itheta[(d_beta+1):d_theta,.];
    ilambda = (ilambda'*tran)'; 
    indx    = iz.*ibeta[1,1] + sumc(iw.*ibeta[2:d_beta,1]);
    if is==1;
        D1f     = exp(-sumc(ilambda).*exp(indx)).*(-sumc(ilambda).*exp(indx)).*iz;
    elseif is<=d_beta;
        D1f     = exp(-sumc(ilambda).*exp(indx)).*(-sumc(ilambda).*exp(indx)).*iw[is-1,.];
    else;
        D1f     = exp(-sumc(ilambda).*exp(indx)).*(-sumc(tran[is-d_beta,.]').*exp(indx));
    endif;

    endif; @ iy!=0 @        

    retp( D1f );    
    endp;

 proc(1) = D2f_cens(is,it,iy,iz,iw,itheta);
    local ibeta,ilambda,tran,indx,indx1,D2f,temp;
    local f,Df_b,Df_l,D2f_b,D2f_lb,D2f_l;

    if iy==0; D2f= 0;
    else;

    tran    = transfer[.,1:iy];
    ibeta   = itheta[1:d_beta,.];
    ilambda = itheta[(d_beta+1):d_theta,.];
    ilambda = (ilambda'*tran)'; 
    indx    = iz.*ibeta[1,1] + sumc(iw.*ibeta[2:d_beta,1]);
    indx1   = -sumc(ilambda).*exp(indx);

    @ WLOG, is>=it @
    if is<it; temp=it; it=is; is=temp; endif;

    f     =   exp(indx1);
    Df_b  =   f.*indx1;

    D2f_b =   Df_b.*indx1 + f.*indx1;
    D2f_lb=   f.*exp(indx).*indx1 + f.*exp(indx);
    D2f_l =   f.*exp(indx).*exp(indx);

    if     it==1 and is==1;             D2f = D2f_b  .*iz.^2; 
    elseif it==1 and is<=d_beta;        D2f = D2f_b  .*iz.*iw[is-1,.];
    elseif it==1 and is<=d_theta;       D2f = D2f_lb .*iz;

    elseif it<=d_beta and is<=d_beta;   D2f = D2f_b  .*iw[it-1,.].*iw[is-1,.];
    elseif it<=d_beta and is<=d_theta;  D2f = D2f_lb .*iw[it-1,.].*(-sumc(tran[is-d_beta,.]'));

    elseif it<=d_theta and is<=d_theta; D2f = D2f_l  .*(-sumc(tran[is-d_beta,.]')).*(-sumc(tran[it-d_beta,.]'));

    else;                               D2f = 0;
    endif;

    endif; @ iy!=0 @    
    retp(D2f);
    endp;

 proc(1) = fstar(iy,id,iz,iw,itheta);
    retp(         f_cens((iy-1),iz,iw,itheta) 
         -(1-id).*f_cens( iy   ,iz,iw,itheta) 
         );
    endp;

 proc(1) = Dfstar(is,iy,id,iz,iw,itheta);
    retp(         Df_cens(is,(iy-1),iz,iw,itheta)
         -(1-id).*Df_cens(is, iy   ,iz,iw,itheta) 
         );
    endp;

 proc(1) = D2fstar(is,it,iy,id,iz,iw,itheta);
    retp(         D2f_cens(is,it,(iy-1),iz,iw,itheta)
         -(1-id).*D2f_cens(is,it, iy   ,iz,iw,itheta) 
         );
    endp;    


/* A5 procedures of Hermite related functions                               */
/* fun and proc : kesi(), kesiV(), hermite(),kkk()                          */
/* kesi(): evaluate the hermite function                                    */
/* kesiV(): evaluate the hermite function from the order 0                  */
/* hermite(): return the coefficients of hermite functions                  */
/* kkk(): return index of the hermite series                                */

/* kesi() : return a scalar */    
    proc(1) = kesi(_k,xx); 
    @ xx is the testing points, could be a vector @
    local Ljj,h,h0,h1,h2,_x;
    _x = sqrt(2*pi).*xx;
    h0 = 1.*_x.^0;    
    h1 = 2.*_x;
    if _k==0;
        h = h0;
    elseif _k==1;
        h = h1;
    else;
        Ljj=1;do until Ljj==_k; Ljj=Ljj+1;
            h2 = 2.*_x.*h1 - 2.*(Ljj-1).*h0;
            h0 = h1;
            h1 = h2;
        endo;
        h = h2;
    endif;
    retp(h.*exp(-pi.*xx.^2)); 
    endp;    

/* kesiV() : return a vector 0,1,2,...,_k */    
    proc(1) = kesiV(_k,xx); 
    @ xx is the testing points, must be a scalar @
    local Ljj,h,h0,h1,h2,_x;
    _x = sqrt(2*pi).*xx;
    h   =zeros(_k+1,1);
    h0 = 1.*(_x)^0;     
    h1 = 2.*_x; h=h0|h1;
    Ljj=2;do until Ljj==_k+1; Ljj=Ljj+1;
        h2 = 2.*_x.*h1 - 2.*(Ljj-2).*h0;
        h = h|h2;
        h0 = h1;
        h1 = h2;
    endo;
    retp(h.*exp(-pi.*xx.^2)); 
    endp;    

/* Hermite polynomials */
    proc(1) = hermite(k);
    local Ljj,c0,c1,c2,ck;
    c0 = 1;
    c1 = 2|0;
    if k==0;
        ck = c0;
    elseif k==1;
        ck = c1;
    else;
        Ljj=0;do until Ljj==(k-1); Ljj=Ljj+1;
        c2 = polymult( (2|0) , c1 ) - polymult( (0|(2*Ljj)) ,(0|c0) );
        c0 = c1;
        c1 = c2;
        endo;
        ck = c2;
    endif;    
    retp(ck); 
    endp;    
    
/* kkk() : generate multivariate series index: 1,2,...,(bigK2+1)^K */
    proc(1) = kkk(mvctj); 
    @ return a K*1 vector as index @
    local mmmj,buff1,buff2,j;
    mmmj = ones(K,1);
    buff2 = mvctj;
    j=K+1; do until j==1; j=j-1;
        buff1 = floor( buff2./(bigK2+1) );
        mmmj[j,1] = buff2-(bigK2+1).*buff1;
        buff2 = buff1;
    endo;
    retp(mmmj); 
    endp;    
        
/* mmm() : generate multivariate series index */
    proc(1) = mmm(mvctj); 
    @ return a K*1 vector as index @
    local mmmj,buff,j,temp,temp1;
    mmmj = ones(K,1);
    j=0; do until j==K; j=j+1;
        temp = (2.*ptTzw+1)^j;
        temp1= (2.*ptTzw+1);        
        buff = mvctj-(temp ) .* trunc( mvctj./temp );
        buff = ceil( buff./(temp/temp1));      
        if buff==0; buff = temp1; endif;
        mmmj[K-j+1,1] = sequ_Tzw[buff,1];            
    endo;
    retp(mmmj); 
    endp;
    
/* end of the code */
