@Gauss Code Version 3, January, 2017.@

new;
format /ld 6,4;

load data[161,3]=c:\gauss12\fourier\code2\hadcrust.txt; @Read your data@
y = data[.,3];  

pd = 1;  @pd =0 for constant model
             =1 for constant and trend model@

ma = 1;  @ma = 0 for the upper biased estimator
             = 1 for the median unbiased estimator@ 

fk = 1; @Input a frequency from {1,2,3,4,5}@ 

T = rows(y); @the number of observations@

maxp = int(12*(T/100)^(1/4)); @maximum number of lag length@

/*Please do not change the following code*/
constant = ones(T,1);
trend = seqa(1,1,T);
sint=sin(2*pi*trend*fk/T);
cost=cos(2*pi*trend*fk/T);

if pd==0;
    reg = constant~sint~cost;
    R1 = zeros(2,1)~(1|0)~(0|1);
elseif pd==1;
    reg = constant~trend~sint~cost;
    R1 = zeros(2,2)~(1|0)~(0|1);
endif;

{cbar1} = cbar(fk,pd); 
{khat}=mic1(y,reg,cbar1,0,maxp,0); @Lag Selection by MAIC@
{ahat,amu} = RF(y,khat,pd,fk,ma);
{b, VCV} = QFGLS(y,reg,khat,amu);
std = sqrt(diag(vcv));
wald = (R1*b)'inv(R1*VCV*R1')*(R1*b);

/***********************************************/
print "Estimation Results"; 
print "fk 			 =" fk;
print "alpha(OLS)               =" ahat;
if ma == 1; 
print "alpha(median unbiased)	 =" amu; 
elseif ma == 0; 
print "alpha(upper biased)       =" amu; 
endif;
CR=(T^0.5)*abs(amu-1);	
amus=amu*(CR>1)+1*(CR<=1);
print "alpha(super efficient)   =" amus;
print " ";
print "                coef    std";
print "constant       "   b[1]~std[1];
if pd == 1;
print "trend          "   b[2]~std[2];
endif;
print "sin(2*pi*fk/T) "   b[pd+2]~std[pd+2];
print "cos(2*pi*fk/T) "   b[pd+3]~std[pd+3];
print " ";
print "H0: gamma1=gamma2=0, H1: at least one of them is not zero";
print "	Wald ="   wald;
print "Note that the critical values of the Wald statistic are the following:";
cv01 = cdfchii(0.99,2); cv05 = cdfchii(0.95,2); cv10 = cdfchii(0.90,2);
print "	10%:" cv10 ",5%:" cv05 ",1%:" cv01;
print "Note that the constant term is not estimated when alpha(super efficient)=1.";


/*Define functions used above*/
@lagn(x,n) => x{t-n}@
proc(1) = lagn(x,n); 
	local y;
	if n>0;
		y = zeros(n,cols(x)) | trimr(x,0,n);
	else;
		y = trimr(x,abs(n),0) | zeros(abs(n),cols(x));
	endif;
	retp(y);
endp;

@diff(x,n) with n>0 => x{t}-x{t-n}@  
proc(1) = diff(x,n); 
	local y;
	if(n==0);
		y = x;
	else;
		y = zeros(n,cols(x)) | (trimr(x,n,0)-trimr(lagn(x,n),n,0));
	endif;
	retp(y);
endp;

@This function is to take the autocovariance functions of x as
ACF(x) = [R(0), R(1),...,R(T-1)]'. Thus, R[1]=R(0), R[2]=R(1), and so on@ 
proc(1) = ACV(x);
	local R, rho, i, j, xbar, T;
	T = rows(x);
	R = zeros(T,1); 
	xbar = meanc(x); 
	i = 1;
	do while i <= T;
		j = i-1;
		R[i] = (x[1:T-j,1]-xbar)'(x[1+j:T,1]-xbar)/T;
		i = i+1;	
	endo; 
	retp(R);
endp;

@Andrews(1991) method using Quadratic Spectral window@
proc(1) = h0W(x);
	local m,s,R,a,delta,lamda,h0,i,b,ll,e,vcb,IC1,IC2, T;
    T=rows(x);	
    b=olsqr(x[2:T],x[1:T-1]);
	a=(4*(b^2))/((1-b)^4);
	R = ACV(x);
	lamda = zeros(T-1,1);
	s=seqa(1,1,T-1);
	m = 1.3221*((a*T)^(1/5));
	delta = (6*pi*s)/(5*m);
	i=1;
	do while i<=T-1; 
		lamda[i] = 3*((sin(delta[i])/delta[i])-cos(delta[i]))/(delta[i]^2);
		i = i+1;
	endo;
	h0 = (R[1] + 2*lamda'*R[2:T,1]);
	retp(h0);	
endp;

@the values of Tau50 and Tau85 for the case of single frequency@
proc(2) = pct(fk,pd);
	local t50, t85;
    if pd == 0;
        if fk==1;
            t50 = -2.3918; t85 = -3.2567;
        elseif fk==2;
            t50 = -1.7146; t85 = -2.6655;
        elseif fk==3;
            t50 = -1.6317; t85 = -2.5134;
        elseif fk==4;
            t50 = -1.5956; t85 = -2.4520;
        elseif fk==5;
            t50 = -1.5939; t85 = -2.4322;
        endif;
    elseif pd == 1;
        if fk==1;
            t50 = -3.0861; t85 = -3.8254;
        elseif fk==2;
            t50 = -2.5566; t85 = -3.4499;
        elseif fk==3;
            t50 = -2.3341; t85 = -3.2099;
        elseif fk==4;
            t50 = -2.2718; t85 = -3.0880;
        elseif fk==5;
            t50 = -2.2313; t85 = -3.0466;
        endif;
    endif;
	retp(t50, t85);
endp;

proc(1) = cbar(fk,pd);
    local cbar;
    if pd == 0;
        if fk==1;
            cbar = -12.25;
        elseif fk==2;
            cbar = -8.25;
        elseif fk==3;
            cbar = -7.75;
        elseif fk==4;
            cbar = -7.50;
        elseif fk==5;
            cbar = -7.25;
        endif;
    elseif pd == 1;
        if fk==1;
            cbar = -22.00;
        elseif fk==2;
            cbar = -16.25;
        elseif fk==3;
            cbar = -14.75;
        elseif fk==4;
            cbar = -14.25;
        elseif fk==5;
            cbar = -14.00;
        endif;
    endif;
	retp(cbar);
endp;

@Roy-Fuller estimator@
proc(2) = RF(x,p,pd,fk,ma);
/*------------------------------------------------------------
x: dependent variable
p: lag length
-------------------------------------------------------------*/
	local T, dep, reg, u, du, r, depa, rega, bhat, ss, vbhat, ehat;
	local a, c1, c2, tpct, Ip, tau1, ctau, rhows, rhomd, i, t50, t85;

    T=rows(x);
    dep=x; 
    if pd==0;
        reg=ones(T,1)~sin(2*pi*seqa(1,1,T)*fk/T)~cos(2*pi*seqa(1,1,T)*fk/T);
    elseif pd==1;
        reg=ones(T,1)~seqa(1,1,T)~sin(2*pi*seqa(1,1,T)*fk/T)~cos(2*pi*seqa(1,1,T)*fk/T);
    endif;

    u = (eye(T)-reg*inv(reg'reg)*reg')*dep;				
    du = diff(u,1);
	depa = u; 
    rega = lagn(u,1);
	i=1;
	do while i<=p;
		rega=rega~lagn(du,i);
		i=i+1;
	endo;
	depa=trimr(depa,p+1,0);
	rega=trimr(rega,p+1,0);
    bhat=inv(rega'rega)*(rega'depa);
    ehat = depa-rega*bhat;
	ss = ehat'ehat/rows(ehat);
	vbhat = ss*inv(rega'rega);
    ahat = bhat[1];
	tau1=(ahat-1)/sqrt(vbhat[1,1]);

    {t50,t85}=pct(fk,pd);

	if ma==1;
		tpct = t50;@the median unbiased estimator@
	elseif ma==0;
		tpct = t85;@the upper biased estimator@
	endif;
    
	a=10; 
	r=cols(reg); 
	IP=int((p+2)/2); 
	c1=(1+r)*T;
	c2=((1+r)*T-(tpct^2)*(IP+T))/(tpct*(a+tpct)*(IP+T));
    if (tau1>tpct);
		ctau=-tau1; 
	elseif (tau1<=tpct)*(tau1>-a)==1;
		ctau=IP*(tau1/T)-(1+r)/(tau1+c2*(tau1+a));
	elseif (tau1<=-a)*(tau1>-sqrt(c1))==1;
		ctau=IP*(tau1/T)-(1+r)/tau1;
	elseif (tau1<=-sqrt(c1));
		ctau=0;
	endif;
    amu = ahat + ctau*sqrt(vbhat[1,1]);
    amu= 1*(amu>=1)+amu*(abs(amu)<1);

retp(ahat,amu);
endp;

/* Quasi Feasible GLS*/
proc(2) = QFGLS(x,reg,p,ahat);
/*------------------------------------------------------------
x: dependent variable
reg: deterministic components
p: lag length
ahat: the estimate of the sum of the autoregressive coefficients
---------------------------------------------------------------------*/
    local stdb, v, fit, b, coef, regv, depv, e, regx, depx, VCV;
    local j, T, dep, dx, u, du, CR, amus, depg, regg, h0, phi, ad;

	T=rows(x); 
    dep=x; 
	dx=diff(x,1);
    u = (eye(T)-reg*inv(reg'reg)*reg')*dep; 
	du = diff(u,1);

	@---Estimation of alpha----@	
	CR=(T^0.5)*abs(ahat-1);	
	amus=ahat*(CR>1)+1*(CR<=1);
    ad = (1-amus^2)^0.5;

	@-----QFGLS-----@
	depg=((ad*dep[1])~(trimr(dep,1,0)-amus*trimr(dep,0,1))')';
	regg=((ad*reg[1,.])'~(trimr(reg,1,0)-amus*trimr(reg,0,1))')';
	b=invswp(regg'regg)*regg'depg;
	v=depg-regg*b;

	@----Estimation of long-run variance---@
	if (p==0);
		h0=v'v/(rows(v));
	elseif (p>0);
		if (amus==1);	
            h0 = h0W(v);
		elseif (abs(amus)<1);
    		j=1;
			do while j<=p;
				if (j==1);
					regx=lagn(u,j)~lagn(du,j);
				else;
					regx=regx~lagn(du,j);
				endif;
				j=j+1;
			endo;			
			depx=trimr(u,p+1,0);	
			regx=trimr(regx,p+1,0);		
			{coef,e,fit}=olsqr2(depx,regx);		
			h0=e'e/rows(e);			
		endif;
	endif;

	VCV=(h0)*invswp(regg'regg);

retp(b, VCV);
endp;


proc(1)=mic1(y,reg,cbar,penalty,kmax,kmin);
	local nt,yt,ssra,krule;

	nt=rows(y);
	{yt,ssra}=glsd(y,reg,cbar); /* transforming the data*/
	krule=s2ar(yt,penalty,kmax,kmin); /* estimate s2ar */
	
	retp(krule);
endp;

proc(1)=s2ar(yts,penalty,kmax,kmin);@penalty: 0 for aic and 1 for bic@
    local nt,min,s2vec,dyts,reg,k,b,e,fit,nef,s2e,dyts0,reg0,i;
    local bic,kbic,sumb,j,msbar,gap,kopt,ssr,trgff,sumy,tau,mic,kk;

    nt=rows(yts);
    min=9999999999;
    tau=zeros(kmax+1,1);
    s2e=999*ones(kmax+1,1);

    dyts=diff(yts,1);
    reg=lagn(yts,1);
    i=1;
    do while i <= kmax;
        reg=reg~lagn(dyts,i);
    i=i+1;
    endo;
    dyts0=dyts;
    reg0=reg;

    /*loop over k*/
    dyts0=trimr(dyts,kmax+1,0);
    reg0=trimr(reg,kmax+1,0);
    sumy=sumc(reg0[.,1].*reg0[.,1]);
    nef=nt-kmax-1;
    k=kmin;
    do while k <= kmax;
        b=dyts0/reg0[.,1:k+1];
        e=dyts0-reg0[.,1:k+1]*b;
        s2e[k+1]=e'e/nef;
        tau[k+1]=(b[1]*b[1])*sumy/s2e[k+1];
        k=k+1;
    endo;

	kk=seqa(0,1,kmax+1);
    if penalty == 0;
        mic=ln(s2e)+2.0*(kk+tau)./nef;
    else;
        mic=ln(s2e)+ln(nef)*(kk)./nef;
    endif;
    kopt=minindc(mic)-1;
    retp(kopt);
endp;

proc(2)=glsd(y,z,cbar);
local nt,abar,ya,za,bhat,yt,ssr;

    nt=rows(y);
    abar=1+cbar/nt;
    ya=zeros(nt,1);
    za=zeros(nt,cols(z));
    ya[1:1,1]=y[1:1,1];
    za[1:1,.]=z[1:1,.];
    ya[2:nt,1]=y[2:nt,1]-abar*y[1:nt-1,1];
    za[2:nt,.]=z[2:nt,.]-abar*z[1:nt-1,.];
    bhat=inv(za'za)*za'ya;
    yt=y-z*bhat;
    ssr=(ya-za*bhat)'(ya-za*bhat);

retp(yt,ssr);
endp;