! ****************************************************************** ! matrix2.mac ! Copyright(c) 2000 ! ! Created: 3/21/2013 3:14:17 PM ! Author : HOUSTON STOKES ! Last change: HS 5/23/2013 11:15:41 AM ! ****************************************************************** ==README /; /; Library of subroutines and functions that extend the capability /; of the Matrix Command. These commands are documented in the /; b34s help file for the matrix command. The commands in staging2.mac /; are not documented in the b34s help command but have internal /; documentation. /; /; The command /; /; call load(acf_plot); /; will load the acf_plot subroutine that is called as: /; /; call acf_plot(series,nacf,title); /; == ==ACE_OLS Tests ACE Model using OLS program ace_ols; /; /; Extracts "best" ACE Model and saves transformed y in %ybest /; and saves transformed x in %xbest %best = index /; /; Obtains %k, %ssres %ty and %tx from last acefit model /; /; Experimental version 19 February 2006 /; /; For reference and motivation see Faraway (2006) P242 /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; /; Can be called as a program or as a subroutine using /; /; call aceols2( ); /; iprint=1; call aceols2(%k,%ns,%ssres,%yhat,%ty,%tx,%best,%ybest,%xbest, iprint,%ace,%y); call print(' ':); call print('Test sum of squares ',sumsq(%y-%ybest):); return; end; subroutine aceols2(k,ns,ssres,yhat,ty,tx,best,ybest,xbest,iprint,ace,y); /; /; Extracts best ACE model data and optionally shows implied OLS models /; /; Let y* = theta(y) /; /; 1. y* = f( smoothed x) /; 2. y* = f( smoothed x without constant) /; 3. y = f( smoothed x ) /; /; Y can be forecasted two ways (See Hastie-Tibshirani page 194): /; -using inverse of y filter /; -using equation 3. /; /; aceols2 can be called by ACE_OLS or directly /; /; k => # right hand side variables /; ns => # of ACE models attempted /; ssres => array with ns elements showing residual sum of squares /; of ACE model /; yhat => nob,ns 2d object containing y hat /; ty => transformed y /; tx => nob,k,ns of nob * (k*ns) object containing transformed x /; best => # of ACE model that has minimum e'e /; ybest => nob element transformed y of "best" model /; xbest => nob,k matrix of transfrmed x elements of "best" model /; iprint => =0 only calculate, NE 0 => print OLS models of /; ybest = f(xbest) /; ace => Set by call acefit. use %ACE /; /; Experimental version 19 February 2006 /; /; For reference and motivation see Faraway (2006) P242 /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ best=imin(ssres); ybest = yhat(,best); tybest = ty(,best); iijunk1=((best-1)*k)+1; xbest=matrix(norows(tx),k:); ijunk2=0; do ii=iijunk1,(iijunk1+k-1); ijunk2=ijunk2+1; xbest(,ijunk2)=tx(,ii); enddo; if(iprint.ne.0)then; if(ace.eq.0)then; call print(' ':); call print('Best ACE Model was # ',best:); endif; if(ace.ne.0)then; call print(' ':); call print('AVAS Model':); endif; call print('Model with transformed Y data should have coef ~ 1.0':); call olsq(tybest xbest :noint :print :qr); call print('Restriction - Y transform is linear':); call olsq(y xbest :print :qr); endif; return; end; == ==ACE_PLOT Plot ACE Response Curves program ace_plot; /; /; Plot ACE Transformations for BEST Model /; ibest=imin(%ssres); %ybest =%ty(,ibest); iijunk1=((ibest-1)*%k)+1; %xbest=matrix(norows(%tx),%k:); ijunk2=0; do ii=iijunk1,(iijunk1+%k-1); ijunk2=ijunk2+1; %xbest(,ijunk2)=%tx(,ii); enddo; call aceplot2(%y,%ybest,%xbest,%x,%names,%lag,%ace); return; end; subroutine aceplot2(y,ybest,xbest,xorig,names,lag,ace); /; /; Show Ace Transforms in Graphs /; See Faraway (2006) page 243 /; /; y => Usually %y /; ybest => Best ytransform /; xbest => best xtransform /; xorig => %x from :savex /; names => %names /; lag => %lag /; ace => %ACE /; /; ***************************************************************** if(kind(xorig).ne.8)then; call epprint( 'ERROR: Need :savex on acefit command line to use ace_plot'); call stop; endif; i=ranker(y); yvar=y(i); trans_y=ybest(i); if(ace.eq.0) call graph(yvar, trans_y :xlabel 'Raw y Variable' :ylabelleft 'Transformed y Variable' 'c9' :plottype xyplot :nocontact :nolabel :markpoint 1 1 3 14 :colors black bblue :hardcopyfmt WMF :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file 'ace_ytrans.wmf' :heading 'ACE Y Transform'); if(ace.ne.0) call graph(yvar trans_y :plottype xyplot :xlabel 'Raw y Variable' :ylabelleft 'Transformed y Variable' 'c9' :plottype xyplot :nocontact :nolabel :markpoint 1 1 3 14 :colors black bblue :hardcopyfmt WMF :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file 'avas_ytrans.wmf' :heading 'AVAS Y Transform'); do k=1,nocols(xbest); if(lag(k).eq.0)then; c1=c1array(8:names(k)); j=integers(1,8); j2=j+27; if(ace.eq.0) cc3=' vs ACE Transform '; if(ace.ne.0) cc3=' vs AVAS Transform '; cc3(j) =c1(j); cc3(j2)=c1(j); endif; if(lag(k).ne.0)then; c1=c1array(8:names(k)); j=integers(1,8); if(ace.eq.0) cc3=' lag vs ACE Transform '; if(ace.ne.0) cc3=' lag vs AVAS Transform '; cc3(j) =c1(j); if(lag(k).le.9)then; call inttostr(lag(k),b8 ,'(i1)'); cc3(17)=b8(1); endif; if(lag(k).gt.9.and.lag(k).le.99)then; call inttostr(lag(k),b8 ,'(i2)'); cc3(17)=b8(2); cc3(16)=b8(1); endif; if(lag(k).gt.99.and.lag(k).le.999)then; call inttostr(lag(k),b8 ,'(i3)'); cc3(17)=b8(3); cc3(16)=b8(2); cc3(15)=b8(1); endif; endif; xtrans=xbest(,k); xvar =xorig(,k); i=ranker(xvar); xvar=xvar(i); trans_x=xtrans(i); if(k.le.9)then; call fprint(:col 1 :string 'ace_____' :col 8 :display k '(i1)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(k.ge.10).and.(k.lt.100)then; call fprint(:col 1 :string 'ace____' :col 7 :display k '(i2)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(k.ge.100).and.(k.lt.1000)then; call fprint(:col 1 :string 'ace___' :col 6 :display k '(i3)' :col 9 :string '.wmf' :save labchrt :clear); endif; * call graph(xvar trans_x :plottype xyplot :file labchrt :heading cc3); call graph(xvar, trans_x :xlabel 'Raw X Variable' :ylabelleft 'Transformed X Variable' 'c9' :plottype xyplot :nocontact :nolabel :markpoint 1 1 3 14 :colors black bblue :hardcopyfmt WMF :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file labchrt :heading cc3); enddo; return; end; == ==ACF_PLOT Plot ACF subroutine acf_plot(series,nacf,title); /; Simple ACF Plot routine /; Series = Input series /; nacf = # NACF and PACF /; Title = Title /; /; DATA_ACF is a more complex command /; /; Command makes files acf_plot.wmf & pacf_plot.wmf /; ********************************************** acf1=acf(series,nacf,se1,pacf1); call character(cc,'ACF Plot for '); call character(cc2,title); call ialen(cc2,ii); call expand(cc,cc2,14,14+ii); call graph(acf1 se1 :overlay acfplot :heading cc :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :colors black bblue bred :file 'acf_plot.wmf' ); call character(cc,'PACF Plot for '); call character(cc2,title); call expand(cc,cc2,15,15+ii); call graph(pacf1 se1 :overlay acfplot :heading cc :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :colors black bblue bred :file 'pacf_plot.wmf' ); return; end; == ==ALTSE Copies lower triangle to upper and gets SE subroutine altse(hess,se); /; Routine takes hess and copies lower triangle to /; upper triangle /; DSQRT of absolute values of diagonal taken n=norows(hess); do i=1,n; do j=1,n; if(i.gt.j)then; hess(j,i)=hess(i,j); endif; enddo; enddo; ihess=inv(hess); i=integers(n); * call print(ihess); do i=1,n; se(i)=dsqrt(dabs(ihess(i,i))); enddo; call print(se); return; end; == ==AUTOCOV Autocovaiance subroutine autocov(series,acov,nacov); /; **************************************************** /; /; Usage call autocov(x,acov,nacov); /; /; x = series /; acov = autocovariance /; nacov = # of acov values calculated /; /; Test autocov /; /; Uses large sample approximations /; **************************************************** if(kind(series).ne.8.or.kind(nacov).ne.-4)then; call epprint('ERROR: autocov inputs not correct'); go to finish; endif; n=norows(series); if(n.le.nacov.or.n.le.2)then; call epprint('ERROR: # observations and nacov not matched'); go to finish; endif; v1=variance(series)*dfloat(n-1)/dfloat(n); a=acf(series,nacov); acov=a*v1; finish continue; return; end; == ==BJ_IDEN List / Plot ACF and PACF subroutine bj_iden(x,nacf,heading,iplot,file); /; /; x => Series /; nacf => # acf/pacf calculated printed /; heading => Heading /; iplot => NE 0 => plot /; file => File to save high res plot /; acf1=acf(x,nacf,se1,pacf1,mq1,probq1); call print(' ':); call print(heading:); call print(' ':); call print('Autocorrelation Function':); call print(' ':); sd=dsqrt(variance(x)*dfloat(norows(x)-1)/dfloat(norows(x))); call print('Mean of Series ',mean(x):); call print('S. D. of Series ',sd:); call print('Number of Observations ',norows(x):); /; idone=0; do i=1,nacf,12; iend=min1(i+11,nacf); j=integers(i,iend); work1=acf1(j); work2=se1(j); work3=mq1(j); work4=probq1(j); call print(' ':); call fprint(:clear :col 1 :display i '(i4)' :col 5 :string '-' :col 6 :display iend '(i4)' :col 10 :display work1 '(12f9.2)' :print :clear :col 1 :display ' S. E.' :col 10 :display work2 '(12f9.2)' :print :clear :col 4 :string 'Mod. Q' :col 10 :display work3 '(12f9.2)' :print :clear :col 4 :string 'Prob. Q' :col 10 :display work4 '(12f9.2)' :print); enddo; call print(' ':); call print('Partial Autocorrelation Function':); call print(' ':); idone=0; do i=1,nacf,12; iend=min1(i+11,nacf); j=integers(i,iend); work1=pacf1(j); call fprint(:clear :col 1 :display i '(i4)' :col 5 :string '-' :col 6 :display iend '(i4)' :col 10 :display work1 '(12f9.2)' :print :clear); enddo; if(iplot.ne.0)then; call graph(x :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p1.hp1' :hardcopyfmt HP_GL2 :heading heading); call graph(acf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p2.hp1' :hardcopyfmt HP_GL2 :heading 'ACF of Above Series'); call graph(pacf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p3.hp1' :hardcopyfmt HP_GL2 :heading 'PACF of Above Series'); call grreplay(:start :file file ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); endif; return; end; == ==B_G_TEST Breusch- Godfrey (1978) Test on Residuals subroutine b_g_test(iorder, x, res,gbtest,gbprob,iprint,iprint2); /; /; Implements Breusch(1978)- Godfrey (1978) Test /; See Greene (2000) page 541, Greene(2008) page 644 /; /; Reference: Breusch, T. "Testing for Autocorrelation in Dynamic Linear /; Models." Australian Economic Papers, 17, 1978, pp.334-355 /; /; Godfrey, L. "Testing Against General Autoregressive and /; Moving Average Error Models When the Regressors Include /; Lagged Dependent Variables." Econometrica, 46, (1978), /; pp. 1293-1302. /; /; iorder => Max order of the test /; x => original x matrix /; res => residual from original equation /; gbtest => Breusch-Godfrey (1978) test Stat /; gbprob => Probability of stat /; iprint => ne 0 prints results /; iprint2 => ne 0 prints stage 2 results /; +++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; Use: call olsq(y x1 x2 x3 :savex); /; do iorder=1,4; /; call b_g_test(iorder,%x,%res,gbtest.gbprob,1,0); /; enddo; /; xnew=matrix(norows(x),nocols(x)+iorder:); do i=1,nocols(x); xnew(,i)=x(,i); enddo; do i=1,iorder; icol=nocols(x)+i; j=integers(1,norows(x)-i); jj=j+i; xnew(jj,icol)=res(j); enddo; /; call print(res, xnew,x); if(iprint2.ne.0)then; call print('Breusch-Godfrey (1978) x matrix, and lag residuals':); call olsq(res xnew :noint :print); endif; if(iprint2.eq.0)call olsq(res xnew :noint); gbtest=%rsq*dfloat(%nob); gbprob=chisqprob(gbtest,dfloat(iorder)); if(iprint.ne.0)then; call fprint(:clear :display 'Breusch- Godfrey(1978) Test using 0.0' :col 40 :display gbtest '(g16.8)' :col 57 :display 'DF' :col 62 :display iorder '(i3)' :col 68 :display 'Probability' :col 80 :display gbprob '(g12.4)' :print); endif; return; end; == ==B_G_ALT Breusch- Godfrey (1978) Test using dropping subroutine b_g_alt(iorder,x,res,gbtest,gbprob,iprint1,iprint2); /; /; This approach is consistent with Rats and Modler /; It implies we replace 0.0 with missing data /; /; iorder => Max order of the test /; x => original x matrix /; res => residual from original equation /; gbtest => Breusch-Godfrey (1978) test Stat /; gbprob => Probability of stat /; iprint => ne 0 prints results /; iprint2 => ne 0 prints stage 2 results /; +++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; Use: call olsq(y x1 x2 x3 :savex); /; do iorder=1,4; /; call b_g_alt(iorder,%x,%res,gbtest,gbprob,1,0); /; enddo; /; xnew=matrix(norows(x),nocols(x)+iorder:); reshold=res; do i=1,nocols(x); xnew(,i)=x(,i); enddo; do i=1,iorder; icol=nocols(x)+i; j=integers(1,norows(x)-i); jj=j+i; xnew(jj,icol)=res(j); enddo; do i=1,iorder; xnew(i,1) =missing(); reshold(i)=missing(); enddo; reshold=goodrow(reshold); xnew=goodrow(xnew); if(iprint2.ne.0)then; call print('This is Helping regression for Breusch-Godfrey':); call olsq(reshold xnew :noint :print); endif; if(iprint2.eq.0)call olsq(reshold xnew :noint); gbtest=%rsq*dfloat(%nob); gbprob=chisqprob(gbtest,dfloat(iorder)); if(iprint1.ne.0)then; call fprint(:clear :display 'Breusch-Godfrey(1978) Test dropping 0.0' :col 40 :display gbtest '(g16.8)' :col 57 :display 'DF' :col 62 :display iorder '(i3)' :col 68 :display 'Probability' :col 80 :display gbprob '(g12.4)' :print); if(iprint2.ne.0)call print('++++++++++++++++++++++++++++++++++++++++':); endif; return; end; == ==BLUS BLUS master subroutine blus(itype,x,olse,ibase,bluse,bluse2,eigb,sumeig,sumsqb, olsbeta,blusbeta,ibad,x1,teststat,iprint); /; /; Routine to calculate BLUS residuals tests /; Routine mimics what is available in RA card and BLUS capability /; in regresion command. /; /; Routines BLUSBASE BLUSTEST and BLUSRES are needed. /; Except where base is known, the BLUS routine is all that needs to /; be called. /; /; Routine built 25 June 2003 by Houston H. Stokes /; /; itype = 0 DW test /; itype = 1 MVN test /; itype = 2 Het Base /; itype = 3 Parabola base /; x = n by k x matrix. OLSQ command saves this if /; :savex is effect (input) /; olse = OLS Error. usually %res (input) /; ibase = Integer vector of the base for the BLUS calculation /; bluse = BLUS residual vector /; bluse2 = BLUS residual vector with base marked as missing /; eigb = eigenvalues from blus /; sumeig = sum dsqrt of eigenvalues /; sumsqb = sum of blus residuals squared /; olsbeta = OLS Beta (input) /; blusbeta= BLUS Beta Note %x*blusbeta => blus_yhat /; y-blus_yhat => bluse2 /; ibad = 0 all ok, = 1 base singular, = 2 error on input /; /; ********************************************************************** /; /; x1 = vector used for the sort. Needed if itype = 3 /; teststat= test statistic /; iprint = 1 print results; iopt=0; n=norows(x); k=norows(olsbeta); call blusbase(iopt,itype,n,k,ibase,nbase); if(nbase.eq.1)then; iopt=1; call blusbase(iopt,itype,n,k,ibase,nbase); call blusres(x,olse,ibase,bluse,bluse2,eigb,sumeig,sumsqb, olsbeta,blusbeta,ibad); if(ibad.eq.0)then; call blustest(bluse,x1,ibase,itype,teststat); if(iprint.ne.0)then; if(itype.eq.0)call print('DW on BLUS ',teststat:); if(itype.eq.1)call print('MVN on BLUS ',teststat:); if(itype.eq.2)call print('HET on BLUS ',teststat:); if(itype.eq.3)call print('Tprob on BLUS ',teststat:); call print('Sum of squared BLUS residuals ',sumsq(goodrow(bluse2)):); call print('Sum of squared OLS residuals ',sumsq(olse):); call print('Sum of eigenvalues ',sumeig:); call print('Base used ',ibase); endif; endif; endif; if(nbase.ne.1)then; hsumeig=-.1e+32; ihold=1; iopt=1; do i=1,nbase; call blusbase(iopt,itype,n,k,ibase,i); call blusres(x,olse,ibase,bluse,bluse2,eigb,sumeig,sumsqb, olsbeta,blusbeta,ibad); if(ibad.eq.0)then; if(sfam(sumeig).gt.hsumeig)then; ihold=i; hsumig=sfam(sumeig); endif; endif; enddo; call blusbase(iopt,itype,n,k,ibase,ihold); call blusres(x,olse,ibase,bluse,bluse2,eigb,sumeig,sumsqb, olsbeta,blusbeta,ibad); if(ibad.eq.0)then; call blustest(bluse,x1,ibase,itype,teststat); if(iprint.ne.0)then; if(itype.eq.0)call print('DW on BLUS ',teststat:); if(itype.eq.1)call print('MVN on BLUS ',teststat:); if(itype.eq.2)call print('HET on BLUS ',teststat:); if(itype.eq.3)call print('Tprob on BLUS ',teststat:); call print('Sum of squared BLUS residuals',sumsq(goodrow(bluse2)):); call print('Sum of squared OLS residuals',sumsq(olse):); call print('Sum of eigenvalues ',sumeig:); call print('Base used ',ibase); endif; endif; endif; return; end; subroutine blusbase(iopt,itype,n,k,ibase,nbase); /; /; Gets BLUS base /; /; iopt = 0 get number of bases for itype in nbase /; iopt = 1 get base number nbase for itype /; Example: if N = 20 and k = 4 there are 5 bases /; [1 2 3 4] [1 2 3 20] [1 2 19 20] /; [1 18 19 20] [17 18 19 20] /; itype = 0 DW and MVN base /; itype = 1 DW and MVN base /; itype = 2 Het Base /; itype = 3 Parabola base /; n = # of observations /; k = # right hand side variables /; ibase = Blus base /; nbase = # of bases if iopt=0, bane /; **************************************************************** /; DW and MVN base if(itype.eq.0.or.itype.eq.1)then; if(iopt.eq.0)nbase=k+1; if(iopt.eq.1)then; if(nbase.le.(k))ibase=integers(1,k-nbase+1); if(nbase.lt.(k+1).and.nbase.gt.1)then; itop=integers(n-nbase+2,n); ibase=idint(array(k:catrow(ibase,itop))); endif; if(nbase.eq.(k+1))ibase=integers(n-nbase+2,n); endif; endif; /; Het Base if(itype.eq.2)then; if(iopt.eq.0)then; nbase=2; if(dmod((n-k),2).eq.0)nbase=1; endif if(iopt.eq.1)then; if(dmod((n-k),2).eq.0)then; istart=((n-k)/2)+1; ibase=integers(istart,istart+k-1); endif; istart=((n-k)/2)+nbase-1; ibase=integers(istart,istart+k-1); endif; /; Parabola base if(itype.eq.3)then; if(iopt.eq.0)then; nbase=2; if(dmod((n-k),2).eq.0)nbase=1; endif if(iopt.eq.1)then; if(dmod((n-k),2).eq.0)then; istart=((n-k)/4)+2; iend=istart+(k/2)-1; ibase =integers(istart,iend); istart=((3*(n-k)/4)+2); iend=istart+(k/2)-1; ibase2=integers(istart,iend); /; call print('at 1 k was ',k:); /; call print('norows(ibase) ',norows(ibase):); /; call print('norows(ibase2)',norows(ibase2):); ibase=idint(array(k:catrow(ibase,ibase2))); endif; if(dmod((n-k),2).ne.0)then; iadd1=1; iadd2=0; if(nbase.eq.2)then; iadd1=0; iadd2=1; endif; istart=((n-k)/4)+2; iend=istart+(k/2)+iadd1-1; ibase=integers(istart,iend); istart=(3*(n-k)/4); iend=istart+(k/2)+iadd2-1; ibase2=integers(istart,iend); /; call print('at 2 k was ',k:); /; call print('norows(ibase) ',norows(ibase):); /; call print('norows(ibase2)',norows(ibase2):); ibase=idint(array(k:catrow(ibase,ibase2))); endif; endif; return; end; subroutine blustest(bluse,x,ibase,itype,test); /; /; Construct Tests on BLUS Residuals /; /; Routine built 15 May 2003 /; /; bluse = Blus residuals /; x = Vector used for the sort. Needed if /; itype=3 /; ibase = BLUS base integer*4 vector of k elements /; itype = 0 DW /; = 1 mvn /; = 2 F /; = 3 parabola /; test = test value /; if(itype.eq.0)then; test=sumsq(dif(bluse))/sumsq(bluse); endif; if(itype.eq.1)then; rn=dfloat(norows(bluse)); test=(rn*sumsq(dif(bluse))/(rn-1.0))/sumsq(bluse); endif; if(itype.eq.2)then; n=norows(bluse); n2=n/2; iadd=0; iend=n2+dmod(n,2); itop=integers(1,iend); ibot=integers(iend+1,n); test=sumsq(bluse(itop))/sumsq(bluse(ibot)); endif; if(itype.eq.3)then; n=norows(x); k=norows(ibase); sortedx=x; do i=1,norows(ibase); ii=ibase(i); sortedx(ii)=missing(); enddo; sortedx=goodrow(sortedx); xx=afam(sortedx)-mean(afam(sortedx)); xx=xx*xx; ah=sum(xx*afam(bluse))-(variance(afam(sortedx))*sum(afam(bluse))); bh=sum(xx*xx)-(dfloat(n-k)*(variance(afam(sortedx))**2.)); ss=sumsq(afam(bluse))/dfloat(n-k); test=(dsqrt(dfloat(n-k-1))*ah)/(dsqrt(dfloat(n-k)*ss*bh-(ah*ah))); endif; return; end; subroutine blusres(x,olse,ibase,bluse,bluse2,eigb,sumeig,sumsqb, olsbeta,blusbeta,ibad); /; /; Routine to calculate BLUS residuals /; Routine mimics what is available in RA card and BLUS capability /; in regresion command. /; /; Routine built 15 May 2003 by Houston H. Stokes /; Improvements 25 June 2003 /; Better rank error recovery 15 May 2006 /; /; x = n by k x matrix. OLSQ command saves this if /; :savex is effect (input) /; olse = OLS Error. usually %res (input) /; ibase = Integer vector of the base for the BLUS calculation /; bluse = BLUS residual vector /; bluse2 = BLUS residual vector with base marked as missing /; eigb = eigenvalues from blus /; sumeig = sum dsqrt of eigenvalues /; sumsqb = sum of blus residuals squared /; olsbeta = OLS Beta (input) /; blusbeta= BLUS Beta /; ibad = 0 all ok, = 1 base singular, = 2 error on input /; /; ********************************************************************** /; olse=vfam(olse); k=nocols(x); n=norows(x); ibad=0; if(k.ne.norows(ibase))then; call epprint('ERROR: # cols of X NE # elements in base'); call epprint(' # cols of X ',k:); call epprint(' # elements in base ',norows(ibase):); ibad=2; go to done; endif; if(norows(x).ne.norows(olse))then; call epprint('ERROR: # rows X matrix NE # rows OLS residual.'); call epprint(' # rows of X ',norows(x):); call epprint(' # rows OLS Residual ',norows(olse):); ibad=2; go to done; endif; e0=vector(k:olse(ibase)); x0=matrix(k,k :); /; mask is blus integer pointer /; mask1 is ols pointer iunuitialy real*8 mask = integers(1,n-k); mask1 = dfloat(integers(1,n)); do i=1,k; ii=ibase(i); x0(i,)=x(ii,); mask1(ii)=missing(); enddo; mask1=idint(goodrow(mask1)); test=x0*inv(transpose(x)*x)*transpose(x0); eigb=seig(test,q); if(min(eigb).le.0.0)then; call eprint('ERROR: Less than full rank getting base':); ibad=1; go to done; endif; dd=dsqrt(eigb); sumeig=sum(dd); /; now get the BLUS using Theil Eq 2.9 ; e1=olse; x1=x; s=matrix(k,k:); do i=1,k; jj=ibase(i); e1(jj) =missing(); x1(jj,1)=missing(); qq1=matrix(k,1:q(,i)); qq=qq1*transpose(qq1); s=s+(sfam(dd(i))/(1.0+sfam(dd(i))))*qq; enddo; x1=goodrow(x1); e1=goodrow(e1); /; need to trap bad rank --- invx0=inv(x0); not used call gminv(x0,invx0,info,rcond); if(info.ne.0)then; ibad=1; call epprint('ERROR: Cannot invert X0.'); call print(' rcond was ',rcond:); go to done; endif; bluse =e1 - (x1* invx0*s*e0); blusbeta=olsbeta + (invx0*s*e0); sumsqb=sumsq(bluse); bluse2=vector(n:)+missing(); bluse2(mask1)=bluse(mask); done continue; return; end; == ==BPF Baxter - King Symmetric MA Filter subroutine bpf(datain,dataout,highfreq,lowfreq,nterms); /; Program based on Baxter & King MA band-pass filter; /; /; For detail see their paper: /; 'Measuring Business Cycles: Approximate Band-Pass Filters /; for Macroeconomic Time Series' /; /; NBER Working Paper 5022 Feb 1995 /; /; This subroutine reverse engineers their MATLAB(r) m file /; bpf.m /; /; datain => Series to be filtered /; dataout => Series that is filtered /; highfreq => High Freq (6) /; lowfreq => Low Freq (32) /; nterms => N terms in filter /; /; Subroutine built 7 May 1999 by Houston H. Stokes /; Note: bpfilter command replaces this subroutine /; implementation /; /; call echooff; nobs=norows(datain); if(nterms.gt.(nobs/4))then; call epprint('ERROR: NTERMS set too large given # of obs in data'); go to done; endif; if(highfreq.ge.lowfreq)then; call epprint('ERROR: Highfreq set ge Lowfreq'); go to done; endif; if(kind(datain).ne.8)then; call epprint('ERROR: Data must be real*8'); go to done; endif; if(kind(highfreq).ne.8.or.kind(lowfreq).ne.8.or. kind(nterms).ne.-4)then; call epprint('ERROR: Highfreq, lowfreq must be real*8.'); call epprint(' NTERMS must be integer.'); go to done; endif; if(klass(datain).ne.1.and.klass(datain).ne.5)then; call epprint('ERROR: Datain must be a 1d real*8 object'); go to done; endif; if(highfreq.le.1..or.lowfreq.le.1.)then; call epprint('ERROR: Highfreq or lowfreq le 1.'); go to done; endif; omubar=2.*pi()/highfreq; omlbar=2.*pi()/lowfreq; /; /; construct filter weights /; weight=array(nterms+1:); weight(1)=(omubar-omlbar)/pi(); do i=1,nterms; j=i+1; weight(j)=(dsin(dfloat(i)*omubar)-dsin(dfloat(i)*omlbar))/ (dfloat(i)*pi()); enddo; phi=0.0; if(lowfreq.gt.1000.)phi=1.0; theta=(sum(weight)*2.0)-weight(1); theta=phi-(theta/((2.0*dfloat(nterms))+1.0)); weight=weight+theta; mask=array(((2*nterms)+1):); j=nterms+1; mask(j)=weight(1); do i=1,nterms; n1=nterms+1-i; n2=nterms+1+i; mask(n1)=weight(i+1); mask(n2)=weight(i+1); enddo; dataout=array(nobs:); hold=array((2*nterms+1):); j=integers((2*nterms+1)); do i=1+nterms,nobs-nterms; ii=j+i-1-nterms; hold(j)=vfam(datain(ii)); dataout(i)=afam(vfam(mask)*hold); enddo; done continue; call echoon; return; end; == ==BPFM Baxter - King Symmetric MA Filter - Missing Data at Ends subroutine bpfm(datain,dataout,highfreq,lowfreq,nterms); /; Program based on Baxter & King MA band-pass filter; /; /; For detail see their paper: /; 'Measuring Business Cycles: Approximate Band-Pass Filters /; for Macroeconomic Time Series' /; /; NBER Working Paper 5022 Feb 1995 /; /; This subroutine reverse engineers their MATLAB(r) m file /; bpf.m but places missing data at both ends of series. /; /; datain => Series to be filtered /; dataout => Series that is filtered /; highfreq => High Freq (6) /; lowfreq => Low Freq (32) /; nterms => N terms in filter /; /; Subroutine built 12 May 1999 by Houston H. Stokes /; call echooff; nobs=norows(datain); if(nterms.gt.(nobs/4))then; call epprint('ERROR: Nterms set too large given # of obs in data'); go to done; endif; if(highfreq.ge.lowfreq)then; call epprint('ERROR: Highfreq set ge Lowfreq'); go to done; endif; if(kind(datain).ne.8)then; call epprint('ERROR: Data must be real*8'); go to done; endif; if(kind(highfreq).ne.8.or.kind(lowfreq).ne.8.or. kind(nterms).ne.-4)then; call epprint('ERROR: Highfreq, lowfreq must be real*8.'); call epprint(' Nterms must be integer.'); go to done; endif; if(klass(datain).ne.1.and.klass(datain).ne.5)then; call epprint('ERROR: Datain must be a 1d real*8 object'); go to done; endif; if(highfreq.le.1..or.lowfreq.le.1.)then; call epprint('ERROR: Highfreq or lowfreq le 1.'); go to done; endif; omubar=2.*pi()/highfreq; omlbar=2.*pi()/lowfreq; /; /; construct filter weights /; weight=array(nterms+1:); weight(1)=(omubar-omlbar)/pi(); do i=1,nterms; j=i+1; weight(j)=(dsin(dfloat(i)*omubar)-dsin(dfloat(i)*omlbar))/ (dfloat(i)*pi()); enddo; phi=0.0; if(lowfreq.gt.1000.)phi=1.0; theta=(sum(weight)*2.0)-weight(1); theta=phi-(theta/((2.0*dfloat(nterms))+1.0)); weight=weight+theta; mask=array(((2*nterms)+1):); j=nterms+1; mask(j)=weight(1); do i=1,nterms; n1=nterms+1-i; n2=nterms+1+i; mask(n1)=weight(i+1); mask(n2)=weight(i+1); enddo; dataout=array(nobs:)+missing(); hold=array((2*nterms+1):); j=integers((2*nterms+1)); do i=1+nterms,nobs-nterms; ii=j+i-1-nterms; hold(j)=vfam(datain(ii)); dataout(i)=afam(vfam(mask)*hold); enddo; done continue; call echoon; return; end; == ==bag Implements bagging - See bag and bag_mod /; /; bag_mod is driving routines. bag can be called stand alone /; subroutine bag_mod(y,x,xname,basedf,class_k,e,itype,ntry,iprint,iprintb, iprintc,iprintx,igraph,bagrss1,bagrss2,bagssq1,bagssq2, ccf1,ccf2,bagcoef,bagt,medbcof,meanbcof medbt,meanbt,coef,t); /; /; Implements bagging as discribed in Hastie- Tibshirani-Friedman /; /; Code is experimental and can change /; /; OLS, GAM, L1, MINIMAX, PPREG Supported /; /; Code is experimental and can change /; /; y => left hand variable. Usually set as %y from olsq /; x => n by k matrix of right hand side variables /; set as %x from call olsq /; xname => Series name vector. Usually %names from call OLS /; basedf => Sets DF of gam smoothing. Usually set as 3.0 /; Assume 8 series where df set to 3 /; If first series is 0-1 can set basedf=1. and let the rest /; default to 3. /; /; For ppreg sets switches such as /; :alpha .3 => smoothing /; :m k => # trees /; :reg => continuous data (default) /; /; As an example basef = ':alpha .3 :class 3'; /; /; For marspline sets switches such as /; :nk 50 :mi 2 /; /; class_k => set = 0 for ppreg :reg models, /; set to number of classes for ppreg :class models /; e => % in bag. Usually .66667 /; itype => =0 OLS, =1 GAM, =2 L1, =3 minimax, =4 ppreg, =5 marspline /; ntry => Number of datasets to bag /; iprint => =0 no printing, =1 print step data, =2 print OLS step also /; iprintb => ne 0 prints the results for the complete dataset /; This is a good setting to use. /; iprintc => ne 0 prints the correlations for bag and non bag data /; iprintx => Prints inbag, inobs,outobs,x1, x2,y1,y2 for each try. /; This generates a great deal of output /; igraph => produce Graphs /; bagrss1 => Residual sum of squares for bag dataset /; bagrss2 => Residual sum of squares for out of bag dataset /; bagssq1 => sqrt(var(residual 1)) for bag dataset /; bagssq2 => sqrt(var(residual 2)) for out of bag dataset /; ccf1 => Correlation y and yhat for bag dataset /; ccf22 => Correlation y and yhat for oob dataset /; bagcoef => ntry by nocols(x) dataset of bagged dataset coeff /; bagt => ntry by nocols(x) dataset of bagges dataset coef / se /; medbcof => Median bag coefficient /; meanbcof=> Mean bag coefficient /; medbt => median bag t(z) /; meanbt => mean bag t(z) /; coef => coef for complete sample /; t => t(z) for complete sample /; /; Built 5 December 2011 by Houston H. Stokes /; Mods 18 December 2011 /; Mods 18 January 2012 to add ppreg /; /; bagrss1=vector(ntry:); bagrss2=vector(ntry:); bagssq1=vector(ntry:); bagssq2=vector(ntry:); ccf1 =vector(ntry:); ccf2 =vector(ntry:); bagcoef=array(ntry,nocols(x):); bagt =array(ntry,nocols(x):); if(kind(basedf).ne.8.and.itype.eq.1)basedf=3.; do i=1,ntry; call bag(y,x,y1,yhat1,res1,y2,yhat2,res2,coef1,t1, rss1,rss2,x1,x2,ssq1,ssq2,corr1,corr2, inbag,e,itype,basedf,class_k,iprint); bagcoef(i,)=coef1; bagt(i,) =t1; if(iprintx.ne.0)then; call print(' ':); if(itype.eq.0)call print('Bag and OOB datasets for OLS Model':); if(itype.eq.1)call print('Bag and OOB datasets for GAM Model':); if(itype.eq.2)call print('Bag and OOB datasets for L1 Model':); if(itype.eq.3)call print('Bag and OOB datasets for MINIMAX Model':); if(itype.eq.4)call print('Bag and OOB datasets for PPREG Model':); if(itype.eq.5)call print('Bag and OOB datasets for MARSPLINE Model':); inobs1=dfloat(integers(1,norows(y))); outobs1=inobs1; inobs1=afam(inbag)*afam(inobs1); outbag= (inbag .eq. 0.0); outobs1=afam(outbag)*afam(outobs1); outobs=outobs1+missing(); inobs =inobs1 +missing(); where(outobs1 .gt. 0.0)outobs=outobs1; where(inobs1 .gt. 0.0)inobs =inobs1; outobs=goodrow(outobs); inobs =goodrow(inobs); call tabulate(inbag,inobs,y1,yhat1,outobs,y2,yhat2); call print(x1,x2); endif; if(igraph.ne.0)then; call graph(y1,yhat1 :nocontact :pgborder :nolabel :heading 'Y & Yhat for bag dataset'); call graph(y2,yhat2 :nocontact :pgborder :nolabel :heading 'Y & Yhat for oob dataset'); endif; bagrss1(i)=rss1; bagrss2(i)=rss2; bagssq1(i) =ssq1; bagssq2(i) =ssq2; ccf1(i) =corr1; ccf2(i) =corr2; call compress; enddo; meanbcof =array(nocols(x):); medbcof =array(nocols(x):); meanbt =array(nocols(x):)*missing(); medbt =array(nocols(x):)*missing(); do i=1,nocols(x); meanbcof(i)= mean(bagcoef(,i)); medbcof(i)= median(bagcoef(,i)); if(itype.eq.0.or.itype.eq.1)then; meanbt(i)= mean(bagt(,i)); medbt(i)= median(bagt(,i)); endif; enddo; call print(' ':); if(itype.eq.0)call print('Results of bagging OLS Model':); if(itype.eq.1)call print('Results of bagging GAM Model':); if(itype.eq.2)call print('Results of bagging L1 Model':); if(itype.eq.3)call print('Results of bagging MINIMAX Model':); if(itype.eq.4)call print('Results of bagging PPREG Model':); if(itype.eq.5)call print('Results of bagging MARSPLINE Model':); call print(' ':); call print('# of Models estimated ',ntry:); call print('% of data in bag sample ',e:); call print(' ':); /; OLS if(itype.eq.0)then; if(iprintb.eq.0)call olsq(y x :noint); if(iprintb.ne.0)call olsq(y x :noint :print); endif; /; gam if(itype.eq.1)then; xx=x; call deletecol(xx); if(iprintb.eq.0)call gamfit(y xx :basedf basedf); if(iprintb.ne.0)call gamfit(y xx :basedf basedf :print); endif; /; L1 if(itype.eq.2)then; if(iprintb.eq.0)call olsq(y x :noint :L1); if(iprintb.ne.0)call olsq(y x :noint :L1 :print); endif; /; MINIMAX if(itype.eq.3)then; if(iprintb.eq.0)call olsq(y x :noint :minimax); if(iprintb.ne.0)call olsq(y x :noint :minimax :print); endif; /; PPREG if(itype.eq.4)then; if(class_k.eq.0)then; if(iprintb.eq.0)call ppreg(y x argument(basedf) :reg); if(iprintb.ne.0)call ppreg(y x argument(basedf) :reg :print); endif; if(class_k.ne.0)then; if(iprintb.eq.0)call ppreg(y x argument(basedf) :class class_k); if(iprintb.ne.0)call ppreg(y x argument(basedf) :class class_k :print); endif; endif; /; MARSPLINE if(itype.eq.5)then; if(iprintb.eq.0)call marspline(y x argument(basedf) ); if(iprintb.ne.0)call marspline(y x argument(basedf) :print); endif; if(itype.ne.4.and.itype.ne.5)then; coef=%coef; if(itype.eq.2)coef=%l1coef; if(itype.eq.3)coef=%mmcoef; if(itype.ne.1)t=%t; if(itype.eq.1)t=%z; endif; meanc1=mean(ccf1); sdc1 =sqrt(variance(ccf1)); meanc2=mean(ccf2); sdc2 =sqrt(variance(ccf2)); cc =ccf(ccf1,ccf2); meanr1 =mean(bagrss1); meanr2 =mean(bagrss2); meanssq1=mean(bagssq1); meanssq2=mean(bagssq2); if(itype.ne.4.and.itype.ne.5)then; call tabulate(xname,coef,t,meanbcof,medbcof,meanbt,medbt); endif; if(iprintc.gt.0)then; call print('Correlations for bag sample ',ccf1); call print('Correlations for oob sample ',ccf2); endif; if(iprintc.lt.0)then; call tabulate(bagrss1,bagrss2,bagssq1,bagssq2,ccf1,ccf2 :title 'Detailed Data for bag and OOB samples'); call print(' '); endif; if(iprintc.eq.0)call print(' '); call print('Mean correlation for bag sample ',meanc1:); call print('Standard Deviation ',sdc1:); call print('Mean correlation for oob sample ',meanc2:); call print('Standard Deviation ',sdc2:); call print('Correlation of bag and OOB correlations ',cc:); call print('Mean residual sum of squares for bag sample',meanr1:); call print('Mean residual sum of squares for oob sample',meanr2:); call print('Mean residual SE for bag sample ',meanssq1:); call print('Mean residual SE for oob sample ',meanssq2:); return; end; subroutine bag(y,x,y1,yhat1,res1,y2,yhat2,res2,coef1,t1,rss1,rss2,x1,x2, ssq1,ssq2,corr1,corr2,inbag,e,itype,basedf,class_k,iprint); /; /; Implements bagging as discribed in Hastie- Tibshirani-Friedman /; /; Code is experimental and can change /; /; OLS, GAM, L1 and MINIMAX Supported /; /; y => left hand variable. Usually set as %y from olsq /; x => n by k matrix of right hand side variables /; set as %x from call olsq /; y1 => y for bag dataset /; yhat1 => Forecasted y for bag dataset /; res1 => Residual for bag dataset /; y2 => y for out of bag dataset /; yhat2 => Forecasted y for out of bag dataset /; res2 => Residual for out of bag dataset /; x1 => bag x matrix /; x2 => oob x matrix /; coef1 => Coefficients for bag dataset /; z1 => z for bag dataset /; rss1 => Residual sum of squares for bag dataset /; rss2 => Residual sum of squares for out of bag dataset /; ssq1 => sqrt(resvar1) /; ssq2 => sqrt(resvar2) /; corr1 => Correlation y and yhat for bag dataset /; corr2 => Correlation y and yhat for oob dataset /; inbag => work vector telling what vectors in X used /; inbag = 1. implies that observation in /; e => % in bag usually .6667 /; itype => =0 OLS, =1 GAM, =2, L1 =3 minimax, =4 ppreg, =5 marspline /; basedf => Sets DF of gam smoothing. Usually set as 3.0 /; Assume 8 series where df set to 3 /; If first series is 0-1 can set basedf=1. and test rest /; default /; /; For ppreg sets switches such as /; :alpha .3 => smoothing /; :m k => # trees /; :reg => continuous data (default) /; /; As an example basef = ':alpha .3 :class 3'; /; /; For marspline sets switches such as /; :nk 50 :mi 2 /; /; class_k => set = 0 for ppreg :reg models, /; set to number of classes for ppreg :class models /; iprint => =0 no printing, =1 print step data, =2 print OLS step also /; /; /; Built 5 December 2011 by Houston H. Stokes /; Mods 18 January 2012 /; inbag=(rec(array(norows(x):)).le.e); outbag=(inbag.eq.0.0); nn1=idint(sum(inbag)); nn2=norows(x)-nn1; ndf1=nn1-nocols(x); ndf2=nn2-nocols(x); if(itype.eq.0)then; if(iprint.lt.2)call olsq(y x :sample inbag :noint :savex); if(iprint.gt.1)call olsq(y x :sample inbag :noint :savex :print); coef1=vfam(%coef); t1 =vfam(%t); yhat1=%yhat; y1=%y; res1=%res; ssq1=missing(); rss1=sumsq(res1); if(ndf1.gt.1)then; ssq1=sqrt(rss1/dfloat(ndf1)); endif; endif; /; gam if(itype.eq.1)then; xx=x; call deletecol(xx); if(iprint.lt.2)call gamfit(y xx :basedf basedf :sample inbag :savex); if(iprint.gt.1)call gamfit(y xx :basedf basedf :sample inbag :savex :print); coef1=vfam(%coef); t1 =vfam(%z); yhat1=%yhat; y1=%y; res1=%res; ssq1=missing(); rss1=sumsq(res1); if(ndf1.gt.1)then; ssq1=sqrt(rss1/dfloat(ndf1)); endif; endif; /; L1 if(itype.eq.2)then; if(iprint.lt.2)call olsq(y x :sample inbag :noint :savex :L1); if(iprint.gt.1)call olsq(y x :sample inbag :noint :savex :L1 :print); coef1=vfam(%l1coef); t1 =missing(); yhat1=%l1yhat; y1=%y; res1=%l1res; ssq1=missing(); rss1=sumsq(res1); if(ndf1.gt.1)then; ssq1=sqrt(rss1/dfloat(ndf1)); endif; endif; /; MINIMAX if(itype.eq.3)then; if(iprint.lt.2)call olsq(y x :sample inbag :noint :savex :minimax); if(iprint.gt.1)call olsq(y x :sample inbag :noint :minimax :print); coef1=vfam(%mmcoef); t1 =missing(); yhat1=%mmyhat; y1=%y; res1=%mmres; ssq1=missing(); rss1=sumsq(res1); if(ndf1.gt.1)then; ssq1=sqrt(rss1/dfloat(ndf1)); endif; endif; /; PPREG if(itype.eq.4)then; xx=x; call deletecol(xx); if(class_k.eq.0)then; if(iprint.lt.2)call ppreg(y xx :sample inbag :savex :savemodel argument(basedf) :reg); if(iprint.gt.1)call ppreg(y xx :sample inbag :savex :savemodel argument(basedf) :reg :print); endif; if(class_k.ne.0)then; if(iprint.lt.2)call ppreg(y xx :sample inbag :savex :savemodel argument(basedf) :class class_k); if(iprint.gt.1)call ppreg(y xx :sample inbag :savex :savemodel argument(basedf) :class class_k :print); endif; coef1=missing(); t1 =missing(); yhat1=%yhat; y1=%y; res1=%res; ssq1=missing(); rss1=sumsq(res1); if(ndf1.gt.1)then; ssq1=sqrt(rss1/dfloat(ndf1)); endif; endif; /; MARSPLINE if(itype.eq.5)then; xx=x; call deletecol(xx); if(iprint.lt.2)call marspline(y xx :sample inbag :savex :savemodel argument(basedf)); if(iprint.gt.1)call marspline(y xx :sample inbag :savex :savemodel argument(basedf) :print); coef1=missing(); t1 =missing(); yhat1=%yhat; y1=%y; res1=%res; ssq1=missing(); rss1=sumsq(res1); if(ndf1.gt.1)then; ssq1=sqrt(rss1/dfloat(ndf1)); endif; endif; x1=%x; x2=matrix(nn2,nocols(x):); y2 =vector(nn2:); /; This code is clear but slow /; itest=0; /; do j=1,norows(x); /; if(outbag(j).ne.0.0)then; /; itest=itest+1; /; y2(itest) =y(j); /; x2(itest,)=x(j,); /; endif; /; enddo; /; This code is less clear but very much faster ibase=afam(dfloat(integers(1,norows(x)))); ibase = ibase * afam(outbag); ibaseout=integers(1,nn2); r=ranker(ibase); ibase=ibase(r); ibase=idint(ibase); call deleterow(ibase,1,nn1); x2(ibaseout,) =x(ibase,); y2(ibaseout) =y(ibase); /; Get yhat for OLS, L1, MINIMAX if(itype.eq.0.or.itype.eq.2.or.itype.eq.3)then; yhat2=mfam(x2)*coef1; res2=vfam(y2)-yhat2; rss2=sumsq(res2); ssq2=missing(); endif; /; Get yhat for GAM if(itype.eq.1)then; degmod=5; newx2=x2; call deletecol(newx2); call gamfore(%spline,%x,newx2,degmod,coef1,yhat2,%link,%vartype, %df,0); res2=vfam(y2)-vfam(yhat2); rss2=sumsq(res2); ssq2=missing(); endif; /; ppreg if(itype.eq.4)then; if(class_k.eq.0)then; if(iprint.lt.2)call ppreg(:forecast x2 :reg ); if(iprint.gt.1)call ppreg(:forecast x2 :reg :print); endif; if(class_k.ne.0)then; if(iprint.lt.2)call ppreg(:forecast x2 :class class_k ); if(iprint.gt.1)call ppreg(:forecast x2 :class class_k :print); endif; yhat2=%fore; res2=vfam(y2)-vfam(yhat2); rss2=sumsq(res2); ssq2=missing(); endif; /; marspline if(itype.eq.5)then; xx2=x2; call deletecol(xx2); if(iprint.lt.2)call marspline(%y %x :getmodel 'marss.psv' :forecast xx2 ); if(iprint.gt.1)call marspline(%y %x :getmodel 'marss.psv' :forecast xx2 :print); yhat2=%fore; res2=vfam(y2)-vfam(yhat2); rss2=sumsq(res2); ssq2=missing(); endif; if(ndf2.gt.0)then; ssq2=sqrt(rss2/dfloat(ndf2)); endif; corr1=ccf(y1,yhat1); corr2=ccf(y2,yhat2); if(iprint.ne.0)then; call print(' '); call print('Residual sum of squares for bag dataset ',rss1:); call print('Residual sum of squares for oob dataset ',rss2:); call print('Number of Observations in bag dataset ',nn1:); call print('Number of Observations in oob dataset ',nn2:); call print('Sigma Squared bag dataset ',ssq1:); call print('Sigma Squared oob dataset ',ssq2:); call print('Correlation y & yhat for bag dataset ',corr1:); call print('Correlation y & yhat for oob dataset ',corr2:); endif; return; end; == ==BOOST BOOST, BOOST2, BOOST3 & BOOST4 code /; /; These routines are subject to change /; /; BOOST does the usual Boosting procedure /; BOOST2 does Modified Forward Statewise model boosting /; BOOST3 Works simular to BOOST but does not require data centering /; saves vector info and coefficients for using with boost4 /; BOOST4 Allows out of sample forecasting for model estimated with /; boost3 /; subroutine boost(y,yhat,res,x,in,e,ipass,itype,iprint); /; /; Implements OLS boosting as discribed in "Least Angle Regression" /; by Bradley Efron, Trevor Hastie, Iain Johnson and Robert Tibshirani /; The Annals of Statistics Vol 32 No. 2 (April 2004) pp 407-451 /; /; y => left hand variable /; yhat => Forecasted y /; res => error /; x => n by k matrix of right hand side variables /; in => work vector telling what vectors in X used /; in = 0 implies that vector in /; e => Step size - use a small number /; ipass => Number of times called. Be sure called enough times /; one way to test this is to monitor progress in the /; correlation improvement /; itype => =0 OLS, =1 MARS, =2 GAM, =3 L1 =4 minimax /; iprint => =0 no printing, =1 print step data, =2 print correlations /; /; Note: X must be centered. Y must have mean removed. Code to do this /; is shown next /; /; b34sexec matrix; /; call loaddata; /; call load(center :staging); /; call load(center2 :staging); /; call load(boost :staging); /; call echooff; /; /; iboost=0 => ols boost /; iboost=1 => modified OLS boost /; iboost=0; /; e=.01 ; /; ntry=900; /; /; itype=0 => ols /; itype=1 => mars /; itype=2 => gam not ready /; itype=0; /; iprint=0; /; /; x=center2(catcol(age sex bmi bp s1 s2 s3 s4 s5 s6)); /; y=y-mean(y); /; /; fit=array(ntry:); /; /; do i=1,ntry; /; if(iboost.eq.0)call boost( y,yhat,res,x,in,e,i,itype,iprint); /; if(iboost.eq.1)call boost2(y,yhat,res,x,xbuild,in,e,i,itype, /; iprint); /; fit(i)=ccf(y,yhat); /; /; call outstring(1,2,'Iteration'); /; call outinteger(20,2,i); /; call outstring(1,3,'Correlation'); /; call outdouble(20,3,fit(i)); /; enddo; /; /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; This routine only adds one tree at a time. /; /; This procedure is very effective is data mining applications /; where there are many columns in X and the objective is to /; obtain the information in x without the "cost" of forming /; X'X /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; cc=array(nocols(x):); if(ipass.eq.1)then; in=array(nocols(x):)+1.; yhat=y*0.0; res=y; endif; do i=1,nocols(x); cc(i)=ccf(res,x(,i)); enddo; /; cc=afam(cc)*afam(in); ij=imax(abs(cc)); if(iprint.eq.2)then; call print('Largest Correlation vector was ',ij:); call tabulate(in,cc); endif; /; in(ij)=0.0; if(iprint.eq.0)then; if(itype.eq.0)call olsq( res,x(,ij) :noint); if(itype.eq.1)call marspline(res,x(,ij) ); if(itype.eq.2)call gamfit( res,x(,ij)[predictor,3] :noint); if(itype.eq.3)call olsq( res,x(,ij) :noint :l1); if(itype.eq.4)call olsq( res,x(,ij) :noint :minimax); endif; if(iprint.ne.0)then; if(itype.eq.0)call olsq( res,x(,ij) :noint :print); if(itype.eq.1)call marspline(res,x(,ij) :print ); if(itype.eq.2)call gamfit( res,x(,ij)[predictor,3] :noint :print); if(itype.eq.3)call olsq( res,x(,ij) :noint :print :l1); if(itype.eq.4)call olsq( res,x(,ij) :noint :print :minimax); endif; if(itype.eq.3)%yhat=%l1yhat; if(itype.eq.4)%yhat=%mmyhat; yhat=yhat+ afam(e)*afam(%yhat); res=y-yhat; return; end; subroutine boost2(y,yhat,res,x,xbuild,in,e,ipass,itype,iprint); /; /; Implements modified OLS/MARS/GAM boosting /; Suggested by below listed reference as an interesting extension /; to boosting. This can be thought of as Modified Forward Stagewise /; boosting /; /; Modified OLS boosting is described in "Least Angle Regression" /; by Bradley Efron, Trevor Hastie, Iain Johnson and Robert Tibshirani /; The Annals of Statistics Vol 32 No. 2 (April 2004) pp 407-451 /; /; y => left hand variable /; yhat => Forecasted y /; res => error /; x => n by k matrix of right hand side variables /; xbuild => Work array. /; in => work vector telling what vectors in X used in set = 0 /; e => Step size /; ipass => Number of times called /; itype => =0 OLS, =1 MARS, =2 GAM, =3 L1, =4 Minimax /; iprint => =0 no printing, =1 print step data, =2 print correlations /; /; Note: X must be centered. Y must have mean removed. Code to do this /; is shown next /; /; b34sexec matrix; /; call loaddata; /; call load(center :staging); /; call load(center2 :staging); /; call load(boost :staging); /; call echooff; /; /; iboost=0 => ols boost /; iboost=1 => modified OLS boost /; iboost=0; /; e=.01 ; /; ntry=900; /; /; itype=0 => ols /; itype=1 => mars /; itype=2 => gam not ready /; itype=0; /; iprint=0; /; /; x=center2(catcol(age sex bmi bp s1 s2 s3 s4 s5 s6)); /; y=y-mean(y); /; /; fit=array(ntry:); /; /; do i=1,ntry; /; if(iboost.eq.0)call boost( y,yhat,res,x,in,e,i,itype,iprint); /; if(iboost.eq.1)call boost2(y,yhat,res,x,xbuild,in,e,i,itype, /; iprint); /; fit(i)=ccf(y,yhat); /; /; call outstring(1,2,'Iteration'); /; call outinteger(20,2,i); /; call outstring(1,3,'Correlation'); /; call outdouble(20,3,fit(i)); /; enddo; /; /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; This routine only adds new tree plus all old trees at each step. /; This is called modified Forward Statewise /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; cc=array(nocols(x):); if(ipass.eq.1)then; in=array(nocols(x):)+1.; yhat=y*0.0; res=y; endif; do i=1,nocols(x); cc(i)=ccf(res,x(,i)); enddo; /; cc=afam(cc)*afam(in); ij=imax(abs(cc)); if(iprint.eq.2)then; call print('Largest Correlation vector was ',ij:); call tabulate(in,cc); endif; if(iprint.ne.0)call print(ipass,cc,ij); if(ipass.eq.1) xbuild=array(norows(x),1:x(,ij)); if(ipass.gt.1.and.in(ij).ne.0.0)xbuild=catcol(xbuild,x(,ij)); in(ij)=0.0; do j=1,nocols(xbuild); if(iprint.eq.0)then; if(itype.eq.0)call olsq( res,xbuild(,j):noint); if(itype.eq.1)call marspline(res,xbuild(,j)); if(itype.eq.2)call gamfit( res,xbuild(,j)[predictor,3] :noint); if(itype.eq.3)call olsq( res,xbuild(,j):noint :l1); if(itype.eq.4)call olsq( res,xbuild(,j):noint :minimax); endif; if(iprint.ne.0)then; if(itype.eq.0)call olsq( res,xbuild(,j) :noint :print); if(itype.eq.1)call marspline(res,xbuild(,j) :print); if(itype.eq.2)call gamfit( res,xbuild(,j)[predictor,3] :noint :print); if(itype.eq.3)call olsq( res,xbuild(,j) :noint :print :l1); if(itype.eq.4)call olsq( res,xbuild(,j) :noint :print :minimax); endif; if(itype.eq.3)%yhat=%l1yhat; if(itype.eq.4)%yhat=%mmyhat; yhat=yhat+ afam(e)*afam(%yhat); res=y-yhat; enddo; return; end; subroutine boost3(y,yhat,res,x,in,beta1,beta2,e,ipass,itype,iprint); /; /; Implements a mod to OLS boosting as described in /; "Least Angle Regression" /; by Bradley Efron, Trevor Hastie, Iain Johnson and Robert Tibshirani /; The Annals of Statistics Vol 32 No. 2 (April 2004) pp 407-451 /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; HHS Mods involve use of constant and no mean adjustment /; Goal is to facilitate forecasting using boost4 routine /; in, beta1, beta2 used as input into boost4 /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; y => left hand variable /; yhat => Forecasted y /; res => error /; x => n by k matrix of right hand side variables /; in => work vector telling vector in X used /; beta1 => saves the beta /; beta2 => saves the constant /; e => Step size - use a small number /; ipass => Number of times called. Be sure called enough times /; one way to test this is to monitor progress in the /; correlation improvement /; itype => =0 OLS, =1 MARS, =2 GAM, =3 L1 =4 minimax /; iprint => =0 no printing, =1 print step data, =2 print correlations /; /; b34sexec matrix; /; call loaddata; /; call load(center ); /; call load(center2); /; call load(boost ); /; call echooff; /; /; e=.01 ; /; ntry=900; /; /; itype=0 => ols /; itype=1 => mars not ready /; itype=2 => gam not ready /; itype=3 => L1 /; itype=4 => MINIMAX /; itype=0; /; iprint=0; /; /; fit =array(ntry:); /; beta1 =array(ntry:); /; beta2 =array(ntry:); /; in =idint(array(ntry:)); /; /; do i=1,ntry; /; call boost3(y,yhat,res,x,in,beta1,beta2,e,i,itype,iprint); /; fit(i)=ccf(y,yhat); /; call outstring(1,2,'Iteration'); /; call outinteger(20,2,i); /; call outstring(1,3,'Correlation'); /; call outdouble(20,3,fit(i)); /; enddo; /; /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; This routine only adds one tree at a time. /; /; This procedure is very effective is data mining applications /; where there are many columns in X and the objective is to /; obtain the information in x without the "cost" of forming /; X'X /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; cc=array(nocols(x):); if(itype.eq.1.or.itype.eq.2)then; call print('ERROR: ITYPE in boots3 cannot be 1 or 2':); call stop; endif; if(ipass.eq.1)then; yhat=y*0.0; res=y; endif; do i=1,nocols(x); cc(i)=ccf(res,x(,i)); enddo; ij=imax(abs(cc)); in(ipass)=ij; if(iprint.eq.2)then; call print('Largest Correlation vector was ',ij:); call tabulate(in,cc); endif; if(iprint.eq.0)then; if(itype.eq.0)call olsq( res,x(,ij) ); /; if(itype.eq.1)call marspline(res,x(,ij) ); /; if(itype.eq.2)call gamfit( res,x(,ij)[predictor,3] :noint); if(itype.eq.3)call olsq( res,x(,ij) :l1); if(itype.eq.4)call olsq( res,x(,ij) :minimax); endif; if(iprint.ne.0)then; if(itype.eq.0)call olsq( res,x(,ij) :print); /; if(itype.eq.1)call marspline(res,x(,ij) :print ); /; if(itype.eq.2)call gamfit( res,x(,ij)[predictor,3] :noint :print); if(itype.eq.3)call olsq( res,x(,ij) :print :l1); if(itype.eq.4)call olsq( res,x(,ij) :print :minimax); endif; if(itype.eq.0)then; beta1(ipass)=%coef(1); beta2(ipass)=%coef(2); endif; if(itype.eq.3)then; %yhat=%l1yhat; beta1(ipass)=%l1coef(1); beta2(ipass)=%l1coef(2); endif; if(itype.eq.4)then; %yhat=%mmyhat; beta1(ipass)=%mmcoef(1); beta2(ipass)=%mmcoef(2); endif; yhat=yhat+ afam(e)*afam(%yhat); res=y-yhat; return; end; subroutine boost4(yhat,x,in,beta1,beta2,e); /; /; HHS boosting Forecasting for model estimated with boost3 /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; HHS Mods involve use of constant and no mean adjustment /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; yhat => Forecasted y /; x => n by k matrix of right hand side variables /; in => work vector telling what vectors in X used /; beta1 => Beta Coef /; beta2 => Constant coef /; e => Step size used /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; yhat=array(norows(x):); do i=1,norows(beta1); add=(beta1(i)*x(,in(i)))+beta2(i); yhat=yhat+ afam(e)*afam(add); enddo; return; end; == ==BOOTOLS Bootstrap OLS Model subroutine bootols(y,xin,error,coef,nboot,bcoef,bse,isave,lag); /; /; Bootstrap a model y = f(x) /; /; OLS Estimation used /; /; Usually y = %y from olsq call /; xin = %x from olsq. usually built with call with /; :savex option /; Note: that xin is a matrix and when lags are /; present has the lagged data already in the /; matrix. /; error = %res from olsq call /; coef = %coef from olsq call /; nboot = # of bootstraps /; bcoef = bootstrap coef /; bse = bootstrap se /; isave = 0 => do not save internal variables /; 1 => save %hcoef %hse %hrsq in global variables /; lag NE 0 assumes there are lag y values in x /; %hcoef = nboot by k matrix of estimated coefficients /; %hse = nboot by k matrix of estimated se scores /; %hrsq = nboot vector of r**2 /; /; Since lags already in the x matrix => works for cross section /; or time series models /; /; Note: Simulate is used to speed up recursive nature of /; problem when lag > 0. Simulate uses added space and is not /; used when lag=0 /; /; Command built 20 August 2003 /; /; **************************************************************** /; /; Example: /; /; b34sexec options ginclude('gas.b34')$ b34srun$ /; b34sexec matrix$ /; call loaddata; /; call echooff; /; /; call load(bootols,'c:\b34slm\staging2.mac'); /; /$ call load(bootols,'/usr/local/lib/b34slm/staging2.mac'); /; /; call print(bootols)$ /; nlag=6$ /; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} /; :print :savex)$ /; /; nboot=50; /; isave=1; /; lag=0; /; /; call bootols(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /; /$ call print(%hcoef,%hse,%hrsq)$ /; call print(bcoef,bse); /; /; call print('Boot Strap Assuming Time Series Correction':); /; /; lag=nlag; /; call bootols(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /; /$ call print(%hcoef,%hse,%hrsq)$ /; call print(bcoef,bse); /; /; b34srun$ /; /; End of Example of Use /; /; **************************************************************** /; x=xin; nob=norows(x); %hcoef=matrix(nboot,nocols(x):); %hse =matrix(nboot,nocols(x):); %hrsq =vector(nboot:); ywork=vector(nob:); error=vfam(error); if(lag.eq.0)then; do ii=1,nboot; ywork=vfam(coef)*transpose(mfam(x))+ error(booti(nob)); /; /; simulate uses more space and provides no gain /; call simulate(ywork,coef,x,bootv(error)); /; call olsq(ywork x :noint); %hcoef(ii,)=%coef; %hse(ii,) =%se; %hrsq(ii) =%rsq; call outstring(3,3,'Bootstrap #'); call outinteger(30,3,ii); enddo; endif; if(lag.ne.0)then; do ii=1,nboot; call simulate(ywork,coef,x,bootv(error) :lags lag bootv(y)); call olsq(ywork x :noint); %hcoef(ii,)=%coef; %hse(ii,) =%se; %hrsq(ii) =%rsq; call outstring(3,4,'Time Series Bootstrap #'); call outinteger(30,4,ii); x=xin; enddo; endif; bcoef=vector(nocols(%hcoef):); bse =vector(nocols(%hcoef):); do j=1,nocols(%hcoef); bcoef(j)=mean(%hcoef(,j)); call quantile(%hcoef(,j),.025, lower); call quantile(%hcoef(,j),.975, upper); if(upper.ne.lower)bse(j)=(upper-lower)/4.0; enddo; if(isave.eq.1)then; call copy(%hcoef,%hcoef,level()-1); call copy(%hse, %hse, level()-1); call copy(%hrsq, %hrsq, level()-1); endif; return; end; == ==BOOTPLOT Plots an ordered series subroutine bootplot(series,yaxis,heading,filename,noshow); /; /; Display a sorted Series /; /; series => Series to be displayed /; yaxis => Character string for Y axis /; heading => Title for plot /; filename => File Name for saved plot /; noshow => =0 1f show plot, otherwise just save plot /; /; Built 13 February 2008 /; +++++++++++++++++++++++++++++++++++++++++++++++ hold=series; hold=hold(ranker(series)); if(noshow.eq.0)call graph(hold :ylabelleft yaxis 'C9' :heading heading :file filename); if(noshow.eq.1)call graph(hold :ylabelleft yaxis 'C9' :heading heading :file filename); return; end; == ==BOOTL1 Bootstrap L1 Model subroutine bootl1(y,xin,error,coef,nboot,bcoef,bse,isave,lag); /; /; Bootstrap a model y = f(x) /; /; L1 Estimator Used /; /; Usually y = %y from olsq call /; xin = %x from olsq. usually built with call with /; :savex option /; Note: that xin is a matrix and when lags are /; present has the lagged data already in the /; matrix. /; error = %res from olsq call /; coef = %coef from olsq call /; nboot = # of bootstraps /; bcoef = bootstrap coef /; bse = bootstrap se /; isave = 0 => do not save internal variables /; 1 => save %hcoef %hse %hrsq in global variables /; lag NE 0 assumes there are lag y values in x /; %hcoef = nboot by k matrix of estimated coefficients /; /; Since lags already in the x matrix => works for cross section /; or time series models /; /; Note: Simulate is used to speed up recursive nature of /; problem when lag > 0. Simulate uses added space and is not /; used when lag=0 /; /; Command built 12 September 2003 /; /; **************************************************************** /; /; Example: /; /; /; b34sexec options ginclude('gas.b34')$ b34srun$ /; b34sexec matrix$ /; call loaddata; /; call echooff; /; /; call load(bootl1,'c:\b34slm\staging2.mac'); /; /$ call load(bootl1,'/usr/local/lib/b34slm/staging2.mac'); /; /; call print(bootl1)$ /; nlag=6$ /; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :l1 /; :print :savex)$ /; /; nboot=50; /; isave=1; /; lag=0; /; /; call bootl1(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /; /$ call print(%hcoef,%hse,%hrsq)$ /; call print(bcoef,bse); /; /; call print('Boot Strap Assuming Time Series Correction':); /; /; lag=nlag; /; call bootl1(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /; /$ call print(%hcoef)$ /; call print(bcoef,bse); /; /; b34srun$ /; /; End of Example of Use /; /; **************************************************************** /; x=xin; nob=norows(x); %hcoef=matrix(nboot,nocols(x):); ywork=vector(nob:); error=vfam(error); if(lag.eq.0)then; do ii=1,nboot; ywork=vfam(coef)*transpose(mfam(x))+ error(booti(nob)); /; /; simulate uses more space and provides no gain /; call simulate(ywork,coef,x,bootv(error)); /; call olsq(ywork x :noint :l1); %hcoef(ii,)=%l1coef; call outstring(3,3,'L1 Bootstrap #'); call outinteger(30,3,ii); enddo; endif; if(lag.ne.0)then; do ii=1,nboot; call simulate(ywork,coef,x,bootv(error) :lags lag bootv(y)); call olsq(ywork x :noint :l1); %hcoef(ii,)=%l1coef; call outstring(3,4,'Time Series L1 Bootstrap #'); call outinteger(30,4,ii); x=xin; enddo; endif; bcoef=vector(nocols(%hcoef):); bse =vector(nocols(%hcoef):); do j=1,nocols(%hcoef); bcoef(j)=mean(%hcoef(,j)); call quantile(%hcoef(,j),.025, lower); call quantile(%hcoef(,j),.975, upper); if(upper.ne.lower)bse(j)=(upper-lower)/4.0; enddo; if(isave.eq.1)call copy(%hcoef,%hcoef,level()-1); return; end; == ==BOOTMM Bootstrap MM Model subroutine bootmm(y,xin,error,coef,nboot,bcoef,bse,isave,lag); /; /; Bootstrap a model y = f(x) /; /; Minimax estimator used /; /; /; Usually y = %y from olsq call /; xin = %x from olsq. usually built with call with /; :savex option /; Note: that xin is a matrix and when lags are /; present has the lagged data already in the /; matrix. /; error = %res from olsq call /; coef = %coef from olsq call /; nboot = # of bootstraps /; bcoef = bootstrap coef /; bse = bootstrap se /; isave = 0 => do not save internal variables /; 1 => save %hcoef %hse %hrsq in global variables /; lag NE 0 assumes there are lag y values in x /; %hcoef = nboot by k matrix of estimated coefficients /; %hse = nboot by k matrix of estimated se scores /; %hrsq = nboot vector of r**2 /; /; Since lags already in the x matrix => works for cross section /; or time series models /; /; Note: Simulate is used to speed up recursive nature of /; problem when lag > 0. Simulate uses added space and is not /; used when lag=0 /; /; Command built 12 September 2003 /; /; **************************************************************** /; /; Example: /; /; b34sexec options ginclude('gas.b34')$ b34srun$ /; b34sexec matrix$ /; call loaddata; /; call echooff; /; /; call load(bootmm,'c:\b34slm\staging2.mac'); /; /$ call load(bootmm,'/usr/local/lib/b34slm/staging2.mac'); /; /; call print(bootmm)$ /; nlag=6$ /; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :minimax /; :print :savex)$ /; /; nboot=50; /; isave=1; /; lag=0; /; /; call bootmm(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /; /$ call print(%hcoef,%hse,%hrsq)$ /; call print(bcoef,bse); /; /; call print('Boot Strap Assuming Time Series Correction':); /; /; lag=nlag; /; call bootmm(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /; /$ call print(%hcoef,%hse,%hrsq)$ /; call print(bcoef,bse); /; /; b34srun$ /; /; End of Example of Use /; /; **************************************************************** /; x=xin; nob=norows(x); %hcoef=matrix(nboot,nocols(x):); ywork=vector(nob:); error=vfam(error); if(lag.eq.0)then; do ii=1,nboot; ywork=vfam(coef)*transpose(mfam(x))+ error(booti(nob)); /; /; simulate uses more space and provides no gain /; call simulate(ywork,coef,x,bootv(error)); /; call olsq(ywork x :noint :minimax); %hcoef(ii,)=%mmcoef; call outstring(3,3,'MM Bootstrap #'); call outinteger(30,3,ii); enddo; endif; if(lag.ne.0)then; do ii=1,nboot; call simulate(ywork,coef,x,bootv(error) :lags lag bootv(y)); call olsq(ywork x :noint :minimax); %hcoef(ii,)=%coef; call outstring(3,4,'Time Series MM Bootstrap #'); call outinteger(30,4,ii); x=xin; enddo; endif; bcoef=vector(nocols(%hcoef):); bse =vector(nocols(%hcoef):); do j=1,nocols(%hcoef); bcoef(j)=mean(%hcoef(,j)); call quantile(%hcoef(,j),.025, lower); call quantile(%hcoef(,j),.975, upper); if(upper.ne.lower)bse(j)=(upper-lower)/4.0; enddo; if(isave.eq.1)call copy(%hcoef,%hcoef,level()-1); return; end; == ==BUILDLAG Builds NEWY and NEWX for VAR Modeling subroutine buildlag(x,nlag,ibegin,iend,newx,newy); /; /; This routine builds lags of x for VAR modeling /; new y is also built /; x(n,k) - n,k matrix of data values /; nlag - Number of lags /; ibegin - Begin Data point /; iend - End Data Point /; newx - nob,(nlags*k) matrix of x variables /; newy - nob,k matrix of left hand variables /; nob=iend-ibegin+1-nlag /; 10 October 2002 /; ************************************************************** nfinal=iend-ibegin+1-nlag; newy=mfam(submatrix(x,ibegin+nlag,iend, 1,nocols(x))); newx=mfam(submatrix(x,ibegin+nlag-1, ibegin+nlag+nfinal-2,1,nocols(x))); if(nlag.gt.1)then; do j=2,nlag; newx=catcol(newx, mfam(submatrix(x,ibegin+nlag-j, ibegin+nlag-j+nfinal-1,1,nocols(x)))); enddo; endif; return; end; == ==CATS Cointegration Analysis using Johansen Approach subroutine cats(y,maxlag,eigval,eigvec,lamtrace,lammax, alpha,beta,pi,icon,itrend,iprint,ieprint); /; /; Implements Johansen (1988, ,1992) Cointegration Testing Methods /; as discussed in William Greene 2008, pp 761-767 /; /; See also Russell Davidson and James MacKinnon /; 'Econometric Theory and Methods' (2004) 640-641. /; /; This routine is experimental. It is intended as a first pass at /; testing for cointegration using the Johansen method. For more /; extended analysis, see "CATS in Rats" which was developed under /; Johansen and is available from Estima. /; /; y = basic data of VAR model to be tested /; maxlag = must be ge 1 /; eigval = ordered eigenvalues /; eigvec = ordered eigenvectors /; lamtrace = eigenvalue trace test /; lammax = eigenvalue max test /; alpha = Speed of adjustment matrix /; beta = BIG_Z=psi(dd)*eigvec /; psi(dd)*transpose(psi(dd)=inv(sigma(dd)) /; beta is first k by k matrix in big_Z /; pi = alpha * transpose(beta) /; icon = 1 => have constant in model /; itrend = 1 => have trend in the model /; testtab = Test table /; iprint = 1 => print extended results /; ieprint = 1 => print steps /; /; Basic code implemented in Beta release September 2009. /; Improvements October 2011 /; by Houston H. Stokes /; k=nocols(y); n=norows(y); new_y=y; nn=n-maxlag-1; /; Row 1 95% of Table C.1 trace test of CATS Manual /; Row 2 95% of Table C.3 of Cats Manual /; Rom 3 ? /; Row 4 95% of Table C.1 cointegrating rank Cats manual testtab=array(4,12: 4.07 12.28 24.21 40.10 59.96 83.82 111.68 143.53 179.38 219.23 263.09 310.94 3.84 15.41 29.80 47.71 69.61 95.51 125.42 159.32 197.22 239.12 285.02 334.92 3.84 18.15 34.56 54.11 77.79 104.76 135.75 170.15 208.53 250.53 296.02 345.27 9.14 20.16 35.07 53.94 76.81 103.68 134.54 169.41 208.27 251.13 297.99 348.85); testtab=transpose(testtab); /; if(iprint.ne.0)then; call print(' ':); call print('CATS B34S Version - Beta Test October 2011':); call print('Number of observations in raw series ',n:); call print('Number of series ',k:); call print('Number of lags ',maxlag:); call print('Number of Data points for analysis ',nn:); if(icon .ne.0 )call print('Constant assumed':); if(icon .eq.0 )call print('Constant not assumed':); if(itrend.ne.0)call print('Trend assumed':); if(itrend.eq.0)call print('Trend not assumed':); call print(' ':); /; endif; /; ydif=matrix(n-1,k:); /; do i=1,k; ydif(,i)=dif(y(,i),1,1); enddo; /; /; d = residuals of delta y on z /; e = residuals of y(t-p) on z /; d=matrix(nn,k*(maxlag):); e=matrix(nn,k*(maxlag):); /; /; build z /; z=lag(ydif,1); if(maxlag.gt.1)then; do i=2,maxlag; z=catcol(z,lag(ydif,i)); enddo; endif; z=goodrow(z); if(nn.ne.norows(z))then; call print('ERROR: Logic error in cats - nn .ne. norows(z)':); call print(' nn was ',nn:); call print(' norows(z) was ',norows(z):); call stop; endif; n1=norows(ydif); n2=norows(z); if(n1.gt.n2)then; ydif2=dropfirst(ydif,n1-n2); ydif2=goodrow(ydif2); endif; yt_m_p=goodrow(lag(y,1)); n3=norows(yt_m_p); if(n3.gt.n2)then; yt_m_p = dropfirst(yt_m_p,n3-n2); yt_m_p= goodrow(yt_m_p); endif; /; /; get d=> get residuals of delta y on z /; trend=dfloat(integers(1,norows(z))); one=array(norows(z):)+1.; arg=' '; if(itrend.ne.0.and.icon.eq.0)arg='trend'; if(itrend.ne.0.and.icon.ne.0)arg='trend one'; if(itrend.eq.0.and.icon.ne.0)arg='one'; /; do i=1,k; if(ieprint.ne.0)call print(' ':); if(ieprint.ne.0)call print('Delta y = f(z,t) for series ',i:); if(ieprint.ne.0)call olsq(ydif2(,i) z argument(arg) :noint :qr :print); if(ieprint.eq.0)call olsq(ydif2(,i) z argument(arg) :noint :qr ); d(,i)=%res; enddo; /; /; get e=> get residuals of y(t-p) on z /; do i=1,k; if(ieprint.ne.0)call print(' ':); if(ieprint.ne.0)call print('y(t-p) = f(z,t) for series ',i:); if(ieprint.ne.0)call olsq(yt_m_p(,i) z argument(arg) :noint :qr :print); if(ieprint.eq.0)call olsq(yt_m_p(,i) z argument(arg) :noint :qr ); e(,i)=%res; enddo; /; rdd=matrix(k,k:); rde=matrix(k,k:); ree=matrix(k,k:); red=matrix(k,k:); /; do i=1,k; do j=1,k; rdd(i,j)=ccf(d(,i),d(,j)); rde(i,j)=ccf(d(,i),e(,j)); ree(i,j)=ccf(e(,i),e(,j)); red(i,j)=ccf(e(,i),d(,j)); enddo; enddo; /; if(ieprint.ne.0)then; call print(rdd,rde,ree,red); call print(ydif2,yt_m_p,z,d,e); endif; /; pp=-.5; rstar = real(complex(rdd)**complex(pp))*rde*inv(ree)*red *real(complex(rdd)**complex(pp)); /; /; eigval= eigenval(rstar,eigvec :lapack); /; eigval= seigenval(rstar,eigvec); alpha=eigval; beta =eigvec; jj=0; /; lamtrace=vector(k:); lammax =vector(k:); /; do i=k,1,-1; jj=jj+1; eigval(jj)=alpha(i); eigvec(,jj)=beta(,i); lammax(jj) =dfloat(((-1)*nn))*(dlog(1.- eigval(jj))); enddo; /; lamtrace(k)=lammax(k); lm_test=lammax*missing(); tr_test=lammax*missing(); jj=1; if(k.le.12)then; do i=k,1,-1; lm_test(jj)=testtab(i,2); tr_test(jj)=testtab(i,1); jj=jj+1; enddo; endif; /; if(k.gt.1)then; do i=k-1,1,-1; lamtrace(i)=lammax(i)+lamtrace(i+1); enddo; endif; /; /; if(iprint.ne.0)then; call tabulate(eigval,lammax,lamtrace,lm_test,tr_test); call print(' ':); call print('lm_test 95% for LR test. Cats Manual Table C3':); call print('value > critical value => Rejects null of r=0.':); call print('tr_test 95% for trace test. Cats Manual Table C1':); call print('value > critical value => variables are cointegrated.':); if(iprint.ne.0)then; call print('R_star',rstar); call print('Eigenvector of rstar',eigvec); tt1=eig(rstar,tt :lapack); tt=real(tt); call print('scaled',tt); endif; /; /; get alpha, beta and pi /; /; what Davidson-MacKinnon call 22 is dd in Greene's notation /; psi_dd= transpose(pdfac(inv(rdd))); /; before reordering eigval2=seigenval(rstar,eigvec2); big_z=psi_dd*eigvec ; /; /; validate calculation so far /; if(iprint.ne.0)then; testbeta=transpose(big_z)*rdd*big_z; call print('psi_ee,big_z, is testbeta=I ?',psi_dd,big_z,testbeta); rstar2 = transpose(psi_dd)*rde*inv(ree)*red*psi_dd; call print('are eig of rstar2 = to eigenvalues of rstar?',seig(rstar2)); endif; /; /; Now get pi from coef of y = f(x y(lags) ) as coef- I /; ylag= lag(y,1); if(maxlag.gt.1)then; do i=2,maxlag; ylag=catcol(ylag,lag(ylag,i)); enddo; endif; ylag=goodrow(ylag); pi=matrix(k,k:); kk=integers(1,k); yt_m_p=y; n2=norows(ylag); n3=norows(yt_m_p); if(n3.gt.n2)then; yt_m_p = dropfirst(yt_m_p,n3-n2); yt_m_p= goodrow(yt_m_p); endif; trend=dfloat(integers(1,norows(ylag))); one=array(norows(ylag):)+1.; beta=submatrix(big_z,1,k,1,k); do i=1,k; if(ieprint.ne.0)call print(' ':); if(ieprint.ne.0)call print('Level Equation for series ',i:); if(ieprint.ne.0) call olsq(yt_m_p(,i) ylag argument(arg) :noint :qr :print); if(ieprint.eq.0) call olsq(yt_m_p(,i) ylag argument(arg) :noint :qr ); pi(i,)=%coef(kk); enddo; ii=matrix(k,k:); ii(kk,kk)=1.0; pi=pi-ii; alpha = mfam(pi)*inv(transpose(beta)); if(iprint.ne.0)then; call print('Alpha - Weight matrix ',alpha); call print('Beta = Cointegrating Parms',beta); call print('Pi ',pi); call print('Eigenvalues of Estimate of Impact Matrix pi',eig(pi)); endif; return; end; == ==CCFTEST Tests Cross Correlations subroutine ccftest(res1,y,nccf,lags,title); /; /; res1 => First Moment Residual /; y => Input Series /; nccf => Number ccf terms /; lags => lags /; title => Title /; /; ********************************************************** /; Version 23 December 2001 /; ********************************************************** call echooff; ccfun=ccf(res1,y,nccf,lags); se1=array(norows(lags):)+ 2.0*(1./dsqrt(dfloat(norows(res1)))); se2=-1.*se1; call tabulate(lags ccfun se1 :title title); call graph(lags ccfun se1,se2 :file 'ccf.wmf' :pspaceon :pgyscaleright 'i' :pgborder :nokey :fitspline :nocontact :nolabel :ylabelleft 'Cross Correlations' 'C9' :plottype xyplot :pgxscaletop 'i' :colors black bblue bred bred :heading title); return; end; == ==CENTER Center a series or 2 D object mean=0 variance=1 function center(x); /; /; Standardizes data such that mean = 0 and unit variance /; X can be an array, vector or matrix /; /; Built 24 February 2008 by Houston H. Stokes if(kind(x).ne.8.and.kind(x).ne.-16)then; call epprint('ERROR: function center requires real*8 or real*16 data':); dataout=missing(); go to finish; endif; if(norows(x).le.1)then; call epprint('ERROR: function center passed one element object':); dataout=missing(); go to finish; endif; dataout=afam(x); if(nocols(x).eq.1)then; v=variance(dataout); dataout=dataout-mean(dataout); if(v.ne.kindas(x,0.0))dataout=dataout/sqrt(v); if(klass(x).eq.1)dataout=vfam(dataout); endif; if(nocols(x).gt.1)then; do i=1,nocols(x); v=variance(dataout(,i)); dataout(,i)=(dataout(,i)-mean(dataout(,i))); if(v.ne.kindas(x,0.0)) dataout(,i)=(dataout(,i))/sqrt(v); enddo; if(klass(x).eq.2)dataout=mfam(dataout); endif; finish continue; return(dataout); end; == ==CENTER2 Standardizes a Series mean=0 Unit length function center2(x); /; /; Standardizes data such that mean = 0 and series has unit length /; X can be an array, vector or matrix /; /; Built 24 February 2008 by Houston H. Stokes if(kind(x).ne.8.and.kind(x).ne.-16)then; call epprint('ERROR: function center2 requires real*8 or real*16 data': ); dataout=missing(); go to finish; endif; if(norows(x).le.1)then; call epprint('ERROR: function center2 passed one element object':); dataout=missing(); endif; dataout=afam(x); if(nocols(x).eq.1)then; dataout=dataout-mean(dataout); v=sumsq(dataout); if(v.ne.kindas(x,0.0))dataout=(dataout-mean(dataout))/sqrt(v); if(klass(x).eq.1)dataout=vfam(dataout); endif; if(nocols(x).gt.1)then; do i=1,nocols(x); dataout(,i)=(dataout(,i)-mean(dataout(,i))); v=sumsq(dataout(,i)); if(v.ne.kindas(x,0.0))dataout(,i)=(dataout(,i))/sqrt(v); enddo; if(klass(x).eq.2)dataout=mfam(dataout); endif; finish continue; return(dataout); end; == ==CFFILTER Christiano-Fitzgerald Filter subroutine cffilter(x,pl,pu,idetrend,fx); /; /; This is program filters time series data using an approximation to /; the band pass filter as discussed in the paper /; "The Band Pass Filter" by Lawrence J. Christiano and /; Terry J. Fitzgerald (1999). /; /; Required Inputs: /; X - series of data to be filtered. Should be real*8. /; pl - minimum period of oscillation of desired component /; pu - maximum period of oscillation of desired component /; (2<=pl Input data. /; sortx => Sorted x data. /; c => cumulative freq if(norows(x).le.0)then; call print('X Data in subroutine CFREQ has no rows.'); go to bad; endif; j=ranker(x); sortx=x(j); c=array(norows(x):); i=integers(norows(x)); c(i)=dfloat(i)/dfloat(norows(x)); bad continue; return; end; == ==COINT2 Cointegreation of Two Series subroutine coint2(method,m,alpha,deg,mi,nk,x,y,xname,yname, dfx,dfy,adfx,adfy, lagx,lagy,speedx,speedy,tspeedx,tspeedy, dfx2,dfy2,adfx2,adfy2,dflag,resid0,resid1,resid2,iprint ); /; ******************************************************************* /; Tests for Cointegration using Engle Procedure and two series /; allows for OLS, MARS, GAM and ppreg models /; Method = 0 => OLS, =1 => MARS, =2 => GAM, =3 => PPREG /; m = # of trees for PPREG (method =3) /; alpha = smoothing coef for ppreg usually = 0.0 /; deg = degree for gam estimation. Usually = 3. /; mi = maximum number of interactions for mars. -n range 1-3 /; nk = number of knots for mars /; x = first series /; y = second series /; xname = name of first series set with call character(xname,' ') /; yname = name of second series set with call character(yname,' ') /; dfx = Unit root test for x /; dfy = Unit root test for y /; adfx = Augmented DF test for x for lag=dflag /; adfy = Augmented DF test for y for lag=dflag /; lagx = Number of lags of x /; lagy = Number of lags of y /; speedx = Speed of adjustment of x /; speedy = Speed of adjustment of y /; tspeedx= t stat of speedx /; tspeedy= t stat of speedy /; dfx2 = Unit root test for x RES /; dfy2 = Unit root test for y RES /; adfx2 = Augmented DF test for x RES for lag=dflag /; adfy2 = Augmented DF test for y RES for lag=dflag /; dflag = Lag of DF test /; resid0 = Residual for Cointegrating Eq /; resid1 = Residual for Equation 1 /; resid2 = Residual for Equation 2 /; iprint = 0 no print, = 1 print /; ******************************************************************* /; /; Built 9 September 2012 /; if(iprint.ne.0)then; call print(' ':); call print('------------------------------------------------------':); if(method.eq.0) call print('Tests for Cointegration using OLS for EC Model':); if(method.eq.1) call print('Tests for Cointegration using MARS for EC Model':); if(method.eq.2) call print('Tests for Cointegration using GAM for EC Model':); if(method.eq.3) call print('Tests for Cointegration using PPREG for EC Model':); call print('------------------------------------------------------':); call print('X series was ',xname); call print('Y Series was ',yname); call print(' ':); call print('Unit root tests for Series x and y':); call df(x,dfx :print); call df(y,dfy :print); call df(x,adfx:adf dflag :print); call df(y,adfy:adf dflag :print); call olsq(x,y:print); call print(' ':); call print('DF and Augmented DF tests of Residual':); call df(%res,dd :print); call df(%res,dd2 :adf dflag :print); endif; if(iprint.eq.0)then; call df(x,dfx); call df(y,dfy); call df(x,adfx:adf dflag); call df(y,adfy:adf dflag); call olsq(x,y); endif resid0=%res; difx=dif(x); dify=dif(y); rres=goodrow(lag(%res,-1)); if(iprint.ne.0)then; if(method.eq.0) call olsq(difx rres{1} difx{1 to lagx} dify{1 to lagy}:print); if(method.eq.1) call marspline(difx rres{1} difx{1 to lagx} dify{1 to lagy} :mi mi :nk nk :print); if(method.eq.2) call gamfit(difx rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} :print); if(method.eq.3) call ppreg(difx rres{1} difx{1 to lagx} dify{1 to lagy} :m m :alpha alpha :print); endif; if(iprint.eq.0)then; if(method.eq.0) call olsq(difx rres{1} difx{1 to lagx} dify{1 to lagy}); if(method.eq.1) call marspline(difx rres{1} difx{1 to lagx} dify{1 to lagy} :mi mi :nk nk); if(method.eq.2) call gamfit(difx rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy}); if(method.eq.3) call ppreg(difx rres{1} difx{1 to lagx} dify{1 to lagy} :m m :alpha alpha); call df(%res,dfx2); call df(%res,adfx2 :adf dflag); endif; resid1=%res; if(method.eq.0)then; speedx=%coef(1); tspeedx=%t(1); endif; if(method.eq.2)then; speedx=%coef(2); tspeedx=%z(2); endif; if(iprint.ne.0)then; if(method.eq.0) call olsq(dify rres{1} difx{1 to lagx} dify{1 to lagy} :print); if(method.eq.1) call marspline(dify rres{1} difx{1 to lagx} dify{1 to lagy} :print :mi mi :nk nk); if(method.eq.2) call gamfit(dify rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} :print); if(method.eq.3) call ppreg(dify rres{1} difx{1 to lagx} dify{1 to lagy} :m m :alpha alpha :print); endif; if(iprint.eq.0)then; if(method.eq.0)call olsq(dify rres{1} difx{1 to lagx} dify{1 to lagy}); if(method.eq.1) call marspline(dify rres{1} difx{1 to lagx} dify{1 to lagy} :mi mi :nk nk); if(method.eq.2) call gamfit(dify rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy}); if(method.eq.3) call ppreg(dify rres{1} difx{1 to lagx} dify{1 to lagy} :m m :alpha alpha); call df(%res,dfy2); call df(%res,adfy2 :adf dflag); endif; resid2=%res; if(method.eq.0)then; speedy=%coef(1); tspeedy=%t(1); endif; if(method.eq.2)then; speedy=%coef(2); tspeedy=%z(2); endif; if(iprint.ne.0)then; call print(' ':); call print('DF Tests on two equations ':); call df(resid1,adfx1 :print); call df(resid2,adfy1 :print); call print(' ':); call print('Augmented DF Tests on the Two Equations':); call df(resid1,adfx2 :adf dflag :print); call df(resid2,adfy2 :adf dflag :print); endif; if(method.eq.1.or.method.eq.3)then; speedx =missing(); speedy =missing(); tspeedx=missing(); tspeedy=missing(); endif; return; end; == ==COINT2LM Cointegreation of Two Series - Gives L1 and Minimax subroutine coint2LM(x,y,xname,yname,dfx,dfy,adfx,adfy, lagx,lagy,speedx,speedy,tspeedx,tspeedy, l1speedx,l1speedy,mmspeedx,mmspeedy dfx2,dfy2,adfx2,adfy2,dflag,resid0,resid1,resid2,iprint); /; Tests for Cointegration using Engle Procedure and two series /; Gives OLS, L1 and Minimax /; x = first series /; y = second series /; xname = name of first series set with call character(xname,' ') /; yname = name of second series set with call character(yname,' ') /; dfx = Unit root test for x /; dfy = Unit root test for y /; adfx = Augmented DF test for x for lag=dflag /; adfy = Augmented DF test for y for lag=dflag /; lagx = Number of lags of x /; lagy = Number of lags of y /; speedx = Speed of adjustment of x /; speedy = Speed of adjustment of y /; tspeedx= t stat of speedx /; tspeedy= t stat of speedy /; L1speedx= Speed of Adjustment of x with L1 estimator /; L1speedy= Speed of Adjustment of y with L1 estimator /; mmspeedx= Speed of Adjustment of x with Minimax estimator /; mmspeedx= Speed of Adjustment of y with Minimax estimator /; dfx2 = Unit root test for x RES /; dfy2 = Unit root test for y RES /; adfx2 = Augmented DF test for x RES for lag=dflag /; adfy2 = Augmented DF test for y RES for lag=dflag /; dflag = Lag of DF test /; resid0 = Residual for Cointegrating Eq /; resid1 = Residual for Equation 1 /; resid2 = Residual for Equation 2 /; iprint = 0 no print, = 1 print if(iprint.ne.0)then; call print('X series was ',xname); call print('Y Series was ',yname); call print(' ':); call print('Unit root tests for Series x and y':); call df(x,dfx:print); call df(y,dfy:print); call df(x,adfx:adf dflag:print); call df(y,adfy:adf dflag:print); call olsq(x,y :l1 :minimax :print); call print(' ':); call print('DF and Augmented DF tests of Residual':); call df(%res,dd :print); call df(%res,dd2 :adf dflag :print); endif; if(iprint.eq.0)then; call df(x,dfx); call df(y,dfy); call df(x,adfx:adf dflag); call df(y,adfy:adf dflag); call olsq(x,y :l1 :minimax); endif resid0=%res; difx=dif(x); dify=dif(y); rres =goodrow(lag(%res,-1)); rresl1=goodrow(lag(%l1res,-1)); rresmm=goodrow(lag(%mmres,-1)); if(iprint.ne.0)then; call olsq(difx rres{1} difx{1 to lagx} dify{1 to lagy}:print); speedx=%coef(1); resid1=%res; tspeedx=%t(1); call olsq(difx rresl1{1} difx{1 to lagx} dify{1 to lagy}:print :l1); l1speedx=%l1coef(1); call olsq(difx rresmm{1} difx{1 to lagx} dify{1 to lagy}:print :minimax); mmspeedx=%mmcoef(1); endif; if(iprint.eq.0)then; call olsq(difx rres{1} difx{1 to lagx} dify{1 to lagy}); speedx=%coef(1); resid1=%res; tspeedx=%t(1); call df(%res,dfx2); call df(%res,adfx2 :adf dflag); call olsq(difx rresl1{1} difx{1 to lagx} dify{1 to lagy} :l1); l1speedx=%l1coef(1); call olsq(difx rresmm{1} difx{1 to lagx} dify{1 to lagy} :minimax); mmspeedx=%mmcoef(1); endif; if(iprint.ne.0)then; call olsq(dify rres{1} difx{1 to lagx} dify{1 to lagy}:print); speedy=%coef(1); resid2=%res; tspeedy=%t(1); call olsq(dify rresl1{1} difx{1 to lagx} dify{1 to lagy}:print :l1); l1speedy=%l1coef(1); call olsq(dify rresmm{1} difx{1 to lagx} dify{1 to lagy}:print :minimax); mmspeedy=%mmcoef(1); endif; if(iprint.eq.0)then; call olsq(dify rres{1} difx{1 to lagx} dify{1 to lagy}); speedy=%coef(1); resid2=%res; tspeedy=%t(1); call df(%res,dfy2); call df(%res,adfy2 :adf dflag); call olsq(dify rresl1{1} difx{1 to lagx} dify{1 to lagy} :l1); l1speedy=%l1coef(1); call olsq(dify rresmm{1} difx{1 to lagx} dify{1 to lagy} :minimax); mmspeedy=%mmcoef(1); endif; if(iprint.ne.0)then; call print(' ':); call print('DF Tests on two equations ':); call df(resid1,adfx1 :print); call df(resid2,adfy1 :print); call print(' ':); call print('Augmented DF Tests on the Two Equations':); call df(resid1,adfx2 :adf dflag :print); call df(resid2,adfy2 :adf dflag :print); endif; return; end; == ==COINT2M Moving Cointegration of Two Series - Simple Version subroutine coint2m(x,y,xname,yname,number,lagx,lagy,speedx,speedy tspeedx,tspeedy); /; Routine to drive coint2 using windows of data /; x = Input series # 1 /; y = Input series # 2 /; xname = Name of x series /; yname = Name of y series /; number = Number of observations in moving model /; lagx = Number of lags of X /; lagy = Number of lags of y /; speedx = Moving Error correction coefficient for x /; speedy = Moving Error correction coefficient for y /; tspeedx= t Stat of speedx /; tspeedy= t stat of speedy n=norows(x); if(n.ne.norows(y))then; call print('# of rows of x .NE. # of rows of y'); call stop; endif; if(n.le.number)then; call print('Number is too large given n',n,number); call stop; endif; nn=n-number+1; xwork =array(number:); ywork=array(number:); speedx =array(nn:); speedy=array(nn:); tspeedx=array(nn:); tspeedy=array(nn:); ii=integers(number); call cls; call outstring(1,2,'Moving Cointegration Analysis'); call outstring(1,3,'Case Speedx Speedy, t-Speedx t-Speedy'); method=0; m=0; alpha=0.0; deg=3.0; mi=2; nk=30; do j=1,nn; xwork=x(j+ii-1); ywork=y(j+ii-1); call coint2(method,m,alpha,deg,mi,nk,xwork,ywork,xname,yname,dfx,dfy, adfx,adfy,lagx,lagy,speedx1,speedy1,tspeedx1,tspeedy1, dfx2,dfy2,adfx2,adfy2,4,resid0,resid1,resid2,0); speedx(j) =speedx1; speedy(j) =speedy1; tspeedx(j)=tspeedx1; tspeedy(j)=tspeedy1; call outinteger(1,4,j); call outdouble(25,4,speedx1,'(e16.8)'); call outdouble(60,4,speedy1,'(e16.8)'); call outdouble(25,5,tspeedx1,'(e16.8)'); call outdouble(60,5,tspeedy1,'(e16.8)'); enddo; return; end; == ==COINT2M2 Moving Cointegration Two Series OLS, L1 Minimax subroutine coint2m2(x,y,xname,yname,number,lagx,lagy,speedx,speedy, tspeedx,tspeedy,l1speedx,l1speedy,mmspeedx,mmspeedy, dfx,dfy,adfx,adfy,dfres1,dfres2,adfres1,adfres2,dflag); /; ********************************************************************* /; Routine to drive coint2 using windows of data. Uses expanded Arg list /; OLS, L1 and Minimax Estimates Given /; x = Input series # 1 /; y = Input series # 2 /; xname = Name of x series /; yname = Name of y series /; number = Number of observations in moving model /; lagx = Number of lags of X /; lagy = Number of lags of y /; speedx = Moving Error correction coefficient for x /; speedy = Moving Error correction coefficient for y /; tspeedx = t-Stat for speedx /; tspeedy = t-stat for speedy /; l1speedx= Moving Error correction L1 coefficient for x /; l1speedy= Moving Error correction L1 coefficient for y /; mmspeedx= Moving Error correction Minimax coefficient for x /; mmspeedy= Moving Error correction Minimax coefficient for y /; dfx = Dickey Fuller Test on Raw Data Series x /; dfy = Dickey Fuller Test on Raw Data Series y /; adfx = Augmented Dickey Fuller Test Raw Data Series x lag=dflag /; adfy = Augmented Dickey Fuller Test Raw Data Series y lag=dflag /; dfres1 = Dickey Fuller Test on RES1 Data Series /; dfres2 = Dickey Fuller Test on RES1 Data Series /; adfres1 = Augmented Dickey Fuller Test RES1 Data Series lag=dflag /; adfres2 = Augmented Dickey Fuller Test RES2 Data Series lag=dflag /; dflag = Lags for augmented DF test /; ********************************************************************* n=norows(x); if(n.ne.norows(y))then; call print('# of rows of x .NE. # of rows of y'); call stop; endif; if(n.le.number)then; call print('Number is too large given n',n,number); call stop; endif; nn=n-number+1; xwork =array(number:); ywork=array(number:); speedx =array(nn:); speedy =array(nn:); l1speedx =array(nn:); l1speedy =array(nn:); mmspeedx =array(nn:); mmspeedy =array(nn:); tspeedx =array(nn:); tspeedy =array(nn:); dfx =array(nn:); dfy =array(nn:); adfx =array(nn:); adfy =array(nn:); dfres1 =array(nn:); dfres2 =array(nn:); adfres1 =array(nn:); adfres2 =array(nn:); ii=integers(number); call cls; call outstring(1,2,'Moving Cointegration Analysis'); call outstring(1,3,'Case Speedx Speedy OLS, L1 MM t-Speedx t-Speedy'); do j=1,nn; xwork=x(j+ii-1); ywork=y(j+ii-1); call coint2LM(xwork,ywork,xname,yname,dfxa,dfya, adfxa,adfya,lagx,lagy,speedx1,speedy1,tspeedx1,tspeedy1, l1sx,l1sy,mmsx,mmsy, dfx2a,dfy2a,adfx2a,adfy2a,dflag,resid0,resid1,resid2,0); speedx(j) = speedx1; speedy(j) = speedy1; l1speedx(j) = l1sx; l1speedy(j) = l1sy; mmspeedx(j) = mmsx; mmspeedy(j) = mmsy; tspeedx(j) = tspeedx1; tspeedy(j) = tspeedy1; dfx(j) = dfxa; dfy(j) = dfya; adfx(j) = adfxa; adfy(j) = adfya; dfres1(j) = dfx2a; dfres2(j) = dfy2a; adfres1(j) = adfx2a; adfres2(j) = adfy2a; call outinteger(1,4,j); call outdouble(20,4,speedx1, '(e12.4)'); call outdouble(32,4,speedy1, '(e12.4)'); call outdouble(44,4,l1sx, '(e12.4)'); call outdouble(60,4,l1sy, '(e12.4)'); call outdouble(20,5,mmsx, '(e12.4)'); call outdouble(32,5,mmsy, '(e12.4)'); call outdouble(44,5,tspeedx1,'(e12.4)'); call outdouble(60,5,tspeedy1,'(e12.4)'); enddo; return; end; == ==COINT2ME Moving Cointegration of Two Series - Extended Args subroutine coint2me(method,deg,x,y,xname,yname,number,lagx,lagy, speedx,speedy,tspeedx,tspeedy,dfx,dfy,adfx,adfy, dfres1,dfres2,adfres1,adfres2,dflag); /; Routine to drive coint2 using windows of data. Uses expanded Arg list /; method = 0 => use OLS /; ne 0 => implies uses GAM with degree deg /; deg = degree for gam /; x = Input series # 1 /; y = Input series # 2 /; xname = Name of x series /; yname = Name of y series /; number = Number of observations in moving model /; lagx = Number of lags of X /; lagy = Number of lags of y /; speedx = Moving Error correction coefficient for x /; speedy = Moving Error correction coefficient for y /; tspeedx = t-Stat for speedx /; tspeedy = t-stat for speedy /; dfx = Dickey Fuller Test on Raw Data Series x /; dfy = Dickey Fuller Test on Raw Data Series y /; adfx = Augmented Dickey Fuller Test Raw Data Series x lag=dflag /; adfy = Augmented Dickey Fuller Test Raw Data Series y lag=dflag /; dfres1 = Dickey Fuller Test on RES1 Data Series /; dfres2 = Dickey Fuller Test on RES1 Data Series /; adfres1 = Augmented Dickey Fuller Test RES1 Data Series lag=dflag /; adfres2 = Augmented Dickey Fuller Test RES2 Data Series lag=dflag /; dflag = Lags for augmented DF test n=norows(x); if(n.ne.norows(y))then; call print('# of rows of x .NE. # of rows of y'); call stop; endif; if(n.le.number)then; call print('Number is too large given n',n,number); call stop; endif; nn=n-number+1; xwork =array(number:); ywork=array(number:); speedx =array(nn:); speedy =array(nn:); tspeedx =array(nn:); tspeedy =array(nn:); dfx =array(nn:); dfy =array(nn:); adfx =array(nn:); adfy =array(nn:); dfres1 =array(nn:); dfres2 =array(nn:); adfres1 =array(nn:); adfres2 =array(nn:); ii=integers(number); call cls; call outstring(1,2,'Moving Cointegration Analysis'); call outstring(1,3,'Case Speedx Speedy t-Speedx t-Speedy'); method2=0; m=0; alpha=0.0; mi=2; nk=30; if(method.ne.0)method2=2; do j=1,nn; xwork=x(j+ii-1); ywork=y(j+ii-1); call coint2(method2,m,alpha,deg,mi,nk,xwork,ywork,xname,yname,dfxa,dfya, adfxa,adfya,lagx,lagy,speedx1,speedy1,tspeedx1,tspeedy1, dfx2a,dfy2a,adfx2a,adfy2a,dflag,resid0,resid1,resid2,0); speedx(j)= speedx1; speedy(j)= speedy1; tspeedx(j)=tspeedx1; tspeedy(j)=tspeedy1; dfx(j) =dfxa; dfy(j) =dfya; adfx(j) =adfxa; adfy(j) =adfya; dfres1(j) =dfx2a; dfres2(j) =dfy2a; adfres1(j) =adfx2a; adfres2(j) =adfy2a; call outinteger(1,4,j); call outdouble(25,4,speedx1,'(e16.8)'); call outdouble(60,4,speedy1,'(e16.8)'); call outdouble(25,5,tspeedx1,'(e16.8)'); call outdouble(60,5,tspeedy1,'(e16.8)'); enddo; return; end; == ==COINT3 Cointegration of Three Series subroutine coint3(method,m,alpha,deg,mi,nk,x,y,z,xname,yname,zname, dfx,dfy,dfz,adfx,adfy,adfz, lagx,lagy,lagz,speedx,speedy,speedz,tspeedx,tspeedy,tspeedz, dfx2,dfy2,dfz2,adfx2,adfy2,adfz2, dflag,resid0,resid1,resid2,resid3,iprint); /; Tests for Cointegration using Engle Procedure and three series /; Method = 0 => OLS, =1 => MARS, =2 => GAM, =3 => PPREG /; m = # of trees for PPREG (method =3) /; alpha = smoothing coef for ppreg usually = 0.0 /; deg = degree for gam estimation. Usually = 3. /; mi = maximum number of interactions for mars. -n range 1-3 /; nk = number of knots for mars /; x = first series /; y = second series /; z = third series /; xname = name of first series set with call character(xname,' ') /; yname = name of second series set with call character(yname,' ') /; zname = name of third series ser with call character(zname,' ') /; dfx = Unit root test for x /; dfy = Unit root test for y /; dfz = Unit root test for z /; adfx = Augmented DF test for x lag=dflag /; adfy = Augmented DF test for y lag=dflag /; adfz = Augmented DF test for z lag=dflag /; lagx = Number of lags of x /; lagy = Number of lags of y /; lagz = Number of lags of z /; speedx = Speed of adjustment of x /; speedy = Speed of adjustment of y /; speedz = Speed of adjustment of z /; tspeedx = t of Speed of adjustment of x /; tspeedy = t of Speed of adjustment of y /; tspeedz = t of Speed of adjustment of z /; dfx2 = Unit root test for x RES /; dfy2 = Unit root test for y RES /; dfy2 = Unit root test for y RES /; adfx2 = Augmented DF test for x RES lag=dflag /; adfy2 = Augmented DF test for y RES lag=dflag /; adfz2 = Augmented DF test for z RES lag=dflag /; dflag = Sets lag on DF test /; resid0 = Residual for Cointegrating Eq /; resid1 = Residual for Equation 1 /; resid2 = Residual for Equation 2 /; resid3 = Residual for Equation 3 /; iprint = 0 no print, = 1 print /; /; Built 9 September 2012 /; if(iprint.eq.0)then; call df(x,dfx); call df(y,dfy); call df(z,dfz); call df(x,adfx:adf dflag); call df(y,adfy:adf dflag); call df(z,adfz:adf dflag); endif; if(iprint.ne.0)then; call print(' ':); call print('------------------------------------------------------':); if(method.eq.0) call print('Tests for Cointegration using OLS for EC Model':); if(method.eq.1) call print('Tests for Cointegration using MARS for EC Model':); if(method.eq.2) call print('Tests for Cointegration using GAM for EC Model':); if(method.eq.3) call print('Tests for Cointegration using PPREG for EC Model':); call print('------------------------------------------------------':); call print('X series was ',xname); call print('Y Series was ',yname); call print('Z Series was ',zname); call print(' ':); call print('Dickey Fuller Tests on raw series':); call df(x,dfx :print); call df(y,dfy :print); call df(z,dfz :print); call print('Augmented DF Tests on Raw Series':); call df(x,adfx:adf dflag :print); call df(y,adfy:adf dflag :print); call df(z,adfz:adf dflag :print); call olsq(x y z:print); call print(' '); call print('DF tests on the level equation':); call df(%res,dd :print); call df(%res,dd2:adf dflag :print); endif; if(iprint.eq.0)call olsq(x y z); resid0=%res; difx=dif(x); dify=dif(y); difz=dif(z); rres=goodrow(lag(%res,-1)); if(iprint.ne.0)then; if(method.eq.0) call olsq(difx rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :print); if(method.eq.1) call marspline(difx rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :mi mi :nk nk :print); if(method.eq.2) call gamfit(difx rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} difz[predictor,deg]{1 to lagz} :print); if(method.eq.3) call ppreg(difx rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :print :m m :alpha alpha); call print(' ':); call print( 'DF & Augmented DF Tests series on x of Error Correction Model'); call df(%res,dfx2 :print); call df(%res,adfx2 :adf dflag :print); resid1=%res; if(method.eq.0)then; speedx=%coef(1); tspeedx=%t(1); endif; if(method.eq.2)then; speedx=%coef(2); tspeedx=%z(2); endif; if(method.eq.0) call olsq(dify rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :print); if(method.eq.1) call marspline(dify rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :mi mi :nk nk :print); if(method.eq.2) call gamfit(dify rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} difz[predictor,deg]{1 to lagz} :print); if(method.eq.3) call ppreg(dify rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :print :m m :alpha alpha); call print(' ':); call print( 'DF & Augmented DF Tests series on y of Error Correction Model'); call df(%res,dfy2 :print); call df(%res,adfy2 :adf dflag :print); resid2=%res; if(method.eq.0)then; speedy=%coef(1); tspeedy=%t(1); endif; if(method.eq.2)then; speedy=%coef(2); tspeedy=%z(2); endif; if(method.eq.0) call olsq(difz rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :print); if(method.eq.1) call marspline(difz rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :mi mi :nk nk :print); if(method.eq.2) call gamfit(difz rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} difz[predictor,deg]{1 to lagz} :print); if(method.eq.3) call ppreg(difz rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :m m :alpha alpha :print); call print(' ':); call print( 'DF & Augmented DF Tests series on z of Error Correction Model'); call df(%res,dfz2 :print); call df(%res,adfz2 :adf dflag :print); resid3=%res; if(method.eq.0)then; speedz=%coef(1); tspeedz=%t(1); endif; if(method.eq.2)then; speedz=%coef(2); tspeedz=%z(2); endif; endif; if(iprint.eq.0)then; if(method.eq.0) call olsq(difx rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} ); if(method.eq.1) call marspline(difx rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :mi mi :nk nk); if(method.eq.2) call gamfit(difx rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} difz[predictor,deg]{1 to lagz}); if(method.eq.3) call ppreg(difx rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :m m :alpha alpha); call df(%res,dfx2); call df(%res,adfx2 :adf dflag); resid1=%res; if(method.eq.0)then; speedx=%coef(1); tspeedx=%t(1); endif; if(method.eq.2)then; speedx=%coef(2); tspeedx=%z(2); endif; if(method.eq.0) call olsq(dify rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} ); if(method.eq.1) call marspline(dify rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :mi mi :nk nk); if(method.eq.2) call gamfit(dify rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} difz[predictor,deg]{1 to lagz}); if(method.eq.3) call ppreg(dify rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :m m :alpha alpha); resid2=%res; if(method.eq.0)then; speedy=%coef(1); tspeedy=%t(1); endif; if(method.eq.2)then; speedy=%coef(2); tspeedy=%z(2); endif; call df(%res,dfy2); call df(%res,adfy2 :adf dflag); if(method.eq.0) call olsq(difz rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} ); if(method.eq.1) call marspline(difz rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :mi mi :nk nk); if(method.eq.2) call gamfit(difz rres[predictor,deg]{1} difx[predictor,deg]{1 to lagx} dify[predictor,deg]{1 to lagy} difz[predictor,deg]{1 to lagz}); if(method.eq.3) call ppreg(difz rres{1} difx{1 to lagx} dify{1 to lagy} difz{1 to lagz} :m m :alpha alpha); resid3=%res; if(method.eq.0)then; speedz=%coef(1); tspeedz=%t(1); endif; if(method.eq.2)then; speedz=%coef(2); tspeedz=%z(2); endif; call df(%res,dfz2); call df(%res,adfz2 :adf dflag); endif; if(method.eq.1.or.method.eq.3)then; speedx =missing(); speedy =missing(); speedz =missing(); tspeedx=missing(); tspeedy=missing(); tspeedz=missing(); endif; return; end; == ==COINT3ME Moving Cointegration of Three Series subroutine coint3me(method,deg,x,y,z,xname,yname,zname,number, lagx,lagy,lagz, speedx,speedy,speedz,tspeedx,tspeedy,tspeedz, dfx,dfy,dfz,adfx,adfy,adfz,dfres1,dfres2,dfres3, adfres1,adfres2,adfres3,dflag); /; Routine to drive coint2 using windows of data. Uses expanded Arg list /; method = 0 => use OLS /; ne 0 => implies uses GAM with degree deg /; deg = degree for gam /; x = Input series # 1 /; y = Input series # 2 /; z = Input series # 3 /; xname = Name of x series /; yname = Name of y series /; zname = Name of z series /; number = Number of observations in moving model /; lagx = Number of lags of X /; lagy = Number of lags of y /; speedx = Moving Error correction coefficient for x /; speedy = Moving Error correction coefficient for y /; speedz = Moving Error correction coefficient for z /; tspeedx = t-Stat for speedx /; tspeedy = t-stat for speedy /; tspeedz = t-stat for speedz /; dfx = Dickey Fuller Test on Raw Data Series x /; dfy = Dickey Fuller Test on Raw Data Series ygo to finish; /; dfz = Dickey Fuller Test on Raw Data Series z /; adfx = Augmented Dickey Fuller Test Raw Data Series x lag=dflag /; adfy = Augmented Dickey Fuller Test Raw Data Series y lag=dflag /; dfres1 = Dickey Fuller Test on RES1 Data Series /; dfres2 = Dickey Fuller Test on RES2 Data Series /; dfres3 = Dickey Fuller Test on RES3 Data Series /; adfres1 = Augmented Dickey Fuller Test RES1 Data Series lag=dflag /; adfres2 = Augmented Dickey Fuller Test RES2 Data Series lag=dflag /; adfres3 = Augmented Dickey Fuller Test RES3 Data Series lag=dflag /; dflag = Lags for augmented DF test n=norows(x); if(n.ne.norows(y))then; call print('# of rows of x .NE. # of rows of y'); call stop; endif; if(n.ne.norows(z))then; call print('# of rows of x .NE. # of rows of z'); call stop; endif; if(n.le.number)then; call print('Number is too large given n',n,number); call stop; endif; nn=n-number+1; xwork =array(number:); ywork=array(number:); zwork=array(number:); speedx =array(nn:); speedy =array(nn:); speedz =array(nn:); tspeedx =array(nn:); tspeedy =array(nn:); tspeedz =array(nn:); dfx =array(nn:); dfy =array(nn:); dfz =array(nn:); adfx =array(nn:); adfy =array(nn:); adfz =array(nn:); dfres1 =array(nn:); dfres2 =array(nn:); dfres3 =array(nn:); adfres1 =array(nn:); adfres2 =array(nn:); adfres3 =array(nn:); ii=integers(number); call cls; call outstring(1,2,'Moving Cointegration Analysis'); call outstring(1,3,'Case Speedx Speedy Speedz t-1 t-2 t-3'); method2=0; m=0; alpha=0.0; mi=2; nk=30; if(method.ne.0)method2=2; do j=1,nn; xwork=x(j+ii-1); ywork=y(j+ii-1); zwork=z(j+ii-1); call coint3(method2,m,alpha,deg,mi,nk,xwork,ywork,zwork, xname,yname,zname,dfxa,dfya,dfza,adfxa,adfya,adfza, lagx,lagy,lagz,speedx1,speedy1,speedz1,tspeedx1,tspeedy1,tspeedz1, dfx2a,dfy2a,dfz2a,adfx2a,adfy2a,adfz2a, dflag,resid0,resid1,resid2,resid3,0); speedx(j) =speedx1; speedy(j) =speedy1; speedz(j) =speedz1; tspeedx(j)=tspeedx1; tspeedy(j)=tspeedy1; tspeedz(j)=tspeedz1; dfx(j) =dfxa; dfy(j) =dfya; dfz(j) =dfza; adfx(j) =adfxa; adfy(j) =adfya; adfz(j) =adfza; dfres1(j) =dfx2a; dfres2(j) =dfy2a; dfres3(j) =dfz2a; adfres1(j) =adfx2a; adfres2(j) =adfy2a; adfres3(j) =adfz2a; call outinteger(1,4,j); call outdouble(15,4,speedx1,'(e16.8)'); call outdouble(30,4,speedy1,'(e16.8)'); call outdouble(50,4,speedz1,'(e16.8)'); call outdouble(15,5,tspeedx1,'(e16.8)'); call outdouble(30,5,tspeedy1,'(e16.8)'); call outdouble(50,5,tspeedz1,'(e16.8)'); enddo; return; end; == ==COINT_SW Stock-Watson DOLS Cointegration analysis subroutine coint_sw(xvar,maxlag,res1,ec_coef,ec_vec,const,shock,iprint); /; /; Estimate Stock-Watson (1993) Cointegration test /; See Stock, James and Mark Watson. /; "A Simple Estimator of Cointegrating Vectoprs in higher /; order systems" Econometrica (61(4) (1993) : pp 783-820 /; /; Setup for VECM (Vector Error Component Analysis) /; /; xvar = matrix of variables for VECM /; maxlag = Maximum lag in plus and minus direction /; res1 = Residual from DOLS equation. Check acf to see if /; maxlag is set high enough /; ec_coef = Error Correction Coefficients /; ec_vec = Error Correction Vector /; const = mean(y-ec_vec); /; shock = y-ec_vec-const /; iprint = ne 0 => print estimated equation /; /; Built October 2009 by Houston H. Stokes /; Mods made April 2011 for > 3 series /; n=norows(xvar); k=nocols(xvar); /; /; get error correction term /; difx1=dif(xvar(,2)); maxlag2=(-1)*maxlag; call lagmatrix(difx1{maxlag2 to maxlag} :noint :matrix difx); if(k.gt.2)then; do i=3,k; difx1=dif(xvar(,i)); call lagmatrix(difx1{maxlag2 to maxlag} :noint :matrix difx2); difx=catcol(difx,difx2); enddo; endif; /; y=xvar(,1); /; y=dropfirst(y,maxlag+1); /; y= droplast(y,maxlag ); /; y=submatrix(xvar,maxlag+2,n-maxlag,1,1); /; /; add levels to the first of difx /; do i=2,k; /; xwork=dropfirst(xvar(,i),maxlag+1); /; xwork=droplast(xwork,maxlag); difx=catcol(submatrix(xvar,maxlag+2,n-maxlag,i,i),difx); enddo; /; if(iprint.ne.0)call olsq(y,difx :qr :print); if(iprint.eq.0)call olsq(y,difx :qr); res1=%res; kk=integers(1,k-1); ec_coef=%coef(kk); ec_vec = -1.*(mfam(submatrix(xvar,1,n,2,k))*ec_coef); shock = vfam(xvar(,1))-ec_vec; const = mean(shock); shock = shock-const; if(iprint.ne.0)then; call print(' ':); call print('Estimate of Cointegrating Coef',ec_coef); call print('Estimate of Constant ',const:); endif; return; end; == ==CONTRIB Advanced routine do MARS contrib analysis /; start -------------------------------------------------------------- /; -------------------------------------------------------------------- /; ranforest capability for :reg models added 29 November 2009 /; /; added routines also loaded /; contribi => load all needed routines and call contribs /; contribs => Initialize key settings /; contribl => List settings /; contrib2 => Main routine. Called by contrib or can be called /; directly /; fixend => removes last three characters of a name and replaces /; contrib3 => save file subroutine /; contrib4 => save file subroutine /; contrib5 => save file subroutine /; contrib6 => save file subroutine /; marsmodc => loads MARS save file /; contribd => Driver subroutine contrib(iopt,message,medians,iversion,isave,ihp, iols,olscoef,igrid,ishow,fsv_info); /; /; Produce Contribution Charts for all explanatory variables in /; a saved Multivariate Adaptive Regression Splines MARS model. /; Operates on medians and range of focus variable. 300 points /; are generated. /; /; In place of medians, user can supply values /; /; Added arguments by HH Stokes 22 February 2009 /; /; Original contrib subroutine was developed by William Lattyak /; and is in wbsuppl. This routine has different arguments. /; /; ************************************************************ /; /; Arguments: /; /; iopt => =0 => use medians /; =1 => use user supplied message 'medians.' /; 123456789012 /; message => used in place of ', o=Medians]' if /; iopt=1 /; /; allowed lengths iversion = 1 22 /; iversion = 2 16 /; iversion = 3 20 /; iversion = 4 20 /; iversion = 5 11 /; medians=> the stored medians of the righthand side /; variables /; /; iversion settings /; 1 => leverage effect of target variable on YHat holding /; all others constant /; 2 => contribution effect of target variable unit increase /; on YHat->YHat(t)-YHat(1) /; 3 => additive contribution of target variable removing /; all others /; 4 => contribution knot effect of target var on /; YHat diff1(Yhat) /; 5 => cumulative contribution of target variable unit /; increase on YHat->YHat(t)-YHat(1) /; /; note: isave saves info by graph cchart..... /; isave=0 => no saves /; isave=1 => sca fsv /; isave=2 => rats por /; isave=3 => both sca fsv and rats por /; ihp =0 => graphs are *.wmf /; ihp =1 => graphs are *.hp1 /; iols =0 => do not place OLS vector on graphs /; iols =1 => place ols vector on graphs /; Note: iols only works with iversion=1 /; corrently hotwired to do marspline only /; iols = 2 => Place ols and GAM vectors on graphs /; Note: iols only works with iversion=1 /; = -2 => suppress mars on graph. Mars material must be /; supplied /; iols =3 => Place ols, GAM, MARS and ppreg vectors on graphs /; Note: iols ne 0 only works with iversion=1 /; iols =4 => Place ols, GAM MARS RF ppreg vectors on graphs /; Note: iols ne 0 only works with iversion=1 /; olscoef => vector of OLS coefficients. /; if one more than # MARS variables => constant /; igrid => 0 => no grid, =1 => grid lines /; ishow => 0 => no show, =1 => show /; fsv_info => Comment to place in fsv file. Max of 64 /; characters. /; /; Note: /; names of fsv and por files are the same as the corresponding /; graph files /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; %spline=0; %xgam=0; if(iols.gt.1)iols=1; %gamcoef=0.0; %vartype=' '; %df=0; %link=0; %ppmod=0; %degmod=6; call contrib2(iopt,message,medians,iversion,isave,ihp,iols,olscoef, igrid,ishow,fsv_info,%spline,%xgam,%gamcoef,%link, %vartype,%df,%degmod,%ppmod); /; return; end; subroutine contrib2(iopt,message,medians,iversion,isave,ihp, iols,olscoef,igrid,ishow,fsv_info,%spline, %xgam,%gamcoef,%link,%vartype,%df,%degmod, %ppmod); /; /; Produce Contribution Charts for all explanatory variables in /; a saved Multivariate Adaptive Regression Splines MARS model. /; allows also showing OLS, OLS GAM and OLS GAM PPREG forecasts /; Operates on medians and range of focus variable. 300 points /; are generated. /; /; In place of medians, user can supply values /; /; Added arguments by H. H. Stokes 22 February 2009 /; /; Original contrib subroutine was developed by William Lattyak /; and is in wbsuppl. This routine has different arguments. /; /; ************************************************************ /; /; Arguments: /; /; iopt => =0 => use medians /; =1 => use user supplied message 'medians.' /; 123456789012 /; message => used in place of ', o=Medians]' if /; iopt=1 /; /; allowed lengths iversion = 1 22 /; iversion = 2 16 /; iversion = 3 20 /; iversion = 4 20 /; iversion = 5 11 /; medians=> the stored medians of the righthand side /; variables /; /; iversion settings /; 1 => leverage effect of target variable on YHat holding /; all others constant /; 2 => contribution effect of target variable unit increase /; on YHat->YHat(t)-YHat(1) /; 3 => additive contribution of target variable removing /; all others /; 4 => contribution knot effect of target var on /; YHat diff1(Yhat) /; 5 => cumulative contribution of target variable unit /; increase on YHat->YHat(t)-YHat(1) /; /; note: isave saves in cchart .... /; isave=0 => no saves /; isave=1 => sca fsv /; isave=2 => rats por /; isave=3 => both sca fsv and rats por /; ihp =0 => graphs are *.wmf /; ihp =1 => graphs are *.hp1 /; iols =0 => do not place OLS vector on graphs /; iols =1 => place ols vector on graphs /; Note: iols only works with iversion=1 /; iols = 2 => Place ols and GAM vectors on graphs /; Note: iols only works with iversion=1 /; = -2 => suppress mars on graph. Mars material must be /; supplied /; iols =3 => Place ols, GAM, MARS and ppreg vectors on graphs /; Note: iols ne 0 only works with iversion=1 /; iols =4 => Place ols, GAM MARS RF ppreg vectors on graphs /; Note: iols ne 0 only works with iversion=1 /; olscoef => vector of OLS coefficients. /; if one more than # MARS variables => constant /; igrid => 0 => no grid, =1 => grid lines /; ishow => 0 => no show, =1 => show /; fsv_info => Comment to place in fsv file. Max of 64 /; characters. /; %spline => from gamfit if iabs(iols) ge 2 /; %xgam => from gamfit if iabs(iols) ge 2 /; %gamcoef => from gamfit if iabs(iols) ge 2 /; %link => from gamfit if iabs(iols) ge 2 /; %vartype => from gamfit if iabs(iols) ge 2 /; %df => from gamfit if iabs(iols) ge 2 /; degmod => Degree of polynomial fit for gam forecasts. /; %ppmod => from ppreg if iols eq 3 /; /; Note: /; names of fsv and por files are the same as the corresponding /; graph files /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; Note: if the variable si not in the MARS model, the variable /; chart will not be produced /; icases=300; /; icons=-99; printgam=0; degmod=%degmod; markp=':markpoint 1 1 3 14'; /; markp=':markpoint 1 1 0 0'; color=':colors black bblue bgreen bred'; ido_ols=iols; grid=':nocontact'; /; 1234567890123456 if(igrid.ne.0)grid=':nocontact :grid'; show=':noshow'; if(ishow.ne.0)show=' '; hardcopy=':hardcopyfmt WMF'; call character(fsv,'wmf'); if(ihp .ne.0)then; hardcopy=':hardcopyfmt HP_GL2'; call character(fsv,'hp1'); endif; if(iols.ne.0)then; icons=1; if(norows(olscoef).eq.norows(medians))icons=0; if(icons.eq.1)then; kk=integers(1,norows(medians)); olscoef1=olscoef(kk); endif; if(ido_ols.ne.0.and.iversion.ne.1)ido_ols=0; if(norows(olscoef).lt.norows(medians))then; n1=norows(medians); n2=norows(olscoef); call epprint('ERROR: iols set but olscoef vector not correct':); call epprint(' # values of medians was ',n1:); call epprint(' # values in olscoef was ',n2:); call opprint(' ols line turned off ':); ido_ols=0; endif; endif; dools='marsyhat '; if(ido_ols.eq.-2)dools='ols_yhat gam_yhat'; if(ido_ols.eq. 1)dools='marsyhat ols_yhat'; if(ido_ols.eq. 2)dools='marsyhat ols_yhat gam_yhat'; if(ido_ols.eq. 3)dools='marsyhat ols_yhat gam_yhat ppr_yhat'; if(ido_ols.eq. 4)dools='marsyhat ols_yhat gam_yhat ppr_yhat rf_yhat'; if(ido_ols.eq.-2)ido_ols=2; y=array(icases,1:); x=array(icases,norows(medians):); nchart=1; call marspline(y x :getmodel ); /; call names(all); xklas=klass(%names); if(xklas.eq.0)then; %names=c8array(1: %names); %minvar=array(1: %minvar); %maxvar=array(1: %maxvar); %typevar=array(1: %typevar); %lag=array(1: %lag); tmpknd=kind(%lag); if(tmpknd.eq.8)%lag=idint(%lag); tmpknd=kind(%typevar); if(tmpknd.eq.8)%typevar=idint(%typevar); endif; coefsv=%coef; gflag=int(float(%bestin)*float(%flag)); /; call print(%flag %bestin gflag %coef %names); call print(''); call fprint(:clear); hfuture=array(icases,norows(%names):); ifcsts=integers(1, icases); call dodos('erase CChart*.wmf',:); do i=1,norows(%names); c1=c1array(8:); cfix=c1array(1:); c8=%names(i); c1=c1array(8:c8); ichar=integers(4,8); c1(ichar)=cfix; c8=c8array(1:c1); icatskip=0; tstnam=c8array(1:,'CT1 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT2 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT3 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT4 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT5 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT6 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT7 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT8 '); if(c8.eq.tstnam) icatskip=1; tstnam=c8array(1:,'CT9 '); if(c8.eq.tstnam) icatskip=1; ivars=-1; interact=1; if(sum(gflag(,i)) .gt. 0) then; ivars=i; do j=1,%nk; if((gflag(j,i) .eq. 1).and.(sum(gflag(j,)) .gt. 1))then; if( sum(gflag(j,)).gt.interact) interact=sum(gflag(j,)); endif; enddo; endif; if((iversion.eq.3).and.(icatskip.eq.0))then; call marspline(y x :getmodel ); coefnew=array(norows(%coef):); ivars=-1; coefnew=%coef; icoef=2; do j=1,norows(gflag); if (sum(gflag(,i)) .gt. 0)then; ivars=i; coefnew(1)=0.; do j=1,norows(gflag); if((gflag(j,i) .eq. 1).and.(sum(gflag(j,)).gt.1))then; coefnew(icoef)=0.; icoef=icoef+1; endif; if((gflag(j,i) .eq. 0).and.(sum(gflag(j,)).gt.0))then; coefnew(icoef)=0.; icoef=icoef+1; endif; if((gflag(j,i) .eq. 1).and.(sum(gflag(j,)).eq.1))then; icoef=icoef+1; endif; enddo; endif; enddo; if(ivars.gt.0)then; if(xklas.eq.0)then; %names=c8array(1: %names); %minvar=array(1: %minvar); %maxvar=array(1: %maxvar); %typevar=array(1: %typevar); %lag=array(1: %lag); endif; call marsmodc(coefnew); call fprint(:clear :col 1 :string '*** Model for additive contribution of ' :col 41 :display %names(ivars) :print :clear); call print(' '); /$ call marspline(y x :getmodel 'marszero.psv' :dispmars); call marspline(y x :getmodel 'marszero.psv' ); if(xklas.eq.0)then; %names=c8array(1: %names); %minvar=array(1: %minvar); %maxvar=array(1: %maxvar); %typevar=array(1: %typevar); %lag=array(1: %lag); tmpknd=kind(%lag); if(tmpknd.eq.8)%lag=idint(%lag); tmpknd=kind(%typevar); if(tmpknd.eq.8)%typevar=idint(%typevar); endif; call print(' ':); endif; endif; /; **************************************************************** /; Create target XVAR with incremental values; Others set to Median /; **************************************************************** if((ivars.gt.0).and.(interact.ge.1).and.(icatskip.eq.0))then; do k=1,norows(%names); if(k.eq.ivars)then; dinc=(%maxvar(k)-%minvar(k))/dfloat(icases); hfuture(1,k)=%minvar(k); do j=2,icases; hfuture(j,k)= hfuture(j-1,k)+dinc; enddo; endif; if(k.ne.ivars)hfuture(,k)=medians(k); enddo; /; ************************************************************** /; Forecast OLS, GAM PPREG /; ************************************************************** if(ido_ols.ne.0)then; if(icons.eq.0)ols_yhat=mfam(hfuture)*vfam(olscoef); if(icons.eq.1)ols_yhat=vector(:(mfam(hfuture)*vfam(olscoef1))) + olscoef(norows(olscoef)); endif; if(ido_ols.ge.2)call gamfore(%spline,%xgam,hfuture,degmod, %gamcoef,gam_yhat,%link, %vartype,%df,printgam); if(ido_ols.ge.3)then; if(icons.eq.0)call ppreg(:forecast hfuture :modname %ppmod); if(icons.eq.1)then; adds=vector(norows(hfuture):)+1.0; hfuture2=catcol(mfam(hfuture),adds); call ppreg(:forecast hfuture2 :modname %ppmod); endif; ppr_yhat=%fore; endif; if(ido_ols.ge.4)then; call ranforest(:forecast hfuture :reg :yhatav ); rf_yhat=%fore; endif; /; ************************************************************** if(iversion.ne.3)then; call marspline(y x :getmodel :forecast hfuture ); marsyhat=%fore; endif; if(iversion.eq.3)then; call marspline(y x :getmodel 'marszero.psv' :forecast hfuture ); marsyhat=%fore; endif; if(xklas.eq.0)then; %names=c8array(1: %names); %minvar=array(1: %minvar); %maxvar=array(1: %maxvar); %typevar=array(1: %typevar); %lag=array(1: %lag); tmpknd=kind(%lag); if(tmpknd.eq.8)%lag=idint(%lag); tmpknd=kind(%typevar); if(tmpknd.eq.8)%typevar=idint(%typevar); endif; if(iopt.eq.0)then; if(iVersion.eq.1)then; call fprint(:col 1 :display 'Prediction Leverage of ' :col 23 :display %names(ivars) :col 33 :display '[lag=' :col 39 :display %lag(ivars) '(i2)' :col 41 :display ', int=' :col 48 :display interact '(i2)' :col 50 :display ', o=Medians]' :save label :clear); endif; if(iVersion.eq.2)then; call fprint(:col 1 :display 'Contribution of Unit Chng in ' :col 29 :display %names(ivars) :col 39 :display '[lag=' :col 45 :display %lag(ivars) '(i2)' :col 47 :display ', int=' :col 54 :display interact '(i2)' :col 56 :display ', o=Medians]' :save label :clear); endif; if(iVersion.eq.3)then; call fprint(:col 1 :display 'Additive Contribution of ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display ', o=Removed]' :save label :clear); endif; if(iVersion.eq.4)then; call fprint(:col 1 :display 'Contribution of Knot on ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display ', o=Medians]' :save label :clear); endif; if(iVersion.eq.5)then; call fprint(:col 1 :display 'CSUM Contribution of Unit Chng in ' :col 34 :display %names(ivars) :col 44 :display '[lag=' :col 50 :display %lag(ivars) '(i2)' :col 52 :display ', int=' :col 59 :display interact '(i2)' :col 61 :display ', o=Medians]' :save label :clear); endif; endif; if(iopt.eq.1)then; if(iVersion.eq.1)then; call fprint(:col 1 :display 'Prediction Leverage of ' :col 23 :display %names(ivars) :col 33 :display '[lag=' :col 39 :display %lag(ivars) '(i2)' :col 41 :display ', int=' :col 48 :display interact '(i2)' :col 50 :display message :save label :clear); endif; if(iVersion.eq.2)then; call fprint(:col 1 :display 'Contribution of Unit Chng in ' :col 29 :display %names(ivars) :col 39 :display '[lag=' :col 45 :display %lag(ivars) '(i2)' :col 47 :display ', int=' :col 54 :display interact '(i2)' :col 56 :display message :save label :clear); endif; if(iVersion.eq.3)then; call fprint(:col 1 :display 'Additive Contribution of ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display message :save label :clear); endif; if(iVersion.eq.4)then; call fprint(:col 1 :display 'Contribution of Knot on ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display message :save label :clear); endif; if(iVersion.eq.5)then; call fprint(:col 1 :display 'CSUM Contribution of Unit Chng in ' :col 34 :display %names(ivars) :col 44 :display '[lag=' :col 50 :display %lag(ivars) '(i2)' :col 52 :display ', int=' :col 59 :display interact '(i2)' :col 61 :display message :save label :clear); endif; endif; call fprint(:clear); if(nchart.lt.10)then; call fprint(:col 1 :string 'CChart0' :col 8 :display nchart '(i1)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(nchart.ge.10).and.(i.lt.100)then; call fprint(:col 1 :string 'CChart' :col 7 :display nchart '(i2)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(iversion.eq.2)then; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)-marsyhat(1); enddo; marsyhat(1)=0.; endif; if(iversion.eq.4)then; _fcst=marsyhat; do j=2,norows(marsyhat); marsyhat(j)=_fcst(j)-_fcst(j-1); enddo; marsyhat(1)=0.; endif; if(iversion.eq.5)then; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)-marsyhat(1); enddo; marsyhat(1)=0.; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)+marsyhat(j-1); enddo; endif; /; if(ihp .ne.0)then; hardcopy=':hardcopyfmt HP_GL2'; call character(fsv,'hp1'); endif; call fixend(labchrt,fsv,labchrt2); call graph(hfuture(,ivars) argument(dools) argument(show) :xlabel %names(ivars) :ylabelleft 'Contribution' 'c9' :plottype xyplot argument(grid) :nolabel argument(color) argument(markp) argument(hardcopy) :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file labchrt2 :heading label); /; ************************************************************* /; Save file /; ************************************************************* if(isave.ne.0.and.ido_ols.eq.0) call contrib3(isave,labchrt,hfuture(,ivars),marsyhat,fsv_info); if(isave.ne.0.and.ido_ols.eq.1) call contrib4(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info); if(isave.ne.0.and.ido_ols.eq.2) call contrib5(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info,gam_yhat); if(isave.ne.0.and.ido_ols.eq.3) call contrib6(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info,gam_yhat,ppr_yhat); if(isave.ne.0.and.ido_ols.eq.4) call contrib7(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info,gam_yhat,ppr_yhat,rf_yhat); /; ************************************************************* nchart=nchart+1; /; *************************************************************** /; Set Others to their minimums and re-chart /; (if interactions > 1) turned off /; iversion <> 3 /; *************************************************************** if((interact.ge.1).and.(iversion.ne.3).and. (icatskip.eq.0))then; do k=1,norows(%names); if(k.ne.ivars)then; hfuture(,k)=%minvar(k); endif; enddo; if(iversion.ne.3)then; call marspline(y x :getmodel :forecast hfuture ); endif; /; ************************************************************** /; Forecast OLS, GAM, PPREG /; ************************************************************** if(ido_ols.ne.0)then; if(icons.eq.0)ols_yhat=mfam(hfuture)*vfam(olscoef); if(icons.eq.1)ols_yhat=vector(:(mfam(hfuture)*vfam(olscoef1))) + olscoef(norows(olscoef)); endif; if(ido_ols.ge.2)call gamfore(%spline,%xgam,hfuture,degmod, %gamcoef,gam_yhat,%link, %vartype,%df,printgam); if(ido_ols.ge.3)then; if(icons.eq.0)call ppreg(:forecast hfuture :modname %ppmod); if(icons.eq.1)then; adds=vector(norows(hfuture):)+1.0; hfuture2=catcol(mfam(hfuture),adds); call ppreg(:forecast hfuture2 :modname %ppmod); endif; ppr_yhat=%fore; endif; if(ido_ols.ge.4)then; call ranforest(:forecast hfuture :reg :yhatav); rf_yhat=%fore; endif; /; ************************************************************** if(iversion.eq.3)then; call marspline(y x :getmodel 'marszero.psv' :forecast hfuture ); marsyhat=%fore; endif; if(xklas.eq.0)then; %names=c8array(1: %names); %minvar=array(1: %minvar); %maxvar=array(1: %maxvar); %typevar=idint(array(1: %typevar)); %lag=array(1: %lag); tmpknd=kind(%lag); if(tmpknd.eq.8)%lag=idint(%lag); tmpknd=kind(%typevar); if(tmpknd.eq.8)%typevar=idint(%typevar); endif; if(iVersion.eq.1)then; call fprint(:col 1 :display 'Prediction Leverage of ' :col 23 :display %names(ivars) :col 33 :display '[lag=' :col 39 :display %lag(ivars) '(i2)' :col 41 :display ', int=' :col 48 :display interact '(i2)' :col 50 :display ', o=Minimums]' :save label :clear); endif; if(iVersion.eq.2)then; call fprint(:col 1 :display 'Contribution of Unit Chng in ' :col 29 :display %names(ivars) :col 39 :display '[lag=' :col 45 :display %lag(ivars) '(i2)' :col 47 :display ', int=' :col 54 :display interact '(i2)' :col 56 :display ', o=Minimums]' :save label :clear); endif; if(iVersion.eq.3)then; call fprint(:col 1 :display 'Additive Contribution of ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display ', o=Removed]' :save label :clear); endif; if(iVersion.eq.4)then; call fprint(:col 1 :display 'Contribution of Knot on ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display ', o=Minimums]' :save label :clear); endif; if(iVersion.eq.5)then; call fprint(:col 1 :display 'CSUM Contribution of Unit Chng in ' :col 34 :display %names(ivars) :col 44 :display '[lag=' :col 50 :display %lag(ivars) '(i2)' :col 52 :display ', int=' :col 59 :display interact '(i2)' :col 61 :display ', o=Minimums]' :save label :clear); endif; call fprint(:clear); if(nchart.lt.10)then; call fprint(:col 1 :string 'CChart0' :col 8 :display nchart '(i1)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(nchart.ge.10).and.(i.lt.100)then; call fprint(:col 1 :string 'CChart' :col 7 :display nchart '(i2)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(iversion.eq.2)then; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)-marsyhat(1); enddo; marsyhat(1)=0.; endif; if(iversion.eq.4)then; _fcst=marsyhat; do j=2,norows(marsyhat); marsyhat(j)=_fcst(j)-_fcst(j-1); enddo; marsyhat(1)=0.; endif; if(iversion.eq.5)then; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)-marsyhat(1); enddo; marsyhat(1)=0.; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)+marsyhat(j-1); enddo; endif; if(ihp .ne.0)then; hardcopy=':hardcopyfmt HP_GL2'; call character(fsv,'hp1'); endif; call fixend(labchrt,fsv,labchrt2); call graph(hfuture(,ivars), argument(dools) argument(show) :xlabel %names(ivars) :ylabelleft 'Contribution' 'c9' :plottype xyplot argument(grid) :nolabel argument(color) argument(markp) argument(hardcopy) :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file labchrt2 :heading label); /; ************************************************************* /; Save file /; ************************************************************* if(isave.ne.0.and.ido_ols.eq.0) call contrib3(isave,labchrt,hfuture(,ivars),marsyhat,fsv_info); if(isave.ne.0.and.ido_ols.eq.1) call contrib4(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info); if(isave.ne.0.and.ido_ols.eq.2) call contrib5(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info,gam_yhat); if(isave.ne.0.and.ido_ols.eq.3) call contrib6(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info,gam_yhat,ppr_yhat); /; /; ************************************************************* nchart=nchart+1; /; *************************************************************** /; Set Others to their maximums and re-chart (if interactions > 1) /; iversion <> 3 /; *************************************************************** do k=1,norows(%names); if(k.ne.ivars)then; hfuture(,k)=%maxvar(k); endif; enddo; /; ************************************************************** /; Forecast OLS, GAM, PPREG /; ************************************************************** if(ido_ols.ne.0)then; if(icons.eq.0)ols_yhat=mfam(hfuture)*vfam(olscoef); if(icons.eq.1)ols_yhat=vector(:(mfam(hfuture)*vfam(olscoef1))) + olscoef(norows(olscoef)); endif; if(ido_ols.ge.2)call gamfore(%spline,%xgam,hfuture,degmod, %gamcoef,gam_yhat,%link, %vartype,%df,printgam); if(ido_ols.eq.3)then; if(icons.eq.0)call ppreg(:forecast hfuture :modname %ppmod); if(icons.eq.1)then; adds=vector(norows(hfuture):)+1.0; hfuture2=catcol(mfam(hfuture),adds); call ppreg(:forecast hfuture2 :modname %ppmod); endif; ppr_yhat=%fore; endif; /; ************************************************************** if(iversion.ne.3)then; call marspline(y x :getmodel :forecast hfuture ); marsyhat=%fore; endif; if(iversion.eq.3)then; call marspline(y x :getmodel 'marszero.psv' :forecast hfuture ); marsyhat=%fore; endif; if(xklas.eq.0)then; %names=c8array(1: %names); %minvar=array(1: %minvar); %maxvar=array(1: %maxvar); %typevar=idint(array(1: %typevar)); %lag=array(1: %lag); tmpknd=kind(%lag); if(tmpknd.eq.8)%lag=idint(%lag); tmpknd=kind(%typevar); if(tmpknd.eq.8)%typevar=idint(%typevar); endif; if(iVersion.eq.1)then; call fprint(:col 1 :display 'Prediction Leverage of ' :col 23 :display %names(ivars) :col 33 :display '[lag=' :col 39 :display %lag(ivars) '(i2)' :col 41 :display ', int=' :col 48 :display interact '(i2)' :col 50 :display ', o=Maximums]' :save label :clear); endif; if(iVersion.eq.2)then; call fprint(:col 1 :display 'Contribution of Unit Chng in ' :col 29 :display %names(ivars) :col 39 :display '[lag=' :col 45 :display %lag(ivars) '(i2)' :col 47 :display ', int=' :col 54 :display interact '(i2)' :col 56 :display ', o=Maximums]' :save label :clear); endif; if(iVersion.eq.3)then; call fprint(:col 1 :display 'Additive Contribution of ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display ', o=Removed]' :save label :clear); endif; if(iVersion.eq.4)then; call fprint(:col 1 :display 'Contribution of Knot on ' :col 25 :display %names(ivars) :col 35 :display '[lag=' :col 41 :display %lag(ivars) '(i2)' :col 43 :display ', int=' :col 50 :display interact '(i2)' :col 52 :display ', o=Maximums]' :save label :clear); endif; if(iVersion.eq.5)then; call fprint(:col 1 :display 'CSUM Contribution of Unit Chng in ' :col 34 :display %names(ivars) :col 44 :display '[lag=' :col 50 :display %lag(ivars) '(i2)' :col 52 :display ', int=' :col 59 :display interact '(i2)' :col 61 :display ', o=Maximums]' :save label :clear); endif; call fprint(:clear); if(nchart.lt.10)then; call fprint(:col 1 :string 'CChart0' :col 8 :display nchart '(i1)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(nchart.ge.10).and.(i.lt.100)then; call fprint(:col 1 :string 'CChart' :col 7 :display nchart '(i2)' :col 9 :string '.wmf' :save labchrt :clear); endif; if(iversion.eq.2)then; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)-marsyhat(1); enddo; marsyhat(1)=0.; endif; if(iversion.eq.4)then; _fcst=marsyhat; do j=2,norows(marsyhat); marsyhat(j)=_fcst(j)-_fcst(j-1); enddo; marsyhat(1)=0.; endif; if(iversion.eq.5)then; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)-marsyhat(1); enddo; marsyhat(1)=0.; do j=2,norows(marsyhat); marsyhat(j)=marsyhat(j)+marsyhat(j-1); enddo; endif; if(ihp .ne.0)then; hardcopy=':hardcopyfmt HP_GL2'; call character(fsv,'hp1'); endif; call fixend(labchrt,fsv,labchrt2); call graph(hfuture(,ivars), argument(dools) argument(show) :plottype xyplot :xlabel %names(ivars) :ylabelleft 'Contribution' 'c9' argument(grid) :nolabel argument(color) argument(markp) argument(hardcopy) :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file labchrt2 :heading label); /; ************************************************************* /; Save file /; ************************************************************* if(isave.ne.0.and.ido_ols.eq.0) call contrib3(isave,labchrt,hfuture(,ivars),marsyhat,fsv_info); if(isave.ne.0.and.ido_ols.eq.1) call contrib4(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info); if(isave.ne.0.and.ido_ols.eq.2) call contrib5(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info,gam_yhat); if(isave.ne.0.and.ido_ols.eq.3) call contrib6(isave,labchrt,hfuture(,ivars),marsyhat,ols_yhat, fsv_info,gam_yhat,ppr_yhat); /; /; ************************************************************* nchart=nchart+1; endif; endif; enddo; return; end; subroutine fixend(labchrt,fsv,scaname); /; /; removes last 3 characters of a name and replaces with fsv /; /; used in contrib and contribs /; /; call character(fsv,'fsv'); /; call fixend(name1,fsv,name2); /; /; Built 30 December 2007 by Houston H. Stokes /; ------------------------------------------- /; call ialen(labchrt,jjunk); jjjunk=integers(1,jjunk); scaname=c1array(jjunk:); scaname(jjjunk)=labchrt(jjjunk); ijunk=jjunk-2; iijunk2=0; do iijunk=ijunk,jjunk; iijunk2=iijunk2+1; scaname(iijunk)=fsv(iijunk2); enddo; return; end; subroutine contrib3(isave,labchrt,var1,marsyhat,fsv_info); /; ************************************************************* /; Save file subroutine for contrib /; isave = 0 => return /; isave = 1 => sca fsv file using graph name with .fsv /; isave = 2 => sca fsv file using grahh name with .por /; isave = 3 => both fsv & por files made /; labchrt => sets file name used for chart /; var1 => data for chart x axis /; marsyhat => data for chart y axis /; fsv_info => Comment to place in fsv file /; ************************************************************* /; built by H H Stokes 29 December 2007 /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(isave.eq.1.or.isave.eq.3)then; call character(fsv,'fsv'); call fixend(labchrt,fsv,scaname); call makesca(var1 marsyhat :file scaname) :comment fsv_info; endif; if(isave.eq.2.or.isave.eq.3)then; call character(fsv,'por'); call fixend(labchrt,fsv,ratsname); call makerats(var1 marsyhat :file ratsname); endif; /; ************************************************************* return; end; subroutine contrib4(isave,labchrt,var1,marsyhat,olsyhat,fsv_info); /; ************************************************************* /; Save file subroutine for contrib /; isave = 0 => return /; isave = 1 => sca fsv file using graph name with .fsv /; isave = 2 => sca fsv file using grahh name with .por /; isave = 3 => both fsv & por files made /; labchrt => sets file name used for chart /; var1 => data for chart x axis /; Marsyhat => data for chart y axis /; olsyhat => data 2 for chart y axis /; fsv_info => Comment to place in fsv file /; ************************************************************* /; built by H H Stokes 15 February 2009 /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(isave.eq.1.or.isave.eq.3)then; call character(fsv,'fsv'); call fixend(labchrt,fsv,scaname); call makesca(var1 marsyhat olsyhat :file scaname :comment fsv_info); endif; if(isave.eq.2.or.isave.eq.3)then; call character(fsv,'por'); call fixend(labchrt,fsv,ratsname); call makerats(var1 marsyhat olsyhat :file ratsname); endif; /; ************************************************************* return; end; subroutine contrib5(isave,labchrt,var1,marsyhat,olsyhat,fsv_info gamyhat); /; ************************************************************* /; Save file subroutine for contrib /; isave = 0 => return /; isave = 1 => sca fsv file using graph name with .fsv /; isave = 2 => sca fsv file using grahh name with .por /; isave = 3 => both fsv & por files made /; labchrt => sets file name used for chart /; var1 => data for chart x axis /; Marsyhat => data for chart y axis /; olsyhat => data 2 for chart y axis /; fsv_info => Comment to place in fsv file /; gamyhat => Gam forecasts /; ************************************************************* /; built by H H Stokes 15 February 2009 /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(isave.eq.1.or.isave.eq.3)then; call character(fsv,'fsv'); call fixend(labchrt,fsv,scaname); call makesca(var1 marsyhat olsyhat gamyhat :file scaname :comment fsv_info); endif; if(isave.eq.2.or.isave.eq.3)then; call character(fsv,'por'); call fixend(labchrt,fsv,ratsname); call makerats(var1 marsyhat olsyhat gamyhat :file ratsname); endif; /; ************************************************************* return; end; subroutine contrib6(isave,labchrt,var1,marsyhat,olsyhat,fsv_info gamyhat,ppr_yhat); /; ************************************************************* /; Save file subroutine for contrib /; isave = 0 => return /; isave = 1 => sca fsv file using graph name with .fsv /; isave = 2 => sca fsv file using grahh name with .por /; isave = 3 => both fsv & por files made /; labchrt => sets file name used for chart /; var1 => data for chart x axis /; Marsyhat => data for chart y axis /; olsyhat => data 2 for chart y axis /; fsv_info => Comment to place in fsv file /; gamyhat => Gam forecasts /; ppr_yhat => ppreg forecasts /; ************************************************************* /; built by H H Stokes 27 February 2009 /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(isave.eq.1.or.isave.eq.3)then; call character(fsv,'fsv'); call fixend(labchrt,fsv,scaname); call makesca(var1 marsyhat olsyhat gamyhat ppr_yhat :file scaname :comment fsv_info); endif; if(isave.eq.2.or.isave.eq.3)then; call character(fsv,'por'); call fixend(labchrt,fsv,ratsname); call makerats(var1 marsyhat olsyhat gamyhat ppr_yhat :file ratsname); endif; /; ************************************************************* return; end; subroutine contrib7(isave,labchrt,var1,marsyhat,olsyhat,fsv_info gamyhat,ppr_yhat,rf_yhat); /; ************************************************************* /; Save file subroutine for contrib /; isave = 0 => return /; isave = 1 => sca fsv file using graph name with .fsv /; isave = 2 => sca fsv file using grahh name with .por /; isave = 3 => both fsv & por files made /; labchrt => sets file name used for chart /; var1 => data for chart x axis /; Marsyhat => data for chart y axis /; olsyhat => data 2 for chart y axis /; fsv_info => Comment to place in fsv file /; gamyhat => Gam forecasts /; ppr_yhat => ppreg forecasts /; rf_yhat => rf forecasts /; ************************************************************* /; built by H H Stokes 27 February 2009 /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(isave.eq.1.or.isave.eq.3)then; call character(fsv,'fsv'); call fixend(labchrt,fsv,scaname); call makesca(var1 marsyhat olsyhat gamyhat ppr_yhat rf_yhat :file scaname :comment fsv_info); endif; if(isave.eq.2.or.isave.eq.3)then; call character(fsv,'por'); call fixend(labchrt,fsv,ratsname); call makerats(var1 marsyhat olsyhat gamyhat ppr_yhat rf_yhat :file ratsname); endif; /; ************************************************************* return; end; subroutine marsmodc(coefvec); call restore(:file 'marss.psv'); %coef=coefvec; call checkpoint(:file 'marszero.psv' :var %BESTIN %FLAG %DIR %CUT %YVAR %NAMES %TYPEVAR %LAG %COEF %MINVAR %MAXVAR %K %NOB %RSS %SUMRE %REMAX %RESVAR %MARS_VR %SE %MODTYPE %NK); return; end; program contribd; /; mars - ols - gam - ppreg - ranforest /; /; Settings outside call to contrib /; /; MARS /; _knots=16; /; _mi=1; /; _ms=0; /; /; gam /; /; degmod=6; /; basedf = 3.; /; /; ppreg /; /; _m =4; /; iopt=0; /; iols=3; /; ihp=0; /; isave=3; /; iversion=1; /; igrid=1; /; ishow=1; /; alpha=0.0; /; /; specific settings /; /; call character(fsv_info,'M1 =Fish Model'); /; call character(l_hand_s,'m1'); /; call character(_args, /; 'shift m1{1 to 2} fw ssam1'); /; call character(_argsg, /; 'shift[factor,1] m1[predictor,3]{1 to 2} fw ssam1 '); /; call contribd; /; /; Key local variables created /; /; %olsyhat /; %olscoef /; %maryhat /; %gamcoef /; %gamyhat /; %ppryhat /; %rfyhat /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(kind(_df).eq.-99)then; _df=3.; endif; if(do_tests.ne.0)then; call olsq( argument(l_hand_s) argument(_args) :diag :qr :print); %olscoef=%coef; %olsyhat=%yhat; call marspline(argument(l_hand_s) argument(_args) :mathform :print :nk _knots :mi _mi :df _df :savemodel :xx :savex ); %maryhat=%yhat; /; Analysis by observation of variables. /; June 2009 changed 2,2 to default of to remove output /; c_sums - k element vector indicating # of times each vector ne 0 /; r_sums - n element vector indicating # of non zero vectors in row /; _printcr - => 1 print c_sums r_sums /; _printcr - => 2 print c_sums r_sums as columns /; _printcr - => 3 print c_sums r_sums as numbered rows /; _plotcr - => 1 Draw a histogram /; _plotcr - => 2 Draw a histogram and save in file fname call marsdiag(%xx,c_sums,r_sums,_printcr,_plotcr,'test1.wmf'); call marsinfo; /$ **************************************************************$/ /$ Create contribution charts for righthand-side variables /$ **************************************************************$/ /; /; First save the data and get medians/means etc /; call lagmatrix( argument(_args) :noint :matrix tmat); _medians=array(nocols(tmat):); _means=_medians; do i=1,norows(_medians); call describe(tmat(,i)); _medians(i) =%median; _means(i) =%mean; enddo; call gamfit(argument(l_hand_s) argument(_argsg) :basedf _gdf :dist gauss :print :savex :punch_sur); %gamcoef=%coef; %xgam=%x; %gamyhat=%yhat; call ppreg(argument(l_hand_s) argument(_args) :savemodel :modname %test :alpha _alpha :print :m _m ); %ppryhat=%yhat; call compress; call ranforest(argument(l_hand_s) argument(_args) :imp :savex :savemodel :yhatav :reg :maxtree _mtree :print :mtry _mtry ); %rfyhat=%yhat; endif; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(do_ppexp.ne.0)then; if(do_ppexp.eq.2) call ppexp(argument(l_hand_s) argument(_args) :mm _mm :jj _jj :fei _fei :nei _nei :trm _trm :print ); if(do_ppexp.eq.1) call ppexp(argument(l_hand_s) argument(_args) :mm _mm :jj _jj :fei _fei :nei _nei :trm _trm ); call print('Exploratory Projection Pursuit Index',%ppindex); call ppexp_p(%xpa,%mm,%nob,0,'t2',%ppindex); /; call ppexp_p(%xpa,%mm,%nob,1,'t2',%ppindex); endif; if(do_tests.ne.0)then; call contrib2(iopt,message,_medians,iversion,isave,ihp,iols, %olscoef,igrid,ishow,fsv_info, %spline,%xgam,%gamcoef,%link, %vartype,%df,degmod,%test); call graph(%y %olsyhat %gamyhat :nolabel :grid :file 'ols_gam_fit.wmf' :heading 'OLS and Gam Fits of a Nonlinear Model' :nocontact :pgborder); endif; return; end; program contribs; /; /; quick way to run OLS, MARS, GAM, ppexp and PPREG /; /; have set iols=2. For ppreg set iols=3 /; call before call to contribd; /; /; mars - ols - gam - ppreg /; /; Example of use: /; /; First call loads routines /; Call contribi calls other needed routines. Needed only once /; contribi calls contribs to set /; /; call load(contrib); /; call contribi; /; call character(fsv_info,'M1 =Fish Model'); /; call character(l_hand_s,'m1'); /; call character(_args, /; 'shift m1{1 to 2} fw ssam1'); /; call character(_argsg, /; 'shift[factor,1] m1[predictor,3]{1 to 2} fw ssam1 '); /; /; override settings here /; /; call contribd; /; /; Settings outside call to contribd /; /; MARS _knots=16; _mi=1; _ms=0; _printcr=0; _plotcr=2; /; /; gam /; _gdf=2.0; degmod=6; /; /; ppreg /; _m =4; _alpha=0.0; iopt=0; iols=2; ihp=0; isave=3; iversion=1; igrid=1; ishow=1; /; /; RF settings /; _mtree=50; _mtry=-10; /; /; ppexp_p /; do_tests=1; do_ppexp=0; /; sets number of solutions _mm=5; /; sets order of legenre _jj=2; /; Threshold for data space dimensionality reduction _fei=.1e-4; /; Max dimension of search space _nei = 1; /; Trimming Threshold _trm=.0; return; end; program contribi; /; /; load routines to run contrib analysis /; call load(marsdiag :staging); call load(marsinfo :staging); call load(contrib); call load(polyfit); call load(polyval); call load(gamfore); call load(ppexp_p); call contribs; return; end; program contribl; /; /; list settings in effect for contrib analysis /; /; /; quick way to run OLS, MARS, GAM, ppexp and PPREG /; /; call before call to contribd; /; /; mars - ols - gam - ppreg /; /; Example of use: /; /; First call loads routines /; Call contribi calls other needed routines. Needed only once /; /; call load(contrib); /; call contribi; /; call contribs; /; call character(fsv_info,'M1 =Fish Model'); /; call character(l_hand_s,'m1'); /; call character(_args, /; 'shift m1{1 to 2} fw ssam1'); /; call character(_argsg, /; 'shift[factor,1] m1[predictor,3]{1 to 2} fw ssam1 '); /; /; override settings here /; /; call contribl; /; call contribd; /; /; Settings outside call to contribd /; /; MARS if(do_tests.ne.0)then; call print('Settings for Leverage plots':); call print('Mars Models':); call print('Number of knots for MARS (_knots) ',_knots:); call print('Number of interactions (_mi) ',_mi:); call print('Max span between each knot (_ms=0) ',_ms:); call print('C_rows / r_rows print setting ',_printcr:); call print('Plot setting ',_plotcr:); call print(' ':); call print('GAM Models':); call print('Degree of Polynomial for forecasts (degmod) ',degmod:); call print('Default degree of GAM model (_gdf) ',_gdf:); call print(' ':); call print('PPREG Models':); call print('Number of trees (_m) ',_m:); call print('Smoothing Parameter (_alpha) ',_alpha:); call print(' ':); if(do_ppexp.eq.0) call print('Exploratory Projection Pursuit turned off (do_ppexp=0)':) if(do_ppexp.ne.0) call print('Exploratory Projection Pursuit turned on (do_ppexp=1)':) if(iopt.eq.0) call print('Medians will be calculated (iopt=0)':); if(iopt.ne.0) call print('User setting used ',message:); if(iols.eq.0) call print('OLS vector not placed MARS vector (iols=0)':); if(iols.eq.1) call print('OLS vector placed over MARS vector (iols=1)':); if(iols.eq.2) call print('OLS, GAM and MARS plotted (iols=2)':); if(iols.eq.-2) call print('OLS, GAM plotted (iols=-2)':); if(iols.eq.3) call print('OLS, GAM, MARS and PPREG plotted (iols=3)':); if(iols.eq.4) call print('OLS, GAM, MARS PPREG and RF plotted (iols=4)':); if(ihp.eq.0) call print('Plots produced in WMF form (ihp=0)':); if(ihp.ne.0) call print('Plots produced in HP form (ihp=1)':); if(isave.eq.0) call print('No saves of plot data (isave=0)':); if(isave.eq.1) call print('Data saved in SCA fsv format (isave=1)':); if(isave.eq.2) call print('Data saved in RATS por format (isave=2)':); if(isave.eq.3) call print('Data saved in fsv and por format (isave=3)':); call print(' ':); if(iversion.eq.1)call print( 'Leverage effect of target variable (iversion=1)':); if(iversion.eq.2)call print( 'Leverage effect of difference YHat->YHat(t)-YHat(1) (iversion=2)':); if(iversion.eq.3)call print( 'Additive contribution of target variable (iversion=3)':); if(iversion.eq.4)call print( 'Knot effect of target var on YHat diff1(Yhat) (iversion=4)':); if(iversion.eq.5)call print( 'Cumulative contribution of target variable unit increase (iversion=5)': ); if(igrid.eq.0) call print('No grids placed on graphs (igrid=0)':); if(igrid.ne.0) call print('Grids placed on graphs (igrid=1)':); if(ishow.eq.0) call print('Do not show graphs (ishow=0)':); if(ishow.ne.0) call print('Show graphs (ishow=1)':); call print('Data to write in fsv file (fsv_info) ', fsv_info:); endif; if(iols.ge.4)then; call print(' ':); call print('Random Forest Settings (iold=4) ':); call print('Minimum number of variables rendomly selected (_mtry) ', _mtry:); call print('Maximum number of trees (_mtree) ', _mtree:); endif; if(do_ppexp.ne.0)then; call print(' ':); call print('Settings for Exploratory Projection Pursuit':); call print('Number of PPEXP solutions (_mm) ', _mm:); call print('Order of Legenre (_jj) ', _jj:); call print('Threshold for data space dimension reduction (_fei) ', _fei:); call print('Max dimension of search space (_nei) ', _nei:); call print('Trimming Threshold (_trm) ', _trm:); endif; call print(' ':); call print('Left hand side variable (l_hand_s) ', l_hand_s:); call print('Right hand side variables (_args) ', _args); call print('GAM right hand side variables (_argsg) ', _argsg); call print(' ':); return; end; /; end ---------------------------------------- == ==CANCORR Canonical Correlations subroutine cancorr(cc,x,z,a,lamda); /; /; calculated canonical Cross correlations /; cc => Canonical crtpss cortrelations /; x => right hand side. Usually set as %x from OLS step /; z => instrumental Variables /; a => eigenvectors of (inv(xpx)*xpz*inv(z'z)*zpx /; lamda => eigenvectors of inv(zpz)*zpx*inv(xpx)*xpz) /; /; See Hall-Rudebusch-Wilcox /; "Judging Instrumental Re;evance in Instrumental Variable /; Estimation" International Economic Review 1996 pp. 283-298 /; Command built 26 May 2010 /; n1=norows(z); n2=norows(x); if(n1.ne.n2)then; call epprint('ERROR: # obs for Z ne # obs for X'); go to done; endif; if(klass(z).ne.2.and.klass(z).ne.1)then; call epprint('ERROR: Z not a vector or matrix'); go to done; endif; if(klass(x).ne.2.and.klass(x).ne.1)then; call epprint('ERROR: X not a vector or matrix'); go to done; endif; zpz = transpose(z)*z; zpx = transpose(z)*x; xpx = transpose(x)*x; if(rank(x).ne.nocols(x))then; call epprint('ERROR: X not full rank'); go to done; endif; if(rank(z).ne.nocols(z))then; call epprint('ERROR: z not full rank'); go to done; endif; /; /; squared canonical correlations /; cc =real( eig(inv(xpx)*transpose(zpx)*inv(zpz)*zpx ,a )); cc1=real( eig(inv(zpz)*zpx *inv(xpx)*transpose(zpx),lamda)); /; cc=sqrt(cc); a=real(a); lamda=real(lamda); done continue; return; end; == ==CPERIOD Normalized Cumulative Periodogram subroutine cperiod(x,name,c_period,c_p_freq,idrop); /; /; Normalized Cumulative Periodogram /; /; Box-Jenkins-Rensel (2008,347-350) suggests calculation of /; cumulative Periodogram to test detect periodic nonrandomness /; /; See Jenkins and Watts (1968, 235) /; /; For significance of .95 and .75 lamda = 1.36 and 1.02 /; .99 and .90 lamda = 1.63 and 1.22 /; band is +- lamda/sqrt(n/2)-1)) /; /; Command built October 2009 by Houston H. Stokes /; /; x = series to test /; name = name of series /; c_period = normalized cumulative periodogram /; c_p_freq = frequency of normalized cumulative periodogram /; idrop = Number of c_period values to drop /; /; name of file is 'c_n_period.wmf' /; n=dfloat(norows(x)); varx=variance(x); if(varx.le.0.0d+00)then; call print('ERROR: Series has no variance':); go to done; endif; p =spectrum(x,freq2); c_p_freq=freq2; c_period=cusum(p)/(n*varx); if(idrop.gt.0)then; c_p_freq =dropfirst(freq2, idrop); c_period=dropfirst(c_period,idrop); endif; diag=dfloat(integers(1,norows(c_period))); diag=diag/dfloat(norows(c_period)); test=1./dsqrt(((n/2.) -1.)); upper99=diag+((1.63)*test); lower99=diag-((1.63)*test); upper95=diag+((1.36)*test); lower95=diag-((1.36)*test); /; /; These bands can be added if desired /; /; upper90=diag+((1.22)*test); /; lower90=diag-((1.22)*test); upper75=diag+((1.02)*test); lower75=diag-((1.02)*test); call character(cc,'Cumulative Periodogram of '); call character(cc2,name); call ialen(cc2,ii); call expand(cc,cc2,27,27+ii); call graph(c_p_freq,c_period,diag, upper99 lower99 upper95, lower95 upper75 lower75 :heading cc :pgborder :nocontact :nolabel :plottype xyplot :file 'n_c_period.wmf'); done continue; return; end; == ==DATAVIEW Interactively View Data subroutine dataview(x,xx); /; /; Views data series x under User Control /; /; x => series /; xname => x series name /; weights=array(5:)+1.; nacf=dmin1((norows(x)/4),48); ask continue; i3=5; call menu(i3 :menutype menuvert :text 'Use raw data ' :text 'Use (1-B)*X ' :text 'Use (1-B)**2.' :text 'Set # of ACF / PACF terms' :text 'Stop ' :heading 'Select Differencing' ); if(i3.eq.5)go to done; i4=1; call menu(i4 :menutype menuvert :text 'Calculate and display ACF ' :text 'Do Spectral Analysis' :text 'Stop ' :heading 'Task selection' ); if(i4.eq.3)go to done; if(i4.eq.2)then; i5=3; call menu(i5 :menutype menuvert :text 'Set weights of 1 1 1 1 1 ' :text 'Enter Manual Mode to set weights' :text 'Use already supplied / default weights' :text 'Stop ' :heading 'Set Weights array (odd # elements)' ); if(i5.eq.1)weights=array(5:)+1.; getw continue; if(i5.eq.2)call manual; if(i5.eq.4)go to done; if(dmod(norows(weights),2).eq.0)then; i6=1; call menu(i6 :menutype menutwo :prompt '# Weights must be odd >' :text 'Set weights ' :text ' Stop'); if(i6.eq.2)go to done; if(i6.eq.1)then; i5=2; go to getw; endif; endif; endif; if(i3.eq.1)go to run1; if(i3.eq.2)go to run2; if(i3.eq.3)go to run3; if(i3.eq.4)go to run4; if(i3.eq.5)go to done; run1 continue; call free(heading1); if(i4.eq.2)call character(heading1,'Series '); if(i4.eq.1)call character(heading1,'Plot of '); call character(cc2,xx); call ialen(cc2,ii); call expand(heading1,cc2,9,9+ii); if(i4.eq.1)call data_acf(x,heading1,nacf); if(i4.eq.2)then; call do_spec(x,heading1,weights); call cperiod(x,heading1,c_period,c_p_freq,1); endif; go to ask; run2 continue; call free(heading1); d=dif(x); call character(heading1,'(1-B) * '); call character(cc2,xx); call ialen(cc2,ii); call expand(heading1,cc2,9,9+ii); if(i4.eq.1)call data_acf(d,heading1,nacf); if(i4.eq.2)then; call do_spec(d,heading1,weights); call cperiod( d,heading1,c_period,c_p_freq,1); endif; go to ask; run3 continue; call free(heading1); d2=dif(x,2,1); call character(heading1,'(1-B)**2 * '); call character(cc2,xx); call ialen(cc2,ii); call expand(heading1,cc2,12,12+ii); if(i4.eq.1)call data_acf(d2,heading1,nacf); if(i4.eq.2)then; call do_spec(d2,heading1,weights); call cperiod( d2,heading1,c_period,c_p_freq,1); endif; go to ask; run4 continue; call menu(nacf2 :menutype inputint :heading 'Set NACF' :prompt 'Input # NAC terms' ); if(nacf2.lt.1)then; i=2; call menu(i :menutype menutwo :text 'Reset' :text 'Use Default' :prompt 'NACF set LE 1' ); if(i.eq.1)go to run4; if(i.eq.2.or.i.eq.0)go to ask; endif; if(nacf2.gt.(norows(x)-2))then; i=2; call menu(i :menutype menutwo :text 'Reset' :text 'Use Default' :prompt 'NACF set too large' ); if(i.eq.1)go to run4; if(i.eq.2.or.i.eq.0)go to ask; endif; nacf=nacf2; go to ask; done continue; return; end; subroutine data_acf(x,heading1,nacf); /; /; Display series and ACF /; /; x = Series to display /; heading = Heading for series /; nacf = Number of ACF and PACF /; /; Note: Can be called alone or under dataview /; /; *********************************************** /; acf1=acf(x,nacf,se1,pacf1); call graph(x :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call graph(acf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p2.hp1' :hardcopyfmt HP_GL2 :heading 'ACF of Above Series'); call graph(pacf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p3.hp1' :hardcopyfmt HP_GL2 :heading 'PACF of Above Series'); call menu(cc :menutype inputtext :prompt 'ACF Save File Name. blank => clipboard' ); call grreplay(:start :file cc ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); return; end; subroutine do_spec(x,heading1,weights); /; /; Display Periodogram and Spectrum /; /; x = Input Series /; heading1 = Heading for series /; weights = Smoothing weights /; /; Note: Can be called alone or under dataview /; /; *********************************************** /; period =spectrum(x,freq3); spec =spectrum(x,freq3 :weights); freq2=freq3/(2.0*pi()); call graph(freq2 period :plottype xyplot :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :ylabelleft 'Periodogram' 'C9' :file 'period1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call graph(freq2 spec :plottype xyplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :ylabelleft 'Spectrum' 'C9' :file 'spec1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call menu(cc :menutype inputtext :prompt 'Spectral Save File Name. blank => clipboard' ); call grreplay(:start :file cc ); call grreplay(:cont 'period1.hp1' :gformat twograph 1); call grreplay(:cont 'spec1.hp1' :gformat twograph 2); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'period1.hp1' :gformat twograph 1); call grreplay(:cont 'spec1.hp1' :gformat twograph 2); call grreplay(:final); return; end; == ==DATA_ACF Plot ACF and PACF of a series subroutine data_acf(x,heading1,nacf); /; /; Display series and ACF /; /; x = Series to display /; heading = Heading for series /; nacf = Number of ACF and PACF /; /; Note: Can be called alone or under dataview /; /; data2acf has an added argument for plot file name /; /; ********************************************************** /; acf1=acf(x,nacf,se1,pacf1); call graph(x :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call graph(acf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p2.hp1' :hardcopyfmt HP_GL2 :heading 'ACF of Above Series'); call graph(pacf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p3.hp1' :hardcopyfmt HP_GL2 :heading 'PACF of Above Series'); call menu(cc :menutype inputtext :prompt 'ACF Save File Name. blank => clipboard' ); call grreplay(:start :file cc ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); return; end; == ==DATA2ACF Plot ACF and PACF of a series with file name subroutine data2acf(x,heading1,nacf,file); /; /; Display series and ACF /; /; x = Series to display /; heading = Heading for series /; nacf = Number of ACF and PACF /; file = Plot File name /; /; Note: Can be called alone or under dataview /; /; data_acf does not have argument cc /; /; *********************************************** /; acf1=acf(x,nacf,se1,pacf1); call graph(x :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call graph(acf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p2.hp1' :hardcopyfmt HP_GL2 :heading 'ACF of Above Series'); call graph(pacf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p3.hp1' :hardcopyfmt HP_GL2 :heading 'PACF of Above Series'); call grreplay(:start :file file ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 3); call grreplay(:cont 'p3.hp1' :gformat fourgraph 4); call grreplay(:final); return; end; == ==DATA3ACF Plot ACF,PACF & spectrum of a series with file name subroutine data3acf(x,heading1,nacf,file); /; /; Display series and ACF /; /; x = Series to display /; heading = Heading for series /; nacf = Number of ACF and PACF /; file = Plot File name /; /; Note: Can be called alone or under dataview /; /; data_acf does not have argument cc /; /; *********************************************** /; acf1=acf(x,nacf,se1,pacf1); call spectral(x,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call graph(x :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call graph(sx:noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p2.hp1' :hardcopyfmt HP_GL2 :heading 'Spectrum with weights 1 2 3 2 1'); call graph(acf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p3.hp1' :hardcopyfmt HP_GL2 :heading 'ACF of Above Series'); call graph(pacf1 se1 :overlay acfplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :file 'p4.hp1' :hardcopyfmt HP_GL2 :heading 'PACF of Above Series'); call grreplay(:start :file file ); call grreplay(:cont 'p1.hp1' :gformat fourgraph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 2); call grreplay(:cont 'p3.hp1' :gformat fourgraph 3); call grreplay(:cont 'p4.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'p1.hp1' :gformat fourgraph 1); call grreplay(:cont 'p2.hp1' :gformat fourgraph 2); call grreplay(:cont 'p3.hp1' :gformat fourgraph 3); call grreplay(:cont 'p4.hp1' :gformat fourgraph 4); call grreplay(:final); return; end; == ==DF_GLS Elliot-Rothenberg-Stock DF_GLS Test subroutine DF_GLS(x,lag1,notrend,trend,notrendx,trendx,iprint); /; /; Implements Elliot-Rothenberg-Stock (1996) Unit root test /; documented in "Efficient Tests for an Autoregressive Root" /; Econometrica 64(4): 813-836. See also "Introduction to /; Econometrics," By James Stock and Mark Watson, Addison /; Wesley New York 2003 page 549-550 /; In the 2007 2nd edition published by Pearson the discussion of the /; test is contained on pages 650 - 653 /; /; Patch made 26 April to initialize v1(1) & v2(1) to x(1) and /; provide alternative second stage output. /; /; ********************************************************** /; /; x = series to test /; lag1 = Lag for DF part of test. Must be GE 1 /; notrend = > no trend test statistic /; This statistic estimated without a constant /; trend = > trend test statistic /; This statistic restimated without a constant /; notrendx = x smoothed without a trend /; trendx = x smoothed with a trend /; iprint = 2 to print steps and test, = 1 print test only /; = 3 print internal data v1 v2 /; /; Note: notrendx and trendx can be styudied externally from this /; routine. /; Improvements made 26 April 2009 by Houston H. Stokes /; /; a1=1.0-(13.5/dfloat(norows(x))); a2=1.0-( 7.0/dfloat(norows(x))); v1=x; v2=x; i=integers(2,norows(x)); v1(i) =afam(x(i))- a1*afam(x(i-1)); v2(i) =afam(x(i))- a2*afam(x(i-1)); x11=array(norows(x):)+1.; x12=x11; x11(i)=x11(i)-a1; x12(i)=x12(i)-a2; i=integers(1,norows(x)); x21=dfloat(i)-(a1*dfloat(i-1)); if(iprint.lt.2)call olsq(v1 x11 x21 :noint); if(iprint.ge.2)call olsq(v1 x11 x21 :noint :print); trendx= afam(x)- (%coef(1)+%coef(2)*dfloat(i)); if(iprint.lt.2)call olsq(v2 x12 :noint); if(iprint.ge.2)call olsq(v2 x12 :noint :print); if(iprint.eq.3)call tabulate(v1,v2); notrendx= x-%coef(1); /; dx1=dif(trendx) ; dx2=dif(notrendx) ; lx1=goodrow(lag( trendx,1)); lx2=goodrow(lag(notrendx,1)); if(iprint.eq.2)then; call olsq(dx1 lx1 dx1{1 to lag1} :noint :print); call olsq(dx2 lx2 dx2{1 to lag1} :noint :print); endif; call df(trendx, trend :df lag1 ); call df(notrendx,notrend :df lag1 ); if(iprint.ne.0)then; call print('Elliot-Rothenberg-Stock (1996) Unit root test. Lag ',lag1:); call print('ADF_GLS test: Assuming notrend and no constant ', notrend:); call print('Critical values are 10% -1.62, 5% -1.95, 1% -2.58 ':); call print('ADF_GLS test: Assuming trend but no constant ', trend:); call print('Critical values are 10% -2.57, 5% -2.89, 1% -3.48 ':); call print('Test value < critical value => reject unit root ':); call print(' ':); call df(notrendx,a2:adf lag1 ); call print('ADF (II) analysis of notrendx ',a2:); call df(trendx, a2:adf lag1 ); call print('ADF (II) analysis of trendx ',a2:); endif; return; end; == ==DIST_TAB Distribution Table subroutine dist_tab(x,n,q,qvalue,number,iprint); /; /; Shows Cumulative distribution of a variable /; /; x => input series /; n => input # of quantile values /; q => Q /; qvalue => qvalue /; number => # in the group /; iprint => NE 0 = print /; /; Built July 2003 /; start=1.0/dfloat(n); q =grid(start, 1.0, start-.1e-10); call quantile(x,q,qvalue,xlow,xhigh); number=idint(array(n-1:)); one=array(norows(x):)+1.0; do i=1,n; mask=array(norows(x):); if(i.eq.1)then; test=array(norows(x):)+qvalue(i); where(x .le. sfam(qvalue(i)))mask=one; endif; if(i.ne.1)then; if(klass(x).eq.5)then; test =array(norows(x):)+qvalue(i-1); test2=array(norows(x):)+qvalue(i); endif; if(klass(x).eq.1)then; test =vector(norows(x):)+qvalue(i-1); test2=vector(norows(x):)+qvalue(i); endif; where((x .gt. test) .and.( x .le. test2)) mask=one; endif; number(i)=idint(sum(mask)); enddo; if(iprint.ne.0)then; cum_sum=cusum(dfloat(number)); call tabulate(q,qvalue,number,cum_sum,xlow,xhigh); endif; return; end; == ==DO_SPEC View Spectrum subroutine do_spec(x,heading1,weights); /; /; Display Periodogram and Spectrum /; /; x = Input Series /; heading1 = Heading for series /; weights = Smoothing weights /; /; Note: Can be called alone or under dataview /; do2spec has a file argument /; /; *********************************************** /; period =spectrum(x,freq3); spec =spectrum(x,freq3 :weights); freq2=freq3/(2.0*pi()); call graph(freq2 period :plottype xyplot :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :ylabelleft 'Periodogram' 'CV' :file 'period1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call graph(freq2 spec :plottype xyplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :ylabelleft 'Spectrum' 'CV' :file 'spec1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call menu(cc :menutype inputtext :prompt 'Spectral Save File Name. blank => clipboard' ); call grreplay(:start :file cc ); call grreplay(:cont 'period1.hp1' :gformat twograph 1); call grreplay(:cont 'spec1.hp1' :gformat twograph 2); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'period1.hp1' :gformat twograph 1); call grreplay(:cont 'spec1.hp1' :gformat twograph 2); call grreplay(:final); return; end; == ==DO2SPEC View Spectrum with a file name subroutine do2spec(x,heading1,weights,cc); /; /; Display Periodogram and Spectrum /; /; x = Input Series /; heading1 = Heading for series /; weights = Smoothing weights /; cc = file name /; /; Note: Can be called alone or under dataview /; do_spec does not have a file argument /; /; *********************************************** /; period =spectrum(x,freq3); spec =spectrum(x,freq3 :weights); freq2=freq3/(2.0*pi()); call graph(freq2 period :plottype xyplot :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :ylabelleft 'Periodogram' 'CV' :file 'period1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call graph(freq2 spec :plottype xyplot :noshow :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :ylabelleft 'Spectrum' 'CV' :file 'spec1.hp1' :hardcopyfmt HP_GL2 :heading heading1); call grreplay(:start :file cc ); call grreplay(:cont 'period1.hp1' :gformat twograph 1); call grreplay(:cont 'spec1.hp1' :gformat twograph 2); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'period1.hp1' :gformat twograph 1); call grreplay(:cont 'spec1.hp1' :gformat twograph 2); call grreplay(:final); return; end; == ==DUD Derivative Free Nonlinear Estimation subroutine dud(xvar,yvar,beta,r,f,sse,seb,covb,corrb,iprint,iout); /; /; Based on SAS(r) nonlinear routine dud in technical report a-102 /; page 8-9 /; /; DUD does Derivative free nonlinear estimation. /; /; DUD needs user subroutine resid /; /; DUD was built for Speakeasy(r) by Houston H. Stokes April 1987 /; /; DUD was converted for B34S Matrix Command June 1998 /; /; DUD illustrates the power in the 4th generation SAS MATRIX, /; Speakeasy and B34S programming languages /; /; xvar = matrix of x variables - input /; yvar = left hand side variable vector - input /; beta = vector of initial guess on coefficients - input/output /; r = residual vector - output /; f = predicted variable vector - output /; sse = sum of squared residuals (sumsq(r)) - output /; seb = se's of the beta coefficients - output /; covb = covariance matrix of beta coefficients - output /; corrb = correlation matrix of beta coefficients - output /; iprint= 0 for no iteration print, =1 for iteration print - input /; iout =0 for no output printing, =1 output will be given - input /; call cls(-1); maxit=3000; xvar=vfam(xvar) ; yvar=vfam(yvar) ; p=norows(beta) ; n=norows(xvar) ; bb=matrix(p,p:) ; sss=vector(p:) ; ff=matrix(n,p:) ; beta=vfam(beta) ; for i=1,p ; b=beta ; /; Change ? b(i)=beta(i) *1.01 ; /; If problems user can adjust /;b(i)=beta(i) * 1.0001 ; bb(1,i)=b ; call resid(b,f,r,sse,xvar,yvar) ; sss(i)=sse ; ff(1,i)=f ; call break('Loop one') ; next i ; /; sort initial values by sse & beta; r=ranker((-1.0)*afam(sss)); i=integers(1,norows(sss)) ; z=sss ; sss(r)=z(i) ; z=ff ; ff(1,r)=z(1,i) ; bhold=bb ; bb(1,r)=bhold(1,i) ; /; start iterations b=beta ; call resid(b,f,r,sse,xvar,yvar) ; eps=1. ; if(iout.eq.1) call print('Nonlinear Estimation using derivative free method' ' ' 'Initial sse betas', sse,beta,' '); iter=0 ; subiter=0 ; if(iprint .eq. 1)call print(iter,subiter,eps,sse,b); j=matrix(1,p:); call setrow(j,1,1.0); do iter=1,maxit; call outstring(1,2,'Nonlinear Estimation using derivative free method'); call outstring(1,3,'Iter eps sse'); call outinteger(15,3,iter); call outdouble(30,3,eps,'(e16.8)'); call outdouble(50,3,sse,'(e16.8)'); if(eps.le..0001)go to fdone; oldb=b ; oldsse=sse ; oldf=f ; temp=matrix(norows(f),1:) ; temp(,1)=f ; x=ff - temp*j ; alpha=inv((transpose(x)*x):pdmat) *(transpose(x)*mfam(yvar - f)); temp=matrix(norows(b),1:) ; temp(,1)=b ; dp=bb-temp*j ; delta=vfam(dp*alpha) ; b=b+delta ; eps=dmax(dabs(afam(delta))) ; call outdouble(30,3,eps,'(e16.8)'); call resid(b,f,r,sse,xvar,yvar ) ; if(iprint.eq.1)call print(iter,subiter,eps,sse,b); /; step shortening do subiter=1,10; call outstring(1 ,4,'Subiter') ; call outinteger(15,4,subiter) ; call outdouble(30,3,eps,'(e16.8)') ; call outdouble(50,3,sse,'(e16.8)') ; if(sse .le. oldsse)go to done ; /; Change ? /; .5 is default delta=delta*.5; /;delta=delta* .9 ; b=oldb+delta ; call resid(b,f,r,sse,xvar,yvar) ; if(iprint.eq.1)call print(iter,subiter,eps,sse,b); call break('Loop two'); enddo; /; done done continue; subiter=0; bb=rollleft(bb) ; bb(1,p)=oldb ; sss=rollleft(sss) ; sss(p)=oldsse ; ff=rollleft(ff) ; ff(1,p)=oldf ; call break('Loop three') ; enddo ; /; Finally done fdone continue; beta=b; if(iter.ge.maxit)call print('Convergence failed.') ; covb=dp*inv(transpose(x)*x :pdmat)*sse*transpose(dp) ; covb=mfam(afam(covb)/(dfloat(norows(xvar))-dfloat(norows(beta)))); seb=afam(dsqrt(diag(covb))) ; s=vfam(1./seb) ; s=diagmat(:s) ; corrb=s*covb*s ; if(iout.eq.1)then ; tscore=vfam(afam(beta)/afam(seb)) ; call tabulate(beta,seb,tscore) ; see=dsqrt(sse/dfloat(norows(xvar)-norows(beta))) ; call print(' ', sse,see,' ', 'Covariance of betas',covb, ' ', 'Correlation of Betas ',corrb) ; endif; return; end; == ==DUD2 Derivative Free Nonlinear Estimation subroutine dud2(xvar,yvar,beta,r,f,sse,seb,covb,corrb,iprint,iout, eps1,eps2); /; /; Routine is built to run REAL*8 or REAL*16 /; Based on SAS(r) nonlinear routine dud in technical report a-102 /; page 8-9 /; /; DUD does Derivative free nonlinear estimation. /; /; DUD needs user subroutine resid /; /; DUD was built for Speakeasy(r) by Houston H. Stokes April 1987 /; /; DUD was converted for B34S Matrix Command June 1998 /; /; DUD illustrates the power in the 4th generation SAS MATRIX, /; Speakeasy and B34S programming languages /; /; xvar = matrix of x variables - input /; yvar = left hand side variable vector - input /; beta = vector of initial guess on coefficients - input/output /; r = residual vector - output /; f = predicted variable vector - output /; sse = sum of squared residuals (sumsq(r)) - output /; seb = se's of the beta coefficients - output /; covb = covariance matrix of beta coefficients - output /; corrb = correlation matrix of beta coefficients - output /; iprint= 0 for no iteration print, =1 for iteration print - input /; iout = 0 for no output printing, =1 output will be given - input /; eps1 = change in beta to try - input /; eps2 = convergence tol. - input /; call cls(-1); maxit=3000; xvar=vfam(xvar) ; yvar=vfam(yvar) ; p=norows(beta) ; n=norows(xvar) ; bb= kindas(xvar,matrix(p,p:)) ; sss=kindas(xvar,vector(p:)) ; ff= kindas(xvar,matrix(n,p:)) ; beta=kindas(xvar,vfam(beta)) ; for i=1,p ; b=beta ; b(i)=beta(i) *eps1; /; If problems user can adjust /;b(i)=beta(i)*kindas(beta,1.00001); bb(1,i)=b ; call resid(b,f,r,sse,xvar,yvar) ; call print('sse ',sse); sss(i)=sse ; ff(1,i)=f ; call break('Loop one') ; next i ; /; sort initial values by sse & beta; r=ranker(kindas(sss,-1.0)*afam(sss)); i=integers(1,norows(sss)) ; z=sss ; sss(r)=z(i) ; z=ff ; ff(1,r)=z(1,i) ; bhold=bb ; bb(1,r)=bhold(1,i) ; /; start iterations b=beta ; call resid(b,f,r,sse,xvar,yvar) ; eps=kindas(b,1.) ; if(iout.eq.1) call print('Nonlinear Estimation using derivative free method' ' ' 'Initial sse betas', sse,beta,' '); iter=0 ; subiter=0 ; if(iprint .eq. 1)call print(iter,subiter,eps,sse,b); j=matrix(1,p:); j=kindas(bhold,j); call setrow(j,1,kindas(bhold,1.0)); do iter=1,maxit; call outstring(1,2,'Nonlinear Estimation using derivative free method'); call outstring(1,3,'Iter eps sse'); call outinteger(15,3,iter); call outdouble(30,3,eps,'(e16.8)'); call outdouble(50,3,sse,'(e16.8)'); if(eps.le.eps2)go to fdone; oldb=b ; oldsse=sse ; oldf=f ; temp=matrix(norows(f),1:) ; temp(,1)=f ; x=ff - temp*j ; alpha=inv((transpose(x)*x):pdmat)*(transpose(x)*mfam(yvar - f)); temp=matrix(norows(b),1:) ; temp(,1)=b ; dp=bb-temp*j ; delta=vfam(dp*alpha) ; b=b+delta ; eps=dmax(dabs(afam(delta))) ; call outdouble(30,3,eps,'(e16.8)'); call resid(b,f,r,sse,xvar,yvar ) ; if(iprint.eq.1)call print(iter,subiter,eps,sse,b); /; step shortening do subiter=1,10; call outstring(1 ,4,'Subiter') ; call outinteger(15,4,subiter) ; call outdouble(30,3,eps,'(e16.8)') ; call outdouble(50,3,sse,'(e16.8)') ; if(sse .le. oldsse)go to done ; /; Change ? /; .5 is default delta=delta*kindas(delta,.5); /;delta=delta* .9 ; b=oldb+delta ; call resid(b,f,r,sse,xvar,yvar) ; if(iprint.eq.1)call print(iter,subiter,eps,sse,b); call break('Loop two'); enddo; /; done done continue; subiter=0; bb=rollleft(bb) ; bb(1,p)=oldb ; sss=rollleft(sss) ; sss(p)=oldsse ; ff=rollleft(ff) ; ff(1,p)=oldf ; call break('Loop three') ; enddo ; /; Finally done fdone continue; beta=b; if(iter.ge.maxit)call print('Convergence failed.'); covb=dp*inv(transpose(x)*x:pdmat)*sse*transpose(dp); covb=mfam(afam(covb)/kindas(covb, (dfloat(norows(xvar))-dfloat(norows(beta))))); seb=afam(dsqrt(diag(covb))) ; s=vfam(kindas(seb,1.)/seb) ; s=diagmat(:s) ; corrb=s*covb*s ; if(iout.eq.1)then ; tscore=vfam(afam(beta)/afam(seb)) ; call tabulate(beta,seb,tscore) ; see=dsqrt(sse/kindas(sse,dfloat(norows(xvar)-norows(beta)))); call print(' ', sse,see,' ', 'Covariance of betas',covb, ' ', 'Correlation of Betas ',corrb) ; endif; return; end; == ==FDIFINFO Fractional Differencing subroutine fdifinfo(d,nterms,ar,ma,p); /; /; See Cambell-Lo-MacKinlay page 55-60 /; /; d = fractional differencing. must be < .5 /; must not be an integer /; nterms = # of terms /; ar = ar coefficients /; ma = ma coefficiants /; p = p Correlation coefficiants /; /; Illustrates use of DGAMMA in the calculation of /; ar and ma. Built-in fracdif calculates ar and ma and the /; differenced series. call echooff; if(kind(d).ne.8)then; call eprint('ERROR: d in call fdifinfo not real*8'); return; endif; if(d.ge..5)then; call eprint('ERROR: d in call fdifinfo GE .5'); return; endif; if(kind(nterms).ne.-4)then; call eprint('ERROR: nterms in call fdifinfo not integer'); return; endif; if(nterms.le.0)then; call eprint('ERROR: nterms in call fdifinfo LE 0'); return; endif; ar =array(nterms:); ma =array(nterms:); p =array(nterms:); k =dfloat(integers(nterms)); ar =dgamma(k-d)/(dgamma((-1.)*d)*dgamma(k+1.0)); ma =dgamma(k+d)/(dgamma( d)*dgamma(k+1.0)); p =(dgamma(k+d)*dgamma(1.0-d))/(dgamma(k-d+1.)*dgamma(d)); return; end; == ==FILTER High Low Pass Filter using Real FFT subroutine filter(xold,xnew,nlow,nhigh); /; /; Depending on nlow and nhigh filter can be a low pass /; or a high pass filter /; /; Real FFT is done for a series. FFT values are zeroed /; out if outside range nlow - nhigh. xnew recovered /; by inverse FFT /; /; FINTERC subroutine uses Complex FFT /; /; Use of FILTER in place of FILTERC may result in /; Phase and Gain loss /; /; xold - input series /; xnew - filtered series /; nlow - lower filter bound /; nhigh - upper filter bound /; /; Routine built 2 April 1999 /; n=norows(xold); if(n.le.0)then; call print('Filter finds # LE 0'); go to done; endif; if(nlow.le.0.or.nlow.gt.n)then; call print('Filter finds nlow not set correctly'); go to done; endif; if(nhigh.le.nlow.or.nhigh.gt.n)then; call print('Filter finds nhigh not set correctly'); go to done; endif; fftold = fft(xold); fftnew = array(n:); i=integers(nlow,nhigh); fftnew(i) = fftold(i); xnew =afam(fft(fftnew :back))*(1./dfloat(n)); done continue; return; end; == ==FILTERC High Low Pass Filter using Complex FFT subroutine filterc(xold,xnew,nlow,nhigh); /; /; Depending on nlow and nhigh filter can be a low pass /; or a high pass filter /; /; FILTER subroutine uses real FFT /; /; Use of FILTER in place of FILTERC may result in /; Phase and Gain loss /; /; Complex FFT is done for a series. FFT values are zeroed /; out if outside range nlow - nhigh. xnew recovered /; by inverse FFT /; /; xold - input series /; xnew - filtered series /; nlow - lower filter bound /; nhigh - upper filter bound /; /; Routine built 2 April 1999 /; n=norows(xold); if(n.le.0)then; call print('Filter finds # LE 0'); go to done; endif; if(nlow.le.0.or.nlow.gt.n)then; call print('Filter finds nlow not set correctly'); go to done; endif; if(nhigh.le.nlow.or.nhigh.gt.n)then; call print('Filter finds nhigh not set correctly'); go to done; endif; czero=complex(0.0,0.0); fftold = fft(complex(xold,0.0)); fftnew = fftold*czero; i=integers(nlow,nhigh); fftnew(i) = fftold(i); xnew =afam(real(fft(fftnew :back)))*(1./dfloat(n)); done continue; return; end; == ==FLSGRAPH Graph FLS Coefficients /; /; loads flsgrapg flsgrf and flsfront /; program flsgraph; call flsgrf(%bfls,%bols,%names,%lag,%x,%y,%resid,%yhatfls,%resfls); return; end; subroutine flsgrf(bfls,bols,names,lags,x,y,resid,yhatfls,resfls); /; /; Graph FLS Estimated Coefficients /; /; Usually called from program flsgraph /; /; bfls => FLS Coefficient matrix. See %bfls /; bols => OLS Coefficient vector. See %bols /; names => Names Vector. See %names /; lags => Lag Vector. See %lag /; x => x matrix. Set :savex and use %x /; y => y vector. Use %y /; resid => OLS Residual. Use %resid /; /; out: /; /; yhatfls=> Yhat from FLS /; resfls => res from FLS /; /; The files FLS1____.wmf ... FLSk____.wmf save coefficient plots. /; Residuals are saved in file fls_ols_residuals.wmf /; /; Experimental Display Routine built 14 September 2010 /; do i=1,nocols(bfls); h1='crap'; hh1='C_______.wmf'; flsbeta=bfls(,i); olsbeta=array(norows(flsbeta):)+bols(i); h1='FLS and OLS Coefficients '; c1=c1array(8:names(i)); ijunk=integers(26,33); h1(ijunk)=c1(ijunk-25); if(lags(i).ne.0)then; call ialen(h1,jj); call character(kk,'{}'); jj1=jj+1; h1(jj1)=kk(1); hh=c1array(8:); call inttostr(lags(i),hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj1+1,jj1+jjj); jj3=integers(jjj); h1(jj2)=hh(jj3); jj1=jj1+jjj+1; h1(jj1)=kk(2); endif; prefix='FLS'; hh1='C_______.wmf'; prefix2=c1array(8:prefix); call ialen(prefix2,jj); hh=c1array(8:prefix); jj1=integers(jj); hh1(jj1)=hh(jj1); call inttostr(i,hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj+1,jj+jjj); jj3=integers(jjj); hh1(jj2)=hh(jj3); call graph(flsbeta,olsbeta :pgborder :nolabel /; :pspaceon :heading h1 :file hh1 :nocontact ); enddo; yhatfls=afam(diag(mfam(x)*transpose(mfam(bfls)))); resfls=afam(y)-afam(yhatfls); call graph(resid resfls :nocontact :nolabel :pgborder /; :pspaceon :file 'fls_ols_residuals.wmf' :heading 'OLS and FLS Residuals'); return; end; subroutine flsfront(lower,upper,inc,head,y,x,iscale,me,de,w,tmat, f_angle,f_rota,c_angle,c_rota); /; /; FLS Frontier /; /; lower => lower bound on weight /; upper => upper bound on weight (closed to OLS) /; inc => Incrument between weights /; head => Heading for Graph /; y => Set to %y from call fls( ) /; x => Set to %x from call fls( :savex) /; iscale => =0 map raw data /; =1 map scaled de data /; =2 map scaled me data /; =3 map both scaled me data and de data /; me => calculated Measurement Error data /; de => calculated Dynamic Error Data /; w => Weights used to calculate DE or ME /; tmat => Matrix of t values to test for Coef. stability given /; cost setting /; f_angle => Angle for Frontier plot /; f_rota => Rotation for Frontier plot /; c_angle => Angle for Coefficient plot /; c_rota => Rotation for Coefficient plot /; /; Experimental. Built 15 September 2010 by Houston H. Stokes /; Mods 24 September 2010, 15 December 2010 /; w=grid(lower,upper,inc); nn=norows(w); me=array(nn:); de=array(nn:); tmat = array(nn,nocols(x):); trow = array(nocols(x):); do i=1,nn; call fls(y x :pweight w(i) :noint); me(i)=%rsumbm; de(i)=%rsumbd; trow=divide(%a_flsb,%se_flsb); tmat(i,)=dabs(trow); enddo; xx ='Dynamic Error'; yy ='Measurement Error'; if(iscale.eq.1.or.iscale.eq.3)then; yy='Scaled Measurement Error'; me=(me/mean(me)); me=me-min(me); endif; if(iscale.eq.2.or.iscale.eq.3)then; xx='Scaled Dynamic Error'; de=(de/mean(de)); de=de-min(de); endif; ntick=4; demin=min(de); demax=max(de); ri1=(demax-demin)/dfloat(ntick-1); memin=min(me); memax=max(me); ri2=(memax-memin)/dfloat(ntick-1); call graph(de me :plottype xyplot :heading head :ylabelleft yy :xlabel xx /; :pspaceon :nocontact :setxscale array(:demin,ri1) :nxticks ntick :setyscale array(:memin,ri2) :nyticks ntick :pgborder :file 'FLS_frontier.wmf'); call graph(de me w :plottype contourc :heading head :ylabelleft yy :xlabel xx :zlabelleft 'Weight' :file 'FLS_3dfrontier.wmf' :angle f_angle :d3axis /; :pspaceon :d3border :rotation f_rota ); call graph(tmat :plottype meshstepc :heading head :ylabelleft 'Coefficient #' :xlabel 'Model Number' :zlabelleft 'Abs (t)' :file 'FLS_3d_stability.wmf' :angle c_angle :d3axis :grid /; :pspaceon :d3border :rotation c_rota ); if(mean(x(,nocols(x))).eq.1.0d+00)then; tmat2=tmat; call deletecol(tmat2); call graph(tmat2 :plottype meshstepc :heading head :ylabelleft 'Coefficient #' :xlabel 'Model Number' :zlabelleft 'Abs (t)' :file 'FLS_3d_stability_nocons.wmf' :angle c_angle :d3axis :grid /; :pspaceon :d3border :rotation c_rota ); endif; return; end; == ==FORPLOT Forecast Plot subroutine forplot(y,yhat,se,se2,title,fileout); /; /; y => Actual Data /; yhat => Forecast /; se => Positive SE /; se2 => Negative SE /; title => Title /; /; ********************************************************** /; Version 3 August 2001 /; ********************************************************** call graphp(:start); mmin1=dmin(y:); mmin2=dmin(yhat:); mmin3=dmin(se2:); mmin_2 =dmin(array(:mmin1,mmin2,mmin3)) ; mmax1=dmax(y:); mmax2=dmax(yhat:); mmax3=dmax(se:); mmax_2 =dmax(array(:mmax1,mmax2,mmax3)); if(mmin_2.lt.0.0)mmin_2=mmin_2*1.05; if(mmin_2.gt.0.0)mmin_2=mmin_2*.95; if(mmin_2.eq.0.0)mmin_2=mmin_2-.05; if(mmax_2.lt.0.0)mmax_2=mmax_2*.95; if(mmax_2.gt.0.0)mmax_2=mmax_2*1.05; if(mmax_2.eq.0.0)mmax_2=mmax_2+.05; mmin_1=0.0; mmax_1=dfloat(norows(y)+norows(yhat)+1); x1=dfloat(integers(norows(y))); x2=dfloat(integers(norows(y)+1,norows(y)+norows(yhat))); call graphp(:cont :grarea array(: 0.0 0.0 1. 1.) :grunits array(:mmin_1 mmin_2 mmax_1 mmax_2) :pgarea array(:.1 .1 .9 .9) :pgunits array(:mmin_1 mmin_2 mmax_1 mmax_2) :color black :heading title :pgxscale 'NT' :pgaxes :pgxscale 'NT' :pgborder :pgyscaleleft 'NT' :pgyscaleright 'I' :pgxscaletop 'I' :pgxscale 'NT' :color red :pgunitstogrunits x1 y gr_x gr_y :grjoin gr_x gr_y :grmarker gr_x gr_y 14 /; This does not work if missing data /; :color byellow /; :grcurve gr_x gr_y 32 :linetype dotted :color bblue :pgunitstogrunits x2 yhat gr_x gr_y :grjoin gr_x gr_y /; /; Actual to start of forecast. This is turned off /; /; :pgunitstogrunits x1(norows(x1)) y(norows(y)) /; grx1 gry1 /; :pgunitstogrunits x2(1) yhat(1) /; grx2 gry2 /; :grjoin grx1 gry1 grx2 gry2 :color bgreen :pgunitstogrunits x2 se gr_xx gr_yy :grjoin gr_xx gr_yy :pgunitstogrunits x2 se2 gr_xxx gr_yyy :grjoin gr_xxx gr_yyy ); call graphp(:final); /; Puts plot on clipboard call graphp(:start :file fileout); mmin1=dmin(y:); mmin2=dmin(yhat:); mmin3=dmin(se2:); mmin_2 =dmin(array(:mmin1,mmin2,mmin3)) ; mmax1=dmax(y:); mmax2=dmax(yhat:); mmax3=dmax(se:); mmax_2 =dmax(array(:mmax1,mmax2,mmax3)); if(mmin_2.lt.0.0)mmin_2=mmin_2*1.05; if(mmin_2.gt.0.0)mmin_2=mmin_2*.95; if(mmin_2.eq.0.0)mmin_2=mmin_2-.05; if(mmax_2.lt.0.0)mmax_2=mmax_2*.95; if(mmax_2.gt.0.0)mmax_2=mmax_2*1.05; if(mmax_2.eq.0.0)mmax_2=mmax_2+.05; mmin_1=0.0; mmax_1=dfloat(norows(y)+norows(yhat)+1); x1=dfloat(integers(norows(y))); x2=dfloat(integers(norows(y)+1,norows(y)+norows(yhat))); call graphp(:cont :grarea array(: 0.0 0.0 1. 1.) :grunits array(:mmin_1 mmin_2 mmax_1 mmax_2) :pgarea array(:.1 .1 .9 .9) :pgunits array(:mmin_1 mmin_2 mmax_1 mmax_2) :color black :heading title :pgxscale 'NT' :pgaxes :pgxscale 'NT' :pgborder :pgyscaleleft 'NT' :pgyscaleright 'I' :pgxscaletop 'I' :pgxscale 'NT' :color red :pgunitstogrunits x1 y gr_x gr_y :grjoin gr_x gr_y :grmarker gr_x gr_y 14 /; This does not work if missing data /; :color byellow /; :grcurve gr_x gr_y 32 :linetype dotted :color bblue :pgunitstogrunits x2 yhat gr_x gr_y :grjoin gr_x gr_y /; /; Actual to start of forecast. This is turned off /; /; :pgunitstogrunits x1(norows(x1)) y(norows(y)) /; grx1 gry1 /; :pgunitstogrunits x2(1) yhat(1) /; grx2 gry2 /; :grjoin grx1 gry1 grx2 gry2 :color bgreen :pgunitstogrunits x2 se gr_xx gr_yy :grjoin gr_xx gr_yy :pgunitstogrunits x2 se2 gr_xxx gr_yyy :grjoin gr_xxx gr_yyy ); call graphp(:final); return; end; == ==GAMFORE Forecast a GAM Model subroutine gamfore(sp,oldx,newx,degmod,oldmodel,fore, link,vartype,df,iprint); /; /; Forecast a gam model /; /; sp => spline set as %spline if :savex supplied to gamfit /; oldx => old x vector /; newx => new x vector /; degmod => degree of polynomial fit of spline /; for reverse engineering. Should be set GE model deg /; However this control can be set too high which while /; "improving" in-sample forecast replication may not be /; optimal for out of sample forecasts. /; oldmodel => set as %coef from call gamfit( ); step /; fore => forecast /; link => Set to %link /; vartype => Set to %vartype 'factor' 'predictor' /; df => %df of term. Set by gamfit to %df /; iprint => Print internal spline equations if =1 /; /; Built 8 May 2007. Mods 10 June 2007. /; Arguments added 7 March 2009 /; /; requires polyfit and polyval be loaded /; /; arguments for polyfit and polyval /; /; call polyfit(x,y,n,coef,printout)$ /; call polyval(coef,xin,yhat)$ /; /; --------------------------------------------------------------- /; /; logic: Obtain coef of mapping of X to spline. From XB we note that: /; /; yhat + sum(spline) = XB /; yhat = XB - sum(spline) /; /; Analysis assumes that spline coef are 1.0 in large samples nf = norows(newx); cc = vector(nf:)+1.; xb = catcol(cc,mfam(newx))*vfam(oldmodel); newsp = matrix(nf,nocols(sp):); fore = array(nf:); j=0; do i=1,norows(vartype); testc1=vartype(i,); call character(testc2,'predictor '); if(sfam(testc1(1)).eq.sfam(testc2(1)).and. sfam(testc1(2)).eq.sfam(testc2(2)).and. sfam(testc1(3)).eq.sfam(testc2(3)).and. sfam(testc1(4)).eq.sfam(testc2(4)))then; if(df(i).gt.1.0d+00)then; j=j+1; if(iprint.ne.0)then; call print(' ':); call print('Spline fit for series # ',j:); endif; call polyfit(oldx(,i),sp(,j),degmod,coef,iprint); call polyval(coef,newx(,i),sphold)$ newsp(,j)=sphold; endif; endif; enddo; if(link.eq.'ident')then; do i=1,nf; fore(i)=xb(i)+ sum(newsp(i,)); enddo; endif; if(link.eq.'inver')then; do i=1,nf; fore(i)=missing(); z=xb(i)+ sum(newsp(i,)); if(z.ne.0.0)fore(i)=(z)**-1.; enddo; endif; if(link.eq.'logar')then; do i=1,nf; fore(i)=dexp(xb(i)+ sum(newsp(i,))); enddo; endif; if(link.eq.'logit ')then; do i=1,nf; z=xb(i)+ sum(newsp(i,)); fore(i)=dexp(z)/(1.0+dexp(z)); enddo; endif; return; end; == ==GAMPLOT Display GAMFIT Results subroutine gamplot(names1,lag1,file,olsyhat,olsres,iprint); /; /; Graph data from GAMFIT *.fsv file /; /; Assumes :punch_sur and :punch_res was supplied /; User Runs OLS /; /; %names,%lag, are automatically created by gamfit command /; %olsyhat,%olsres are the old yhat and the oldres from the olsq /; step /; iprint is coded =0 => display leverage graph /; =1 => save leverage graphs in a file with same /; name as fsv file /; =2 => display and save leverage graphs /; =10 => Same as 0 except raw and smoothed series /; shown in addition /; =11 => Same as 1 except raw and smoothed series /; shown in addition /; =12 => Same as 2 except raw and smoothed series /; shown in addition /; /; Example setup: /; /; call olsq( cpeptide age bdeficit :print); /; %olsyhat=%yhat; /; %olsres =%res; /; file='c:\gam\gam_3.fsv'; /; call gamfit(cpeptide age[predictor,3] bdeficit[predictor,3] /; :punch_sur :punch_res :filename 'gam_3.fsv' :print); /; /; call gamplot(%names,%lag,%df file,%olsyhat,%olsres,0); /; /; /; Function built 3 August 2005 by HH Stokes. /; Mods made 10 March 2006 /; Mods made 8 May 2006 /; Mods made 11 April 2008 /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; call getsca(file :member gam_res :testreturn); if(%getsca.eq.0)then; if(iprint.eq.0.or.iprint.eq.2)then; call graph(residual olsres :nocontact :nolabel /; :markpoint 1 1 3 14 /; , :colors black bblue :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :heading 'GAMFIT vs OLS residual'); call graph(yhat,olsyhat,y :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue red green :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :heading 'GAMFIT Predicted, OLS-predicted and Actual'); endif; if(iprint.eq.1.or.iprint.eq.2)then; call graph(residual olsres :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue :hardcopyfmt WMF :pspaceon :noshow :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file 'gam_res.wmf' :heading 'GAMFIT vs OLS residual'); call graph(yhat,olsyhat,y :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue red :hardcopyfmt WMF :pspaceon :noshow :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file 'gam_fit.wmf' :heading 'GAMFIT Predicted, OLS-predicted and Actual'); endif; endif; nn=norows(names1); /; loop # 1 +++++++++++++++++++++++++++++++++++++++++++++++++ do i=1,nn; call character(base,'SCOEF___' :8); if(i.le.9)then; call inttostr(i,b8 ,'(i1)'); base(8)=b8; endif; if(i.gt.9.and.i.le.99)then; call inttostr(i,b8 ,'(i2)'); base(7)=b8(1); base(8)=b8(2); endif; if(i.gt.99)then; call inttostr(i,b8 ,'(i3)'); base(6)=b8(1); base(7)=b8(2); base(8)=b8(3); endif; call getsca(file :member argument(base) :testreturn); if(%getsca.eq.0)then; c1=c1array(8:names1(i)); if(lag1(i).eq.0)then; /; 12345678901234567890123456 cc='Surface '; j=integers(1,8); j2=j+8; cc(j2)=c1(j); endif; if(lag1(i).ne.0)then; /; 12345678901234567890123456 cc='Surface lag '; j=integers(1,8); j2=j+8; cc(j2)=c1(j); if(lag1(i).le.9)then; call inttostr(lag1(i),b8 ,'(i1)'); cc(25)=b8(1); endif; if(lag1(i).gt.9.and.lag1(i).le.99)then; call inttostr(lag1(i),b8 ,'(i2)'); cc(25)=b8(2); cc(24)=b8(1); endif; if(lag1(i).gt.99.and.lag1(i).le.999)then; b8=c1array(3:); call inttostr(lag1(i),b8 ,'(i3)'); cc(25)=b8(3); cc(24)=b8(2); cc(23)=b8(1); endif; endif; /; 123456789012 fbase=c1array(12:' .wmf'); iia=integers(1,8); fbase(iia)=base(iia); ii=ranker(x_var); x_var =x_var(ii); Leverage=smooth_x(ii); lower_b =lower(ii); upper_b =upper(ii); if(iprint.eq.0.or.iprint.eq.2)call graph(x_var leverage lower_b upper_b :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue :hardcopyfmt WMF :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :plottype xyplot :heading cc); if(iprint.eq.1.or.iprint.eq.2)call graph(x_var leverage lower_b upper_b :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue :hardcopyfmt WMF :pspaceon :noshow :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :file fbase :plottype xyplot :heading cc); endif; enddo; if(iprint.gt.9)then; /; Loop # 2 ++++++++++++++++++++++++++++++++++++++++++++++ do i=1,nn; /; lag 0 case if(lag1(i).eq.0)then; call getsca(file :member argument(names1(i)) :testreturn); jja=c1array(8:names1(i)); fbase(iia)=jja(iia); endif; /; lag ne 0 case if(lag1(i).ne.0)then; call character(base,'SVAR____' :8); if(lag1(i).le.9)then; call inttostr(lag1(i),b8 ,'(i1)'); base(8)=b8; endif; if(lag1(i).gt.9.and.lag1(i).le.99)then; call inttostr(lag1(i),b8 ,'(i2)'); base(7)=b8(1); base(8)=b8(2); endif; if(lag1(i).gt.99)then; call inttostr(lag1(i),b8 ,'(i3)'); base(6)=b8(1); base(7)=b8(2); base(8)=b8(3); endif; call getsca(file :member argument(base) :testreturn); jja=c1array(8:base); fbase(iia)=jja(iia); endif; if(%getsca.eq.0)then; if(lag1(i).eq.0)then; c1=c1array(8:names1(i)); j=integers(1,8); j2=j+21; cc3=' vs smoothed '; cc3(j) =c1(j); cc3(j2)=c1(j); endif; if(lag1(i).ne.0)then; c1=c1array(8:names1(i)); j=integers(1,8); cc3=' lag vs smoothed series'; cc3(j) =c1(j); if(lag1(i).le.9)then; b8=c1array(1:); call inttostr(lag1(i),b8 ,'(i1)'); cc3(17)=b8(1); endif; if(lag1(i).gt.9.and.lag1(i).le.99)then; b8=c1array(2:); call inttostr(lag1(i),b8 ,'(i2)'); cc3(17)=b8(2); cc3(16)=b8(1); endif; if(lag1(i).gt.99.and.lag1(i).le.999)then; b8=c1array(3:); call inttostr(lag1(i),b8 ,'(i3)'); cc3(17)=b8(3); cc3(16)=b8(2); cc3(15)=b8(1); endif; endif; if(iprint.eq.10.or.iprint.eq.12) call graph(x_var smooth_x lower upper :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue :linewidth index(0,0) :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :plottype obsplot :heading cc3); if(iprint.eq.11.or.iprint.eq.12) call graph(x_var smooth_x lower upper :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue :linewidth index(0,0) :hardcopyfmt WMF :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :noshow :plottype obsplot :heading cc3 :file fbase); if(lag1(i).eq.0)then; j2=j+11; cc='Smoothed_x= '; cc(j2)=c1(j); endif; if(lag1(i).ne.0)then; j=integers(1,17); j2=j+11; cc='Smoothed_x= '; cc(j2)=cc3(j); endif; jji=c1array(:'T'); fbase(1)=jji(1); if(iprint.eq.10.or.iprint.eq.12) call graph(part_res smooth_x :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue :hardcopyfmt WMF :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :heading cc); if(iprint.eq.11.or.iprint.eq.12) call graph(part_res smooth_x :nocontact :nolabel /; :markpoint 1 1 3 14 /; :colors black bblue :hardcopyfmt WMF :pspaceon :pgyscaleright 'i' :pgxscaletop 'i' :pgborder :noshow :heading cc :file fbase); endif; enddo; endif; return; end; == ==GARCH2P Two Pass GARCH Using ARMA Command subroutine garch2p(data,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,refine); /; /; Estimate ARMA / GARCH model following Enders (1995, page 150) /; two pass method /; /; Data => Data /; nar => # of ar terms for first moment /; nma => # of ma terms for first moment /; coef1 => first moment coefficients /; se1 => first moment se /; t1 => first moment t /; gnar => second moment # of ar terms /; gnma => second moment # of ma terms /; coef2 => second moment coef /; se2 => second moment se /; t2 => second moment t /; res1 => first moment residual /; res2 => second moment residual /; refine => if NE 0 refine models /; /; call print('First Moment Model ***************'); mm=2000; call arma(data :nar nar :nma nma :print :refine refine :maxit mm ); call print('Second Moment Model ***************'); res1=afam(%res); coef1=%coef; se1=%se; t1=%t; data2=res1*res1; call arma(data2 :nar gnar :nma gnma :print :refine refine :maxit mm ); res2=afam(%res); coef2=%coef; se2=%se; t2=%t; return; end; == ==GARCH2PF Two Pass GARCH Using ARMA Command with Forecasts subroutine garch2pf(data,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,refine,fbase1,nf1,fbase2,nf2, obs1,f1,conf1,obs2,f2,conf2); /; /; Estimate ARMA / GARCH model following Enders (1995, page 150) /; two pass method /; /; Data => Data /; nar => # of ar terms for first moment /; nma => # of ma terms for first moment /; coef1 => first moment coefficients /; se1 => first moment se /; t1 => first moment t /; gnar => second moment # of ar terms /; gnma => second moment # of ma terms /; coef2 => second moment coef /; se2 => second moment se /; t2 => second moment t /; res1 => first moment residual /; res2 => second moment residual /; refine => if NE 0 refine models /; fbase1 => Forecast base for first moment /; nf1 => # of first moment forecasts /; fbase2 => Forecast base for second moment /; nf2 => # of second moment forecasts /; obs1 => Observation for forecast of first moment /; f1 => forecast for first moment /; conf1 => confidence intervals for first moment /; obs2 => Observation for forecast of second moment /; f2 => forecast for second moment /; conf2 => confidence intervals for second moment /; call print('First Moment Model ***************'); mm=1000; call arma(data :nar nar :nma nma :print :refine refine :maxit mm :forecast dmin1(fbase1,norows(data)) nf1); call print('Second Moment Model ***************'); res1=afam(%res); coef1=%coef; se1=%se; t1=%t; obs1=%foreobs; f1=%fcast; conf1=%fconf; data2=res1*res1; call arma(data2 :nar gnar :nma gnma :print :refine refine :maxit mm :forecast dmin1(fbase2,norows(data2)) nf2); res2=afam(%res); coef2=%coef; se2=%se; t2=%t; obs2=%foreobs; f2=%fcast; conf2=%fconf; return; end; == ==GET_NAME Get Name of a Matrix Variable subroutine get_name(nn,ii); /; /; nn = name /; ii = 0 is a problem /; = 1 otherwise /; /; **************************************************************** /; ii=2; call menu(ii :heading 'Select Variable for Analysis' :menutype menuvert :text 'Input Series Name' :text 'Select series' ); if(ii.eq.1)then; call menu(nn :menutype inputtext :prompt 'Input Variable Name.=>' ); go to done1; endif; if(ii.eq.2)then; call names(:); call menu(iii :heading 'Select Variable for Analysis' :menutype menuvert :text %namesl% ); if(iii.le.0)go to done1; if(iii.ne.0)then; nn=%names%(iii); endif; endif; done1 continue; return; end; == ==GRANGER Calculate Granger Test Statistic /; /; granger tests RSS1_unrestricted and RSS2_restricted /; rgranger tests if x maps to y condition on lagged y /; subroutine granger(uss,rss,n,k1,k2,teststat,probf,iprint); /; /; Does a granger test on a restricted and unrestricted model /; /; uss => Unrestricted sum of squares - usually %rss /; rss => Restricted sum of squares /; n => Number of observations - Usually %nob /; k1 => # of right hand side variables in unrestricted model /; k2 => # of right hand side variables in restricted model /; k1 must be > k2 /; teststat => F test (k1-k2, n-k1) /; =((rss-uss)/(k1-k2) )/ (uss/(n-k1)) /; probf => Probability of Granger Test GE .95 => significant /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; Built by Houston H. Stokes 21 December 2010 /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; if((k1-k2).le.0 .or. (n-k1).le.0)then; call print('n, k1 or k2 not set correctly':); call print('n was ',n:); call print('k1 was ',k1:); call print('k2 was ',k2:); teststat =missing(); probf =missing(); go to back; endif; /; teststat=((rss-uss)/dfloat(k1-k2)) / (uss/dfloat(n-k1)); probf=fprob(teststat,dfloat(k1-k2),dfloat(n-k1)); /; if(iprint.ne.0)then; call print(' ':); call print('Granger Test of a restriction':); call print('Unrestricted Error SS ',uss:); call print('Restricted Error SS ',rss:); n1=k1-k2; n2=n-k1; call fprint(:clear :col 1 :string 'F(' :col 3 :display n1 '(i6)' :col 9 :string ',' :col 10 :display n2 '(i9)' :col 19 :string ')' :col 38 :display teststat '(g16.8)' :print :clear); /; F( 10, 265) 313.98367 call print('Significance ',probf:); call print(' ':); endif; /; back continue; return; end; subroutine rgranger(name1,name2,y,x,uss,rss,_lag,teststat, k1,k2,probf,jj,acft,nacf,se,pacf,mq,mq2, max_data,min_data,iprint,iplot); /; /; Runs the Granger Test /; /; name1 => series 1 name This is the dependent variable /; name2 => series 2 name This is the variable to test for /; Granger Causality /; y => Series 1 after any alingment changes /; x => Series 2 after any alingment changes /; uss => Unrestricted e'e /; rss => Restricted e'e /; _lag => Lag to use for Granger test /; teststat => F(k1,k2) to use for Granger test /; k1 => DF 1 for F test /; k2 => DF 2 for F test /; probf => Probability to F test /; jj => Julian date vector for obs. chardate(jj) => d/m/y/ /; acft => ACF vector /; nacf => # of acf terms /; se => SE of acf /; pacf => pacf /; mq => Modified q statistic /; mq2 => Probability of modified Q /; max_data => two element max /; min_data => two element min /; iprint => Internal print from routine /; iplot => Plot acf and pacf for _lag /; Built 28 December 2010 by Houston H. Stokes /; y=name1; x=name2; call tslineup(y,x); jj=%julian%; call align(jj,y,x); max_data(1)=max(y); max_data(2)=max(x); min_data(1)=min(y); min_data(2)=min(x); if(iprint.eq.0)call olsq(y y{1 to _lag} x{1 to _lag} ); if(iprint.ne.0)call olsq(y y{1 to _lag} x{1 to _lag} :print); uss=%rss; k1=%k; acft=acf(%res,nacf,se,pacf,mq,mq2); if(iplot.ne.0)call acf_plot(%res,18,'Test Plot'); if(iprint.eq.0)call olsq(y y{1 to _lag} ); if(iprint.ne.0)call olsq(y y{1 to _lag} :print); rss=%rss; k2=%k; call granger(uss,rss,%nob,k1,k2,teststat,probf,iprint); return; end; == ==GTEST Tests ARCH / GARCH Models subroutine gtest(res1,res2,y,nacf); /; /; res1 => First Moment Residual /; res2 => Second Moment Residual /; y => Input Series /; nacf => Number acf terms /; /; Plots made: /; /; acfa.wmf => acf of residual Moment 1 /; acfb.wmf => acf of residual Moment 2 /; acfy.wmf => acf of y series /; mqa.wmf => Q stats residual Moment 1 /; mqb.wmf => Q stats residual Moment 2 /; pacfa.wmf => pacf of residual Moment 1 /; pacfb.wmf => pacf of residual Moment 2 /; pacfy.wmf => pacf of y series /; resa.wmf => Plot of residual Moment 1 /; resb.wmf => Plot of residual Moment 1 /; /; ********************************************************** /; Version 3 November 2001 /; ********************************************************** call echooff; call print('Residual Sum of Squares is:',sumsq(goodrow(res1)):); /; **************************************************************$/ /; Produce ACF and PACF statistics for D_AA /; **************************************************************$/ call print('*******************************************************'); call print('** Diagnostics/Summary Stats for Dependent Var:'); call print('*******************************************************'); call print('Print--> Describe Dependent Var: '); call describe(y :print); call print('Print--> ACF,Std.Err,PACF,Q-Stat,Prob.Q '); acfy=acf(y,nacf,sey,pacfy,mqy,pmqy); pmqy=1.-pmqy; call tabulate(acfy,sey,pacfy,mqy,pmqy); /; **************************************************************$/ /; Standardize residuals of 1st moment model /; **************************************************************$/ /; Note Alternatives x=array(norows(res1),2:); x(,1)=res1; x(,2)=res2; x=goodrow(x); /; resa=x(,1)/dsqrt(dabs(x(,2))); resa=goodrow(x(,1))/dsqrt(variance(goodrow(x(,1)))); resb=x(,2); /; **************************************************************$/ /; Build LaGrange Multiplier Test for 1st moment residuals /; **************************************************************$/ n=2; lmvalue=array(n:); lag=idint(array(n:)); prob=array(n:); do i=1,n; lag(i)=i; call lm(resa, value,i,pp); lmvalue(i)=value; prob(i)=pp; enddo; call print('*******************************************************'); call print('** Diagnostics of standardized residuals'); call print('*******************************************************'); call print('Print--> Describe standardized resid. series'); call describe(resa :print); call print('Print--> Engle LM Test for standardized res1 series'); call tabulate(lag,lmvalue,prob); /; **************************************************************$/ /; Compute ACF, PACF, Q-stats for residuals in 1st moment model /; **************************************************************$/ call print('Print--> ACF, Std.Err, PACF, Q-Stat, Prob.Q'); acfa=acf(resa,nacf,sea,pacfa,mqa,pmqa); pmqa=1.-pmqa; call tabulate(acfa,sea,pacfa,mqa,pmqa); /; **************************************************************$/ /; Square standardized residuals of 1st moment model /; **************************************************************$/ resb=resa**2.; call print('*******************************************************'); call print('** Diagnostic testing of squared standardized residuals'); call print('*******************************************************'); /; **************************************************************$/ /; Compute ACF, PACF, Q-stats for squared standardized residuals /; **************************************************************$/ call print('Print--> ACF, Std.Err, PACF, Q-Stat, Prob.Q'); acfb=acf(resb,nacf,seb,pacfb,mqb,pmqb); pmqb=1.-pmqb; call tabulate(acfb,seb,pacfb,mqb,pmqb); call print('*******************************************************'); call print('** Display graphics for Dependent Variable'); call print('*******************************************************'); call graph(y :file 'yvar.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Dependent Variable '); call graph(acfy, sey :file 'acfy.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of Dependent Variable'); call graph(pacfy, sey :file 'pacfy.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'Partial ACF of Dependent Variable'); call print('*******************************************************'); call print('** Display graphics for 1st Moment Residuals'); call print('*******************************************************'); call graph(resa :file 'resa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of 1st Moment Residuals'); call graph(acfa, sea :file 'acfa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of 1st Moment Residuals'); call graph(pacfa, sea :file 'pacfa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'PACF of 1st Moment Residuals'); call graph(mqa :file 'mqa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Q-Stats from 1st Moment Residuals'); call print('*******************************************************'); call print('** Display graphs for Squared Standardized Residuals'); call print('*******************************************************'); call graph(resb :file 'resb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Squared Standardized Residuals'); call graph(acfb, seb :file 'acfb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of Squared Standardized Residuals'); call graph(pacfb, seb :file 'pacfb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'Partial ACF of Squared Standardized Residuals'); call graph(mqb :file 'mqb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Q-Stats from Squared Standardized Residuals'); return; end; == ==GWRITE Save Matrix Object in GAUSS Format using one file subroutine gwrite(x,savename,i70); /; /; Saves object x on unit 70 in GAUSS format /; Object x saved with name savename on unit i70 /; /; Sample job: /; /; call open(70,'testdata'); /; y=array(2,2:1 2 3 4); /; nn=namelist(y); /; call gwrite(y,nn,70); /; call close(70); /; /; *********************************************** /; call echooff; call character(n,savename); call ijuststr(n,right); /; Note ; = 59 but ';' causes a problem call igetchari(59,ss); /; 12345678901234567890123456789012345678901234 call character(base,'@ Series saved by B34S on at @'); dd=datenow(); tt=timenow(); base=place(dd,27,34,base); base=place(tt,39,46,base); /; call write(base,70); call free(base); /; 1234567890123456789012345678901234567890 call character(base,'let [ , ]='); call inttostr(norows(x),n1,'(i10)'); call inttostr(nocols(x),n2,'(i10)'); base=place(n , 6,13,base); base=place(n1,15,24,base); base=place(n2,26,35,base); call write(base,70); if(kind(x).eq.8)then; call write(x,70,'(3g25.16)'); endif; if(kind(x).eq.-4)then; call write(x,70,'(7i10)'); endif; if(kind(x).ne.8.and.kind(x).ne.-4)then; call eprint('ERROR: gwrite supports real*8 and integer*4'); go to bad; endif; call write(ss,70); bad continue; return; end; == ==GWRITE2 Pass Large Datasets to GAUSS in 2 files subroutine gwrite2(x,savename,i70); /; /; Saves object in GAUSS format in two files /; Saves object x loading statements in file /; on i70. Data in savename.fmt /; /; Needed if size of object > 1000 /; /; Sample job: /; /; call open(70,'testdata'); /; y=array(2,2:1 2 3 4); /; nn=namelist(y); /; call gwrite2(y,nn,70); /; call close(70); /; /; *********************************************** /; call echooff; call character(n,savename); call ijuststr(n,right); /; Note ; = 59 but ';' causes a problem on older b34s versions call igetchari(59,ss); /; 12345678901234567890123456789012345678901234 call character(base,'@ Series saved by B34S on at @'); dd=datenow(); tt=timenow(); base=place(dd,27,34,base); base=place(tt,39,46,base); call write(base,70); call free(base); call character(base,'load [ , ]='); call inttostr(norows(x),n1,'(i10)'); call inttostr(nocols(x),n2,'(i10)'); base=place(n , 6,13,base); base=place(n1,15,24,base); base=place(n2,26,35,base); call write(base,70); call free(base); /; 1234567890123456789012345678901234567890 call character(base,' .fmt '); /; base2 has ; base2=base; base2=place(ss,13,13,base2); base2=place(n,1,8,base2); call ijuststr(n,right); call ialen(n,ll); ii=1+(8-ll); base =place(n,ii,8,base); call write(base2,70); call ijuststr(base,left); call open(71,base); if(kind(x).eq.8)then; call write(x,71,'(3g25.16)'); endif; if(kind(x).eq.-4)then; call write(x,71,'(7i10)'); endif; if(kind(x).ne.8.and.kind(x).ne.-4)then; call eprint('ERROR: gwrite2 supports real*8 and integer*4'); go to bad; endif; call close(71); bad continue; return; end; == ==HANSEN92 Hansen (1992) Stability test subroutine hansenp(m,lc,p); /; /; Implements Significance of Hansen (1992) Lc test /; Use with hansen92 analysis program /; Hansen, Bruce "Testing for Parameter Instability in /; Linear Models" Journal of Policy Modeling 1992 14(4): 517-533 /; Hansen (1992) 1% 2.5% 5% 7.5% 10% 20% ptable=array(:.01,.025,.05,.075,.1,.20); stat=array(20,6: 0.748 , 0.593 , 0.470 , 0.398 , 0.353 , 0.243 1.07 , 0.898 , 0.749 , 0.670 , 0.610 , 0.469 1.35 , 1.16 , 1.01 , 0.913 , 0.846 , 0.679 1.60 , 1.39 , 1.24 , 1.14 , 1.07 , 0.883 1.88 , 1.63 , 1.47 , 1.36 , 1.28 , 1.08 2.12 , 1.89 , 1.68 , 1.58 , 1.49 , 1.28 2.35 , 2.10 , 1.90 , 1.78 , 1.69 , 1.46 2.59 , 2.33 , 2.11 , 1.99 , 1.89 , 1.66 2.82 , 2.55 , 2.32 , 2.19 , 2.10 , 1.83 3.05 , 2.76 , 2.54 , 2.40 , 2.29 , 2.01 3.27 , 2.99 , 2.75 , 2.60 , 2.49 , 2.22 3.51 , 3.18 , 2.96 , 2.81 , 2.69 , 2.41 3.69 , 3.39 , 3.15 , 3.00 , 2.89 , 2.59 3.90 , 3.60 , 3.34 , 3.19 , 3.08 , 2.77 4.07 , 3.81 , 3.54 , 3.38 , 3.26 , 2.95 4.30 , 4.01 , 3.75 , 3.58 , 3.46 , 3.14 4.51 , 4.21 , 3.95 , 3.77 , 3.64 , 3.32 4.73 , 4.40 , 4.14 , 3.96 , 3.83 , 3.50 4.92 , 4.60 , 4.33 , 4.16 , 4.03 , 3.69 5.13 , 4.79 , 4.52 , 4.36 , 4.22 , 3.86 ); if(m.ge.20)test=stat(20,); if(m.lt.20)test=stat(m,); p=-99.; if(lc.gt.test(1))p=0.01; if(lc.lt.test(6))p=.2+ ((test(6)-lc)/test(6))*.8; if(p.eq.-99.)then; do i=1,5; if(lc.le.test(i).and.lc.ge.test(i+1))then; ddp=ptable(i+1)-ptable(i); ddvalue=test(i)-test(i+1); part=lc-test(i+1); p=ptable(i+1)-((part/ddvalue)*ddp); endif; enddo; endif; p=1.0-p; return; end; subroutine hansen92(y,x,varname,coef,res,varlag,lc,siglc,jointlc, sjointlc,iprint); /; Implements Hansen (1992) Parameter Stability Test. See /; Hansen, Bruce "Testing for Parameter Instability in /; Linear Models" Journal of Policy Modeling 1992 14(4): 517-533 /; /; Subroutine hansen92 based on from lc.m code developed by Hansen /; /; y => left hand variable /; x => Data matrix. Usually %x if :savex is /; supplied on call olsq /; varname => Variable names /; coef => OLS Coefficients usually %coef /; res => ols residual usually %res /; varlag => usually set as %lag /; lc => Test statistic for coefficients and variance. /; siglc => Probability of test /; jointlc => Joint test /; sjouintlc => Significance of joint Lc test /; iprint => Set = 1 to print inside subroutine /; /; Note: A significant test statistic => reject null of stability /; /; hansen92 routine built March 12, 2011 by Houston H. Stokes /; /; --------------------------------------------------------------------- /; work1=mfam(array(1,nocols(x):)+1.); work=matrix(norows(res),1:res)*work1; xe=afam(x)*afam(work); e2=(afam(res)*afam(res)); sig2=mean(e2); e2m=e2-sig2; m=inv(transpose(mfam(x))*mfam(x)); se=array(nocols(x)+1: dsqrt(diag(m*transpose(mfam(xe))*mfam(xe)*m)), dsqrt((mean(afam(e2m)*afam(e2m))/dfloat(norows(res))))); r2=sum((afam(y)-afam(mean(y)))**2.); r2=1.- (sum(e2)/r2); f=mfam(catcol(xe,e2m)); i=integers(1,nocols(f)); s=matrix(norows(f),nocols(f):); s(,i)=cusum(f(,i)); s=cusum(f); v=transpose(f)*f; jointlc=sum( sum(afam(s)*afam(s*inv(v))) )/dfloat(norows(y)); lc=sumcols(afam(s)**2.)/diag(afam(v))/dfloat(norows(y)); siglc=lc; call hansenp(nocols(x)+1,jointlc,sjointlc); do i=1,nocols(x)+1; call hansenp(1,lc(i),pp); siglc(i)=pp; enddo; if(iprint.ne.0)then; call print(' ':); call print( 'Hansen (1992) Stability Test. Significance => reject stability':); call print(' ':); call print('Joint LC ',jointlc:); call print('Joint LC rejection significance ',sjointlc:); call print('R-Squared ',r2:); call print(' ':); coef_var=array(norows(coef)+1:coef,sig2); call print(' ':); var=varname; i=norows(varname)+1; var(i)='Variance'; var_lag=dfloat(varlag); call tabulate(var,var_lag,coef_var,se,lc,siglc :cname :noobslist :title ' Hansen (1992) Coefficient Stability Tests'); endif; /; call rename(s,object(%,s)); /; call makeglobal(%s); /; call rename(f,object(%,f)); /; call makeglobal(%f); /; call rename(v,object(%,v)); /; call makeglobal(%v); return; end; == ==HP_2 Hodrick - Prescott Moving Filtering subroutine hp_2(series1,series2,nwindow,ncc, lamda,cortrh,cordevh,var1trh,var2trh,var1devh,var2devh, corrmat1,corrmat2,corrmat3,corrmat4); /; /; Performs Hodrick - Prescott Anlysis on two series for a moving period /; series1 = Input series /; series2 = Input series /; nwindow = number in window /; ncc = # cc /; lamda = Hodrick-Prescott Lamda /; cortrh = Correlation of trend HP data /; cordevh = Correlation of dev HP data /; var1trh = Variance of series 1 trend HP data /; var2trh = Variance of series 2 trend HP data /; var1devh = Variance of series 1 dev HP data /; var2devh = Variance of series 2 dev HP data /; corrmat1 = Correlation matrix for trend HP data /; corrmat2 = Correlation matrix for dev HP data /; if(norows(series1).ne.norows(series2))then; call epprint('ERROR: # Obs series 1 NE # obs series 2'); return; endif; nn=norows(series1)-nwindow+1; if(nn.le.0)then; call epprint('ERROR: # in Window too great.'); return; endif; if(ncc.gt.(nwindow-6))then; call epprint('ERROR: NCC set too great given nwindow'); return; endif; corrmat1=matrix(nn,(2*ncc)+1:); corrmat2=matrix(nn,(2*ncc)+1:); cortrh =vector(nn:); cordevh =vector(nn:); var1trh =vector(nn:); var2trh =vector(nn:); var1devh=vector(nn:); var2devh=vector(nn:); work1_1=vector(nwindow:); work2_1=vector(nwindow:); work3_1=vector(nwindow:); work6_1=vector(nwindow:); work7_1=vector(nwindow:); work1_2=vector(nwindow:); work2_2=vector(nwindow:); work3_2=vector(nwindow:); work6_2=vector(nwindow:); work7_2=vector(nwindow:); ipoint1=integers(1,nwindow); ipoint2=ipoint1; do i=1,nn; work1_1=series1(ipoint1); work1_2=series2(ipoint1); call hpfilter(work1_1,work2_1,work3_1,lamda); call hpfilter(work1_2,work2_2,work3_2,lamda); work6_1=work2_1(ipoint2); work6_2=work2_2(ipoint2); work7_1=work3_1(ipoint2); work7_2=work3_2(ipoint2); cortrh(i) =ccf(work6_1,work6_2); cordevh(i)=ccf(work7_1,work7_2); var1trh(i) =variance(work6_1); var2trh(i) =variance(work6_2); var1devh(i)=variance(work7_1); var2devh(i)=variance(work7_2); njulian =vector(nn:); corrmat1(i,)=vfam(ccf(work6_1,work6_2,ncc)); corrmat2(i,)=vfam(ccf(work7_1,work7_2,ncc)); ipoint1=ipoint1+1; enddo; return; end; == ==HP_BP_1 Baxter - King & Hodrick - Prescott Filtering subroutine hp_bp_1(julian,series,name,highfreq,lowfreq,nterms,lamda, printit,graphit,rjulian,rseries,hptrend,hpdev,bptrend,bpdev); /; /; Performs Hodrick - Prescott and Baxter King Analysis /; julian = Julian date. If not available pass series /; of zero same length as series /; series = Input series /; name = Character object of name /; highfreq = Barter-King High Freq (6) /; lowfreq = Baxter-King Low Freq (32) /; nterms = # of terms for Baxter - King /; lamda = Hodrick-Prescott Lamda /; printit = 0 => nothing, ne 0 => print /; graphit = 0 => nothing, ne 0 => graph /; rjulian = Revised julian /; rseries = Revised series /; hptrend = Hodrick-Prescott trend /; hpdev = Hodrick-Prescott dev /; bptrend = Baxter-King trend /; bpdev = Baxter-King dev /; call hpfilter(series,hptrend,hpdev,lamda); call bpfilter(series,bptrend,bpdev,highfreq,lowfreq,nterms:); x=goodrow(catcol(series,hptrend,hpdev,bptrend,bpdev,julian)); rseries =x(,1); hptrend =x(,2); hpdev =x(,3); bptrend =x(,4); bpdev =x(,5); rjulian =x(,6); test=mean(rjulian); if(test.ne.0.0)year=fyear(rjulian); if(printit.ne.0)then; if(test.ne.0.0)then; cc=chardatemy(rjulian); call tabulate(cc,rseries,hptrend,hpdev,bptrend,bpdev); endif; if(test.eq.0.0) call tabulate(rseries,hptrend,hpdev,bptrend,bpdev); endif; if(graphit.ne.0)then; if(test.ne.0.0) call graph(year,rseries,hptrend,hpdev,bptrend,bpdev :plottype xyplot :heading name :nolabel); if(test.eq.0.0) call graph(rseries,hptrend,hpdev,bptrend,bpdev :heading name :nolabel); endif; return; end; == ==HP_BP_2 Baxter - King & Hodrick - Prescott Moving Filtering subroutine hp_bp_2(julian,series1,series2,nwindow,ncc, highfreq,lowfreq,nterms,lamda,njulian, cortrhp,cordevhp,cortrbp,cordevbp, var1trh,var2trh,var1devh,var2devh, var1trb,var2trb,var1devb,var2devb, corrmat1,corrmat2,corrmat3,corrmat4); /; /; Performs Hodrick - Prescott and Baxter King Analysis on two series /; for a moving period /; /; Since both Hodrick - Prescott and Baxter - King analysis is done, /; the estimated Hodrick - Prescott Series are truncated BEFORE /; variances and correlations are calculated /; /; julian = Julian date. If not available pass series /; of zero same length as series /; series1 = Input series /; series2 = Input series /; nwindow = number in window /; ncc = # of lags for cross correlations /; highfreq = Barter-King High Freq (6) /; lowfreq = Baxter-King Low Freq (32) /; nterms = # of terms for Baxter - King /; lamda = Hodrick-Prescott Lamda /; njulian = Revised julian vector /; cortrhp = Correlation of trend HP data /; cordevhp = Correlation of dev HP data /; cortrbp = Correlation of trend BP data /; cordevbp = Correlation of dev BP data /; var1trh = Variance of series 1 trend HP data /; var2trh = Variance of series 2 trend HP data /; var1devh = Variance of series 1 dev HP data /; var2devh = Variance of series 2 dev HP data /; var1trb = Variance of series 1 trend BP data /; var2trb = Variance of series 2 trend BP data /; var1devb = Variance of series 1 dev BP data /; var2devb = Variance of series 2 dev BP data /; corrmat1 = Correlation matrix for trend HP data /; corrmat2 = Correlation matrix for dev HP data /; corrmat3 = Correlation matrix for trend BP data /; corrmat4 = Correlation matrix for dev BP data /; if(norows(series1).ne.norows(series2))then; call epprint('ERROR: # Obs series 1 NE # obs series 2'); return; endif; nn=norows(series1)-nwindow+1; if(nn.le.0)then; call epprint('ERROR: # in Window too great.'); return; endif; if(ncc.gt.(nwindow-6))then; call epprint('ERROR: NCC set too great given nwindow'); return; endif; corrmat1=matrix(nn,(2*ncc)+1:); corrmat2=matrix(nn,(2*ncc)+1:); corrmat3=matrix(nn,(2*ncc)+1:); corrmat4=matrix(nn,(2*ncc)+1:); cortrhp =vector(nn:); cortrbp =vector(nn:); cordevhp=vector(nn:); cordevbp=vector(nn:); var1trhp=vector(nn:); var1trbp=vector(nn:); var2trhp=vector(nn:); var2trbp=vector(nn:); var1devh=vector(nn:); var1devb=vector(nn:); var2devh=vector(nn:); var2devb=vector(nn:); njulian =vector(nn:); work1_1=vector(nwindow:); work2_1=vector(nwindow:); work3_1=vector(nwindow:); work4_1=vector(nwindow:); work5_1=vector(nwindow:); work6_1=vector(nwindow-(2*nterms):); work7_1=vector(nwindow-(2*nterms):); work8_1=vector(nwindow-(2*nterms):); work9_1=vector(nwindow-(2*nterms):); work1_2=vector(nwindow:); work2_2=vector(nwindow:); work3_2=vector(nwindow:); work4_2=vector(nwindow:); work5_2=vector(nwindow:); work6_2=vector(nwindow-(2*nterms):); work7_2=vector(nwindow-(2*nterms):); work8_2=vector(nwindow-(2*nterms):); work9_2=vector(nwindow-(2*nterms):); ipoint1=integers(1, nwindow); ipoint2=integers(nterms+1,nwindow-nterms); do i=1,nn; work1_1=series1(ipoint1); work1_2=series2(ipoint1); call hpfilter(work1_1,work2_1,work3_1,lamda); call hpfilter(work1_2,work2_2,work3_2,lamda); call bpfilter(work1_1,work4_1,work5_1,highfreq,lowfreq,nterms:); call bpfilter(work1_2,work4_2,work5_2,highfreq,lowfreq,nterms:); work6_1=work2_1(ipoint2); work6_2=work2_2(ipoint2); work7_1=work3_1(ipoint2); work7_2=work3_2(ipoint2); work8_1=work4_1(ipoint2); work8_2=work4_2(ipoint2); work9_1=work5_1(ipoint2); work9_2=work5_2(ipoint2); cortrhp(i) =ccf(work6_1,work6_2); cortrbp(i) =ccf(work8_1,work8_2); cordevhp(i)=ccf(work7_1,work7_2); cordevbp(i)=ccf(work9_1,work9_2); var1trh(i) =variance(work6_1); var2trh(i) =variance(work6_2); var1devh(i)=variance(work7_1); var2devh(i)=variance(work7_2); var1trb(i) =variance(work8_1); var2trb(i) =variance(work8_2); var1devb(i)=variance(work9_1); var2devb(i)=variance(work9_2); corrmat1(i,)=vfam(ccf(work6_1,work6_2,ncc)); corrmat2(i,)=vfam(ccf(work7_1,work7_2,ncc)); corrmat3(i,)=vfam(ccf(work8_1,work8_2,ncc)); corrmat4(i,)=vfam(ccf(work9_1,work9_2,ncc)); njulian(i)=julian(i+nterms); ipoint1=ipoint1+1; enddo; return; end; == ==IRF Impulse Response Functions for VAR Model subroutine irf(x,ibegin,iend,beta,t1,res,sigma,psi,ipsi,tirf,iprint1, nterms,nlag,var,varxhat,rsq); /; /; Calculate Transfer Function Impulse Response Function (TFIRF) of a /; VAR Model and the VMA form of the IRF model. /; /; Assume A(L)X=e /; Transformed model is: X = PSI(L)e /; where PSI(L) = INV(A(L)) /; /; Note: Model assumed to have a constant /; /; --------------------------------------------------------------------- /; This is in contrast to the Transfer function form of the model tirf /; that is calculated by normalizing by diagonal polynomial. /; /; Assume VAR Model for 2 Series X1 & X2: /; Orig. eq: 1 b11(L)X1 + b12(L)X2 = e1 /; Orig. eq: 2 b21(L)X1 + b22(L)X2 = e2 /; Trans. eq: 1 X1 + [b12(L)/b11(L)]X2 = [1/b11(L)]e1 /; Trans. eq: 2 X2 + [b21(L)/b22(L)]X1 = [1/b22(L)]e2 /; /; If 1 to k-1 cols are multiplied by -1 we get the /; alternative tirf form /; /; Alt. eq: 1 X1 = -[b12(L)/b11(L)]X2 + [1/b11(L)]e1 /; Alt. eq: 2 X2 = -[b21(L)/b22(L)]X1 + [1/b22(L)]e2 /; /; For one variable case [1/b11(L)] is psi(L) /; -------------------------------------------------------------------- /; /; x - n by k matrix of the series in var model. For this /; release must be real*8 /; ibegin - Start of period /; iend - End of period /; beta - Coef saved as a matrix(k,k*nlag+1) /; use polymdisp to display if remove constant /; t1 - t stat saved as a matrix(k,k*nlag+1) /; use polymdisp to display if remove constant /; sigma - Variance Covariance of errors period /; psi - psi weights saved in byorder form /; ipsi - index to read psi weights /; tirf - Transfer function form of IRF /; saved in byorder form which is the same as psi /; 1,1 position effect of variable 2 on variable 1 /; 1,2 position effect of noise /; iprint1 - set 1 => print estimation results Coef by order /; 2 => in addition print psi matrix /; for one series will give graph /; nterms - # of terms in psi matrix /; nlag - lag for VAR /; var - k element variance of series /; varxhat - k element variance of yhat /; rsq - k element centered R**2 /; /; Routine developed 1 May 2007 /; Routine works for one or more series /; /; Notes: 1. psi and tirf saved in same format /; 2. For one series models psi=tirf /; 3. The below listed code shows hou to pull off psi/tirf /; series for listing and or plotting /; /; illustrates extract into vectors for 2 by 2 case /; /; call polymdisp(:extract psi ipsi error11 index(1,1,0)); /; call polymdisp(:extract psi ipsi error12 index(1,2,0)); /; call polymdisp(:extract psi ipsi error21 index(2,1,0)); /; call polymdisp(:extract psi ipsi error22 index(2,2,0)); /; call tabulate(error11,error12,error21,error22); /; call graph(error11,error12,error21,error22 /; :heading 'IRF plots' :nolabel); /; /; /; sample job /; /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /; /; b34sexec matrix; /; call loaddata; /; call load(buildlag); /; call load(varest); /; call load(irf); /; call echooff; /; /; call print(irf); /; /; ibegin=1; /; iend=296; /; nlag=6; /; nterms=18; /; iprint=0; /; x=catcol(gasin,gasout); /; /; /; call olsq(gasin gasin{1 to nlag} gasout{1 to nlag} :print); /; /; call olsq(gasout gasin{1 to nlag} gasout{1 to nlag} :print); /; /; call print('Two variable test':); /; /; call irf(x,ibegin,iend,beta,t1,res,sigma,psi,ipsi,tirf,iprint, /; nterms,nlag,var,varxhat,rsq); /; /; /; /; /; Illustrates how to extract into vectors and display /; /; /; /; call polymdisp(:extract psi ipsi error11 index(1,1,0)); /; call polymdisp(:extract psi ipsi error12 index(1,2,0)); /; call polymdisp(:extract psi ipsi error21 index(2,1,0)); /; call polymdisp(:extract psi ipsi error22 index(2,2,0)); /; call tabulate(error11,error12,error21,error22); /; call graph(error11,error12,error21,error22 :heading 'IRF plots' /; :nolabel); /; call polymdisp(:extract tirf ipsi irf11 index(1,1,0)); /; call polymdisp(:extract tirf ipsi irf12 index(1,2,0)); /; call polymdisp(:extract tirf ipsi irf21 index(2,1,0)); /; call polymdisp(:extract tirf ipsi irf22 index(2,2,0)); /; call tabulate(irf11,irf12,irf21,irf22); /; call graph(irf11,irf12,irf21,irf22 /; :heading 'TIRF plots - Last Col is noise IRF' /; :nolabel); /; b34srun; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; Need to load VAREST and BUILDLAG /; /; ********************************************************** k=nocols(x); iprint=0; if(iprint1.gt.0)iprint=dabs(iprint1); if(iprint.ne.0)then; call print(' ':); call print('Assumptions of VAR Inpulse Response Analysis':); call print('ibeing ',ibegin:); call print('iend ',iend:); call print('nlag ',nlag:); call print('nterms ',nterms:); endif; if(k.eq.1)go to doone; call varest(x,nlag,ibegin,iend,beta,t1,sigma,corr, res,iprint,a,ai,var,varxhat,rsq); call polyminv(a ai psi ipsi nterms); if(iprint.eq.2)then; call print(' ':); call polymdisp(:display psi ipsi); call print(sigma); endif; tirf=0.0*psi; /; /; Calculate tirf /; bottom=array(nlag+1:); top=bottom; /; strip off constant k=norows(beta); ik=nocols(beta); beta2=beta; beta2(1,ik)=missing(); beta2=goodcol(beta2); ibeta2=index(k,k,nlag); do ii=1,k; beta1=array(nlag*k:); /; /; Gets all lags for each eq. and puts coef if order of the call olsq /; kk=integers(nlag); do iii4=1,k; call polymdisp(:extract beta2 ibeta2 newterm index(ii,iii4,0)); beta1(kk)=(-1.0)*newterm; kk=kk+nlag; enddo; kk=integers(nlag); kkp1=kk+1; bottom(1)=1.0; bottom(kkp1)=beta1(kk+((ii-1)*nlag)); icount=0; do iii=1,k+1; if(iii.ne.ii)then; icount=icount+1; if(iii.eq.(k+1))top=1.0; if(iii.ne.(k+1))then; kindex=integers(nlag) + ((iii-1)*nlag); top(kkp1)=beta1(kindex); top(1)=0.0; endif; holdirf=polydv(top,bottom,nterms); /; call print('for ii = ',ii:); /; call print('for iii = ',iii:); /; call print('for icount',icount:); /; call print('top was', top); /; call print('bottom was ',bottom); /; call print(holdirf); call polymdisp(:load tirf ipsi holdirf index(ii,icount,0)); endif; enddo; enddo; go to alldone; /; /; One series case /; doone continue; ii1=integers(ibegin,iend); x1=x(ii1); if(iprint.eq.0)call olsq(x1 x1{1 to nlag} ); if(iprint.ne.0)then; call print(' ':); call olsq(x1 x1{1 to nlag} :print); endif; beta =%coef; coef =%coef; t1 =%t; res =%res; sigma =%rss; var =variance(%y); varxhat=variance(%yhat); rsq =%rsq; nn =norows(%y); top=1.0; k=norows(beta); coef=(-1.0)*afam(coef); bott=array(k:); bott(1)=1.0; kk=integers(1,k-1); kkp1=kk+1; bott(kkp1)=coef(kk); psi=polydv(top,bott,nterms); tirf=psi; if(iprint.eq.2)then; call print('Impulse Response (VMA Form of Model) Weights':); call print(psi); call graph(psi :heading 'Psi weights VAR model'); endif; alldone continue; return; end; == ==KPSS KPSS Stability Test subroutine kpss(series,test1,test2,lagg,iprint); /; /; Kwitkowski D, P. Phillips, P. Schmidt and Y. Shin /; "Testing the Null Hypothesis of Stationarity Against the Alternative /; of a Unit Root." Journal of Econometrics 54, 1992. pp. 159-178 /; /; Series - Series to test /; test1 - Test without trend /; test2 - Test with trend /; lagg - Lag. if lagg = 0 no adjustment to sigma squared is made /; iprint - 1 => print /; 2 => print stat and give OLS equations also /; /; For added detail see Greene (2008) page 755 for logic of calculation /; /; Routine built 24 November 2008 -Tested against Rats Version 7 and /; results in Greene (2008) page 755 /; -------------------------------------------------------------------- /; n=norows(series); t=dfloat(integers(n)); %res = series - mean(series); psum=cusum(%res); %rss = sumsq(%res); resvar = %rss/dfloat(n); if(lagg.eq.0)test1=divide(sumsq(psum),(dfloat(n)*dfloat(n)*resvar)); if(lagg.gt.0)then; tt=matrix(n,1:vfam(%res)); part2=afam(mcov(tt,0.0,0,0.0,0)); do i=1,lagg; t1= afam(mcov(tt,0.0,i,0.0,0)) - afam(mcov(tt,0.0,i-1,0.0,0)); t2=(1.0 - (dfloat(i)/dfloat(lagg+1))); part2=part2+ (t1*t2); enddo; test1=divide(sumsq(psum),(dfloat(n)*part2)); endif; if(iprint.ne.2)call olsq(series t :qr); if(iprint.eq.2)call olsq(series t :qr :print); psum=cusum(%res); %rss =sumsq(%res); resvar = %rss/dfloat(n); if(lagg.eq.0)test2=divide(sumsq(psum),(dfloat(n)*dfloat(n)*resvar)); if(lagg.gt.0)then; tt=matrix(n,1:vfam(%res)); part2=afam(mcov(tt,0.0,0,0.0,0)); do i=1,lagg; t1= afam(mcov(tt,0.0,i,0.0,0))-afam(mcov(tt,0.0,i-1,0.0,0)); t2=(1.0 - (dfloat(i)/dfloat(lagg+1))); part2=part2+ (t1*t2); enddo; test2=divide(sumsq(psum),(dfloat(n)*part2)); endif; if(iprint.ne.0)then; call print(' ':); call print('KPSS Stationarity Test without trend for lag ',lagg:); call print('Test Statistic ',test1:); call print('Critical Values .10 .050 .025 .010 ':); call print(' .347 .463 .573 .739 ':); call print(' ':); call print('KPSS Stationarity Test with trend for lag ',lagg:); call print('Test Statistic ',test2:); call print('Critical Values .10 .050 .025 .010 ':); call print(' .119 .146 .176 .216 ':); endif; return; end; == ==KSWTEST K Period Stock Watson Test subroutine kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2); /; /; Generate k by k Stock Watson Test Statistics /; /; Note: Not set up for moving windows models. /; For moving windows models see KSWTESTM /; /; X = Data to be Analysed. X is 1D or 2D array/Matrix /; vbegin1 = vector/array of subperiod beginning points integer*4 /; vend1 = vector/array of subperiod endinf points integer*4 /; Note: If three terms in vbegin1 and vend1 assumes /; three periods. Will run period 1-2 & /; period 2-3 /; nlag = # of AR lags /; nterms = # of MA terms /; iprint = Controls printing in SWARTEST. Usually = 0. /; iprint2 = Controls printing in kswtest. /; = 1 to print in kswtest /; = 0 to save data in global variable. /; =-1 to print and save data. /; /; Optional data saved: /; /; %var_i Variance of Series /; %varh_i Variance of yhat /; %rsq_i R**2 of series /; %fac_i Test Statistics /; %dfac_i Difference of factural /; %dstr_i Difference in counter factural Structure /; %dvar_i Difference in counter factural variance /; /; Note: Optional data for orders > # series not cleaned. /; /; /; Developed 24 April 2003 by Jin-Man Lee /; Refinements made by Houston H. Stokes /; /; Routines needed: buildlag, varest, swartest /; /; **************************************************************** /; n =norows(x); nc=nocols(x); if(n.le.10)then; call epprint('ERROR: # of rows passed to kswtest LE 10'); go to isbad; endif; nn=dmax(vend1); if(nn.gt.n)then; call epprint('ERROR: Endpoint bigger than # obs in data'); call print( ' # Data points was ',n:); call print( ' # max endpoint was ',nn:); go to isbad; endif; breakp = norows(vbegin1) ; testij = matrix(breakp,breakp:); var_i = vector(breakp:); varhat_i = vector(breakp:); rsq_i = vector(breakp:); vfact1 = vector(breakp:); /; test for bad input do kk=1,nc; do i=1,breakp-1 ; do j=i+1,breakp ; ibegin1=vbegin1(i) ; iend1=vend1(i) ; ibegin2=vbegin1(j) ; iend2=vend1(j) ; call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); /; ****************************************************** /; Changed 30 September 2003 /; Failed on Linux 10 May 2005 ?????????????????????????? /; call compress(5); /; ****************************************************** if(nc.eq.1)then; testij(i,i) = test11 ; testij(i,j) = test12 ; testij(j,i) = test21 ; testij(j,j) = test22 ; var_i(i) = var1 ; var_i(j) = var2 ; varhat_i(i) = varxhat1 ; varhat_i(j) = varxhat2 ; rsq_i(i) = rsq1 ; rsq_i(j) = rsq2 ; vfact1(i) = test11 ; vfact1(j) = test22 ; endif; if(nc.gt.1)then; testij(i,i)=test11(kk) ; testij(i,j) = test12(kk) ; testij(j,i)=test21(kk) ; testij(j,j) = test22(kk) ; var_i(i) =var1(kk) ; var_i(j) = var2(kk) ; varhat_i(i)=varxhat1(kk) ; varhat_i(j) = varxhat2(kk); rsq_i(i) =rsq1(kk) ; rsq_i(j) = rsq2(kk) ; vfact1(i) =test11(kk) ; vfact1(j) = test22(kk) ; endif; enddo ; enddo ; fact1 = matrix(breakp,breakp:) ; do ii = 1,breakp ; fact1(,ii)=vfact1 ; enddo ; dfac1 = dabs(fact1-transpose(fact1)) ; dvar1 = dabs(testij-fact1) ; dstr1 = dabs(transpose(testij)-fact1) ; if(iprint2.ne.0)then; if(nc.gt.1)then; if(kk.eq.1)then; call print('++++++++++++++++++++++++++++++++++++++':); call print(' Multivariate Model':); call print('++++++++++++++++++++++++++++++++++++++':); endif; call print('++++++++++++++++++++++++++++++++++++++':); call print('Analysis of series ',kk:); call print('++++++++++++++++++++++++++++++++++++++':); endif; if(nc.eq.1)then; call print('++++++++++++++++++++++++++++++++++++++':); call print(' Univariate Model ':); call print('++++++++++++++++++++++++++++++++++++++':); endif; call print('Assumptions of Analysis:':); call print('# AR lags ',nlag:); call print('# Terms in IRF ',nterms:); call print('Number of periods ',breakp:); call print('Begining and End Points of Analysis':); call tabulate(vbegin1,vend1) ; call print(' ':); call print('Actual Variance by period',var_i) ; call print('Yhat Variance by period', varhat_i) ; call print('Center R**2 by period', rsq_i) ; call print('Factual and Counter-Factual Variances',testij) ; call print('Term(i,j) = dabs(testij(i,i)-testij(j,j))':); call print('Difference of Factual Variances',dfac1) ; call print('Term(i,j) = dabs(testij(i,i)-testij(j,i))':); call print('Difference of counter factual structure',dstr1) ; call print('Term(i,j) = dabs(testij(i,i)-testij(i,j))':); call print('Difference of counter factual variances',dvar1) ; endif; if(iprint2.eq.0.or.iprint2.eq.-1)then; call inttostr(kk,cn,'(i2)'); call character(hold,'%VAR____'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(var_i,c8 :global); call character(hold,'%VARH___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(varhat_i,c8 :global); call character(hold,'%RSQ____'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(rsq_i,c8 :global); call character(hold,'%FAC____'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(testij,c8 :global); call character(hold,'%DFAC___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dfac1,c8 :global); call character(hold,'%DSTR___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dstr1,c8 :global); call character(hold,'%DVAR___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dvar1,c8 :global); endif; enddo; isbad continue; return; end; == ==KSWBOOTS K periods Stock-Watson Bootstrap Critical Values subroutine kswboots(x,p,ninit,printout,niter,method,vbegin1,vend1, nterms); /; /; Note: kswboots designed for multiple periods /; swboots designed for two period model /; /; Input: /; x -> VAR data matrix (d_1~d_2~etc, where d_i is /; column vector of observations on ith endogenous /; variable) /; p -> VAR order /; ninit -> # of start-up transient observations /; printout -> -1: No print of any kind /; 0: no print out of values for each iteration. /; Answers returned for the bootstrap variable(s) /; This is rthe usual setting. /; 1: print the orignal coefficient and y /; niter -> # of bootstraps. Usually set ge 100 /; method -> 0 Resample the error using random number /; 1 Bootstap errors /; 2 Random Errow with Bootstrap /; 3 Monte Carlo simulation /; 4 Centered Bootstrap /; Method=0 Resample the error using random number /; Method=1 Bootstrap Errors using Original Errors /; Method=2 Use the Random Error and New error using Bootstrap /; Method=3 Monte Carlo Critical Values /; Method=4 Bootstrap Errors using Centered Original Errors /; /; vbegin1 = vector of begin points /; vend1 = vector of end points /; /; Output: /; /; %mtii90 => Testii critical value at 90 /; %mdfac90 => Difference in FACTUAL critical value at 90 /; %mdstr90 => Difference in STRUCTURE critical value at 90 /; %mdvar90 => Difference in Variance critical value at 90 /; %mtii95) => Testii critical value at 95 /; %mdfac95 => Difference in FACTUAL critical value at 95 /; %mdstr95 => Difference in STRUCTURE critical value at 95 /; %mdvar95 => Difference in Variance critical value at 95 /; /; /; References: * D.E. Runkle, 'Vector autoregressions and reality,' /; _Journal of Business and Economic Statistics_ /; (Oct. 1987): 437-42 /; * J. Berkowitz and L. Kilian, 'Recent developments /; in bootstrapping time series,' Federal Reserve /; Board Finance and Economics Discussion Series /; Paper 1996-45 (November 1996) /; /; This routine requires the following routines be loaded: /; buildlag, kswtest & varest /; /; Routine built by Jin-Man Lee /; Minor mods made May 2008 by Houston H. Stokes /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; Example setup: /; call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /; niter=10; /; printout=0; /; k=0; /; call kswboots(x,p,k,printout,niter,1,vbegin1,vend1,nterms); /; call kswboots(x,nlag,k,printout,niter,2,vbegin1,vend1,nterms); /; call kswboots(x,nlag,k,printout,niter,3,vbegin1,vend1,nterms); /; if(p.lt.1)then; call epprint('ERROR: VAR order must be ge 1'); go to finish; endif; if(ninit.lt.0)then; call epprint('ERROR: # of start-up observations must be ge 0'); go to finish; endif; if(niter.lt.2)then; call epprint('ERROR: # iterations must be gt 1'); go to finish; endif; if(method.lt.0.or.method.gt.4)then; call epprint('ERROR: Method must be in range 0-4'); go to finish; endif; if(norows(vbegin1).ne.norows(vend1))then; call epprint('ERROR: # rows in vbegin1 must = # rows in venmd1'); go to finish; endif; mr=norows(x) ; m=nocols(x) ; breakp = norows(vbegin1) ; if(m.eq.1) then ; tempx=x ; x = array(mr,m:) ; x(,1) = tempx ; endif ; begin1 = vbegin1(1) ; end1 = vend1(1) ; begin2 = vbegin1(2) ; end2 = vend1(2) ; npi = norows(vbegin1) ; call buildlag(x,p,1,mr,xx,yy); xx = mfam(xx) ; yy = mfam(yy) ; do ai=1,npi-1 ; endi = vend1(ai) ; beginj = vbegin1(ai+1) ; dl_pt = beginj-endi ; if(dl_pt.ne.1) then ; do bi=endi-p+1,beginj-1 ; xx(bi,)=missing() ; yy(bi,)=missing() ; enddo ; endif ; enddo ; xx= goodrow(xx) ; yy= goodrow(yy) ; t1=norows(yy) ; U=matrix(t1,m:) ; b=matrix(p*m+1,m:) ; tval=matrix(p*m+1,m:) ; Do i=1,m ; y1 = yy(,i) ; call olsq(y1 xx) ; u(,i)=%res ; b(,i)=%coef ; tval(,i)=%t ; enddo ; if(printout.ge.0)then; call print('------------------------------':) ; call print('Random Seed ') ; call i_rnget; call print('Number of Iterations ',niter:); call print('------------------------------':) ; call print(' ':); endif; t=mr ; /; Method=1 Bootstrap Errors using Original Errors /; Method=2 Use the Random Error and New error using Bootstrap /; Method=3 Monte Carlo Critical Values /; Method=4 Bootstrap Errors using Centered Original Errors u1=rn(matrix(t+ninit,m:)) ; u2 = matrix(t+ninit,m:) ; do ui=1,m ; u2(,ui)= u1(,ui)*(variance(u(,ui))/variance(u1(,ui)))**0.5 ; enddo ; bt_b1=matrix(niter,m+m*p:) ; bt_b2=matrix(niter,m:) ; tii = matrix(niter,breakp*breakp:) ; dfac = matrix(niter,breakp*breakp:) ; dstr = matrix(niter,breakp*breakp:) ; dvar = matrix(niter,breakp*breakp:) ; if(method.eq.4) then ; do ui=1,m ; u(,ui)= u(,ui)-mean(u(,ui)) ; enddo ; endif ; call outstring(1,3,'KSWBOOTS calculating distribution of statistics'); call outstring(1,4,'Iteration:'); do gi=1,niter ; call outinteger(14,4,gi); if(method.eq.1)ustar=u(booti(t1,t+ninit)) ; if(method.eq.2)ustar= u2(booti(t+ninit)); if(method.eq.3) then ; u1=rn(matrix(t+ninit,m:)) ; ustar=rn(matrix(t+ninit,m:)) ; do ui=1,m ; ustar(,ui)= u1(,ui)*(variance(u(,ui))/variance(u1(,ui)))**0.5 ; enddo ; endif ; if(method.eq.4)ustar=u(booti(t1,t+ninit)) ; ystar = matrix(T+ninit,M:) ; r1 = submatrix(xx,1,1,1,m*p) ; r2 = matrix(1,1:1) ; r = mfam(catcol(r1 r2)) ; if(p.gt.1)then ; do i=1,t+ninit ; ystar(i,)= r*b + submatrix(ustar,i,i,1,m) ; r1=submatrix(ystar,i,i,1,m) ; r2=submatrix(r,1,1,1,m*(p-1)) ; r3=matrix(1,1:1) ; r=mfam(catcol(r1 r2 r3)) ; enddo ; endif ; if(p.eq.1)then ; do i=1,t+ninit ; ystar(i,)= r*b + submatrix(ustar,i,i,1,m) ; r1=submatrix(ystar,i,i,1,m) ; r3=matrix(1,1:1) ; r=mfam(catcol(r1 r3)) ; enddo ; endif ; p1 = integers(p) ; p2 = integers(ninit+1,t+p+ninit,1) ; ystar=catrow(x(p1,) ystar) ; ystar=ystar(p2,) ; /; not implemented by HH Stokes /; call print(ystar) ; /; Stock-Watson Test x = ystar ; nlag=p ; /; nterms=10; iprint=0 ; iprint2=0 ; call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /; call names(all) ; tij_i = matrix(1,breakp*breakp:) ; dfac_i = matrix(1,breakp*breakp:) ; dstr_i = matrix(1,breakp*breakp:) ; dvar_i = matrix(1,breakp*breakp:) ; /; call print(%fac___1,%dfac__1,%dstr__1,%dvar__1) ; do i=1,breakp ; do j=1,breakp ; kkk = j+breakp*(i-1) ; tij_i(1,kkk) = %fac___1(i,j) ; dfac_i(1,kkk) = %dfac__1(i,j) ; dstr_i(1,kkk) = %dstr__1(i,j) ; dvar_i(1,kkk) = %dvar__1(i,j) ; enddo ; enddo ; if(printout.eq.1)call print(%fac___1,%dfac__1,%dstr__1,%dvar__1) ; tii(gi,) = tij_i ; dfac(gi,) = dfac_i ; dstr(gi,) = dstr_i ; dvar(gi,) = dvar_i ; call compress(50) ; enddo ; %mtii90 = matrix(breakp,breakp:) ; %mdfac90 = matrix(breakp,breakp:) ; %mdstr90 = matrix(breakp,breakp:) ; %mdvar90 = matrix(breakp,breakp:) ; %mtii95 = matrix(breakp,breakp:) ; %mdfac95 = matrix(breakp,breakp:) ; %mdstr95 = matrix(breakp,breakp:) ; %mdvar95 = matrix(breakp,breakp:) ; q1=array(2:.90,.95); do i=1,breakp ; do j=1,breakp ; vtii = tii(,j+(i-1)*breakp) ; vdfac = dfac(,j+(i-1)*breakp) ; vdstr = dstr(,j+(i-1)*breakp) ; vdvar = dvar(,j+(i-1)*breakp) ; call quantile(vtii, q1,qvtii); call quantile(vdfac, q1,qdfac); call quantile(vdstr, q1,qdstr); call quantile(vdvar, q1,qdvar); %mtii90(i,j) =qvtii(1) ; %mdfac90(i,j)=qdfac(1) ; %mdstr90(i,j)=qdstr(1) ; %mdvar90(i,j)=qdvar(1) ; %mtii95(i,j) =qvtii(2) ; %mdfac95(i,j)=qdfac(2) ; %mdstr95(i,j)=qdstr(2) ; %mdvar95(i,j)=qdvar(2) ; enddo ; enddo ; if(printout.ge.0)then; if(method.eq.0)call print( 'Method=0 => Resample the error using random number':); if(method.eq.1)call print( 'Method=1 => Bootstrap Errors using Original Errors':); if(method.eq.2)call print( 'Method=2 => Use the Random Error and New error using Bootstrap':) ; if(method.eq.3)call print( 'Method=3 => Monte Carlo Critical Values':); if(method.eq.4)call print( 'Method=4 Bootstrap Errors using Centered Original Errors':); call print(' ':); call print('Critical Values of Stock Watson Test':); call print('____________________________________':); call print('Testii critical value at 90' , %mtii90) ; call print('Difference in FACTUAL critical value at 90',%mdfac90) ; call print('Difference in STRUCTURE critical value at 90',%mdstr90) ; call print('Difference in Variance critical value at 90',%mdvar90) ; call print('Testii critical value at 95' , %mtii95) ; call print('Difference in FACTUAL critical value at 95 ',%mdfac95) ; call print('Difference in STRUCTURE critical value at 95 ',%mdstr95) ; call print('Difference in Variance critical value at 95 ',%mdvar95) ; endif; call makeglobal(%mtii90); call makeglobal(%mdfac90); call makeglobal(%mdstr90); call makeglobal(%mdvar90); call makeglobal(%mtii95); call makeglobal(%mdfac95); call makeglobal(%mdstr95); call makeglobal(%mdvar95); finish continue; return ; end ; == ==KSWTESTM Moving Period Stock Watson Test subroutine kswtestm(x,vbegin1,vend1,vbegin2,vend2,nlag,nterms, iprint,iprint2); /; /; Generate k Stock Watson Test Statistics /; This code is made for a moving window application /; For a limited number of break points see kswtest routine /; /; X = Data to be Analysed. X is 1D or 2D array/Matrix /; vbegin1 = vector/array of subperiod beginning points integer*4 /; vend1 = vector/array of subperiod endinf points integer*4 /; vbegin2 = vector/array of subperiod beginning points integer*4 /; vend2 = vector/array of subperiod endinf points integer*4 /; nlag = # of AR lags /; nterms = # of MA terms /; iprint = Controls printing in SWARTEST. Usually = 0. /; iprint2 = Controls printing in kswtest. /; = 1 to print in kswtest /; = 0 to save data in global variable. /; =-1 to print and save data. /; /; Optional data saved: /; /; %t11___1 Period 1 structure period 1 variance /; %t12___1 Period 1 structure period 2 variance /; %t22___1 Period 2 structure period 2 variance /; %t21___1 Period 2 structure period 1 variance /; %VAR1__1 Actual variance period 1 series 1 /; %VAR2__1 Actual Variance period 2 series 1 /; %RSQ1__1 R**2 period 1 series 1 /; %VARH1_1 Variance of yhat period 1 series 1 /; %VARH2_1 Variance of yhat period 2 series 1 /; %RSQ2__1 R**2 period 2 series 1 /; %DFAC__1 dabs(t11-t22) /; %DVAR1_1 dabs(t11-t12) /; %DVAR2_1 dabs(t21-t22) /; %DSTR1_1 dabs(t11-t21) /; %DSTR2_1 dabs(t22-t12) /; /; If more that one series we get for series 2 /; /; %t11___2 Period 1 structure period 1 variance /; %t12___2 Period 1 structure period 2 variance /; %t22___2 Period 2 structure period 2 variance /; %t21___2 Period 2 structure period 1 variance /; %VAR1__2 Actual variance period 1 series 1 /; %VAR2__2 Actual Variance period 2 series 1 /; %RSQ1__2 R**2 period 1 series 2 /; %VARH1_2 Variance of yhat period 1 series 2 /; %VARH2_2 Variance of yhat period 2 series 2 /; %RSQ2__2 R**2 period 2 series 2 /; %DFAC__2 dabs(t11-t22) /; %DVAR1_2 dabs(t11-t12) /; %DVAR2_2 dabs(t21-t22) /; %DSTR1_2 dabs(t11-t21) /; %DSTR2_2 dabs(t22-t12) /; /; Note: Optional data for orders > # series not cleaned. /; /; /; Developed 24 April 2003 by Jin-Man Lee & Houston H. Stokes /; This code is a moving window variant of kswtest /; /; Added arguments January 2004 /; /; Routines needed: buildlag, varest, swartest /; /; **************************************************************** /; n =norows(x); nc=nocols(x); if(n.le.10)then; call epprint('ERROR: # of rows passed to kswtest LE 10'); go to isbad; endif; nn=dmax(vend1); if(nn.gt.n)then; call epprint('ERROR: Endpoint bigger than # obs in data'); call print( ' # Data points was ',n:); call print( ' # max endpoint was ',nn:); go to isbad; endif; breakp = norows(vbegin1) ; /; /; Note: Storage different since we compare only one before and after /; t11 = vector(breakp:); t21 = vector(breakp:); t12 = vector(breakp:); t22 = vector(breakp:); var1 = vector(breakp:); var2 = vector(breakp:); varhat1 = vector(breakp:); varhat2 = vector(breakp:); rsq1 = vector(breakp:); rsq2 = vector(breakp:); vfact1 = vector(breakp:); vfact2 = vector(breakp:); /; test for bad input do kk=1,nc; do i=1,breakp ; ibegin1=vbegin1(i) ; iend1=vend1(i) ; ibegin2=vbegin2(i) ; iend2=vend2(i) ; call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, hvar1,hvar2,varxh1,varxh2,rrsq1,rrsq2); /; ****************************************************** /; Changed 30 September 2003 /; Failed on Linux 10 May 2005 ?????????????????????????? /; call compress(5); /; ****************************************************** if(nc.eq.1)then; t11(i) = test11; t12(i) = test12; t21(i) = test21; t22(i) = test22; var1(i) = hvar1; var2(i) = hvar2; varhat1(i)= varxh1; varhat2(i)= varxh2; rsq1(i) = rrsq1; rsq2(i) = rrsq2; endif; if(nc.gt.1)then; t11(i)= test11(kk); t12(i)= test12(kk); t21(i)= test21(kk); t22(i)= test22(kk); var1(i) = hvar1(kk); var2(i) = hvar2(kk); varhat1(i)= varxh1(kk); varhat2(i)= varxh2(kk); rsq1(i) = rrsq1(kk); rsq2(i) = rrsq2(kk); endif; enddo ; dfac1 = dabs(t11-t22) ; dvar1 = dabs(t11-t12) ; dvar2 = dabs(t21-t22) ; dstr1 = dabs(t11-t21) ; dstr2 = dabs(t22-t12) ; if(iprint2.ne.0)then; if(nc.gt.1)then; if(kk.eq.1)then; call print('++++++++++++++++++++++++++++++++++++++':); call print(' Multivariate Model':); call print('++++++++++++++++++++++++++++++++++++++':); endif; call print('++++++++++++++++++++++++++++++++++++++':); call print('Analysis of series ',kk:); call print('++++++++++++++++++++++++++++++++++++++':); endif; if(nc.eq.1)then; call print('++++++++++++++++++++++++++++++++++++++':); call print(' Univariate Model ':); call print('++++++++++++++++++++++++++++++++++++++':); endif; call print('Assumptions of Analysis:':); call print('# AR lags ',nlag:); call print('# Terms in IRF ',nterms:); call print('Number of periods ',breakp:); call print('Begining and End Points of Analysis':); call tabulate(vbegin1,vend1) ; call print(' ':); call print('Actual Variance by period',var1) ; call print('Actual Variance by period',var2) ; call print('Yhat Variance by period', varhat1) ; call print('Yhat Variance by period', varhat2) ; call print('Center R**2 by period', rsq1) ; call print('Center R**2 by period', rsq2) ; call print('Factual and Counter-Factual Variances'); call tabulate(test11,test12,test21,test22); call print('dfac1 = dabs(vfac1-vfac2) ':); call print('dvar1 = dabs(t11-t12)':); call print('dvar2 = dabs(t21-t22)':); call print('dstr1 = dabs(t11-t21)':); call print('dstr2 = dabs(t22-t12)':); call tabulate(dfac1,dvar1,dvar2,dstr1,dstr2); endif; if(iprint2.eq.0.or.iprint2.eq.-1)then; call inttostr(kk,cn,'(i2)'); call character(hold,'%VAR1___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(var1,c8 :global); call character(hold,'%VAR2___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(var2,c8 :global); call character(hold,'%VARH1__'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(varhat1,c8 :global); call character(hold,'%VARH2__'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(varhat2,c8 :global); call character(hold,'%RSQ1___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(rsq1,c8 :global); call character(hold,'%RSQ2___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(rsq2,c8 :global); call character(hold,'%T11____'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(t11,c8 :global); call character(hold,'%T12____'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(t12,c8 :global); call character(hold,'%T21____'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(t21,c8 :global); call character(hold,'%T22____'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(t22,c8 :global); call character(hold,'%DFAC___'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dfac1,c8 :global); call character(hold,'%DSTR1__'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dstr1,c8 :global); call character(hold,'%DVAR1__'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dvar1,c8 :global); call character(hold,'%DSTR2__'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dstr2,c8 :global); call character(hold,'%DVAR2__'); hold(8)=cn(2); if(kk.gt.9)hold(7)=cn(1); c8=c8array(1:hold); call rename(dvar2,c8 :global); endif; enddo; isbad continue; return; end; == ==LAGTEST 3-D Graph to display RSS for Various OLS Lags subroutine lagtest(y,x,ylag,xlag,nsubsets,rss); /; /; Purpose: Use 3-D Graph to display RSS for /; alternative lags /; /; y y-variable /; x x-variable /; ylag # lags on y /; xlag # lags on x /; nsubsets # subsets /; rss=array(ylag,xlag:); do j=1,ylag; do i=1,xlag; call olsq(y y{1 to j} x{1 to i}); rss(j,i)=%rss; enddo; enddo; call graph(rss :plottype meshc :grid :d3axis d3border :rotation 0. :heading 'Full lags displayed 0.0 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 90. :heading 'Full lags displayed 90. degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 180. :heading 'Full lags displayed 180 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 270. :heading 'Full lags displayed 270. degrees'); do i=1,nsubsets; /; 123456789012345678901234567890123456 call free(cc,n1,n2,n3.n4); call character(cc,'X lags - Y lags - '); call inttostr(i, n1,'(i2)'); call inttostr(norows(rss),n2,'(i2)'); call inttostr(i, n3,'(i2)'); call inttostr(nocols(rss),n4,'(i2)'); cc =place(n1,10,11,cc); cc =place(n2,13,14,cc); cc =place(n3,29,30,cc); cc =place(n4,32,33,cc); call graph(submatrix(rss,i,norows(rss),i,nocols(rss)) :plottype meshc :grid :d3axis d3border :rotation 0. :heading cc); enddo; return; end; == ==LAGTEST2 3-D Graph to display RSS for Various MARS Lags subroutine lagtest2(y,x,ylag,xlag,nsubsets,mi,nk,rss); /; /; Purpose: Use 3-D Graph to display RSS for /; alternative lags /; /; y y-variable /; x x-variable /; ylag # lags on y /; xlag # lags on x /; nsubsets # subsets /; mi # interactions /; nk # knots /; rss rss matrix /; rss=array(ylag,xlag:); do j=1,ylag; do i=1,xlag; call mars(y y{1 to j} x{1 to i} :mi mi :nk nk); rss(j,i)=%rss; enddo; enddo; call graph(rss :plottype meshc :grid :d3axis d3border :rotation 0. :heading 'Full lags displayed 0.0 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 90. :heading 'Full lags displayed 90. degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 180. :heading 'Full lags displayed 180 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 270. :heading 'Full lags displayed 270. degrees'); do i=1,nsubsets; /; 123456789012345678901234567890123456 call free(cc,n1,n2,n3.n4); call character(cc,'X lags - Y lags - '); call inttostr(i, n1,'(i2)'); call inttostr(norows(rss),n2,'(i2)'); call inttostr(i, n3,'(i2)'); call inttostr(nocols(rss),n4,'(i2)'); cc =place(n1,10,11,cc); cc =place(n2,13,14,cc); cc =place(n3,29,30,cc); cc =place(n4,32,33,cc); call graph(submatrix(rss,i,norows(rss),i,nocols(rss)) :plottype meshc :grid :d3axis d3border :rotation 0. :heading cc); enddo; return; end; == ==LMTEST Engle LM test for a Range of lags subroutine lmtest(x,nlag,lag,teststat,prob,iprint); /; /; Calculates Engle (1982) Lagrange Multiplie ARCH Test /; /; Tests works the same as Rats UG P 221 /; /; X = real*8 series to test /; nlag = Number of lags to run test /; lag = Vector of lags /; teststat = LM test statistic /; prob = Parbability of teststat /; iprint = 0 => do not print /; 1 => print /; n=norows(x); if(nlag.gt.(n/2).or.kind(x).ne.8)then; if(kind(x).ne.8)then; call eprint('ERROR: X in call LMTEST not real*8'); return; endif; call eprint('ERROR: X in call LMTEST nor long enough'); return; endif; teststat=array(nlag:); lag=idint(array(nlag:)); prob=array(nlag:); do i=1,nlag; lag(i)=i; call lm(x,value,i,pp); teststat(i)=value; prob(i)=pp; enddo; if(iprint.ne.0)then; call print('Engle LM Test for ARCH:'); call tabulate(lag,teststat,prob); endif; return; end; == ==LS2 Two Stage Least Squares and GMM Estimation /; /; Loads LS2, GMMEST and hausman /; subroutine ls2(y1,x1,z1,var_name,yvar,iprint); /; /; y1 => left hand side Usually set as %y from OLS /; x1 => right hand side. Usually set as %x from OLS step /; z1 => instrumental Variables /; var_name => Names from OLS step. Usually set as %names /; yvar => usually set from call olsq as %yvar /; iprint => =1 print coef, =2 print covariance in addition /; /; if # of obs for z1 < x1 then x1 will be truncated /; /; Automatic variables created /; %olscoef => OLS Coefficients /; %ols_se => OLS SE /; %ols_t => OLS t /; %ls2coef => LS2 Coefficients /; %ls2_sel => Large Sample LS2 SE /; %ls2_ses => Small Sample LS2 SE /; %ls2_t_l => Large Sample LS2 t /; %ls2_t_s => Small Sample LS2 t /; %rss_ols => e'e for OLS /; %rss_ls2 => e'e for LS2 /; %yhatols => yhat for OLS /; %yhatls2 => yhat for LS2 /; %resols => OLS Residual /; %resls2 => LS2 Residual /; %covar l => Large Sample covariance /; %covar_s => Small Sample covariance /; %sigma_l => Large Sample sigma /; %sigma_s => Small Sample Sigma /; %z /; %varcov1 => From OLS /; %info => Model is ok if = 0 /; For conditional Heteroskedasticity Sargan(1958)=Hansen(1982) J test /; %sargan => Sargan(1958) test /; %basmann => Basmann(1960) /; /; Example Job: /; /; b34sexec options ginclude('b34sdata.mac') member(kmenta); /; b34srun; /; /; b34sexec matrix; /; call loaddata; /; call echooff; /; call print('OLS for Equation # 1':); /; call olsq(q p d :savex :print); /; call ls2a(%y,%x,catcol(d,f,a,constant),%names,%yvar,1); /; /; call print('OLS for Equation # 2':); /; call olsq(q p a f: a :savex :print); /; call ls2(%y,%x,catcol(d,f,a,constant),%names,%yvar,1); /; b34srun; /; /; Command built 26 April 2010, Mods 26 May 2010 2 August 2010 /; y =vfam(y1); %z=mfam(z1); x =mfam(x1); n1=norows(%z); n2=norows(x); if(n2.lt.n1)call deleterow(%z,1,(n1-n2)); if(n1.lt.n2)then; call epprint('ERROR: # obs for instruments < # obs for equation'); go to done; endif; /; This saves the OLS Results call olsq(y x :noint); %olscoef=%coef; %ols_se=%se; %ols_t =%t; n_k=%nob-%k; %rss_ols=%rss; %yhatols=%yhat; %resols =%res; %varcov1=%resvar*%xpxinv; * 2SLS ; zpz = transpose(%z)*%z; zpx = transpose(%z)*x; zpy = transpose(%z)*y; ypy = y*y; irank=rank(zpx); iorder=rank(zpz); /; if(iorder.lt.irank)then; call epprint('ERROR: Model Underidentified.':); go to done; endif; /; %ls2coef =inv(transpose(zpx)*inv(zpz)*zpx)* (transpose(zpx)*inv(zpz)*zpy); /; /; Error trap turned off /; /; call gminv((transpose(zpx)*inv(zpz)*zpx),%ls2coef,%info,rrcond); /; if(%info.ne.0)then; /; go to done; /; endif; %yhatls2=x*%ls2coef; %resls2 =y-%yhatls2; sigma_w=(ypy - (2.*y*x*%ls2coef) + %ls2coef*transpose(x)*x*%ls2coef)/dfloat(n_k); %covar_s=sigma_w*inv(transpose(x)*%z*inv(zpz)*transpose(%z)*x); %ls2_ses=dsqrt(diag(%covar_s)); * Get sigma(i,j) from fits ; %rss_ls2=sumsq(%resls2); %sigma_l=%rss_ls2/dfloat(%nob); %sigma_s=%rss_ls2/dfloat(n_k); %covar_l=%sigma_l*inv(transpose(zpx)*inv(zpz)*zpx); %ls2_sel=dsqrt(diag(%covar_l)); %ls2_t_s=afam(%ls2coef)/afam(%ls2_ses); %ls2_t_l=afam(%ls2coef)/afam(%ls2_sel); /; /; squared canonical correlations /; if(iprint.ne.0)then; can_corr=real(eig(inv(transpose(x)*x)*(transpose(x)*%z)*inv(zpz)*zpx)); call print(can_corr); anderson=-1.*dfloat(norows(%z)) *dlog(sum(kindas(%z,1.0)-afam(can_corr))); anderlm = dfloat(norows(%z))*min(can_corr); cragg_d = anderlm/(1.0 - min(can_corr)); endif; /; /; %sargan & %basmann /; call olsq(%resls2 %z :noint); %basmann=(dfloat( norows(%z)-nocols(%z))*(sumsq(%resls2)-%rss))/%rss; %sargan = dfloat(norows(%z))*%rsq; /; if(iprint.ne.0)then; call print(' ':); call print('OLS and LS2 Estimation':); call print(' ':); gg= 'Dependent Variable '; gg2=c1array(8:yvar); ff=catrow(gg,gg2); call print(ff:); call print('OLS Sum of squared Residuals ',%rss_ols:); call print('LS2 Sum of squared Residuals ',%rss_ls2:); call print('Large Sample ls2 sigma ',%sigma_l:); call print('Small Sample ls2 sigma ',%sigma_s:); call print('Rank of Equation ',irank:); call print('Order of Equation ',iorder:); if(irank.lt.iorder)call print('Equation is overidentified':); if(irank.eq.iorder)call print('Equation is exactly identified':); /; call print('Anderson LR ident./IV Relevance test ',anderson:); /; if(iorder.ge.irank.and.anderson.gt.0.0)then; aprob=chisqprob(anderson,dfloat(iorder+1-irank)); call print('Significance of Anderson LR Statistic',aprob:); endif; /; call print('Anderson Canon Correlation LM test ',anderlm:); /; if(iorder.ge.irank.and.anderlm.gt.0.0)then; aprob=chisqprob(anderlm,dfloat(iorder+1-irank)); call print('Significance of Anderson LM Statistic',aprob:); endif; /; call print('Cragg-Donald Chi-Square Weak ID Test ',cragg_d:); /; if(iorder.ge.irank.and.cragg_d.gt.0.0)then; aprob=chisqprob(cragg_d,dfloat(iorder+1-irank)); call print('Significance of Cragg-Donald test ',aprob:); endif; /; call print('Basmann ',%basmann:); /; if(iorder.gt.irank.and.%basmann.gt.0.0)then; bprob=chisqprob(%basmann,dfloat(iorder-irank)); call print('Significance of Basmann Statistic ',bprob:); endif; /; call print('Sargan N*R-sq / J-Test Test ',%sargan:); /; if(iorder.gt.irank.and.%sargan.gt.0.0)then; sprob=chisqprob(%sargan,dfloat(iorder-irank)); call print('Significance of Sargan Statistic ',sprob:); endif; /; call print(' ':); call print('Hausman (1978) test - Sig. => need LS2':); call hausman('All coef. tested with Full (small) Covar. Matrix', %olscoef,%varcov1,%ls2coef,%covar_s, hausmant,h_sig,iprint); call hausman('All coef. tested with Full (large) Covar. Matrix', %olscoef,%varcov1,%ls2coef,%covar_l, hausmant,h_sig,iprint); call hausman('All coef. tested with diag (small) Covar. Matrix', %olscoef,diagmat(diag(%varcov1)), %ls2coef,diagmat(diag(%covar_s)), hausmant,h_sig,iprint); call hausman('All coef. tested with diag (large) Covar. Matrix', %olscoef,diagmat(diag(%varcov1)), %ls2coef,diagmat(diag(%covar_l)), hausmant,h_sig,iprint); /; call tabulate(var_name,%olscoef,%ols_se,%ols_t,%ls2coef, %ls2_ses,%ls2_sel, %ls2_t_s,%ls2_t_l :title '+++++++++++++++++++++++++++++++++++++++++++++++++++++'); call print(' ':); if(iprint.eq.2) call print('Estimated Covariance Matrix - Large Sample',%covar_1); endif; /; call makeglobal(%olscoef); call makeglobal(%ols_se); call makeglobal(%ols_t); call makeglobal(%ls2coef); call makeglobal(%ls2_sel); call makeglobal(%ls2_ses); call makeglobal(%ls2_t_l); call makeglobal(%ls2_t_s); call makeglobal(%rss_ols); call makeglobal(%rss_ls2); call makeglobal(%yhatols); call makeglobal(%yhatls2); call makeglobal(%resols); call makeglobal(%resls2); call makeglobal(%covar_l); call makeglobal(%covar_s); call makeglobal(%sigma_l); call makeglobal(%sigma_s); call makeglobal(%z); call makeglobal(%sargan); call makeglobal(%basmann); call makeglobal(%varcov1); /; call makeglobal(%info); /; done continue; return; end; subroutine gmmest(y,x,z,names,yvar,j_stat,sigma,iprint); /; /; GMM Model - Built 12 May 2010 /; /; Must call ls2 prior to this call to produce global variable /; %z /; /; The following global variables are created: /; %resgmm => GMM Residuals /; %segmm => GMM SE /; %tgmm => GMM t /; %coefgmm => GMM Coef /; %yhatgmm => GMM Y hat /; %covar_g => Variance Covariance /; /; The Anderson Test is discussed in Baum /; "An introduction to Modern Econometrics Using Stata" (2006) p. 208 /; Both the IV and LM forms of tgeh test are given. /; /; Generates feasable two-step GMM Estimator. Results are the same as /; produced by the RATS "optimalweights" option. /; /; Note: When running bootstraps inv(s) can fail to invert if dummy /; variables are in the dataset. /; /; See Baum (2006) page 196 /; xpz = transpose(x)*z; xpy = transpose(x)*vfam(y); ypy = vfam(y)*vfam(y); /; /; GMM Coefficients /; irank =rank(xpz); iorder=rank(transpose(z)*z); /; if(iorder.lt.irank)then; call epprint('ERROR: Model Underidentified.':); go to done; endif; /; adj=kindas(z,1.0)/dfloat(norows(z)); s=hc_sigma(adj,z,%resls2); inv_s=inv(s); %coefgmm=inv(xpz*inv_s*transpose(xpz)) * (xpz*inv_s*transpose(z)*vfam(y)); %resgmm =vfam(y)-x*%coefgmm; %yhatgmm=x*%coefgmm; sigma=hc_sigma(kindas(z,1.),z,%resls2); /; /; Logic from Rats User's Guide Version 7 page 245 /; j_stat=%resgmm*z*inv(sigma)*transpose(z)*%resgmm; /; /; Stock Watcon 2007 page 734 /; %covar_g=inv(xpz*inv(sigma)*transpose(xpz)); %segmm=dsqrt(diag(%covar_g)); %tgmm=afam(%coefgmm)/afam(%segmm); /; /; /; squared canonical correlations /; can_corr = real(eig(inv(transpose(x)*x)*(transpose(x)*z) *inv(transpose(z)*z)* transpose(xpz))); /; if(iprint.gt.1)call print(can_corr); anderson=-1.*dfloat(norows(z)) *dlog(sum(kindas(z,1.0)-afam(can_corr))); anderlm = dfloat(norows(z))*min(can_corr); cragg_d = anderlm/(1.0 - min(can_corr)); /; if(iprint.ne.0)then; call print(' ':); call print('GMM Estimates':); call print(' ':); gg= 'Dependent Variable '; gg2=c1array(8:yvar); ff=catrow(gg,gg2); call print(ff:); call print('OLS sum of squares ',sumsq(%resols):); call print('LS2 sum of squares ',sumsq(%resls2):); call print('GMM sum of squares ',sumsq(%resgmm):); call print('Rank of Equation ',irank:); call print('Order of Equation ',iorder:); if(irank.lt.iorder)call print('Equation is overidentified':); if(irank.eq.iorder)call print('Equation is exactly identified':); call print('Anderson ident./IV Relevance test ',anderson:); /; if(iorder.ge.irank.and.anderson.gt.0.0)then; aprob=chisqprob(anderson,dfloat(iorder+1-irank)); call print('Significance of Anderson Statistic ',aprob:); endif; /; call print('Anderson Canon Correlation LM test ',anderlm:); /; if(iorder.ge.irank.and.anderlm.gt.0.0)then; aprob=chisqprob(anderlm,dfloat(iorder+1-irank)); call print('Significance of Anderson LM Statistic',aprob:); endif; /; call print('Cragg-Donald Chi-Square Weak ID Test ',cragg_d:); /; if(iorder.ge.irank.and.cragg_d.gt.0.0)then; aprob=chisqprob(cragg_d,dfloat(iorder+1-irank)); call print('Significance of Cragg-Donald test ',aprob:); endif; /; call print('Hansen J_stat Ident. of instruments',j_stat:); /; if(iorder.gt.irank.and.j_stat.gt.0.0)then; jprob=chisqprob(j_stat,dfloat(iorder-irank)); call print('Significance of Hansen J_stat ',jprob:); /; call print(' ':); call hausman('Hausman (1978) test - Sig. => Need GMM', %olscoef,%varcov1,%coefgmm,%covar_g, hausmant,h_sig,iprint); endif; /; call tabulate(names,%coefgmm,%segmm,%tgmm :title '+++++++++++++++++++++++++++++++++++++++++++++++++++++'); call print(' ':); endif; call makeglobal(%resgmm); call makeglobal(%segmm); call makeglobal(%tgmm); call makeglobal(%coefgmm); call makeglobal(%yhatgmm); call makeglobal(%covar_g); done continue; return; end; subroutine hausman(title,olscoef,varcov1,ivcoef,ivcovar, hausmant,h_sig,iprint); /; /; Hausman (1978) Test if IV Estimation is needed /; /; title => Supply a title /; olscoef => Usually set as %olscoef from ls2 routine /; varcov1 => Usually set as %varcov1 from ls2 routine /; ivcoef => Usually set as %ls2coef from ls2 routine /; or %coefgmm from gmmest routine /; ivcovar => Usually set as %covar_L or %covar_S from ls2 /; or %covar_g from gmmest /; hausmant => Hausman test /; h_sig => Significance of Hausman test /; iprint => NE 0 => print, =2 print internal steps /; /; Logic of test is /; "Cameron-Trivedi Microeconometrics: Methods and Applications" /; Cambridge (2005, 272) equation 8.37. /; /; Logic tracks SAS Hausman statistic in proc model. /; /; Built 6 August 2011 /; d = vfam(ivcoef-olscoef); workm = (mfam(ivcovar)-mfam(varcov1)); n_end = rank(workm); invdif = pinv(workm); hausmant= d*invdif*d; h_sig = chisqprob(dabs(hausmant),dfloat(n_end)); if(iprint.ne.0)then; call print(' ':); call print(title:); call print('Hausman (1978) M test statistic ',hausmant:); call print('Rank of (ivcoef-varcov1) ',n_end:); call print('Significance of Hausman Test ',h_sig:); if(iprint.gt.1)then; call print('Coefficient Difference Vector',d); call print('OLS Var_Covar ',varcov1); call print('IV Var-Covar ',ivcovar); call print('Generalized Inverse of difference',invdif); r_cond = rcond(invdif); call print('rcond ',r_cond:); endif; call print(' ':); endif; return; end; == ==MARQ Estimation of a Nonlinear Model using Derivatives subroutine marq(xvar,yvar,beta,r,f,sse,seb,covb, corrb,lamda,iprint,iout); /; /; based on Sas(r) nonlinear matrix program in technical report /; a-102 pp.8-6 /; /; Converted for Speakeasy(r) by Houston H. Stokes April 1987 /; /; Converted for B34S(r) June 1998 /; /; needs user subroutines resid, deriv /; /; xvar = matrix of x variables - input /; yvar = left hand side variable vector - input /; beta = vector of initial guess on coefficients - input/output /; r = residual vector - output /; f = predicted variable vector - output /; see = sum of squared residuals (sumsq(r)) - output /; seb = se's of the beta coefficients - output /; covb = covariance matrix of beta coefficients - output /; corrb = correlation matrix of beta coefficients - output /; lamda = ridge parameter - usually initialized as .1e-8 - input /; iprint = 0 donot print inerations, = 1 print iterations /; iout = 0 for no output printing, = 1 output will be given /; /; arguments for user supplied subroutines /; /; resid(beta,f,r,xvar,yvar) deriv(der,f,beta,xvar) /; resid calculates f and r given beta, xvar and yvar /; deriv calculates derivative der=matrix(norows(xvar),norows(beta):) /; call cls(-1); eps=1.0 ; yvar=vfam(yvar) ; xvar=vfam(xvar) ; iter=0 ; subiter=0 ; if(iout.eq.1) call print('Nonlinear estimation using Marquardt Derivative Method'); call resid(beta,f,r,sse,xvar,yvar); if(iprint.eq.1)call print(lamda,sse,beta,' ',' ', 'iter subit eps lamda sse betas'); f=vfam(f) ; for iter=1,30 ; call outstring(1,2,'Nonlinear Estimation Marquardt Method'); call outstring(1,3,'Iter eps sse'); call outinteger(20,3,iter); call outdouble(40,3,eps,'(e16.8)'); call outdouble(60,3,sse,'(e16.8)'); subiter=0 ; call deriv(x,f,beta,xvar); lastsse=sse; xpx=(transpose(x)*x) +(lamda*vfam(diag(transpose(x)*x))); xpr=transpose(x)*mfam(r); delta=inv(xpx :pdmat)*xpr ; delta=vfam(delta); oldbeta=beta ; beta=beta+delta ; call resid(beta,f,r,sse,xvar,yvar) ; /; Change ? if(sse.lt.lastsse)lamda=lamda/10.0 ; /; Change ? eps=dabs(lastsse - sse) / (sse + 1.0e-6) ; if(eps.lt.1.0e-8)go to done ; if(iprint.eq.1)call print(iter,subiter,eps,lamda,sse,beta); /; shorten step for subiter=1,10 ; call outstring(1,4,'Subiter'); call outinteger(15,4,subiter); call outdouble(40,3,eps,'(e16.8)'); call outdouble(60,3,sse,'(e16.8)'); if(sse .le. lastsse)go to back ; /; Change ? lamda=lamda*10.0 ; xpx=(transpose(x)*x) +(lamda*vfam(diag(transpose(x)*x))) ; delta=inv(xpx :pdmat)*xpr; delta=vector(norows(delta):delta); beta=oldbeta + delta ; call resid(beta,f,r,sse,xvar,yvar) ; if(iprint.eq.1)call print(iter,subiter,eps,lamda,sse,beta); call break('Loop two'); next subiter ; back continue; if(subiter.le.9)go to back1; call print('Estimates did not improve after 10 ridge scalings.' 'Abort calculation.'); eps=0.0 ; back1 continue ; subiter=0 ; /; Change ? if(eps.le..1e-8)go to done ; call break('Loop three') ; next iter ; done continue ; if (iter.ge.30)call print('Convergence Failed'); covb =inv(transpose(x)*x :pdmat) *sse ; covb=mfam(afam(covb)/dfloat(norows(xvar)-norows(beta)) ); seb=dsqrt(diag(covb)) ; s=1./afam(seb) ; s=diagmat(:vfam(s)) ; corrb=s*covb*s ; if(iout.eq.1)then ; tscore=vfam(afam(beta)/afam(seb)) ; call tabulate(beta,seb,tscore) ; see=dsqrt(sse/dfloat(norows(xvar)-norows(beta))) ; call print(' ', sse,see,' ' 'Covariance of betas',covb, ' ', 'Correlation of Betas ',corrb) ; endif; return; end; == ==MARSPLOT Plot MARS Curves & Surfaces program marsplot; /; /; If :graph is used on Matrix MARS command this program /; Fill automatically plot curves and surfaces /; i_=integers(1,%ngc*2*%nc); bigm_=matrix(%ngc,2*%nc: %crv(i_)); ii_a=0; do ii_=1,%nc,2; ii_a=ii_a+1; m1_=submatrix(bigm_,1,%ngc,ii_,ii_+1); call char1(cc,'Curve Plot '); call inttostr(ii_a,cc2,'(i4)'); ii2_=integers(4); ii3_=ii2_+11; cc(ii3_)=cc2(ii2_); call graph(m1_ :plottype meshstepc /; :plottype meshc :grid :d3axis :d3border :heading cc); enddo; i_=integers(1,%ngs*%ngs*%ns); bigm_=matrix(%ngs,%ngs*%ns:%srf(i_)); do ii_=1,%ns; icol1_=1+((ii_-1)*%ngs); icol2_=icol1_+%ngs-1; m1_=submatrix(bigm_,1,%ngs,icol1_,icol2_); call char1(cc,'Surface Plot '); call inttostr(ii_,cc2,'(i4)'); ii2_=integers(4); ii3_=ii2_+13; cc(ii3_)=cc2(ii2_); call graph(m1_ :plottype meshc /; :plottype meshstepc :grid :d3axis :d3border :plottype meshc :heading cc); enddo; return; end; == ==MCLEODLI McLeod-Li (1983) Linearity test (y,ip,maxacf) subroutine mcleodli(y,ip,maxacf,makeplot); /; /; Calculates y(t) = f(1,y(t-1) ...... y(t-ip)) /; Calculates ACF of %res**2 of equation # 1 /; using max order maxacf /; /; /; y = series to study /; ip = max lag /; maxacf = max ACF to calculate /; makeplot= set =0 for no plot, 1 for a plot /; /; Revised Feb 15 2000 to corrrect bug and add graph option /; Revised Mar 9 2000 to run model with a constant at suggestion /; Jin-Man Lee /; if(norows(y).le.10)then; call print('McLeod-Li Test y vector too small.'); go to done; endif; if(ip.gt.(norows(y)-5))then; call print('McLeod-Li Test IP set too large.'); go to done; endif; call olsq(y y{1 to ip}); %ressq2=afam(%res)*afam(%res); if(maxacf.gt.(norows(%res)-5))then; call print('McLeod-Li Test maxacf set too large.'); go to done; endif; %acf1=acf(%ressq2,maxacf,%se1); if(makeplot.ne.0) call graph(%acf1,%se1 :heading 'McLeod-Li Test - Plot of ACF'); an=dfloat(norows(y)); %acf1sq=%acf1*%acf1; %mltest=(an*(an+2.0)*sum(%acf1sq))/(an-dfloat(ip)); call makeglobal(%res, %ressq2, %acf1, %mltest); done continue; return; end; == ==MINIMAX Minimax Estimation using MAXF2 program minimax; /; /; ***************************************************** /; Perform Minimax Estimation. SE calculated /; Use built-in minimax for speed /; /; The following variables have to be defined as input /; /; y = Left Hand side /; x = Matrix of regressions with constant in col 1 /; iprint = 0 => do not print /; = 1 => print /; /; The following are created ************************** /; /; Coef = estimated coefficients /; Sumabs = sum absolute errors /; Maxerror = maximum abs error /; *************************************************** coef=vector(nocols(x):); y=vfam(y); if(iprint.eq.1)call print(estminmx); call echooff; if(iprint.eq.1)call maxf2(func :name estminmx :parms coef :print); if(iprint.eq.0)call maxf2(func :name estminmx :parms coef); sumabs=sum(dabs(afam(y)-afam(x*coef))); maxerror=dmax(dabs(afam(y)-afam(x*coef))); return; end; program estminmx; xbeta=x*coef; y_xbeta=dabs(y-xbeta); func=-1.*dmax(y_xbeta); call outstring(3,3,'Function'); call outdouble(36,3,func) ; return; end; == ==MISSPLOT Plots Data With Missing Values subroutine missplot(y,points,dots,noline,title); /; /; Plot a Series with Missing Data inside the series /; /; y => Actual Data /; points => if 1 mark points /; dots => if 1 use a dotted line /; noline => if 1 no line /; title => Title /; /; ********************************************************** /; Version 8 August 2001 /; ********************************************************** call echooff; call graphp(:start); mmin_2=dmin(y:); mmax_2 =dmax(y:); mmin_1=0.0; mmax_1=dfloat(norows(y)+1); if(mmin_2.lt.0.0)mmin_2=mmin_2*1.05; if(mmin_2.gt.0.0)mmin_2=mmin_2*.95; if(mmin_2.eq.0.0)mmin_2=mmin_2-.05; if(mmax_2.lt.0.0)mmax_2=mmax_2*.95; if(mmax_2.gt.0.0)mmax_2=mmax_2*1.05; if(mmax_2.eq.0.0)mmax_2=mmax_2+.05; x1=dfloat(integers(norows(y))); call graphp(:cont :grarea array(: 0.0 0.0 1. 1.) :grunits array(:mmin_1 mmin_2 mmax_1 mmax_2) :pgarea array(:.1 .1 .9 .9) :pgunits array(:mmin_1 mmin_2 mmax_1 mmax_2) :color black :heading title :pgxscale 'NT' :pgaxes :pgxscale 'NT' :pgborder :pgyscaleleft 'NT' :pgyscaleright 'I' :pgxscaletop 'I' :pgxscale 'NT' :color red :pgunitstogrunits x1 y gr_x gr_y); if( dots.eq.1)call graphp(:cont :linetype dotted); if(noline.ne.1)call graphp(:cont :grjoin gr_x gr_y); if(points.eq.1)call graphp(:cont :grmarker gr_x gr_y 14); call graphp(:final); return; end; == ==MOVEAVE Moving average of a vector subroutine moveave(x,nobs,ma); /; x = vector of input data /; nobs = # of observations in moving average /; ma = moving average vector /; /; Usage call moveave(x,10,ma); if(nocols(x).gt.1.or.kind(x).ne.8)then; call epprint('ERROR: MOVEAVE requires 1D real*8 objects'); call epprint(' kind(x) = ',kind(x)); call epprint(' nocols(x) = ',nocols(x)); go to finish; endif; if(nobs.lt.1.or.nobs.gt.norows(x))then; call epprint('ERROR: NOBS in moveave not set correctly.'); go to finish; endif; j=integers(nobs); ma=array(norows(x)-nobs+1:); do i=1,norows(ma); test=x(i+j-1); ma(i)=mean(test); enddo; finish continue; return; end; == ==MOVEBJ Moving Arima Forecast using AUTOBJ subroutine movebj(series,iseas,ibegin,actual,fore,obs,nout,iprint,rdif, sdif,iwindow); /; /; Does within sample moving forecasts /; /; series => Series to forecast /; iseas l => seasonal period (must be ge 0) /; ibegin => Seriod to start forecast /; actual => Actual Data /; fore => nout step ahead moving forecast /; obs => Observation Number /; nout => # of period ahead forecast /; iprint => =0 => no printing, =1 => print models /; rdif => if set ne 0 forces differencing /; sdif => if set ne 0 forces seasonal differencing /; iwindow => =0 use complete sample so far. /; ne 0 => use iwindow obs. /; /; Argument iwindow added on 25 June 2008 /; iend=norows(series)-nout; if(ibegin.gt.iend)then; call epprint('ERROR: Call to movebj has ibegin > series length'); go to endit; endif; if(ibegin.lt.iwindow)then; call epprint('ERROR: Call to movebj has iwindow > ibegin'); go to endit; endif; /; We write the arguments to be passed depending on switches!! /; Note that the strings ':print' etc default to character*8 objects code1=c1array(8:':print'); code2=c1array(8:':rdif'); code3=c1array(8:':sdif'); /; :print :rdif :sdif /; 123456789012345678 call character(codes,' '); if(iprint.ne.0)then; ii=integers(6); codes(ii)=code1(ii); endif; if(rdif.ne.0)then; ii=integers(5); jj=ii+7; codes(jj)=code2(ii); endif; if(sdif.ne.0)then; ii=integers(5); jj=ii+13; codes(jj)=code3(ii); endif; actual=array(iend-ibegin+2-nout:); fore=actual; obs =actual; idone=0; do i=ibegin,iend; if(iwindow.eq.0)j=integers(1,i); if(iwindow.ne.0)j=integers(i-iwindow+1,i); series2=series(j); call autobj(series2 :autobuild argument(codes) :seasonal iseas :forecast index(nout,norows(series2))); idone=idone+1; fore(idone) =%fcast(nout); obs(idone) =i+nout; actual(idone) =series(i+nout); call compress; enddo; endit continue; return; end; == ==MOVECORR Moving Correlation of two vectors subroutine movecorr(x,y,nobs,cvec,nlag); /; /; Moving correlation of two vectors /; /; x = vector of input data 1 /; y = vector of input data 2 /; nobs = # of obs in moving correlation /; cvec = moving correlation vector /; nlag = number of lags for cross correlations /; /; Usage call movecorr(x,y,10,cvec,0); if(nocols(x).gt.1.or.kind(x).ne.8.or. norows(x).ne.norows(y).or. nocols(y).gt.1.or.kind(y).ne.8 )then; call epprint('ERROR: MOVECORR requires 1D real*8 objects'); call epprint(' kind(x) = ',kind(x)); call epprint(' nocols(x) = ',nocols(x)); call epprint(' kind(y) = ',kind(y)); call epprint(' nocols(y) = ',nocols(y)); go to finish; endif; if(nobs.lt.1.or.nobs.gt.norows(x))then; call epprint('ERROR: NOBS in movecorr not set correctly.'); go to finish; endif; j=integers(nobs); cvec=array(norows(x)-nobs+1,(nlag*2+1):); do i=1,norows(cvec); test1=x(i+j-1); test2=y(i+j-1); cvec(i,)=ccf(test1,test2,nlag); enddo; finish continue; return; end; == ==MOVEH82 Moving Hinich 82 test subroutine moveh82(x,nobs,g,l,ismoo); /; x = vector of input data /; nobs = # of obs in test /; g = Hinich gaussianity test /; l = Hinich linearity test /; ismoo = 0 => do not smooth, =1 smooth /; /; Usage call moveh82(x,100,g,l,1); if(nocols(x).gt.1.or.kind(x).ne.8)then; call epprint('ERROR: moveh82 requires 1D real*8 objects'); call epprint(' kind(x) = ',kind(x)); call epprint(' nocols(x) = ',nocols(x)); go to finish; endif; if(nobs.lt.1.or.nobs.gt.norows(x))then; call epprint('ERROR: NOBS in moveh82 not set correctly.'); go to finish; endif; j=integers(nobs); g=array(norows(x)-nobs+1:); l=array(norows(x)-nobs+1:); if(ismoo.eq.0)then; do i=1,norows(g); test=x(i+j-1); call hinich82(test,m,t1,t2 :meanonly); call outstring(3,3,'For case'); call outstring(3,4,'Gaussianity Test'); call outstring(3,5,'Nonlinearity Test'); call outinteger(40,3,i); call outdouble(40,4,t1(1)); call outdouble(40,5,t2(1)); g(i)=t1(1); l(i)=t2(1); enddo; endif; if(ismoo.ne.0)then; do i=1,norows(g); test=x(i+j-1); call hinich82(test,m,t1,t2:meanonly :smoothspec); call outstring(3,3,'For case'); call outstring(3,4,'Gaussianity Test'); call outstring(3,5,'Nonlinearity Test'); call outinteger(40,3,i); call outdouble(40,4,t1(1)); call outdouble(40,5,t2(1)); g(i)=t1(1); l(i)=t2(1); enddo; endif; finish continue; return; end; == ==MOVEH96 Moving Hinich 96 test subroutine moveh96(x,nobs,c,v,h); /; x = vector of input data /; nobs = # of obs in moving average /; c = sets # of lags. Must be GE 0 /; v = second order test /; h = third order test /; /; Usage call moveh96(x,nterm,c,v,h); if(nocols(x).gt.1.or.kind(x).ne.8)then; call epprint('ERROR: MOVEAVE requires 1D real*8 objects'); call epprint(' kind(x) = ',kind(x)); call epprint(' nocols(x) = ',nocols(x)); go to finish; endif; if(nobs.lt.1.or.nobs.gt.norows(x))then; call epprint('ERROR: NOBS in moveave not set correctly.'); go to finish; endif; j=integers(nobs); v=array(norows(x)-nobs+1:); h=array(norows(x)-nobs+1:); do i=1,norows(v); test=x(i+j-1); call hinich96(test,c,t1,t2); v(i)=t1; h(i)=t2; enddo; finish continue; return; end; == ==MOVEOLS Moving OLS with LAGS subroutine moveols(y,x,nobs,rss,rsq,resvar,nlag,nxlag); /; /; Moving OLS model of two vectors of form /; y(t)=f(y(t-1),...,y(t-nlag),x(t-nxlag),...,x(t-nlag)) /; /; x = vector of input data 1 /; y = vector of input data 2 /; nobs = # of obs in moving OLS model /; rss = moving residual sum of squares vector /; rsq = moving centered R**2 /; resvar = moving residual variance /; nlag = number of lags /; nxlag = Number of lags on x /; Usage call moveols(y,x,90,rss,rsq,resvar,10,1); if(nocols(x).gt.1.or.kind(x).ne.8.or. norows(x).ne.norows(y).or. nocols(y).gt.1.or.kind(y).ne.8 )then; call epprint('ERROR: MOVEOLS requires 1D real*8 objects'); call epprint(' kind(y) = ',kind(y)); call epprint(' nocols(y) = ',nocols(y)); call epprint(' kind(x) = ',kind(x)); call epprint(' nocols(x) = ',nocols(x)); go to finish; endif; if(nobs.lt.1.or.nobs.gt.norows(x))then; call epprint('ERROR: NOBS in MOVEOLS not set correctly.'); go to finish; endif; if(nxlag.gt.nlag.or.nlag.gt.nobs.or.nobs.gt.norows(x))then; call epprint('ERROR: nxlag, nlag, nobs in moveols not set correctly.'); go to finish; endif; j=integers(nobs); rss =array(norows(x)-nobs+1:); rsq =array(norows(x)-nobs+1:); resvar=array(norows(x)-nobs+1:); do i=1,norows(rss); test1=x(i+j-1); test2=y(i+j-1); call olsq(test1,test1{1 to nlag} test2{nxlag to nlag}); rss(i)=%rss; rsq(i)=%rsq; resvar(i)=%resvar; call outstring(3,3,'For case'); call outstring(3,4,'%RSS'); call outstring(3,5,'%RSQ'); call outstring(3,6,'%RESVAR'); call outinteger(40,3,i); call outdouble(40,4,%rss); call outdouble(40,5,%rsq); call outdouble(40,6,%resvar); enddo; finish continue; return; end; == ==MOVEVAR Moving Variance subroutine movevar(x,nobs,mvar); /; x = vector of input data /; nobs = # of obs in moving average /; mvar = moving variance vector /; /; Usage call movevar(x,10,ma); if(nocols(x).gt.1.or.kind(x).ne.8.or.norows(x).lt.2)then; call epprint('ERROR: MOVEVAR requires 1D real*8 objects with noob > 1'); call epprint(' kind(x) = ',kind(x)); call epprint(' norows(x) = ',norows(x)); call epprint(' nocols(x) = ',nocols(x)); go to finish; endif; if(nobs.lt.1.or.nobs.gt.norows(x))then; call epprint('ERROR: nobs in MOVEVAR not set correctly.'); go to finish; endif; j=integers(nobs); mvar=array(norows(x)-nobs+1:); do i=1,norows(mvar); test=x(i+j-1); mvar(i)=variance(test); enddo; finish continue; return; end; == ==MSMOOTH Moving calls to smooth for forecasting subroutine msmooth(series,method,ibegin,actual,fore,obs,nout, iprint,iwindow,alpha,beta,nma); /; /; Does within sample moving forecasts /; /; series => Series to forecast /; method set as character /; 'nce' /; 'ncept' /; 'dmave' /; 'es' /; 'des' /; 'holt' /; 'winters' /; ibegin => Seriod to start forecast /; actual => Actual Data /; fore => nout step ahead moving forecast /; obs => Observation Number /; nout => # of period ahead forecast /; iprint => =0 => no printing, =1 => print models /; iwindow => =0 use complete sample so far. /; ne 0 => use iwindow obs. /; alpha => used for es, des holt winters. Set /; 0 < alpha < 1. Default=.3 /; beta => smoothing constant for holt or winters. /; Default = .2 /; nma => # of terms for moving average. 0 => dfault = 4. /; /; Built 25 June 2008 /; iend=norows(series)-nout; if(ibegin.gt.iend)then; call epprint('ERROR: Call to movebj has ibegin > series length'); go to endit; endif; if(ibegin.lt.iwindow)then; call epprint('ERROR: Call to movebj has iwindow > ibegin'); go to endit; endif; alpha1 = .3; beta1 = .2; if(alpha .le. 0.0)alpha=alpha1; if(beta .le. 0.0)beta =beta1; /; We write the arguments to be passed depending on switches!! /; Note that the strings ':print' etc default to character*8 objects call character(codes,'series2 '); if(iprint.ne.0)codes='series2 :print '; actual=array(iend-ibegin+2-nout:); fore=actual; obs =actual; idone=0; do i=ibegin,iend; if(iwindow.eq.0)j=integers(1,i); if(iwindow.ne.0)j=integers(i-iwindow+1,i); series2=series(j); call character(method2,'NCE'); if(iprint.eq.0)then; if(nout.le.0)then; call smooth(argument('series2 :nma nma :method ') argument(method)); endif; if(nout.gt.0)then; call smooth(argument('series2 :nma nma :method ') argument(method) argument(' :lag nout')); endif; endif; if(iprint.ne.0)then; if(nout.le.0)then; call smooth(argument(' series2 :nma nma :print :method ') argument(method)); endif; if(nout.gt.0)then; call smooth(argument('series2 :nma nma :print :method ') argument(method) argument(' :lag nout ')); endif; endif; idone=idone+1; iibegin=ibegin +idone; if(iwindow.ne.0)iibegin=iwindow+1; fore(idone) =%xhatmat(iibegin,3+nout-1); obs(idone) =i+nout; if((i+1).le.iend)then; actual(idone) =series(i+1); endif; call compress; enddo; endit continue; return; end; == ==MIXEDEST Mixed Estimation subroutine mixedest(y,x,coef,se,names,varlag,rss,n,k, r,prior,v,mixed_b,mixed_se,compat,compats,iprint); /; /; Implements Theil Mixed Regression Model. /; /; y = %y from call olsq( ) /; x = %x from call olsq( ) /; coef = %coef from call olsq( ) /; se = %SE from call olsq( ) /; names = %names from call olsq( ) /; varlag = %lag from call olsq( ) /; rss = %rss from call olsq() /; n = %nob from call olsq( ) /; k = %k from call olsq( ) /; R = Constraint matrix. Usually set as /; r=catcol(vector(%k-1:),diagmat(vector(%k-1:)+1.)); /; prior = Vector of the prior estimates of coefficients not /; including the constant /; v = Prior covariance matrix of Coefficients not including /; constant. Can be set as v=I /; mixed_b = Mixed Estimation coefficient values /; mixed_se = Mixed Estimation SE values /; compat = Theil Compatibility Measure. Chi Square with DF k-1 /; compats = Significance of the Theil Compatibility Measure. A /; Significant value (GE .95) suggests that priors are not /; compatible with the OLS results. /; iprint = Set = 1 to print results, =2 suppress listing of /; R, prior and V /; References: /; Theil, H "Principles of Ecxonometrics (1971, 347-350) /; Theil, H "On the use of Incompledata Prior Information /; in Regression Analysis ", JASA June 1963 /; Vol.58. No. 302 pp 401-414. /; /; Example: /; /; b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; /; b34sexec matrix; /; call loaddata; /; call echooff; /; call load(mixedest); /; call olsq(log10ct log10rpt log10ri :print :savex); /; prior=vector(%k-1:-.7,1.); /; r=catcol(vector(%k-1:),diagmat(vector(%k-1:)+1.)); /; v=matrix(%k-1,%k-1:.0225, -.01,-.01,.0225); /; iprint=1; /; call mixedest(%y,%x,%coef,%se,%names,%lag,%rss,%nob, /; %k,r,prior,v,mixed_b,mixed_se, /; compat,compats,iprint); /; b34srun; /; /; Preliminary Version 18 July 2011 - arguments subject to change /; x=rollright(x); resvar=rss/dfloat(n-k); /; /; 1963 formula used. /; part1=inv( ((1./resvar)*(transpose(x)*x) ) + (transpose(r)*inv(v)*r )); part2= ( (1./resvar)*transpose(x)*y ) + (transpose(r) *inv(v)*prior ); mixed_b= part1*part2; mixed_se = sqrt(diag(part1)); mixed_ss = sumsq(y-x*mixed_b); mixed_b = rollleft(mixed_b); mixed_se = rollleft(mixed_se); dif=vector(k-1:); ii=integers(1,k-1); dif(ii)=prior(ii)-coef(ii); ols_v_c=resvar*r*inv(transpose(x)*x)*transpose(r); compat=dif*inv(ols_v_c+v)*dif; compats=chisqprob(compat,dfloat(k-1)); if(iprint.ne.0)then; call print(' ':); ols_t =vfam(afam(coef)/afam(se)); mixed_t=vfam(afam(mixed_b)/afam(mixed_se)); call tabulate(names,varlag,coef,se,ols_t,prior, mixed_b,mixed_se,mixed_t :cname :title 'Theil (1963, 1991) Mixed Estimation of OLS Model' ); call print(' ':); call print('OLS Residual Sum of Squares ',rss:); call print('Mixed Estimation Sum of Squares ',mixed_ss:); call print('Theil Chi Square Compatibility Measure',compat:); call print('Significance of Non-Compatibility ',compats:); if(iprint.eq.1)then; call print('Prior covariance Matrix of Coefficients',v); call print('Prior Restriction Matrix. ',r); endif; endif; x=rollleft(x); return; end; == ==NLVARCOV NLLSQ Variance Covariance subroutine nlvarcov(resvar,pcorr,se,varcov); /; resvar = Residual variance %RESVAR from NLLSQ /; pcorr = Correlation Matrix of Coef %CORRMAT from NLLSQ /; se = SE of parameters. %SE from NLLSQ /; varcov = Variance Covariance Matrix /; /; Gallant(1987) p 34 s^2*c(i,j)=se(i)*se(j)*p(i,j) /; /; Usage call nlvarcov(%resvar,%corrmat,%se,varcov); if(norows(se).ne.norows(pcorr).or.kind(se).ne.8.or.kind(pcorr) .ne.8.or.kind(resvar).ne.8.or.norows(pcorr) .ne.nocols(pcorr))then; call epprint('ERROR: MOVEVAR inputs not correct' ); call epprint(' kind(resvar) = ',kind(resvar) ); call epprint(' kind(pcorr) = ',kind(pcorr) ); call epprint(' kind(se) = ',kind(se) ); call epprint(' norows(pcorr) = ',norows(pcorr) ); call epprint(' nocols(pcorr) = ',nocols(pcorr) ); call epprint(' norows(se) = ',norows(se) ); go to finish; endif; varcov=matrix(norows(pcorr),nocols(pcorr):); do i=1,norows(pcorr); do j=1,nocols(pcorr); varcov(i,j)=se(i)*se(j)*pcorr(i,j)/resvar; enddo; enddo; finish continue; return; end; == ==OLSPLOT Plot of Fitted and Actual Data & Res subroutine olsplot(yhat,y,res,cc); /; /; Builds a residual and data and fitted plot /; Graph placed on clipboard /; /; yhat - forefast series /; y - actual series /; res - residual /; cc - Character String /; /; Added 20 September 2012 file name olsplot.wmf /; ******************************************* /; call graph(yhat y :noshow :pgborder :nocontact :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p1.hp1' :hardcopyfmt HP_GL2 :heading cc); call graph(res :noshow :pgborder :nocontact :pgxscaletop 'i' :pgyscaleright 'i' :file 'p2.hp1' :hardcopyfmt HP_GL2 :heading 'Residuals of Above Model'); call grreplay(:start :file 'olsplot.wmf'); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat twograph 2); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat twograph 2); call grreplay(:final); return; end; subroutine olsplot2(date,yhat,y,res,cc); /; /; Builds a residual and data and fitted plot /; Graph placed on clipboard /; /; date - Place date on graph /; yhat - forefast series /; y - actual series /; res - residual /; cc - Character String /; /; Added 20 September 2012 file name olsplot.wmf /; ******************************************* /; call graph(date yhat y :noshow :pgborder :nocontact :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'p1.hp1' :hardcopyfmt HP_GL2 :plottype xyplot :heading cc); call graph(date res :noshow :pgborder :nocontact :pgxscaletop 'i' :pgyscaleright 'i' :file 'p2.hp1' :hardcopyfmt HP_GL2 :plottype xyplot :heading 'Residuals of Above Model'); call grreplay(:start :file 'olsplot.wmf'); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat twograph 2); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat twograph 2); call grreplay(:final); return; end; == ==OLSQ_RES Testing restrictions in OLS Models program olsq_res; /; /; Easy way to test restrictions /; /; inputs that must be in the workspace /; /; _arg1 = Input to unrestricted regression /; _arg2 = Input to restricted regression /; /; outputs in workspace /; %rss1 = Unrestricted sum of squares /; %rss2 = Restricted sum of squares /; %k1 = # of variables in unrestricted equation /; %k2 = # of variables in restricted equation /; %n1 = Argument # 1 to Fprob %k1-%k2 /; %n2 = Argument # 2 to Fprob %nob-%k1 /; %nob = # of observations in unrestricted equation /; %fstat = f(j,nob-k) value /; %fprob = probability of f(j,n-k) /; /; if _noprint=1 => no printing of results /; /; If want to print regression results or turn off options /; place them in _arg1 and _arg2 /; /; Example: /; /; b34sexec matrix; /; call loaddata; /; call load(olsq_res); /; call echooff; /; k=6; /; _arg1='gasout gasout{1 to k} gasin{1 to k} :print'; /; _arg2='gasout gasin{1 to k} :print'; /; call olsq_res; /; b34srun; /; if(kind(_arg1) .eq.-99)then; call epprint( 'ERROR: _arg1 not set in memory.':); call stop; endif; if(kind(_arg2) .eq.-99)then; call epprint( 'ERROR: _arg2 not set in memory.':); call stop; endif; call olsq(argument(_arg1) ); %rss1=%rss; %k1=%k; %nob1=%nob; call olsq(argument(_arg2) ); %rss2=%rss; %k2=%k; if(%nob.ne.%nob1)then; call epprint( 'ERROR: # observations in both equations must be equal.':); call stop; endif; if(%k2.ge.%k1)then; call epprint( 'ERROR: # var in restricted equation GE # in unrestricted eq.':); call stop; endif; %fstat=((%rss2-%rss1)/dfloat(%k1-%k2))/(%rss1/dfloat(%nob-%k1)); %fprob=fprob(%fstat,dfloat(%k1-%k2),dfloat(%nob-%k1)); _print=0; if(kind(_noprint).ne.-99)then; if( _noprint.ne.0)_print=1; endif; if(_print.eq.0)then; call print(' ':); call print('Restricted Sum of Squares ',%rss2:); call print('Unrestricted Sum of Squates',%rss1:); %n1=%k1-%k2; %n2=%nob-%k1; call fprint(:clear :col 1 :string 'F(' :col 3 :display %n1 '(i5)' :col 8 :string ',' :col 9 :display %n2 '(i8)' :col 17 :string ')' :col 27 :display %fstat '(g16.8)' :print :clear); call print('F Probability ',%fprob:); endif; return; end; == ==PAD Pad a 1D Real*8 Series on both ends subroutine pad(oseries,nseries,nleft,nright,value); /; /; Routine pads oseries to line up with another series /; oseries => Old series /; nseries => New Series /; nleft => # to pad on left /; nright => # to pad on right /; value => pad value, usually missing /; if(nleft.lt.0.or.nright.lt.0)then; call epprint('ERROR: nleft or nright LT 0.'); go to done; endif; if(norows(oseries).lt.0.or.kind(oseries).ne.8 .or.(klass(oseries).ne.1.and.klass(oseries).ne.5))then; call epprint('ERROR: Oseries not real*8 1D object.'); go to done; endif; if(klass(oseries).eq.5)nseries= array(norows(oseries)+nleft+nright:); if(klass(oseries).eq.1)nseries=vector(norows(oseries)+nleft+nright:); nseries=nseries+value; i=integers(1,norows(oseries))+nleft; nseries(i)=oseries(i-nleft); done continue; return; end; == ==PC_REG Principle Component Regression subroutine pc_reg(y,x,ols_coef,ols_rss,tss, pc_coef,pc_rss,pc_size,u,iprint); /; Calculate Principle Component Regression /; /; y = Left hand variable. Usually set by call olsq as %y. /; x = Right hand side variables. Usuallt set by call olsq as /; %x /; ols_coef = OLS Coefficients /; ols_rss = OLS Residual sum of squares /; tss = total sum of squares (variance(y)*(n-1)) /; pc_coef = principle component coefficients /; pc_rss = k element residual sum of squares where pc_rss(1) /; is where all principle component vectors in u /; are being used pc_rss(1) will equal ols_rss /; pc_size = k element vector of the number of pc vectors in the /; calculation of pc_rss. pc_size(1) = k /; u = u from the svd decomposition of x=u*s*v /; iprint = 0 nothing printed, = 1 prints /; /; Sample setup /; /; b34sexec options ginclude('gas.b34'); b34srun; /; b34sexec matrix; /; call loaddata; /; call echooff; /; call load(pc_reg); /; nn=6; /; call olsq(gasout gasin{1 to nn} gasout{1 to nn} :print :savex); /; iprint=1; /; call pc_reg(%y,%x,ols_coef,ols_rss,tss,pc_coef, /; pc_rss,pc_size,u,iprint); /; b34srun; /; /; /; Command built May 1011 by Houstion H. Stokes /; /; We write x=u*s*v /; PC Coef a = transpose(u)*y /; OLS Coef = v*inv(s)*a /; tss=variance(y)*dfloat(norows(y)-1); s=svd(x,ibad,21,u,v ); L=afam(s)*afam(s); kactual=idint(sum(L.gt.(sfam(L(1))/1.e+14))); kk=nocols(x); if(kactual.lt.kk)then; s=s(integers(1,kactual)); u=submatrix(u,1,norows(u),1,kactual); v=submatrix(v,1,norows(v),1,kactual); endif; s=diagmat(s); pc_coef = transpose(u)*y; ols_coef=v*inv(s)*pc_coef; pc_res = vfam(afam(y)-afam(u*pc_coef)); ols_res = vfam(afam(y)-afam(x*ols_coef)); k=norows(pc_coef); ols_rss =sumsq(ols_res); pc_rss =vector(k:); pc_size =vector(k:); in=1; pc_rss(in)=sumsq(pc_res); pc_size(in)=k; pc_coef2=pc_coef; do jj=k,2,-1; in=in+1; pc_coef2(jj)=0.0; pc_size(in)=k-in+1; pc_rss(in) = sumsq(vfam(afam(y)-afam(u*pc_coef2))); enddo; rsq=1.0-afam(pc_rss/tss); if(iprint.ne.0)then; call print(' ':); call print('Principle Component Regression Model':); call print('Total Sum of Squares ',tss:); call print('Number of observations in X ',norows(x):); call print('Number of columns in X ',kk:); if(kactual.lt.kk) call print('Number of PC elements ',kactual:); call tabulate(pc_coef,ols_coef :title 'PC and OLS Coefficients'); call tabulate(pc_size,pc_rss,rsq :title 'Shrinkage Accuracy loss'); endif; call graph(pc_size pc_rss :grid :pgborder :plottype xyplot :heading 'Residual ss as function # of PC terms' :file 'pc_rss.wmf' :nocontact ); call graph(pc_size rsq :grid :pgborder :plottype xyplot :heading 'Explained sum of squares as a function # of PC terms' :file 'pc_ess.wmf' :nocontact ); finish continue; return; end; == ==PLS_REG Partial Least Squares Regression subroutine pls_reg(y,x,pls_coef,xload,yload,xscores, yscores,weights,yhat,pls_res,rss,ncomp,iprint); /; Partial Least Squares. See Wold (1975) /; pls_reg is designed to 100% track the Matlab simpls routine /; from which this discussion of PLS and PC regression has been /; developed. /; /; The Matlab code came from /; de Jong, S. "SIMPLS: An Alternative Approach to Partial Least Squares /; Regression." Chemometrics and Intelligent Laboratory Systems. Vol. /; 18, 1993, pp. 251–263. /; /; A newer and substantially faster reference is: /; /; de Jong, Sijmen, Barry Wise, N. Lawrence Ricker "Canonical Partial /; Least Squares and Continuum Power Regression," Journal of /; Chemometrics Vol. 15, 2001, pp 85-100 /; /; pc_reg creates components to explain the observed variability in the /; predictor variables, without considering the response variable at all. /; pls_reg takes the response variable into account, and therefore /; often leads to models that are able to fit the response variable /; with fewer components. /; /; y => left hand variable. Usually %y from olsq with :savex /; Can include more that 1 col! /; x => left hand variable. Usually %x from olsq with :savex /; n by k /; pls_coef => The pls_beta. Calculated as: /; pls_beta=weights*transpose(yload) for each. /; pls_coef is a (k,ncomp) matrix of coefficients. If /; ncomp is set = k, then pls_coef(,ncomp) is the same /; as the ols coefficients /; xload /; yload /; xscores /; yscores /; weights /; yhat => Predicted y value /; res => Residiual for last PLS regression /; rss => Residual Sum of Squares for from 1,...,ncomp models /; ncomp => # of cols in pls_beta /; iprint => =0 print nothing, =1 print results /; /; Built 28 April 2011 by Houston H. Stokes /; k=nocols(x); kk=nocols(y); n=norows(x); if(ncomp.gt.k)then; call epprint( 'ERROR: ncomp must be 0 < ncomp le # cols of x. was',ncomp:); call epprint( ' # of columns of x was ',k:); go to finish; endif; if(norows(y).ne.norows(x))then; call epprint('ERROR: # of obs in y and x not the same':); go to finish; endif; if(kk.gt.1)then; call epprint( 'ERROR: This release of pls_reg limited to one left hand variable':); go to finish; endif; meany=mean(y); meanx=array(k:); y0=y-meany; x0=x; do i=1,k; meanx(i)=mean(x(,i)); x0(,i)=mfam(afam(x(,i))-sfam(afam(meanx(i)))); enddo; vbig =matrix(k,ncomp:); vi =matrix(k,1:); vibig =matrix(k,1:); xload =matrix(k,ncomp:); yload =matrix(kk,ncomp:); xscores =matrix(n,ncomp:); yscores =matrix(n,ncomp:); weights =matrix(k,ncomp:); rss =vector(ncomp:); pls_beta=matrix(k,ncomp:); /; Obtain orthonormal basis for x loadings /; Each new basis vector can be removed from cov /; Find unit length ti=X0*ri and ui=Y0*ci whose covariance, /; ri'*X0'*Y0*ci, is jointly maximized, /; subject to ti'*tj=0 for j=1:(i-1). cov=matrix(nocols(x0),1:transpose(x0)*y0); /; begin major loop; do i=1,ncomp; s=svd(cov,ibad,21,uu,vv ); if(ibad.ne.0)then; call epprint('ERROR: SVD of cov failed':); go to finish; endif; ri=uu(,1); ci=vv(,1); si=s(1); ti=x0*ri; normti=sqrt(sumsq(ti)); if(normti.le.0.0)then; call epprint('ERROR: Norm of ti le 0.0':); go to finish; endif; ti=vfam(afam(ti)/normti); xload(,i)=transpose(x0)*ti; /; = transpose(y0)*ti qi=si*ci/normti; yload(,i)=qi; xscores(,i)=ti; yscores(,i)=y0*qi; weights(,i)=vfam(afam(ri)/sfam(normti)); vi(,1)=xload(,i); do repeat=1,2; if(i.gt.1)then; do j=1,(i-1); vj(,1)=vbig(,j); vi=mfam(afam(vi)-(sfam(transpose(vj)*vi)*afam(vj))); enddo; endif; enddo; normvi=sqrt(sumsq(vi)); if(normvi.le.0.0)then; call epprint('ERROR: Norm of vi le 0.0':); go to finish; endif; xjunk=afam(afam(vi)/ normvi); vi=matrix(norows(xload),1:xjunk); vbig(,i)=vi(,1); cov=cov - (vi*(transpose(vi)*cov)); vibig=submatrix(vbig,1,norows(vbig),1,i); cov=cov - (vibig*(transpose(vibig)*cov)); do iii=1,ncomp; ui=yscores(,iii); do repeat=1,2; if(iii.gt.1)then; do j=1,(iii-1); tj=xscores(,j); xwork=sfam(tj*ui); ui=mfam(afam(ui)-(xwork*afam(tj))); enddo; endif; enddo; yscores(,iii)=ui; enddo; /; pls_beta=weights*transpose(yload); adj=array(nocols(x):); do jj=1,nocols(x); adj(jj)=meanx(jj)*sfam(pls_beta(jj,1)); enddo; scale=meany-sum(adj); jj=norows(pls_beta); pls_beta(jj,1)=scale; yhat=x*pls_beta; pls_res=vfam(afam(y)-afam(yhat)); rss(i)=sumsq(pls_res); pls_coef(,i)=pls_beta(,1); enddo; if(iprint.ne.0)then; call print(' ':); iix=nocols(x); call print('Partial Least Squares - 26 April 2011 Version.' :); call print('Logic from SIMPLS Algorithm. See de Jong (1993).':); call print('Number Columns in origional data ',iix :); call print('Number Columns in PLS Coefficient Vector',ncomp:); call print('PlS sum of squared errors ',rss(ncomp):); endif; /; go to done; finish continue; yhat=missing(); phs_beta=missing(); done continue; return; end; == ==PLS1_REG PLS Code to calculate Continuum Reg /; /; Also includes crmtest to graphically study CRM Model /; subroutine pls1_reg(y,x,y0,x0,r,pls_beta, u,v,s,pls_coef,yhat,pls_res,rss,ncomp1,gamma,iprint); /; Partial Least Squares. See Wold (1975). This subroutine allows /; user to artificially decrease (gamma < 1) or increase (gamma > 1) /; the degree of multicolinearity in the X data. Only one SVD is used /; in contrast to the simpls approach coded in pls_reg which should /; increase performance. This is called canonical PLS. /; /; pls1_reg is designed to implement de Jong-Wise_Ricker Matlab code /; from which this discussion of PLS and PC regression has been /; developed. /; /; Alternative Matlab code came from /; de Jong, S. "SIMPLS: An Alternative Approach to Partial Least Squares /; Regression." Chemometrics and Intelligent Laboratory Systems. Vol. /; 18, 1993, pp. 251–263 and was implemented in B34S as pls_reg. This /; approach is substantially slower and has less capability. /; /; The complete reference for this code is: /; /; de Jong, Sijmen, Barry Wise, N. Lawrence Ricker "Canonical Partial /; Least Squares and Continuum Power Regression," Journal of /; Chemometrics Vol. 15, 2001, pp 85-100 /; /; pc_reg creates components to explain the observed variability in the /; predictor variables, without considering the response variable at all. /; pls_reg and pls1_reg take the response variable into account, and /; therefore often leads to models that are able to fit the response /; variable with fewer components. /; /; y => left hand variable. Usually %y from olsq with :savex /; x => left hand variable. Usually %x from olsq with :savex /; n by k /; u => from svd(x) x=u*diagmat(s)*transpose(v) /; v => from svd(x) /; s => singular values /; y0 => y with mean removed /; x0 => X with means subtracted except for last col /; r => weight matrix. Note bigt=x0*r from equation (16) /; pls_beta => pls_beta such that x0*r*pls_beta + mean(y) maps to yhat /; t*pls_beta + mean(y) /; since t = x0*r /; pls_coef => If ncomp is set = k, then pls_coef is the same as the /; ols coefficients. This might change in future releases /; to be simular to pls_reg. /; Note: (t*pls_beta)+mean(y) = x*pls_coef = yhat /; yhat => Predicted y value for last regression /; res => Residual for last PLS regression /; rss => Residual Sum of Squares all ncomp models /; ncomp => # of cols in pls_beta /; gamma => =0 for OLS =1. for pls => infinity for pc /; /; Note: Use caution changing gamma /; gamma = 0 => OLS /; gamma = 1 => PLS /; gamma > 1 => increasing multicolinearity in dataset /; set .le. 20 /; gamma < 1 => decrease multicolinearity in dataset /; /; iprint => =0 print nothing, =1 print results, /; =2 suppress coef list /; /; Note: bigt= x0*r; /; bigt= u * t_tilda => t_tilda= transpose(u) * bigt /; loadings of bigt with respect to y0 /; cc = y0*u*t_tilda = y0*bigt /; fitted y0= bigt* cc /; = x0*r*y0*x0*r /; Built 11 May 2011 by Houston H. Stokes /; /; Contributions made by Michael Hunstad to Matlab version. /; /; First Equation number refers to de Jong-Sijman-Wise-Ricker (2001) /; kin=nocols(x); kk=nocols(y); n=norows(x); ncomp=ncomp1; if(ncomp.gt.kin)then; call epprint( 'ERROR: ncomp must be 0 < ncomp le # cols of x. was',ncomp:); call epprint( ' # of columns of x was ',kin:); go to finish; endif; if(norows(y).ne.norows(x))then; call epprint('ERROR: # of obs in y and x not the same':); go to finish; endif; if(kk.gt.1)then; call epprint( 'ERROR: This release of pls1_reg limited to one left hand variable':); go to finish; endif; meany=mean(y); meanx=array(kin:); y0=y-meany; x0=x; do i=1,(kin-1); meanx(i)=mean(x(,i)); x0(,i)=mfam(afam(x(,i))-sfam(afam(meanx(i)))); enddo; s=svd(x0,ibad,21,u,v ); if(ibad.ne.0)then; call epprint('ERROR: SVD x0 failed':); go to finish; endif; L=afam(s)*afam(s); k=idint(sum(L.gt.(sfam(L(1))/1.e+14))); L=L(integers(1,k)); ncomp=min1(ncomp,k); u=submatrix(u,1,norows(u),1,k); v=submatrix(v,1,norows(v),1,k); Lgam=vfam(afam(L)**gamma); rho=(y0*u); bigt=matrix(k,ncomp:); rss=vector(ncomp:); do i=1,ncomp; maxcol=max1(1,i-1); t=afam(Lgam)*afam(rho); t=t- afam(submatrix(bigt,1,k,1,maxcol)* (transpose(submatrix(bigt,1,k,1,maxcol))*vfam(t))); t=vfam(afam(t)/sqrt(sumsq((t)))); bigt(,i)=vfam(t); rho=rho-(vfam(t)*(vfam(t)*vfam(rho))); /; Equation (16) (10.4-13) pls_beta=y0*u*bigt; yhat=(u*bigt*pls_beta) + meany; rss(i)=sumsq((afam(y)-afam(yhat))); enddo; /; Equation (14) (10.4-8) r=v*(diagmat((1./dsqrt(afam(L))))*bigt); /; Equation (22) (10.4-13) pls_coef=r*pls_beta; i=norows(pls_coef); pls_coef(i)=sfam(meany)-sfam(vfam(meanx)*pls_coef); /; Equation (11) (10.4-7) bigt=u*bigt; yhat=x*pls_coef; pls_res=vfam(afam(y)-afam(yhat)); tss=variance(y)*dfloat(norows(y)-1); rsq=1.0-afam(rss(ncomp)/tss); if(iprint.ne.0)then; call print(' ':); iix=nocols(x); call print('Partial Least Squares PLS1 - 9 May 2011 Version. ' :); call print('Logic from de Jong, Wise, Ricker (2001) Matlab Code':); call print('Number of rows in original data ', norows(x):); call print('Number Columns in origional data ',iix:); call print('Number Columns in PLS Coefficient Vector ', ncomp:); if(ncomp.lt.ncomp1) call print('Note: PLS coefficient vector reduced due to rank of X':); call print('Gamma ', gamma:); call print('Mean of left hand variable ', meany:); call print('PLS sum of squared errors ', rss(ncomp):); call print('Total sum of squares ',tss:); call print('PLS R^2 ',rsq:); if(iprint.ne.2)then; call tabulate(pls_beta,pls_coef :title '(T*pls_beta)+mean(y) = x*pls_coef'); endif; endif; /; go to done; finish continue; yhat=missing(); phs_coef=missing(); done continue; return; end; subroutine crmtest(y,x,ncomp,gammag,rsstest,rote,iprint,noshow); /; /; Investigates the effect of changes in gamma on the RSS /; Various gamma => alternate Continuum Regression Models /; /; y => left hand variable. Must be vector /; x => right hand variable matrix with constant included /; ncomp => # of PLS/CR vectors /; gammg => Vector of gamma values /; rsstest=> Matrix of RSS values for 1-ncomp vectors and gammag /; rote => Sets rotation /; iprint => =0 do not give pls1_reg output /; =1 give pls1_reg output /; =2 do not give pls1_coef list /; noshow => =1 Just produce graph in crm_test.wmf /; =0 show graph and save graph /; /; /; /; 0 < gamma < 1 => Multicollinearity taken from X matrix /; 1 < gamma < 15.=> Multicollinearity added to X matrix. /; gamma = 1 => PLS Model. a large value of gamma /; approachs PC /; /; Subroutine crmtest built 23 May 2010 by Houston H. Stokes /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; ii=ncomp; jj=norows(gammag); rsstest=matrix(ii,jj:); do j=1,jj; gamma=gammag(j); call pls1_reg(y,x,y0,x0,r,c,,u,v,s,pls2coef,yhat, pls_res,pls_rss, ncomp,gamma,iprint); rsstest(,j)=pls_rss; enddo; scaleadj=array(4: dfloat(1), gammag(1), dfloat(ii),gammag(norows(gammag))); if(noshow.eq.1)then; call graph(rsstest :plottype meshc :d3axis :d3border :grid :noshow :rotation rote :pgborder :file 'crm_test.wmf' :xlabel '# Vectors' :ylabelleft 'Gamma' :pgunits scaleadj :heading 'RSS vs # vectors and gamma' ); endif; if(noshow.ne.1)then; call graph(rsstest :plottype meshc :d3axis :d3border :grid :rotation rote :pgborder :file 'crm_test.wmf' :xlabel '# Vectors' :ylabelleft 'Gamma' :pgunits scaleadj :heading 'RSS vs # vectors and gamma' ); endif; return; end; == ==PERMUTE Reorder a Square Matrix subroutine permute(oldmat,newmat,jold,jnew); /; /; Reorder sqrare matrix /; /; oldmat = old matrix /; newmat = new matrix /; iold = old col /; inew = new col /; /; Built 7 May 2003 by Houston H. Stokes /; ----------------------------------------------- /; ii=norows(oldmat); jj=nocols(oldmat); if(ii.ne.jj)then; call epprint('ERROR: PERMUTE requires square matrix'); go to done; endif; if(jold.gt.jj.or.jnew.gt.jj.or.jold.lt.1.or.jnew.lt.1)then; call epprint('ERROR: PERMUTE old or new col outside range'); go to done; endif; if(jold.eq.jnew)then; newmat=oldmat; go to done; endif; do i=1,ii; do j=1,jj; iiin=i; jjin=j; if(i.eq.jold)iiin=jnew; if(j.eq.jold)jjin=jnew; if(i.eq.jnew)iiin=jold; if(j.eq.jnew)jjin=jold; newmat(i,j)=oldmat(iiin,jjin); enddo; enddo; done continue; return; end; == ==POLYFIT Fit an nth Order Regression subroutine polyfit(x,y,n,coef,printout); /; /; x => input /; y => output /; n => order /; coef => coefficients /; printout => =0 no print, =1 print results /; /; Note: Argument # 1 is x /; Argument # 2 is y /; /; :qr added 8 May 2007 if(norows(y).ne.norows(x))then; call epprint('ERROR: In polyfit: X and Y not same length'); go to done; endif; if(n.lt.1)then; call epprint('ERROR: n must be ge 1'); go to done; endif; xx=array(norows(y),n+1:); do i=1,n; xx(,i)=afam(x)**dfloat(i); enddo; np1=n+1; xx(,np1)=1.; if(printout.ne.1)call olsq(y,xx :noint :qr); if(printout.eq.1)call olsq(y,xx :noint :print :qr); coef=%coef; done continue; return; end; == ==POLYVAL Evaluate an nth Order Polynominam Regression subroutine polyval(coef,xin,yhat); /; /; Get Yhat from a polynomial Model /; /; Coef Coefficients from polyfit /; xin The x values to use for the fit n=norows(coef)-1; xx=array(norows(xin),n+1:); do i=1,n; xx(,i)=afam(xin)**dfloat(i); enddo; np1=n+1; xx(,np1)=1.; xx=mfam(xx); yhat=afam(xx*vfam(coef)); return; end; == ==PPEXP_P Plot and save ppexp output /; /; ppexp_p2 also loaded. progran ppexp_p will automate the use of ppexp /; analysis for most applications. ppexp_p2 allows setting on 3-D /; rotation and angle /; subroutine ppexp_p(xpa,mm,nob,itask,prefix,ppindex); /; /; Graphically display output from ppexp command /; /; xpa => Matrix output %xpa for ppexp /; mm => # of planes %mm from ppexp. Must ge ge 2 /; nob => # of obs %nob from ppexp /; itask => 0 3 D graph /; 1 2 d graphs /; prefix=> name prefix for file - uses 1-4. /; used if itask=1 /; ppindex => Projection Pursuit index saved by call ppexp as %ppindex /; /; Graphs saved as ppexp_1.wmf /; ppexp_2.wmf /; ppindex.wmf /; /; Note ppexp_p calls ppexp_p2 with rotation=20. & angle = 20. /; /; Command built 1 July 2008 /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; Example of Use: /; /; call load(ppexp_p); /; call character(l_hand_s,'y'); /; call character(_args, 'x'); /; call ppexp(argument(l_hand_s) argument(_args) :print); /; call ppexp_p(%xpa,%mm,%nob,0,'t2',%ppindex); /; call ppexp_p(%xpa,%mm,%nob,1,'t2',%ppindex); /; call ppexp_p2(xpa,mm,nob,itask,prefix,ppindex,20.,20.); return; end; subroutine ppexp_p2(xpa,mm,nob,itask,prefix,ppindex,rotation,angle); /; /; Graphically display output from ppexp command /; /; xpa => Matrix output %xpa for ppexp /; mm => # of planes %mm from ppexp. Must ge 2 /; nob => # of obs %nob from ppexp /; itask => 0 3 D graph /; 1 2 d graphs /; prefix=> name prefix for file - uses 1-4. /; used if itask=1 /; ppindex => Projection Pursuit index saved by call ppexp as %ppindex /; rotation => set a real*8 number for 3-d rotation /; angle => set a real*8 number for 3-d angle /; Command built 1 January 2009 /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; if(mm.lt.2)then; call epprint('ERROR: mm in call to PPEXP_p found to be LT 2. Was ',mm); go to home; endif; if(itask.eq.0)then; i=integers(1,2*nob,2); g1=xpa(i,); call graph(g1 :plottype meshc :file 'ppexp_1.wmf' :rotation rotation :pspaceon :xlabelpos .35 :ylabelpos .35 :pgyscaleleft 'NT' :grcharset 'romanbld.chr' :grcharfont 7 :angle angle :grid :xlabel ' Observation' :ylabelleft 'Plane Number' 'C' :zlabelleft 'Mapping Strength' 'C9' :grid :d3axis :d3border :heading 'Projection Pursuit Abscissa (x) Projection'); i=integers(2,2*nob,2); g2=xpa(i,); call graph(g2 :plottype meshc :file 'ppexp_2.wmf' :rotation 0. :pspaceon :xlabelpos .35 :ylabelpos .35 :pgyscaleleft 'NT' :grcharset 'romanbld.chr' :grcharfont 7 :angle 20. :grid :xlabel ' Observation' :ylabelleft 'Plane Number' 'C' :zlabelleft 'Mapping Strength' 'C9' :grid :d3axis :d3border :heading 'Projection Pursuit Ordinate (y) Projection'); endif; if(itask.ne.0)then; i=integers(1,2*nob,2); g1=xpa(i,); i=integers(2,2*nob,2); g2=xpa(i,); icount=0; do i=1,mm; icount=icount+1; hh1='c_______.wmf'; prefix2=c1array(8:prefix); call ialen(prefix2,jj); hh=c1array(8:prefix); jj1=integers(jj); hh1(jj1)=hh(jj1); call inttostr(icount,hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj+1,jj+jjj); jj3=integers(jjj); hh1(jj2)=hh(jj3); g11=array(nob:g1(,i)); g21=array(nob:g2(,i)); title1='Slice from abscissa (x) projection '; title2='Slice from ordinate (y) projection '; call inttostr(i,hh,'(i8)'); call ijuststr(hh,left); title1=catrow(title1,hh); title2=catrow(title2,hh); call graph(g11 :heading title1 :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype obsplot :pgxscaletop 'i' :colors black bblue :file hh1 ); icount=icount+1; hh1='c_______.wmf'; prefix2=c1array(8:prefix); call ialen(prefix2,jj); hh=c1array(8:prefix); jj1=integers(jj); hh1(jj1)=hh(jj1); call inttostr(icount,hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj+1,jj+jjj); jj3=integers(jjj); hh1(jj2)=hh(jj3); call graph(g21 :heading title2 :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype obsplot :pgxscaletop 'i' :colors black bblue :file hh1 ); enddo; endif; call graph(ppindex :heading 'Data Density by Estimated Plane' :ylabelleft 'Projection Pursuit Index' 'c9' :xlabel 'Plane #' /; :markpoint 1 1 3 33 :markpoint 1 1 3 14 :nocontact :pgborder :grid :file 'ppindex.wmf'); home continue; return; end; == ==PVALUE_1 Present value of $1 recieved at end of n years subroutine pvalue_1(iend,r,amount); /; iend = end period /; r = interest /; amount = Present value of $1 recieved at end of n years /; Usage /; call pvalue_1(2,.02,a); => for two years /; /; Gets Present value of $1 recieved at end of n years /; /; See 'Managerial Economics By Evan Douglas 4th Edition /; amount=((1.0 / (1.0 + r))**dfloat(iend)); return; end; == ==PVALUE_2 Present Value of an Annuity of $1 subroutine pvalue_2(iend,r,amount); /; iend = end period /; r = interest /; amount = Present Value of an Annuity of $1 /; /; Usage /; call pvalue_2(2,.02,amount); => for two years /; /; Gets Present Value of an Annuity of $1 /; /; See 'Managerial Economics' By Evan Douglas 4th Edition /; /; Must load pvalue_3 /; amount=0.0; do i=1,iend; call pvalue_1(i,.06,a); amount=amount+a; enddo; return; end; == ==PVALUE_3 Present value of $1 recieved throughout year subroutine pvalue_3(ibegin,iend,r,amount); /; ibegin = begin period /; iend = end period /; r = interest /; amount = Present value of $1 recieved thoughout /; Year on a Daily basis /; Usage /; call pvalue_3(1,2,.02,a); => for two years /; /; Gets present value of $1. recieved throughout year /; /; See 'Managerial Economics By Evan Douglas 4th Edition /; i1=((ibegin-1)*365)+1; i2=365*iend; j=integers(i1,i2); n=i2-i1+1; a=((1./365.)/((1.+r/365.)**dfloat(j))); amount=sum(a); return; end; == ==QUANTREG Quantile Regression program quantreg; /; /; ***************************************************** /; Perform Reqression Quantile Estimation /; /; The following variables have to be defined as input /; /; %y = Left Hand side /; %x = Matrix of regressors with constant in col 1 /; theta = quantile. theta = .5 => l1 /; iprint = 0 => do not print /; = 1 => print /; = 2 => list estqreg also /; /; The following are created ************************** /; /; Coef = estimated coefficients /; Sumabs = sum absolute errors /; /; Arguments changed 7 September 2006 /; /; *************************************************** coef=vector(nocols(%x):); %y=vfam(%y); %x=mfam(%x); if(iprint.eq.2)call print(estqreg); call echooff; if(iprint.ne.0)call maxf2(func :name estqreg :parms coef :maxit 800 :print); if(iprint.eq.0)call maxf2(func :name estqreg :parms coef :maxit 800); sumabs=sum(dabs(afam(%y)-afam(%x*coef))); return; end; program estqreg; xbeta=%x*coef; y_xbeta=%y-xbeta; mask= %y .ge. xbeta; mask2 = %y .lt. xbeta; mask= vfam(theta*mask); mask2= vfam((1.0-theta)*mask2); func=-1.*(mask*dabs(y_xbeta)+mask2*dabs(y_xbeta)); call outstring(3,3,'Function'); call outdouble(36,3,func) ; call outstring(3,4,'Theta') ; call outdouble(36,4,theta) ; return; end; == ==RESET69 Ramsey(1969) Regression Specification Test subroutine reset69(y,yhat,x,rtest,prob,iorder,iprint); /; /; Calculates Ramsey (1969) reset (regression specification test) /; for the prior equation. The RESET69 command is not the same as /; the RESET test which is a modification for the residual. /; y => left hand variable /; yhat => yhat of original equation /; x => Original right hand side /; rtest => reset test /; prob => Probability of test /; iorder => Must be in range 2-(N-k) /; :print => Will give printed output. /; Notes: Takes the estimated residual and runs /; Eq 1 y(t) = f(x1,...,xk) + v /; Eq 2 y(t) = f(x1,...,xk) +(yhat(t)**2),..., /; yhat(t)**iorder) +u /; Uses F test to test sig /; F(iorder-1,n-k-iorder-1) = /; ((v'v - u'u)/(iorder-1)) /(u'u/(n-k-iorder+1)) /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(iorder.lt.2)then; call print('iorder must be ge 2':); go to cont; endif; origepe=sumsq(afam(y)-afam(yhat)); yy=array(norows(y),iorder-1:); do jj=1,iorder-1; yy(,jj) = afam(yhat)**dfloat(jj+1); enddo; call olsq(y catcol(afam(x) yy) :noint :qr); newepe = %rss; rtest= ((origepe-newepe)/dfloat(iorder-1)) / (newepe/dfloat(norows(yhat)-nocols(x)-iorder+1)); prob=fprob(rtest,dfloat(iorder-1), dfloat(norows(yhat)-nocols(x)-iorder+1)); if(iprint.ne.0)then; call print(' ':); ibot=(norows(yhat)-nocols(x)-iorder+1); itop=(iorder-1); call fprint(:clear :display 'RESET(69) Test for Specification' :col 35 :display rtest '(g16.8)' :col 54 :display 'F(' :col 57 :display itop '(i4)' :col 62 :display ',' :col 64 :display ibot '(i4)' :col 68 :display ')' :col 71 :display 'Probability' :col 83 :display prob '(g12.4)' :print); endif; cont continue; return; end; == ==RESET77 RESET77 Nonlinearitry Test subroutine reset77(indata,maxp,maxk,treset77,preset77,printit); /; ******************************************************* /; Test for RESET 77 (Thursby and Schmidt, JASA, 1977) /; y = b1*x_t-1 + ...+ bp*x_t-p + e rss1 =e'e /; e = f(x, x^2,...,x^h)+ u rss2 =u'u /; /; (rss1-rss2)/(h-1) /; F(h-1,n-m-p-h)~ ----------------- /; rss2/(n-m-p-h) /; where m=p*h /; /; /; Ref: "Some Properties of Tests for Specification Error in a /; Linear Regression Model" JASA September 1977 Vol 72 /; Number 359 pp 635-641 /; /; Code first built by JinMan Lee Summer 2000 /; Routine modified by Houston H. Stokes Fall 2000 /; ******************************************************* /; /; indata = real*8 series to be tested /; maxp = integer*4 max ar order /; maxk = integer*4 max order of test /; treset77 = reset77 statistic. reset77 is a maxk-1 array /; preset77 = probability of reset statistic. preset77 is a /; maxk-1 array /; printit = integer switch. 1 => print table of test /; 2 => print OLS and table of test /; ******************************************************* n =norows(indata) ; nreal =dfloat(n) ; treset77 =array(maxk-1:) ; preset77 =array(maxk-1:) ; /; Estimate of AR(maxp) if(printit.lt.2)call olsq(INDATA INDATA{1 to maxp} ); if(printit.eq.2)call olsq(INDATA INDATA{1 to maxp} :print); err1=%res ; rss1=%rss ; /; Generate independent variables and do test /; xx gets bigger!! /; Note: Need to make sure that XX does not get /; redefined from matrix to array and thus lose /; what has been saved, xx=array(n,2*maxp:); do kk=1,maxp; xx(,kk)=afam(lag(INDATA,kk)); enddo; jj=maxp+1; do i=2,maxk; j=i-1; do kk=1,maxp; xx(,jj)=afam(lag(INDATA,kk))**dfloat(i) ; jj=jj+1; enddo; if(printit.lt.2)call olsq(err1 goodrow(xx) ) ; if(printit.eq.2)call olsq(err1 goodrow(xx) :print) ; rss2 = %rss ; df1=dfloat(i)-1.0; df2=nreal-dfloat(i)*dfloat(maxp) -dfloat(i) - dfloat(maxp) ; treset77(j)=((rss1-rss2)/df1) /(rss2/df2); preset77(j)=fprob(treset77(j),df1,df2) ; enddo; h=dfloat(integers(2,norows(treset77)+1)); if(printit.ne.0)then; call print('RESET 77 (Thursby and Schmidt, JASA, 1977)'); call print('Max Ar Order ',maxp :); call tabulate(h,treset77,preset77 :cname) ; call print(' ',:); endif; return; end; == ==RMATLAB Runs Matlab commands program rmatlab; call open(77,'test.m'); call rewind(77); call rewind(4); call copyf(4,77); call close(77); call rewind(4); call dodos('matlab /r test /logfile test.out':); call dounix('matlab < test.m > test.out':); call dodos('pause'); call copyout('test.out'); return; end; == ==RRPLOTS Plots Recursive Residual Data /; /; rrplots & rrplots2 /; subroutine rrplots(rrstd,rss,nob,k,sumsq1,sumsq2,list); /; /; Plots Recursive Residual output from OLSQ /; /; rrstd => Standardized Recursive Residual /; rss => Residual sum of squares for OLS /; nob => Number of Observations for OLS /; k => Number of right hand side variables /; sumsq1 => Sum of squares # 1 /; sumsq2 => Sum of squares # 2 /; list => =0 no list, /; =1 list results, /; =2 save in rr.psv /; variables saved l10 l5 l1 cusumt u1 u5 u10 l /; cusumsqt u di1 ql sigma1 sigma2 /; /; The following files are automatically made: /; /; rr.wmf /; cusum.wmf /; cusumsq.wmf /; ql.wmf /; /; /; ********************************************************** /; Version 3 March 2003 - arguments may change later /; ********************************************************** /; call echooff; rr=goodrow(rrstd(,1)); call copytime(rrstd,rr,0); i1=integers(1,norows(rr))+k; di1=dfloat(i1); if(freq(rr).eq.0.0d+00) call graph(di1 rr :file 'rr.wmf' :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype xyplot :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Standardized Recursive Residual'); if(freq(rr).ne.0.0d+00) call graph(rr :file 'rr.wmf' :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype timeplot :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Standardized Recursive Residual'); /; cusumt=cusum(rr)/dsqrt(rss/dfloat(nob-k)); cusumt=cusum(rr)/dsqrt(variance(rr)); nn=norows(rr); conf10=2.* .85*dsqrt(dfloat(nn)); conf5 =2.* .948*dsqrt(dfloat(nn)); conf1 =2.* 1.143*dsqrt(dfloat(nn)); c2f10 =conf10/dfloat(nn); c2f5 = conf5/dfloat(nn); c2f1 = conf1/dfloat(nn); i=integers(nn)-1; u10=(conf10+(dfloat(i)*c2f10))/2.; u5 =(conf5 +(dfloat(i)*c2f5 ))/2.; u1 =(conf1 +(dfloat(i)*c2f1 ))/2.; l10=-1.*u10; l5 =-1.*u5; l1 =-1.*u1; i1=integers(1,norows(cusumt))+k; di1=dfloat(i1); call copytime(rr,u10,0); call copytime(rr,u5 ,0); call copytime(rr,u1 ,0); call copytime(rr,l10,0); call copytime(rr,l5 ,0); call copytime(rr,l1 ,0); call copytime(rr,cusumt,0); if(freq(cusumt).eq.0.0) call graph(di1 cusumt u10 u5 u1 l10 l5 l1 :file 'cusum.wmf' :pspaceon :plottype xyplot :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :nokey :colors black bblue :heading 'Plot of Cusum Test'); if(freq(cusumt).ne.0.0) call graph(cusumt u10 u5 u1 l10 l5 l1 :file 'cusum.wmf' :pspaceon :plottype timeplot :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :nokey :colors black bblue :heading 'Plot of Cusum Test'); cusumsqt=cusumsq(rr)/sumsq(rr); call copytime(rr,cusumsqt,0); bunk=array(15: .34022 .29296 .26137 .23835 .22061 .20639 .19465 .18475 .17624 .16884 .16230 .15127 .14224 .13468 .12823); nn1=nob+1-k; itable=(nn1/2)+1; if(nn1.gt.10)then; i5=5; d5=5.0d+00; iadj=1; if(itable.gt.60)then; i5=10; d5=10.; iadj=-5; endif; icp1=(itable/i5)-iadj; icp2=icp1+1; icp1=dmin1(icp1,15); icp2=dmin1(icp2,15); c0=bunk(icp1)-(((bunk(icp1)-bunk(icp2))/d5)*(dfloat(itable- ((icp1+iadj)*i5)))); ii=integers(norows(cusumsqt)); c=dfloat(ii)/dfloat(norows(cusumsqt)); zero=array(norows(c):); one =zero+1.0; l=dmax1(zero,c-c0); u=dmin1(one, c+c0); call copytime(rr,c,0); call copytime(rr,u,0); call copytime(rr,l,0); call copytime(rr,cusumsqt,0); if(freq(cusumsqt).eq.0.0) call graph(di1 cusumsqt c l u :file 'cusumsq.wmf' :pspaceon :pgyscaleright 'i' :pgborder :plottype xyplot :nokey :nolabel :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Cusumsq Test'); if(freq(cusumsqt).ne.0.0) call graph(cusumsqt c l u :file 'cusumsq.wmf' :pspaceon :pgyscaleright 'i' :pgborder :plottype timeplot :nokey :nolabel :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Cusumsq Test'); endif; i1=integers(1,norows(sumsq1))+k; di1=dfloat(i1); i2=nob-i1; cc=dfloat(nob)*dlog(rss/dfloat(nob)); sigma1=(afam(sumsq1)/dfloat(i1)); sigma2=(afam(sumsq2)/dfloat(i2)); ql=.5*((dfloat(i1)*dlog(sigma1))+(dfloat(i2)*dlog(sigma2))- cc); xjunk=array(norows(di1),2:); xjunk(,1)=di1; xjunk(,2)=ql; xjunk=goodrow(xjunk); di1=xjunk(,1); ql =xjunk(,2); call copytime(sumsq1,ql,0); if(freq(ql).eq.0.0) call graph(di1 ql :file 'quandtlr.wmf' :pspaceon :plottype xyplot :pgyscaleright 'i' :pgborder :nokey /; :grid :nolabel :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Quandt Likehood Ratio'); if(freq(ql).ne.0.0) call graph(ql :file 'quandtlr.wmf' :pspaceon :plottype timeplot :pgyscaleright 'i' :pgborder :nokey /; :grid :nolabel :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Quandt Likehood Ratio'); if(list.eq.1.and.freq(ql).eq.0.0)then; call tabulate(l10 l5 l1 cusumt u1 u5 u10 l cusumsqt u); call tabulate(di1 ql sigma1 sigma2); endif; if(list.eq.1.and.freq(ql).ne.0.0)then; date=chardate(makejul(ql)); call tabulate(date,l10,l5,l1,cusumt,u1,u5,u10); call tabulate(date,l,cusumsqt,u,di1,ql,sigma1,sigma2); endif; if(list.eq.2) call checkpoint( :var l10 l5 l1 cusumt u1 u5 u10 l cusumsqt u di1 ql sigma1 sigma2 :file 'rr.psv'); return; end; subroutine rrplots2(rrcoef,rrcoeft,vnames,lags,prefix,list,grid); /; /; Plots Recursive Residual Coefficients from OLSQ /; /; rrcoef => Recursive Residual Coefficients - usually %rrcoef /; rrcoeft => Residual sum of squares for OLS - usually %rrceoft /; vnames => Variables - usually %names /; lags => Variables - usually %lag /; prefix => name prefix for file - uses 1-4 /; list => =0 no list, /; =1 list recursive coef /; =2 save in rr2.psv /; grid => =0 no grid. /; ne 0 grid /; /; The following files are automatically made: /; /; prefix___n.wmf /; /; /; Usage call rrplots2(%rrcoef,%rrcoeft,%names,%lag,'c___',0,0); /; /; ********************************************************** /; Version 15 June 2006 - arguments may change later /; ********************************************************** /; call echooff; k=nocols(rrcoef)-1; do i=1,k; h1='Recursively Estimated Coefficient '; r_coef=goodrow(rrcoef(,i)); call copytime(rrcoef,r_coef,0); c1=c1array(8:vnames(i)); ijunk=integers(35,42); h1(ijunk)=c1(ijunk-34); if(lags(i).ne.0)then; call ialen(h1,jj); call character(kk,'{}'); jj1=jj+1; h1(jj1)=kk(1); hh=c1array(8:); call inttostr(lags(i),hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj1+1,jj1+jjj); jj3=integers(jjj); h1(jj2)=hh(jj3); jj1=jj1+jjj+1; h1(jj1)=kk(2); endif; r_tstat=goodrow(rrcoeft(,i)); call copytime(rrcoeft,r_tstat,0); if(freq(r_coef).ne.0.0)then; if(grid.ne.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype timeplot :pgxscaletop 'i' :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype timeplot :pgxscaletop 'i' :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; if(grid.eq.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype timeplot :pgxscaletop 'i' :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype timeplot :pgxscaletop 'i' :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; endif; if(freq(r_coef).eq.0.0)then; if(grid.ne.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype obsplot :pgxscaletop 'i' :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype obsplot :pgxscaletop 'i' :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; if(grid.eq.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype obsplot :pgxscaletop 'i' :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype obsplot :pgxscaletop 'i' :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; endif; hh1='c_______.wmf'; prefix2=c1array(8:prefix); call ialen(prefix2,jj); hh=c1array(8:prefix); jj1=integers(jj); hh1(jj1)=hh(jj1); call inttostr(i,hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj+1,jj+jjj); jj3=integers(jjj); hh1(jj2)=hh(jj3); call grreplay('p1.hpl','p2.hpl' :file hh1 :hardcopyfmt wmf ); call grreplay(hh1); enddo; if(list.eq.1)call print(rrcoef,rrcoeft); if(list.eq.2)call checkpoint(:var rrcoef rrcoeft :file 'rr2.psv'); return; end; == ==RRPLOTS2 Plots Recursive Coefficients /; /; This is loaded with rrplots. /; subroutine rrplots2(rrcoef,rrcoeft,vnames,lags,prefix,list,grid); /; /; Plots Recursive Residual Coefficients from OLSQ /; /; rrcoef => Recursive Residual Coefficients - usually %rrcoef /; rrcoeft => Residual sum of squares for OLS - usually %rrceoft /; vnames => Variables - usually %names /; lags => Variables - usually %lag /; prefix => name prefix for file - uses 1-4 /; list => =0 no list, /; =1 list recursive coef /; =2 save in rr2.psv /; grid => =0 no grid. /; ne 0 grid /; /; The following files are automatically made: /; /; prefix___n.wmf /; /; /; Usage call rrplots2(%rrcoef,%rrcoeft,%names,%lag,'c___',0,0); /; /; ********************************************************** /; Version 15 June 2006 - arguments may change later /; ********************************************************** /; call echooff; k=nocols(rrcoef)-1; do i=1,k; h1='Recursively Estimated Coefficient '; r_coef=goodrow(rrcoef(,i)); call copytime(rrcoef,r_coef,0); c1=c1array(8:vnames(i)); ijunk=integers(35,42); h1(ijunk)=c1(ijunk-34); if(lags(i).ne.0)then; call ialen(h1,jj); call character(kk,'{}'); jj1=jj+1; h1(jj1)=kk(1); hh=c1array(8:); call inttostr(lags(i),hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj1+1,jj1+jjj); jj3=integers(jjj); h1(jj2)=hh(jj3); jj1=jj1+jjj+1; h1(jj1)=kk(2); endif; r_tstat=goodrow(rrcoeft(,i)); call copytime(rrcoeft,r_tstat,0); if(freq(r_coef).ne.0.0)then; if(grid.ne.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype timeplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype timeplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; if(grid.eq.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype timeplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype timeplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; endif; if(freq(r_coef).eq.0.0)then; if(grid.ne.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype obsplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder :grid :plottype obsplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; if(grid.eq.0)then; call graph(r_coef :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype obsplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p1.hpl' :hardcopyfmt HP_GL2 :heading h1); call graph(r_tstat :noshow :nocontact :pspaceon :pgyscaleright 'i' :pgborder /; :grid :plottype obsplot :pgxscaletop 'i' :nocontact :colors black bblue :file 'p2.hpl' :hardcopyfmt HP_GL2 :heading 'Recursive t test'); endif; endif; hh1='c_______.wmf'; prefix2=c1array(8:prefix); call ialen(prefix2,jj); hh=c1array(8:prefix); jj1=integers(jj); hh1(jj1)=hh(jj1); call inttostr(i,hh,'(i8)'); call ijuststr(hh,left); call ialen(hh,jjj); jj2=integers(jj+1,jj+jjj); jj3=integers(jjj); hh1(jj2)=hh(jj3); call grreplay('p1.hpl','p2.hpl' :file hh1 :hardcopyfmt wmf ); call grreplay(hh1); enddo; if(list.eq.1)call print(rrcoef,rrcoeft); if(list.eq.2)call checkpoint(:var rrcoef rrcoeft :file 'rr2.psv'); return; end; == ==RTEST Tests Residuals of TS Models subroutine rtest(res1,y,nacf); /; /; res1 => First Moment Residual /; y => Input Series /; nacf => Number acf terms /; /; Plots made: /; /; acfa.wmf => acf of residual Moment 1 /; acfb.wmf => acf of residual Moment 2 /; acfy.wmf => acf of y series /; mqa.wmf => Q stats residual Moment 1 /; mqb.wmf => Q stats residual Moment 2 /; pacfa.wmf => pacf of residual Moment 1 /; pacfb.wmf => pacf of residual Moment 2 /; pacfy.wmf => pacf of y series /; resa.wmf => Plot of residual Moment 1 /; resb.wmf => Plot of residual Moment 1 /; /; ********************************************************** /; Version 3 November 2001 /; ********************************************************** call print('Residual Sum of Squares is:',sumsq(goodrow(res1)):); /; **************************************************************$/ /; Produce ACF and PACF statistics for series /; **************************************************************$/ call print('*******************************************************'); call print('** Diagnostics/Summary Stats for Dependent Var:'); call print('*******************************************************'); call print('Print--> Describe Dependent Var: '); call describe(y :print); call print('Print--> ACF,Std.Err,PACF,Q-Stat,Prob.Q '); acfy=acf(y,nacf,sey,pacfy,mqy,pmqy); pmqy=1.-pmqy; call tabulate(acfy,sey,pacfy,mqy,pmqy); /; **************************************************************$/ /; Standardize residuals of 1st moment model /; **************************************************************$/ v =dsqrt(variance(goodrow(res1))); resa=afam(goodrow(res1)/v); /; **************************************************************$/ /; Build LaGrange Multiplier Test for 1st moment residuals /; **************************************************************$/ n=2; lmvalue=array(n:); lag=idint(array(n:)); prob=array(n:); do i=1,n; lag(i)=i; call lm(goodrow(resa), value,i,pp); lmvalue(i)=value; prob(i)=pp; enddo; call print('*******************************************************'); call print('** Diagnostics of standardized residuals'); call print('*******************************************************'); call print('Print--> Describe standardized resid. series'); call describe(resa :print); call print('Print--> Engle LM Test for standardized res1 series'); call tabulate(lag,lmvalue,prob); /; **************************************************************$/ /; Compute ACF, PACF, Q-stats for residuals in 1st moment model /; **************************************************************$/ call print('Print--> ACF, Std.Err, PACF, Q-Stat, Prob.Q'); acfa=acf(resa,nacf,sea,pacfa,mqa,pmqa); pmqa=1.-pmqa; call tabulate(acfa,sea,pacfa,mqa,pmqa); /; **************************************************************$/ /; Square standardized residuals of 1st moment model /; **************************************************************$/ resb=resa**2.; call print('*******************************************************'); call print('** Diagnostic testing of squared standardized residuals'); call print('*******************************************************'); /; **************************************************************$/ /; Compute ACF, PACF, Q-stats for squared standardized residuals /; **************************************************************$/ call print('Print--> ACF, Std.Err, PACF, Q-Stat, Prob.Q'); acfb=acf(resb,nacf,seb,pacfb,mqb,pmqb); pmqb=1.-pmqb; call tabulate(acfb,seb,pacfb,mqb,pmqb); call print('*******************************************************'); call print('** Display graphics for Dependent Variable'); call print('*******************************************************'); call graph(y :file 'yvar.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Dependent Variable '); call graph(acfy, sey :file 'acfy.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of Dependent Variable'); call graph(pacfy, sey :file 'pacfy.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'Partial ACF of Dependent Variable'); call print('*******************************************************'); call print('** Display graphics for 1st Moment Residuals'); call print('*******************************************************'); call graph(resa :file 'resa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of 1st Moment Residuals'); call graph(acfa, sea :file 'acfa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of 1st Moment Residuals'); call graph(pacfa, sea :file 'pacfa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'PACF of 1st Moment Residuals'); call graph(mqa :file 'mqa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Q-Stats from 1st Moment Residuals'); call print('*******************************************************'); call print('** Display graphs for Squared Standardized Residuals'); call print('*******************************************************'); call graph(resb :file 'resb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Squared Standardized Residuals'); call graph(acfb, seb :file 'acfb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of Squared Standardized Residuals'); call graph(pacfb, seb :file 'pacfb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'Partial ACF of Squared Standardized Residuals'); call graph(mqb :file 'mqb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Q-Stats from Squared Standardized Residuals'); return; end; == ==RTEST2 Tests Residuals of TS Models - No Res and y Plots subroutine rtest2(res1,y,nacf); /; /; res1 => First Moment Residual /; y => Input Series /; nacf => Number acf terms /; /; RTEST2 does not have y and residual plots /; /; ********************************************************** /; Version 3 November 2001 /; ********************************************************** call echooff; call print('Residual Sum of Squares is:',sumsq(goodrow(res1)):); /; **************************************************************$/ /; Produce ACF and PACF statistics for series /; **************************************************************$/ call print('*******************************************************'); call print('** Diagnostics/Summary Stats for Dependent Var:'); call print('*******************************************************'); call print('Print--> Describe Dependent Var: '); call describe(y :print); call print('Print--> ACF,Std.Err,PACF,Q-Stat,Prob.Q '); acfy=acf(y,nacf,sey,pacfy,mqy,pmqy); pmqy=1.-pmqy; call tabulate(acfy,sey,pacfy,mqy,pmqy); /; **************************************************************$/ /; Standardize residuals of 1st moment model /; **************************************************************$/ v =dsqrt(variance(goodrow(res1))); resa=afam(goodrow(res1)/v); /; **************************************************************$/ /; Build LaGrange Multiplier Test for 1st moment residuals /; **************************************************************$/ n=2; lmvalue=array(n:); lag=idint(array(n:)); prob=array(n:); do i=1,n; lag(i)=i; call lm(goodrow(resa), value,i,pp); lmvalue(i)=value; prob(i)=pp; enddo; call print('*******************************************************'); call print('** Diagnostics of standardized residuals'); call print('*******************************************************'); call print('Print--> Describe standardized resid. series'); call describe(resa :print); call print('Print--> Engle LM Test for standardized res1 series'); call tabulate(lag,lmvalue,prob); /; **************************************************************$/ /; Compute ACF, PACF, Q-stats for residuals in 1st moment model /; **************************************************************$/ call print('Print--> ACF, Std.Err, PACF, Q-Stat, Prob.Q'); acfa=acf(resa,nacf,sea,pacfa,mqa,pmqa); pmqa=1.-pmqa; call tabulate(acfa,sea,pacfa,mqa,pmqa); /; **************************************************************$/ /; Square standardized residuals of 1st moment model /; **************************************************************$/ resb=resa**2.; call print('*******************************************************'); call print('** Diagnostic testing of squared standardized residuals'); call print('*******************************************************'); /; **************************************************************$/ /; Compute ACF, PACF, Q-stats for squared standardized residuals /; **************************************************************$/ call print('Print--> ACF, Std.Err, PACF, Q-Stat, Prob.Q'); acfb=acf(resb,nacf,seb,pacfb,mqb,pmqb); pmqb=1.-pmqb; call tabulate(acfb,seb,pacfb,mqb,pmqb); call print('*******************************************************'); call print('** Display graphics for Dependent Variable'); call print('*******************************************************'); call graph(acfy, sey :file 'acfy.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of Dependent Variable'); call graph(pacfy, sey :file 'pacfy.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'Partial ACF of Dependent Variable'); call print('*******************************************************'); call print('** Display graphics for 1st Moment Residuals'); call print('*******************************************************'); call graph(acfa, sea :file 'acfa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of 1st Moment Residuals'); call graph(pacfa, sea :file 'pacfa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'PACF of 1st Moment Residuals'); call graph(mqa :file 'mqa.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Q-Stats from 1st Moment Residuals'); call print('*******************************************************'); call print('** Display graphs for Squared Standardized Residuals'); call print('*******************************************************'); call graph(resb :file 'resb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of Squared Standardized Residuals'); call graph(acfb, seb :file 'acfb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'ACF of Squared Standardized Residuals'); call graph(pacfb, seb :file 'pacfb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :histscale integers(0,nacf,2) :fitspline :overlay acfplot :colors black bblue bred :heading 'Partial ACF of Squared Standardized Residuals'); call graph(mqb :file 'mqb.wmf' :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Q-Stats from Squared Standardized Residuals'); return; end; == ==SC_TEST Serial Correlation Tests subroutine sc_test(nacf,res,x,bg_order,lmorder); /; /; Routine performs a number of Serial Correlation tests /; including Engle LM ARCH Test /; /; nacf => # of lags for Box-Pierce and Ljung-box /; 0 => do not do test /; res => Residual vector usually %res /; x => x matrix %x /; bg_order => Order of Breusch-Godfrey (1978) test /; => 0 => do not do test /; note both forms of the test are done. /; The alt form drops 0.0 residuals. /; for detail see Greene (2003) page 269 /; lmorder => Order of Engle LM ARCH test & Elliot-Rothenberg- /; Stock test /; /; Box-Pierce, Ljung-Box and DW - Serial Correlation /; Breusch(1978) Godfrey Test - Serial Correlation /; ARCH - ARCH effects /; See RATS UG page 221 /; Elliott-Rothenberg-Stock (1996) Unit root test /; documented in "Efficient Tests for an Autoregressive Root" /; Econometrica 64(4): 813-836. See also Introduction to /; Econometrics," By James Stock and Mark Watson, Addison /; Wesley New York 2003 page 549-550 /; /; /; Routine built December 2005. Arguments subject to change /; /; Requires: call load(b_g_test); /; call load(b_g_alt); /; call load(lmtest); /; call load(df_gls); /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; Example: /; /; b34sexec options ginclude('b34sdata.mac') member(grunfeld); /; b34srun; /; b34sexec matrix; /; call loaddata; /; /; call load(b_g_test); /; call load(b_g_alt); /; call load(lmtest); /; call load(sc_tests); /; /; call echooff; /; /; /; /; /; Set parameters for tests /; /; /; /; nacf=4; /; bg_order=4; /; lmorder=4; /; /; call print(' ':); /; call print('GE Equation':); /; call print('-----------':); /; call print(' ':); /; call olsq(i_ge f_ge c_ge :diag :print :savex); /; call print(' ':); /; call describe(%res :print); /; call sc_tests(nacf,%res,%x,bg_order,lmorder); /; /; b34srun; /; /; if(nacf.gt.0)then; call print(' ':); call print('Box-Pierce and Ljung-Box Statistics':); acf_res = acf(res,nacf,se,pacf,mq,probmq); box_p = dfloat(norows(res))*cusumsq(acf_res); lag=integers(1,nacf); call tabulate(lag,acf_res,se,pacf,mq,probmq,box_p :format '(g12.4)'); endif; /; DW i=integers(2,norows(res)); %dw=sumsq(res(i)-res(i-1))/sumsq(res); call print(' ':); call print('Durbin - Watson ',%dw:); /; Breusch(1978) Godfrey Test if(bg_order.gt.0)then; call print(' ':); do iorder=1,bg_order; call B_G_test(iorder,x,res,gbtest,gbprob,1,0); enddo; call print(' ':); call print('Alternative form of BG test ':); do iorder=1,bg_order; call B_G_alt(iorder,x,res,gbtest2,gbprob2,1,0); enddo; endif; /; ARCH if(lmorder.gt.0)then; call print(' ':); call lmtest(res,lmorder,lag,test,prob,1); endif; /; DF and PP Tests if(norows(res).gt.15)then; call df(res df1 :print); call pp(res pp1 :print); if(lmorder.gt.0)then; do i=1,lmorder; call print('----------------------':); call df(res df2 :adf i :print); call pp(res pp2 :app i :print); call print(' -------- ':); call df(res df3 :adft i :print); call pp(res pp3 :appt i :print); enddo; call print(' ':); endif; endif; /; Elliott-Rotherberg-Stock (1966) Unit root test /$ /$ Subroutine DF_GLS(x,lag1,notrend,trend,notrendx,trendx,iprint); /$ /$ Implements Elliott-Rothenberg-Stock (1996) Unit root test /$ documented in "Efficient Tests for an Autoregressive Root' /$ Econometrica 64(4): 813-836. See also Introduction to /$ Econometrics," By James Stock and Mark Watson, Addison /$ Wesley New York 2003 page 549-550 /$ /$ ********************************************************** /$ /$ x = series to test /$ lag1 = Lag for DF part of test. Must be GE 1 /$ notrend = > no trend test statistic /$ trend = > trend test statistic /$ notrendx = x smoothed without a trend /$ trendx = x smoothed with a trend /$ iprint = 2 to print steps and test, = 1 print test only /$ iprint=1; if(lmorder.gt.0)then; do i=1,lmorder; call print(' ':); call print('Elliott-Rothenberg-Stock (1996) Unit root test. Lag =',i:); call DF_GLS(res,i,notrend,trend,notrendx,trendx,iprint); call print(' ':); enddo; endif; return; end; == ==SUBSET Subset an array under mask control function subset(x,mask); /; *************************************************************** /; X = input 1d, 2d array, vector or matrix /; mask = vector 0.0 , 1.0 /; subset returns a new series the same as x with mask=0.0 values /; removed /; Routine may be replaced by built in code in the future /; *************************************************************** if(klass(x).ne.1.and.klass(x).ne.5.and. klass(x).ne.2.and.klass(x).ne.6)then; call epprint('ERROR: Subset needs a vector, 1d array,':); call epprint(' matrix or 2d array':); newx=missing(); return(newx); endif; if(kind(x).ne.8)then; call epprint('ERROR: SUBSET function requires real*8 input'); newx=missing(); return(newx); endif; if(norows(x).ne.norows(mask).or.kind(mask).ne.8)then; call epprint('ERROR: MASK not set correctly in SUBSET'); newx=missing(); return(newx); endif; if(klass(x).eq.5)newx= array(norows(x):); if(klass(x).eq.1)newx=vector(norows(x):); if(klass(x).eq.6)newx= array(norows(x),nocols(x):); if(klass(x).eq.1)newx=matrix(norows(x),nocols(x):); if(klass(x).eq.1.or.klass(x).eq.5)then; call setcol(newx,1,missing()); where(mask.ne.0.0)newx=x; endif; if(klass(x).eq.2.or.klass(x).eq.6)then; newx=x; hold=x(,1); call setcol(hold,1,missing()); where(mask.ne.0.0)hold=x(,1); newx(,1)=hold; endif; newx=goodrow(newx); return(newx); end; == ==SPECFORE Forecasting Using Spectral Methods subroutine specfore(data,startf,numf,detrend,forecast,obs,error,actual); /; /; Forecast with spectral methods. /; /; Based on code developed by Michael Hunstad using /; regression methods to partially reverse-engineer the RATS /; specfore command. An improved version of the /; Hunsted Matlab code is in c:\b34slm\mfiles as /; specfore.m. This routine will not work well for large datasets /; since it uses the OLS approach to ontain the sin and cos vectors. /; /; This implementation by Houston H. Stokes uses /; a FFT to save space and reduce CPU use. Added capability is /; provided. Unlike the RATS implementation of this technique, /; the current implementation does not smooth the FFT. /; /; If such smoothing is desired, it is suggested that the series /; be filtered prioor to calling the specfore command to remove the /; frequencies. /; /; data => series to forecast. # of obs = n /; startf => last period before start forecasting /; numf => number of forecasts /; detrend => Detrend the data if gt 0. =2 print trend OLS Model /; forecast => Forecast /; obs => Observation number associated with forecast /; error => Defined if startf lt n /; actual => defined if startf lt n /; /; Routine developed 8 December 2009 by Houston H. Stokes /; nobs=norows(data); error=missing(); actual=missing(); if(nobs .lt.startf)then; call epprint('ERROR: In call specfore startf not le nobs of data':); call epprint(' nobs of data was ',nobs:); call epprint(' startf was ',startf:); go to endit; endif; series=data(integers(1,startf)); seriesm=mean(series); series=series-seriesm; if(detrend.ne.0)then; trend=dfloat(integers(startf)); if(detrend.eq.1)call olsq(series trend :qr); if(detrend.eq.2)call olsq(series trend :qr :print); if(klass(series).eq.5)series=series-afam(%yhat); if(klass(series).eq.1)series=series-vfam(%yhat); tcoef=%coef(1); tmean=%coef(2); endif; obs=dfloat(integers(startf+1,startf+numf)); call spectral(series,sinx,cosx,px,sx,freq); beta=vfam(catrow(cosx,sinx)); /; zero out cosx for highest freq ijunk=norows(cosx); beta(ijunk,1)=0.0; forecast=vector(numf:); tt=dfloat(integers(0,numf-1))+dfloat(startf); do i=1,numf; c1=cos(afam(freq)*afam(tt(i))); s1=sin(afam(freq)*afam(tt(i))); cc=vfam(catrow(c1,s1)); if(detrend.eq.0)forecast(i)=transpose(beta)*cc + sfam(seriesm); if(detrend.ne.0)forecast(i)=transpose(beta)*cc + sfam(seriesm) +tmean + (dfloat(startf+i)*tcoef); enddo; if(startf.lt.nobs)then; iend=dmin1(startf+numf,nobs); nn2 =integers(iend-startf); actual = data(integers(startf+1,iend)); if(abs(klass(actual)).eq.1)error = actual - forecast(nn2); if(abs(klass(actual)).eq.5)error = actual - afam(forecast(nn2)); endif; endit continue; return; end; == ==SWARTEST Stock-Watson AR Test subroutine swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint1, nterms,nlag,test11,test12,test21,test22 var1,var2,varxhat1,varxhat2,rsq1,rsq2); /; /; Test of change in structure of VAR model based on work /; by Stock-Watson "Has the Business Cycle changed and Why?" /; NBER Working Paper 9127 December 2002 /; x - n by k matrix of the series in var model /; ibegin1 - Start of period 1 /; iend1 - End of period 1 /; ibegin2 - Start of period 2 /; iend2 - End of period 2 /; sigma1 - Variance Covariance of errors period1 /; sigma2 - Variance Covariance of errors period2 /; psi1 - psi weights period 1 /; ipsi1 - index to read psi weights 1 /; psi2 - psi weights period 2 /; ipsi2 - index to read psi weights 2 /; iprint - set 1 => print estimation results /; 2 => in addition print psi matrix /; -1 or -2 Print compact model spec /; -1 is a useful setting for two period Models /; nterms - # of terms in psi matrix /; nlag - lag for VAR /; test11 - k element vector of variances using psi1 & sigma1 /; test12 - k element vector of variances using psi1 & sigma2 /; test21 - k element vector of variances using psi2 & sigma1 /; test22 - k element vector of variances using psi2 & sigma2 /; var1 - k element variance of series in period 1 /; var2 - k element variance of series in period 2 /; varxhat1 - k element variance of yhat in period 1 /; varxhat2 - k element variance of yhat in period 2 /; rsq1 - k element centered R**2 for period 1 /; rsq2 - k element centered R**2 for period 2 /; /; Global variables /; /; %t11_t21=dabs(test11-test21); /; %t12_t22=dabs(test12-test22); /; %t11_t12=dabs(test11-test12); /; %t21_t22=dabs(test21-test22); /; %t12_t21=dabs(test12-test21); /; %t11_t22=dabs(test11-test22); /; /; Routine developed 1 November 2002 /; Bugs fixed 25 January 2003 /; Added arguments 31 January 2003 /; I/O improved March 2003 /; Minor output improvements Mar 2005 /; Improvements made Mar 2008 /; /; Routine works for one or more series /; /; Stock Watson Tests lets us detect if change is due to /; coefficients changing OR variance changing. If variance /; did not change much test11 ~ test12 and test21~test22 /; /; testij tests each series in the VAR /; /; Need to load VAREST and BUILDLAG /; /; ****************************************************** k=nocols(x); iprint=0; if(iprint1.gt.0)iprint=dabs(iprint1); if(iprint1.ne.0)then; call print(' ':); call print('Assumptions of Stock-Watson Analysis':); call print('ibeing1 ',ibegin1:); call print('iend1 ',iend1:); call print('ibeing2 ',ibegin2:); call print('iend2 ',iend2:); call print('nlag ',nlag:); call print('nterms ',nterms:); endif; if(k.eq.1)go to doone; if(iprint.ne.0)then; call print(' ':); call print('Estimation done for Period # 1':); endif; call varest(x,nlag,ibegin1,iend1,beta1,t1,sigma1,corr1, residual1,iprint,a,ai,var1,varxhat1,rsq1); call polyminv(a ai psi1 ipsi1 nterms); if(iprint.ne.0)then; call print(' ':); call print('Estimation done for Period # 2':); endif; call varest(x,nlag,ibegin2,iend2,beta2,t2,sigma2,corr2, residual2,iprint,a,ai,var2,varxhat2,rsq2); call polyminv(a ai psi2 ipsi2 nterms); if(iprint.eq.2)then; call print(' ':); call polymdisp(:display psi1 ipsi1); call polymdisp(:display psi2 ipsi2); call print(sigma1); call print(sigma2); endif; s=matrix(k,k:); /; /; test11 /; test12 /; atest11 =array(k,k:); atest12 =array(k,k:); /; do i=1,ipsi1(3); do ii=1,k; call polymdisp(:extract psi1 ipsi1 v index(0,ii,i)); s(,ii)=vfam(v); enddo; work1=s*sigma1*transpose(s); work2=s*sigma2*transpose(s); atest11=atest11+afam(work1); atest12=atest12+afam(work2); enddo; /; test11=diag(atest11); test12=diag(atest12); /; /; test21 /; test22 /; atest21 =array(k,k:); atest22 =array(k,k:); /; do i=1,ipsi2(3); do ii=1,k; call polymdisp(:extract psi2 ipsi2 v index(0,ii,i)); s(,ii)=vfam(v); enddo; work1=s*sigma1*transpose(s); work2=s*sigma2*transpose(s); atest21=atest21+afam(work1); atest22=atest22+afam(work2); enddo; /; test21=diag(atest21); test22=diag(atest22); go to alldone; /; /; One series case /; doone continue; ii1=integers(ibegin1,iend1); ii2=integers(ibegin2,iend2); x1=x(ii1); x2=x(ii2); if(iprint.eq.0)then; call olsq(x1 x1{1 to nlag} ); coef1 =%coef; sigma1 =%rss; var1 =variance(%y); varxhat1=variance(%yhat); rsq1 =%rsq; nn1 =norows(%y); call olsq(x2 x2{1 to nlag} ); coef2 =%coef; sigma2 =%rss; var2 =variance(%y); varxhat2=variance(%yhat); rsq2 =%rsq; nn2 =norows(%y); endif; if(iprint.ne.0)then; call print(' ':); call print('Model Estimated for Period # 1':); call olsq(x1 x1{1 to nlag} :print); coef1 =%coef; sigma1 =%rss; var1 =variance(%y); varxhat1=variance(%yhat); rsq1 =%rsq; nn1 =norows(%y); call print(' ':); call print('Model Estimated for Period # 2':); call olsq(x2 x2{1 to nlag} :print); coef2 =%coef; sigma2 =%rss; var2 =variance(%y); varxhat2=variance(%yhat); rsq2 =%rsq; nn2 =norows(%y); endif; adj =dfloat(nn1-1)/dfloat(nn1); var1 =var1*adj; varxhat1=varxhat1*adj; adj =dfloat(nn2-1)/dfloat(nn2); var2 =var2*adj; varxhat2=varxhat2*adj; sigma1=sigma1/dfloat(nn1); sigma2=sigma2/dfloat(nn2); bottom1=-1.0*coef1; bottom2=-1.0*coef2; ii=nlag+1; bottom1(ii)=1.0d+00; bottom2(ii)=1.0d+00; bottom1=rollright(bottom1); bottom2=rollright(bottom2); top=1.0; psi1=polydv(top,bottom1,nterms); psi2=polydv(top,bottom2,nterms); if(iprint.eq.2)call print(psi1,psi2,sigma1,sigma2); ipsi1=index(1 1 nterms); ipsi2=index(1 1 nterms); test11=sumsq(psi1)*sigma1; test12=sumsq(psi1)*sigma2; test21=sumsq(psi2)*sigma1; test22=sumsq(psi2)*sigma2; go to alldone; alldone continue; if(iprint1.ne.0)then; call print(' ':); call print('Variances and Equation Statistics':); call tabulate(test11,test12, test21, test22,var1, var2, varxhat1,varxhat2,rsq1, rsq2); call print(' ':); call print('Difference of Variances':); endif; %t11_t21=dabs(test11-test21); %t12_t22=dabs(test12-test22); %t11_t12=dabs(test11-test12); %t21_t22=dabs(test21-test22); %t12_t21=dabs(test12-test21); %t11_t22=dabs(test11-test22); call makeglobal(%t11_t21); call makeglobal(%t12_t22); call makeglobal(%t11_t12); call makeglobal(%t21_t22); call makeglobal(%t12_t21); call makeglobal(%t11_t22); if(iprint1.ne.0)then; call tabulate(%t11_t21,%t12_t22,%t11_t12,%t21_t22,%t12_t21,%t11_t22); call print(' ':); call print('Note: Tii_Tji counterfactual effect of structural change':); call print(' Tij_Tii counterfactual effect of shock change':); call print(' ':); endif; return; end; == ==SWBOOTS Stock-Watson Bootstrap Critical Values subroutine swboots(xin,pin,k,printout,niter,method,begin1,end1, begin2,end2,nterms); /; /; kswboots designed for multiple periods /; swboots designed for two period model /; /; Input : xin - VAR data matrix (d_1~d_2~etc, where d_i is /; column vector of observations on ith endogenous /; variable) /; pin -- VAR order. If set as -pin will analyse last var only /; k -- # of start-up transient observations /; /; printout -- -1: All printout turned off /; 0: no print out and return the bootstrap /; variable(s) /; 1: print the orignal coefficient and y /; niter => number of iterations /; method -- 0 Resample the error using random number /; 1 Bootstap errors /; 2 Random Errow with Bootstrap /; 3 Monte Carlo simulation /; 4 Centered Bootstrap /; begin1 => start period 1 /; end1 => end period 1 /; begin2 => start period 2 /; end2 => end period 2 /; nterms => # of terms of MA form /; /; /; The following variables and their dimensions are made global where /; m = # of cols in the X matrix: /; if p < 0 only m is set /; %siglev(2) => Significance level (.95 and .99) /; %qtest11(2,m) => Critical value at .95 &. 99 of test11 /; %qtest12(2,m) => Critical value at .95 & .99 of test12 /; %qtest21(2,m) => Critical value at .95 & .99 of test21 /; %qtest22(2,m) => Critical value at .95 & .99 of test22 /; %qd11_21(2,m) => Critical Value at .95 & .99 of |test11-test21| /; %qd12_22(2,m) => Critical Value at .95 & .99 of |test12-test22| /; %qd11_12(2,m) => Critical Value at .95 & .99 of |test11-test12| /; %qd21_22)2,m) => Critical Value at .95 & .99 of |test21-test22| /; %qd12_21(2,m) => Critical Value at .95 & .99 of |test12-test21| /; %qd11_22(2,m) => Critical Value at .95 & .99 of |test11-test22| /; /; References: * D.E. Runkle, 'Vector autoregressions and reality,' /; _Journal of Business and Economic Statistics_ /; (Oct. 1987): 437-42 /; * J. Berkowitz and L. Kilian, 'Recent developments /; in bootstrapping time series,' Federal Reserve /; Board Finance and Economics Discussion Series /; Paper 1996-45 (November 1996) /; This routine requires the following routines be loaded: /; buildlag & varest swartest /; /; Routine built by Jin-Man Lee /; Mods made by Houston H. Stokes May 2008 /; /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /; Example setup: /; /; call swartest(x,ibegin1,iend1,ibegin2,iend2, /; sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, /; nterms,nlag,test11,test12,test21,test22, /; var1,var2,varxhat1,varxhat2,rsq1,rsq2); /; printout=0; /; k=0; /; call print('Bootstrap Errors using Original Errors':); /; call swboots(X,nlag,k,printout,niter,1,ibegin1,iend1,ibegin2, /; iend2,nterms) ; /; call print('Monte Carlo Critical value':) ; /; call swboots(X,nlag,k,printout,niter,3,ibegin1,iend1,ibegin2,iend2, /; nterms) ; /; /; /; iall = 1 => do only last /; x=xin; iall=0; p=pin; if(pin.lt.0)then; p=abs(pin); iall=1; endif; ibegin1=begin1; iend1 =end1 ; ibegin2=begin2; iend2 =end2 ; if(p.eq.0)then; call epprint('ERROR: VAR order must not be =0 '); go to finish; endif; if(niter.le.1)then; call epprint('ERROR: # iterations must be gt 1'); go to finish; endif; if(method.lt.0.or.method.gt.4)then; call epprint('ERROR: Method must be in range 0-4'); go to finish; endif; mr=norows(x) ; m =nocols(x); if(m.eq.1)then ; tempx=x ; x = array(mr,m:) ; x(,1) = tempx ; endif ; /; This code truncates the XX matrix call buildlag(x,p,begin1,mr,xx,yy); call deleterow(XX,end1-p+1,begin2-end1-1+p) ; call deleterow(yy,end1-p+1,begin2-end1-1+p) ; * call print(xx,yy) ; t=norows(yy) ; U=matrix(t,m:) ; b=matrix(p*m+1,m:) ; tval=matrix(p*m+1,m:) ; Do i=1,m ; y1 = yy(,i) ; call olsq(y1 xx) ; u(,i)=%res ; b(,i)=%coef ; tval(,i)=%t ; enddo ; netobs1=iend1-ibegin1-p+1; netobs2=iend2-ibegin2-p+1; /; Sets minimum DF allowed. mindft=10; mindf=min1(netobs1,netobs2)-(p*m)-1; istop=0; if(mindf.le.mindft)istop=1; if(printout.ge.0.or.istop.ne.0)then; call print(' ':); call print('------------------------------':); call print('Random Seed ':); call i_rnget; call print('Number of Iterations ',niter:) ; call print('------------------------------':); call print('begin1 ',begin1:); call print('end1 ',end1:) ; call print('begin2 ',begin2:); call print('end2 ',end2:) ; call print('Net Observations Period 1',netobs1:); call print('Net Observations Period 2',netobs2:); call print('Minimum DF (N-k) ',mindf:); call print('VAR Model of order ',p:); call print('Number of Series ',m:); call print('------------------------------':); call print(' ':); if(istop.eq.1)then; call print('Min DF LT than min DF Tol',mindft:); call print('Expand # obs. in periods':); call epprint('ERROR: Command Terminating. DF < Tol.'); call epprint(' ':); go to finish; endif; endif; /; Method=1 Bootstrap Errors using Original Errors /; Method=2 Use the Random Error and New error using Bootstrap /; Method=3 Monte Carlo Critical Values /; Method=4 Bootstrap Errors using Centered Original Errors u1=rn(matrix(t+k,m:)) ; u2 = matrix(t+k,m:) ; do ui=1,m ; u2(,ui)= u1(,ui)*(variance(u(,ui))/variance(u1(,ui)))**0.5 ; enddo ; bt_b1=matrix(niter,m+m*p:) ; bt_b2=matrix(niter,m:) ; at11 = array(niter,m+1:) ; at12 = array(niter,m+1:) ; at21 = array(niter,m+1:) ; at22 = array(niter,m+1:) ; if(method.eq.4)then ; do ui=1,m ; u(,ui)= u(,ui)-mean(u(,ui)) ; enddo ; endif ; call outstring(1,13,'SWBOOTS calculating distribution of statistics '); call outstring(1,14,'Iteration:'); do gi=1,niter ; call outinteger(14,14,gi); if(method.eq.1)ustar=u(booti(t,t+k)) ; if(method.eq.2)ustar=u2(booti(t+k)); if(method.eq.3) then ; u1=rn(matrix(t+k,m:)) ; ustar=rn(matrix(t+k,m:)) ; do ui=1,m ; ustar(,ui)= u1(,ui)*(variance(u(,ui))/variance(u1(,ui)))**0.5 ; enddo ; endif ; if(method.eq.4)ustar=u(booti(t,t+k)) ; ystar = matrix(T+k,M:) ; r1 = submatrix(xx,1,1,1,m*p) ; r2 = matrix(1,1:1) ; r = mfam(catcol(r1 r2)) ; if(p.gt.1)then ; do i=1,t+k ; ystar(i,)= r*b + submatrix(ustar,i,i,1,m) ; r1=submatrix(ystar,i,i,1,m) ; r2=submatrix(r,1,1,1,m*(p-1)) ; r3=matrix(1,1:1) ; r=mfam(catcol(r1 r2 r3)) ; enddo ; endif ; if(p.eq.1)then ; do i=1,t+k ; ystar(i,)= r*b + submatrix(ustar,i,i,1,m) ; r1=submatrix(ystar,i,i,1,m) ; r3=matrix(1,1:1) ; r=mfam(catcol(r1 r3)) ; enddo ; endif ; p1 = integers(p) ; p2 = integers(k+1,t+p+k,1) ; ystar=catrow(x(p1,) ystar) ; ystar=ystar(p2,) ; /; Output : ystar -- VAR pseudo-data matrix (d_1star~d_2star~etc) /; call print(ystar) ; /; Stock-Watson Test X = ystar; /; moved to top /; ibegin1=1; /; iend1=end1; /; hot wire /; LEE LOOK AT VARIENTS ************************** /; ibegin1=1; /; ibegin2=end1+1 ; /; ibegin2=iend1+1; /; iend2=norows(ystar); /; iend2=min1(norows(ystar),end2-p-1); /; /; ibegin1=begin1; /; iend1 =end1 ; /; ibegin2=begin2; /; iend2 =end2 ; /; nlag=p ; /; as of April 2008 set in call by hhs /; nterms=24; iprint=0 ; iend22=min1(iend2,norows(x)); if(printout.eq.1)call print(ibegin1,iend1,ibegin2,iend2); call swartest(X,ibegin1,iend1,ibegin2,iend22, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); if(printout.eq.1)call print(test11,test12,test21,test22) ; /; gi = iteration at11(gi,) = test11 ; at12(gi,) = test12 ; at21(gi,) = test21 ; at22(gi,) = test22 ; call compress(50) ; enddo ; * call print('The end of loop') ; /; m= # of cols of x /; iall = 1 => do last only mm=m; if(iall.eq.0)mm=1; %siglev=array(2:); %qtest11=array(2,m:); %qtest12=array(2,m:); %qtest21=array(2,m:); %qtest22=array(2,m:); %qd11_21=array(2,m:); %qd12_22=array(2,m:); %qd11_12=array(2,m:); %qd21_22=array(2,m:); %qd12_21=array(2,m:); %qd11_22=array(2,m:); ntest1 = integers(1,niter) ; do i=mm,m ; jj=i; test11 = at11(ntest1,jj) ; test12 = at12(ntest1,jj) ; test21 = at21(ntest1,jj) ; test22 = at22(ntest1,jj) ; d11_21 = dabs(test11 - test21) ; d12_22 = dabs(test12 - test22) ; d11_12 = dabs(test11 - test12) ; d21_22 = dabs(test21 - test22) ; d11_22 = dabs(test11 - test22) ; d12_21 = dabs(test12 - test21) ; q1=array(2:.95,.99); *q1=array(11:.01,.025,.05,.1,.25,.5,.75,.90,.95,.975,.99); call quantile(test11, q1,qtest11); call quantile(test12, q1,qtest12); call quantile(test21, q1,qtest21); call quantile(test22, q1,qtest22); call quantile(d11_21, q1,qd11_21); call quantile(d12_22, q1,qd12_22); call quantile(d11_12, q1,qd11_12); call quantile(d21_22, q1,qd21_22); call quantile(d11_22, q1,qd11_22); call quantile(d12_21, q1,qd12_21); siglev = q1 ; if(printout.ge.0)then; call print(' ':); if(method.eq.1)call print ('Method=1 Bootstrap Errors using Original Errors':); if(method.eq.2)call print ('Method=2 Use the Random Error and New error using Bootstrap':) ; if(method.eq.3)call print ('Method=3 Monte Carlo Critical Values':) ; call print(' ':); call print('Stock Watson Test for variable:',i:) ; call tabulate(siglev,qtest11,qtest12,qtest21,qtest22) ; call print(' ':); call print('Quantile of differences':); call tabulate(siglev, qd11_21,qd12_22,qd11_12,qd21_22,qd12_21,qd11_22); call print(' ':); endif; %qtest11(,jj)=qtest11; %qtest12(,jj)=qtest12; %qtest21(,jj)=qtest21; %qtest22(,jj)=qtest22; %qd11_21(,jj)=qd11_21; %qd12_22(,jj)=qd12_22; %qd11_12(,jj)=qd11_12; %qd21_22(,jj)=qd21_22; %qd11_22(,jj)=qd11_22; %qd12_21(,jj)=qd12_21; enddo ; %siglev=siglev; call makeglobal(%siglev); call makeglobal(%qtest11); call makeglobal(%qtest12); call makeglobal(%qtest21); call makeglobal(%qtest22); call makeglobal(%qd11_21); call makeglobal(%qd12_22); call makeglobal(%qd11_12); call makeglobal(%qd21_22); call makeglobal(%qd11_22); call makeglobal(%qd12_21); finish continue; return ; end ; == ==SWBOOTSM Moving Stock Watson Statistics for last series subroutine swbootsm(x,istart,nlag,kdrop,iprint,printout,niter,method, nterms,dist,cc1,cc2,cc3,fsvname); /; /; Plots and Statistics of Moving Stock Watson Test for last series /; /; istart = # obs on left. Analysis will continue until # obs on right /; = # of obs on the left /; nlag = Order of VAR Model /; /; kdrop = starting values. Can be set = 0. < 0 => test |kdrop| obs /; iprint - set 1 => print estimation results /; 2 => in addition print psi matrix /; -1 or -2 Print compact model spec /; -1 is a useful setting for two period Models /; printout -- -1: All printout turned off /; 0: no print out and return the bootstrap variable(s) /; 1: print the orignal coefficient and y /; niter => number of iterations /; method -- 0 Resample the error using random number /; 1 Bootstap errors /; 2 Random Errow with Bootstrap /; 3 Monte Carlo simulation /; 4 Centered Bootstrap /; /; /; Notes: Lags are made 100% within the ibegin - iend data window. /; /; Results saved in sw_data.fsv /; /; nterms = # MA terms /; dist = = >0 no distribution, = 1 plot 95%, = -1 plot 99% /; cc1 = plot1 name /; cc2 = plot2 name /; cc3 = plot3 name /; fsvname = Name of fsv save file /; /; kdrop < 0 = debug setting to truncate calculation in a controlled /; manner /; /; Built 1 May 2008 by Houston H. Stokes /; /; Uses: buildlag, varest, swartest, & swboots that are called by /; swbootsm. These routines should be studied for further detail /; /; /; Uses swb_plot that can be called stand alone. /; kill=0; if(kdrop.lt.0)then; kill=abs(kdrop); kdrop=0; endif; n = norows(x); m = nocols(x); iend=n-istart; nsaved=iend-istart+1; /; Allocate save arrays htest11=array(nsaved:); htest12=array(nsaved:); htest21=array(nsaved:); htest22=array(nsaved:); hvar1 =array(nsaved:); hvar2 =array(nsaved:); hvarxh1=array(nsaved:); hvarxh2=array(nsaved:); t11_t21=array(nsaved:); t12_t22=array(nsaved:); t11_t12=array(nsaved:); t21_t22=array(nsaved:); t12_t21=array(nsaved:); t11_t22=array(nsaved:); icount=1; if(dist.ne.0)then; qtest11=array(nsaved:); qtest12=array(nsaved:); qtest21=array(nsaved:); qtest22=array(nsaved:); qd11_21=array(nsaved:); qd12_22=array(nsaved:); qd11_12=array(nsaved:); qd21_22=array(nsaved:); qd12_21=array(nsaved:); qd11_22=array(nsaved:); endif; iicount=0; do ii=istart,iend; iicount=icount+1; ibegin1=1; iend1=ii; ibegin2=ii+1; iend2=n; /; this turns on a great deal of output /; iprint=1; /; this limits to first 20 /; if(iicount.le.20)iprint=1; /; call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22 var1,var2,varxhat1,varxhat2,rsq1,rsq2); call outinteger(2,2,icount); call outdouble(2, 4,test11(m)); call outdouble(22,4,test12(m)); call outdouble(2, 5,test21(m)); call outdouble(22,5,test22(m)); htest11(icount)=test11(m); htest12(icount)=test12(m); htest21(icount)=test21(m); htest22(icount)=test22(m); hvar1(icount) =var1(m); hvar2(icount) =var2(m); hvarxh1(icount)=varxhat1(m); hvarxh2(icount)=varxhat2(m); hrsq1(icount) =rsq1(m); hrsq2(icount) =rsq2(m); t11_t21(icount)=%t11_t21(m); t12_t22(icount)=%t12_t22(m); t11_t12(icount)=%t11_t12(m); t21_t22(icount)=%t21_t22(m); t12_t21(icount)=%t12_t21(m); t11_t22(icount)=%t11_t22(m); if(dist.ne.0)then; /; set up for last series to speed calculation nlag2=-1*nlag; call swboots(x,nlag2,kdrop,printout,niter,method,ibegin1,iend1, ibegin2,iend2,nterms); /; created m refers to the last series value /; %siglev(2) => Significance level (.95 and .99) /; %qtest11(2,m) => Critical value at .95 &. 99 of test11 /; %qtest12(2,m) => Critical value at .95 & .99 of test12 /; %qtest21(2,m) => Critical value at .95 & .99 of test21 /; %qtest22(2,m) => Critical value at .95 & .99 of test22 /; %qd11_21(2,m) => Critical Value at .95 & .99 of |test11-test21| /; %qd12_22(2,m) => Critical Value at .95 & .99 of |test12-test22| /; %qd11_12(2,m) => Critical Value at .95 & .99 of |test11-test12| /; %qd21_22)2,m) => Critical Value at .95 & .99 of |test21-test22| /; %qd12_21(2,m) => Critical Value at .95 & .99 of |test12-test21| /; %qd11_22(2,m) => Critical Value at .95 & .99 of |test11-test22| /; j=1; if(dist.lt.0)j=2; qtest11(icount) = %qtest11(j,m); qtest12(icount) = %qtest12(j,m); qtest21(icount) = %qtest21(j,m); qtest22(icount) = %qtest22(j,m); qd11_21(icount) = %qd11_21(j,m); qd12_22(icount) = %qd12_22(j,m); qd11_12(icount) = %qd11_12(j,m); qd21_22(icount) = %qd21_22(j,m); qd12_21(icount) = %qd12_21(j,m); qd11_22(icount) = %qd11_22(j,m); endif; icount=icount+1; if(icount.ge.kill.and.kill.gt.0)go to stop1; call compress; enddo; /; Display what we have found stop1 continue; call tabulate(htest11,htest12,htest21,htest22, hvar1,hvar2, hvarxh1,hvarxh2,hrsq1,hrsq2); head='Stock Watson Moving Test Data'; if(dist.eq.0)call makesca(htest11,htest12,htest21,htest22, hvar1,hvar2, hvarxh1,hvarxh2,hrsq1,hrsq2, t11_t21,t12_t22,t11_t12,t21_t22,t12_t21,t11_t22 :comment head :file fsvname); if(dist.ne.0)then; if(dist.gt.0) head='Stock Watson Moving Test Data critical values are 95%'; if(dist.lt.0) head='Stock Watson Moving Test Data critical values are 99%'; call makesca(htest11,htest12,htest21,htest22, hvar1,hvar2, hvarxh1,hvarxh2,hrsq1,hrsq2, t11_t21,t12_t22,t11_t12, t21_t22, t12_t21,t11_t22, qtest11,qtest12,qtest21,qtest22, qd11_21, qd12_22,qd11_12, qd21_22, qd12_21,qd11_22, :comment head :file fsvname); endif; /; call print('Mean sigma11 ',mean(htest11)); /; call print('Mean sigma12 ',mean(htest12)); /; call print('Mean sigma21 ',mean(htest21)); /; call print('Mean sigma22 ',mean(htest22)); /; Graph what we have found call swb_plot(dist,fsvname,cc1,cc2,cc3); return; end; subroutine swb_plot(dist,fsvname,cc1,cc2,cc3); /; Does Plotting of Moving Stock Watson Data /; /; swb_plot can be called after save file has been built. Or it can be /; modified in the field for a custom plot. /; /; dist = = >0 no distribution, = 1 plot 95%, = -1 plot 99% /; cc1 = plot1 name /; cc2 = plot2 name /; cc3 = plot3 name /; fsvname = Name of fsv save file /; /; Example: /; b34sexec matrix; /; call load(swbootsm); /; dist=1; /; fsvname='sw_data.fsv'; /; cc1='test1.wmf'; /; cc2='test2.wmf'; /; cc3='test3.wmf'; /; call swb_plot(dist,fsvname,cc1,cc2,cc3); /; b34srun; /; /; Built May 2008 smooth=0; iday=0; imonth=0; iyear=0; freqd=0.0; ioff=0; call swb2plot(dist,fsvname,cc1,cc2,cc3,smooth,iday,imonth,iyear, freqd,ioff); return; end; subroutine swb2plot(dist,fsvname,cc1,cc2,cc3,smooth,iday,imonth,iyear, freqd,ioff); /; Does Plotting of Moving Stock Watson Data /; /; swb_plot can be called after save file has been built. Or it can be /; modified in the field for a custom plot. /; /; dist => = >0 no distribution, = 1 plot 95%, = -1 plot 99% /; cc1 => plot1 name /; cc2 => plot2 name /; cc3 => plot3 name /; fsvname => Name of fsv save file /; smooth => smooth series - using q3 in ne 0 /; iday => Makes Time Series /; imonth => start including offset /; iyear => year /; freqd => freq of series 12. 4. 1. /; ioff => Offset. Uasually set to # of obs in first sample /; /; Example: /; /; b34sexec matrix; /; call load(swbootsm); /; dist=1; /; fsvname='sw_data.fsv'; /; cc1='test1.wmf'; /; cc2='test2.wmf'; /; cc3='test3.wmf'; /; dist=1; /; smooth=1; /; iday=1; /; imonth=1; /; iyear = 1960; /; freqd=12.; /; ioff = 80; /; /; call swb_plot(dist,fsvname,cc1,cc2,cc3,smooth, /; iday,imonth,iyear,freqd,ioff); /; b34srun; /; /; Built May 2008 call getsca(fsvname); if(smooth.ne.0)then; qtest11=min1(qtest11,q3(qtest11)); qtest12=min1(qtest12,q3(qtest12)); qtest21=min1(qtest21,q3(qtest21)); qtest22=min1(qtest22,q3(qtest22)); qd11_21=min1(qd11_21,q3(qd11_21)); qd12_22=min1(qd12_22,q3(qd12_22)); qd11_12=min1(qd11_12,q3(qd11_12)); qd21_22=min1(qd21_22,q3(qd21_22)); qd12_21=min1(qd12_21,q3(qd12_21)); qd11_22=min1(qd11_22,q3(qd11_22)); endif; if(iday.ne.0)then; j1=juldaydmy(iday,imonth,iyear); call julian_to_tb(j1,freqd,tbase,tstart); call up_date_tb(tbase,tstart,freqd,tbase2,tstart2,ioff); call settime(htest11,tbase2,tstart2,freqd); call settime(htest12,tbase2,tstart2,freqd); call settime(htest21,tbase2,tstart2,freqd); call settime(htest22,tbase2,tstart2,freqd); call settime(qtest11,tbase2,tstart2,freqd); call settime(qtest12,tbase2,tstart2,freqd); call settime(qtest21,tbase2,tstart2,freqd); call settime(qtest22,tbase2,tstart2,freqd); call settime(t11_t21,tbase2,tstart2,freqd); call settime(t12_t22,tbase2,tstart2,freqd); call settime(t11_t12,tbase2,tstart2,freqd); call settime(t21_t22,tbase2,tstart2,freqd); call settime(t12_t21,tbase2,tstart2,freqd); call settime(t11_t22,tbase2,tstart2,freqd); call settime(qd11_21,tbase2,tstart2,freqd); call settime(qd12_22,tbase2,tstart2,freqd); call settime(qd11_12,tbase2,tstart2,freqd); call settime(qd21_22,tbase2,tstart2,freqd); call settime(qd12_21,tbase2,tstart2,freqd); call settime(qd11_22,tbase2,tstart2,freqd); endif; if(dist.eq.0)then; call graph(htest11 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest11.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(11) - Period 1 Actual'); call graph(htest12 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest12.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(12) - Period 1 Structure, Period 2 Stocks'); call graph(htest21 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest21.hp1' :hardcopyfmt HP_GL2 :heading 'sigma(21) - Period 2 Structure, Period 1 Stocks'); call graph(htest22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest22.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(22) - Period 2 Actual'); endif; if(dist.ne.0)then; call graph(htest11 qtest11 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest11.hp1' :nokey :hardcopyfmt HP_GL2 :heading 'Sigma(11) - Period 1 Actual'); call graph(htest12 qtest12 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest12.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(12) - Period 1 Structure, Period 2 Stocks'); call graph(htest21 qtest21 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest21.hp1' :nokey :hardcopyfmt HP_GL2 :heading 'sigma(21) - Period 2 Structure, Period 1 Stocks'); call graph(htest22 qtest22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest22.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(22) - Period 2 Actual'); endif; call grreplay(:start :file cc1 ); call grreplay(:cont 'htest11.hp1' :gformat fourgraph 1); call grreplay(:cont 'htest12.hp1' :gformat fourgraph 2); call grreplay(:cont 'htest21.hp1' :gformat fourgraph 3); call grreplay(:cont 'htest22.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'htest11.hp1' :gformat fourgraph 1); call grreplay(:cont 'htest12.hp1' :gformat fourgraph 2); call grreplay(:cont 'htest21.hp1' :gformat fourgraph 3); call grreplay(:cont 'htest22.hp1' :gformat fourgraph 4); call grreplay(:final); if(dist.eq.0)then; call graph(t11_t21 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't11_t21.hp1' :hardcopyfmt HP_GL2 :heading 't11_t21 - Given Period 1 Shocks, testing Structural Change'); call graph(t12_t22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't12_t22.hp1' :hardcopyfmt HP_GL2 :heading 't12_t22 - Given Period 2 Shocks, testing Structural Change'); call graph(t11_t12 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't11_t12.hp1' :hardcopyfmt HP_GL2 :heading 't11_t12 - Given Period 1 Structure, testing Shock Change'); call graph(t21_t22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't21_t22.hp1' :hardcopyfmt HP_GL2 :heading 't21_t22 - Given Period 2 Structure, testing Shock Change'); endif; if(dist.ne.0)then; call graph(t11_t21 qd11_21 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nokey :file 't11_t21.hp1' :nolabel :hardcopyfmt HP_GL2 :heading 't11_t21 - Given Period 1 Shocks, testing Structural Change'); call graph(t12_t22 qd12_22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't12_t22.hp1' :hardcopyfmt HP_GL2 :heading 't12_t22 - Given Period 2 Shocks, testing Structural Change'); call graph(t11_t12 qd11_12 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't11_t12.hp1' :nokey :hardcopyfmt HP_GL2 :heading 't11_t12 - Given Period 1 Structure, testing Shock Change'); call graph(t21_t22 qd21_22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't21_t22.hp1' :hardcopyfmt HP_GL2 :heading 't21_t22 - Given Period 2 Structure, testing Shock Change'); endif; call grreplay(:start :file cc2 ); call grreplay(:cont 't11_t21.hp1' :gformat fourgraph 1); call grreplay(:cont 't12_t22.hp1' :gformat fourgraph 2); call grreplay(:cont 't11_t12.hp1' :gformat fourgraph 3); call grreplay(:cont 't21_t22.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 't11_t21.hp1' :gformat fourgraph 1); call grreplay(:cont 't12_t22.hp1' :gformat fourgraph 2); call grreplay(:cont 't11_t12.hp1' :gformat fourgraph 3); call grreplay(:cont 't21_t22.hp1' :gformat fourgraph 4); call grreplay(:final); if(dist.eq.0)then; call graph(t12_t21 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't12_t21.hp1' :hardcopyfmt HP_GL2 :heading 't12_t21 - Difference of Counterfactuals'); call graph(t11_t22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't11_t22.hp1' :hardcopyfmt HP_GL2 :heading 't11_t22 - Difference of Actuals'); endif; if(dist.ne.0)then; call graph(t12_t21 qd12_21 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't12_t21.hp1' :hardcopyfmt HP_GL2 :heading 't12_t21 - Difference of Counterfactuals'); call graph(t11_t22 qd11_22 :noshow :pgborder :plottype timeplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 't11_t22.hp1' :hardcopyfmt HP_GL2 :heading 't11_t22 - Difference of Actuals'); endif; call grreplay(:start :file cc3 ); call grreplay(:cont 't12_t21.hp1' :gformat twograph 1); call grreplay(:cont 't11_t22.hp1' :gformat twograph 2); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 't12_t21.hp1' :gformat twograph 1); call grreplay(:cont 't11_t22.hp1' :gformat twograph 2); call grreplay(:final); return; end; == ==TESTFUN Test Function function testfun(i); /; Used in LOAD program in matrix.mac call print('This is written in testfun'); call print(i); junk=99; return(junk); end; == ==TESTPGM Test Program program testpgm; /; Used in LOAD program in matrix.mac call print('This is written in testpgm'); return; end; == ==TESTSUB Test Subroutine subroutine testsub(i); /; Used in LOAD program in matrix.mac call print('This is written in testsub'); call print(i); return; end; == ==TFILTER Looks at raw, Dif, Log and HP Filter of a Series subroutine tfilter(x,name,nacf,lamda,nolog); /; /; Looks at effect of transformations /; /; x = raw series /; name = Name of raw series /; nacf = Number of ACXF terms /; lamda = Lamda to use for Hodrick Prescott Filter /; Yearly => 100 /; Quarterly => 1600 /; Monthly => 14,400 /; nolog = 0 do log /; = 1 do not do log /; /; 4 Graphs Produced with names: /; raw_series.wmf /; dif_series.wmf /; log_series.wmf /; hp_series.wmf /; /; Routine built 4 November 2012 /; /; /; The command: /; /; call load(data3acf); /; /; needed prior to the call to tfilter /; ----------------------------------- /; dif_x=dif(x); if(nolog.eq.0)log_x=log(x); call hpfilter(x,trend_x,hp_x,lamda); call data3acf(x, name, nacf,'raw_series.wmf'); name2='Difference of series'; call data3acf(dif_x, name2,nacf,'dif_series.wmf'); if(nolog.eq.0)then; name3='Log of series'; call data3acf(log_x, name3,nacf,'log_series.wmf'); endif; name4='Hodrick-Prescott Filter of Series'; call data3acf(hp_x, name4,nacf,'hp_series.wmf'); return; end; == ==UROOT_T Battery of DF, PP, ERS and KPSS test subroutine uroot_t(x,title,n,iprint,makeg); /; /; Battery of DF, PP, ERS and KPSS tests to look for unit root /; df_pp in staging gives more data on :zform results /; /; x => series to test /; title => Title /; n => # of lags /; iprint => 0 no printing. Used with makeg=1 /; 1 print table /; 2 detail as well as table /; -1 same as 1 except critical value table not printed /; -2 same as 2 except critical value table not printed /; makeg => 1 makes global %lag %df_i, %adf, %adft,%pp_i,%app, /; %appt %kpssnt,%kpsst,%ers_nt, %ers_t, /; %df1%, %df5%, %df10%, /; %adf1%, %adf5%, %adf10%, /; %adft1%,%adft5%,%adft10%); /; /; Routine built April 2009 /; /; Note that ppunit and dfunit 100% track Hamilton and SAS /; KPSS tracks Greene and Rats /; need /; call load(kpss); /; call load(df_gls); /; /; --------------------------------------------------------- /; pp_I =array(n+1:); df_I =array(n+1:); app =array(n+1:); appt =array(n+1:); lag=array(n+1:); adf =array(n+1:); adft =array(n+1:); kpssnt=array(n+1:); kpsst =array(n+1:); ers_nt=array(n+1:); ers_t =array(n+1:); %df1% =array(n+1:); %df5% =array(n+1:); %df10% =array(n+1:); %adf1% =array(n+1:); %adf5%=array(n+1:); %adf10% =array(n+1:); %adft1%=array(n+1:); %adft5%=array(n+1:); %adft10%=array(n+1:); do i=0,n; j=i+1; if(abs(iprint).le.1)call df(x, a1 :df i); if(abs(iprint).gt.1)call df(x, a1 :df i :print); df_i(j) =a1; %df1%(j) =%dfvalue(1); %df5%(j) =%dfvalue(2); %df10%(j) =%dfvalue(3); if(abs(iprint).le.1)call df(x, a1 :adf i); if(abs(iprint).gt.1)call df(x, a1 :adf i :print); adf(j) =a1; %adf1%(j) =%dfvalue(1); %adf5%(j) =%dfvalue(2); %adf10%(j) =%dfvalue(3); if(abs(iprint).le.1)call df(x, a2 :adft i); if(abs(iprint).gt.1)call df(x, a2 :adft i :print); adft(j) =a2; %adft1%(j) =%dfvalue(1); %adft5%(j) =%dfvalue(2); %adft10%(j)=%dfvalue(3); if(abs(iprint).le.1)call pp(x, a3 :pp i); if(abs(iprint).gt.1)call pp(x, a3 :pp i :print); pp_i(j)=a3; if(abs(iprint).le.1)call pp(x, a4 :app i); if(abs(iprint).gt.1)call pp(x, a4 :app i :print); app(j) =a4; if(abs(iprint).le.1)call pp(x, a5 :appt i); if(abs(iprint).gt.1)call pp(x, a5 :appt i :print); appt(j) =a5; if(abs(iprint).le.1)call kpss(x,test1,test2,i,0); if(abs(iprint).gt.1)call kpss(x,test1,test2,i,1); kpssnt(j)=test1; kpsst(j) =test2; if(abs(iprint).le.1)call df_gls(x,i,_notrend,_trend,notrendx,trendx,0); if(abs(iprint).gt.1)call df_gls(x,i,_notrend,_trend,notrendx,trendx,1); ers_t(j) =_trend; ers_nt(j) =_notrend; lag(j)=dfloat(i); enddo; if(iprint.ne.0)then; call print('DF, Phillips-Perron, KPSS & ERS tests on ',title:); call print(' ':); mm=mean(x); vv=variance(x); ss=sqrt(vv); nn=norows(x); call print('Mean of Series ',mm:); call print('Variance of Series ',vv:); call print('Stardard Deviation of Series ',ss:); call print('Number of Observations in Series',nn:); call print(' ':); call print('df_i => df ':); call print('adf => augmented df ':); call print('adft => augmented df with trend':); call print('pp_i => pp test ':); call print('app => augmented pp ':); call print('appt => augmented pp with trend':); call print(' ':); call print( 'KPSS Stationarity Test without trend (kpssnt) Critical Velues':); call print('Critical Values .10 .050 .025 .010 ':); call print(' .347 .463 .573 .739 ':); call print(' ':); call print( 'KPSS Stationarity Test with trend (kpsst) Critical Values':); call print('Critical Values .10 .050 .025 .010 ':); call print(' .119 .146 .176 .216 ':); call print(' ':); call print('ERS_NT critical values are 10% -1.62, 5% -1.95, 1% -2.58':); call print('ERS_T critical values are 10% -2.57, 5% -2.89, 1% -3.48':); call print('Test value < critical value => reject unit root ':); call print(' ':); call tabulate(lag, df_i, adf, adft, pp_i,app,appt); call tabulate(lag,kpssnt,kpsst,ers_nt,ers_t); if(iprint.ge.1) call tabulate(lag,%df1%, %df5%, %df10%, %adf1%, %adf5%, %adf10%, %adft1%, %adft5%,%adft10% :title 'Dickey-Fuller Critical Values. Test Value > CV => reject unit root'); endif; if(makeg.ne.0)then; %lag =lag; %df_i =df_i; %adf =adf; %adft =adft; %pp_i =pp_i; %app =app; %appt =appt; %kpssnt =kpssnt; %kpsst =kpsst; %ers_nt =ers_nt; %ers_t =ers_t; call makeglobal(%lag %df_i, %adf, %adft,%pp_i,%app,%appt %kpssnt, %kpsst, %ers_nt, %ers_t, %df1%, %df5%, %df10%, %adf1%, %adf5%, %adf10%, %adft1%, %adft5%,%adft10%); endif; return; end; == ==VAREST VAR Modeling using varest, st_res and varresdc /; /; routines varest, st_res, varstab and varresdc loaded /; subroutine varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,iprint, a,ia,varx,varxhat,rsq); /; /; VAR Estimation in Matrix Command assuming a constant /; x(n,k) - n,k matrix of data values /; nlag - Number of lags /; ibegin - Begin Data point /; iend - End Data Point /; beta - nlag+1 (k+1),matrix of coefficients /; t - nlag+1 (k+1),matrix of t tests coefficients /; sigma - Sigma (k by k) for that period /; corr - correlation (k by k) for that period /; Residual - nn by k matrix of residuals where /; nn = iend-ibegin+1-nlag /; iprint - 0 => do not print, ne 0 print /; a - (I - L(B)) if a is inverted get Psi Weights /; ia - Index for a /; varx - k element variance of series /; varxhat - k element variance of xhat /; rsq - k element centered r**2 /; /; Built 10 October 2002 /; Arguments Changed 31 January 2003 /; I/O Output Improved March 2003 /; Mods to run real*8 or real*16 July 2003 /; /; Note: User must load the routine buildlag /; ********************************************************* /; nseries=nocols(x); noob =norows(x); nfinal=iend-ibegin+1-nlag; k=nocols(x); varx =vector(k:); varxhat=vector(k:); rsq =vector(k:); if(nfinal.le.(nlag*2).or.iend.gt.noob)then; call epprint('ERROR: IEND, IBEGIN & NLAG not correct'); if(nfinal.le.(nlag*2))then; call epprint(' nfinal le nlag*2'); call epprint(' nfinal was ',nfinal); call epprint(' nlag was ',nlag); endif; if(iend.gt.noob)then; call epprint(' iend gt noob '); call epprint(' iend was ',iend); call epprint(' noob was ',noob); endif; go to finish; endif; call buildlag(x,nlag,ibegin,iend,newx,newy); residual=matrix(nfinal,k :); beta =matrix(k, (nlag*k)+1:); t =matrix(k, (nlag*k)+1:); adj=kindas(x,dfloat(nfinal-1)/dfloat(nfinal)); do i=1,k; y=newy(,i); if(iprint.eq.0)call olsq(y newx :qr); if(iprint.ne.0)then; call print(' ':); call print('Estimating Series ',i:); call print(' ':); call olsq(y newx :print :qr); endif; residual(,i)=%res; beta(i,) =%coef; t(i,) =%t ; varx(i) =variance(%y) *adj; varxhat(i) =variance(%yhat)*adj; rsq(i) =%rsq; enddo; xpx=transpose(residual)*residual; corr =xpx; sigma=corr; d=kindas(x,dfloat(norows(residual))); sigma=xpx/d; do i=1,norows(xpx); do j=1,norows(xpx); corr(i,j)=xpx(i,j)/dsqrt(xpx(i,i)*xpx(j,j)); enddo; enddo; /; Calculate [I - L(B)] a=submatrix(beta,1,k,1,nocols(beta)-1); a=kindas(x,-1.)*afam(a); f=kindas(x,matrix(k,k:)+1.); a=catcol(f,mfam(a)); ia=index(k,k,(nocols(a)/k)); finish continue; return; end; subroutine st_res(res,sigma,finv,sres); /; /; call st_res(residual,sigma,finv,sres); /; /; transforms a VAR residual matrix to the structural /; residual matrix. Works like rats @structresids routine; /; /; res = residual from a var. Usually calculated from /; code such as /; x=catcol(gasin,gasout); /; call varest(x,nlag,ibegin,iend,beta,t,sigma, /; corr,res,1,a,ai,varx,varxhat,rsq); /; sigma = mfam(afam(transpose(res)*res)/dfloat(norows(res))). /; usually from varest /; finv = inv(pdfac(sigma)) /; sres = structural residual defined such that sres=finv*res /; /; Built 26 September 2011 /; factor=transpose(pdfac(sigma,rcond,ibad)); if(ibad.ne.0)then; call epprint('ERROR: second argument sigma in st_res not pd matrix':); call stop; endif; finv=inv(factor); sres=matrix(norows(res),nocols(res):); /; do ii=1,nocols(res); sres(,ii)=res*finv(ii,); enddo; /; return; end; subroutine varresdc(a,ai,psi,ipsi,nterms,sigma,residual,sres,finv, se_fore,decomp,pcdecomp,iprint); /; /; Do a Sims Variance Decomposition /; /; /; a,ai, = AR form of model. Set by varest /; psi,ipsi = MA form of model /; nterms = Number of terms in MA form /; sigma = Sigma from reduced form model set by varest /; residual = residual from reduced form model = u(t). /; E u(t)u(t)'=sigma /; sres = Structural Residual = v(t). E v(t)*v(t)'=I /; Set by this routine /; finv = inverse(F) where v(t)=finv*u(t), /; se_fore = Standard error of the forecast. For details see reference /; below /; decomp = Responses to a decomposed shock /; pcdecomp = Percent change responses /; iprint = 1 to print decomp and pcdecomp with SE_FORE in front /; > 1 to print internal tests also /; /; Built 10 October 2011 /; /; Reference: Rats User's Guide Version 8 page 226-228 /; /; /; Example: /; /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /; b34sexec matrix; /; call loaddata; /; call load(buildlag); /; call load(varest); /; call echooff; /; /; ibegin=1; /; iend=296; /; nlag=2; /; nterms=12; /; x=catcol(gasin,gasout); /; iprint=0; /; call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,0, /; a,ai,varx,varxhat,rsq); /; call varresdc(a,ai,psi,ipsi,nterms,sigma,residual,sres,finv, /; se_fore,vardc,pcdecomp,iprint); /; call print(se_fore,vardc,pcdecomp); /; b34srun; /; /; /; set ne 0 for internal tests /; mtests=0; if(iprint.gt.1)mtests=1; call polyminv(a,ai,psi,ipsi,nterms); call st_res(residual,sigma,finv,sres); sigma2=transpose(sres)*sres; if(mtests.ne.0)then; call print('VAR Coefficients':); call polymdisp(:display a ai); call print('MA Coefficients':); call polymdisp(:display psi ipsi); call print('Sigma from Reduced form Residual':); call print(sigma); call print('Structural residual and associated Sigma':); call print(sres); call print(transpose(finv*transpose(residual))); call print('is this sigma?':); call print(inv(finv)*transpose(inv(finv))); endif; nseries=norows(a); f=inv(finv); var_test=matrix(nseries,nseries:); se_fore=matrix(nterms,nseries:); r_sum=matrix(nterms,nseries:); decomp=matrix(nterms,nocols(se_fore)*nocols(se_fore):); vv=vector(nseries*nseries:); do jj=1,nterms; iadd=0; do irow=1,nseries; do icol=1,nseries; call polymdisp(:extract psi ipsi v index(irow,icol,jj)); iadd=iadd+1; vv(iadd)=v; enddo; enddo; testm=matrix(nseries,nseries:vv); psi_star=testm*f; test2=psi_star*transpose(psi_star); var_test=var_test+test2; se_fore(jj, )=sqrt(diag(var_test)); iadd=0; do irow=1,nseries; do icol=1,nseries; iadd=iadd+1; decomp(jj,iadd)=psi_star(irow,icol); enddo; enddo; enddo; pcdecomp=array(norows(decomp),nocols(decomp):); nn=nocols(pcdecomp)/nseries; do jj=1,nocols(pcdecomp); pcdecomp(,jj)=afam(cusumsq(decomp(,jj))); enddo; ss=afam(se_fore)*afam(se_fore); do ii=1,nseries; do jj=1,nn; k=(ii-1)*nn +jj; pcdecomp(,k)=pcdecomp(,k)/ss(,ii); enddo; enddo; if(iprint.ne.0)then; call print('Decomposition of Variance for all VAR Series':); call print(decomp); call print('Standard Error of the VAR Forecasts':); call print(se_fore); call print('Percent Change is Responses':); call print(pcdecomp); endif; return; end; subroutine varstab(beta,compmat,eigdata,modulus,iprint); /; /; Routine to determine if a VAR model is stable /; /; This subroutine is functionally equivalent to the Stata /; command varstable. A reference is Hamilton (1994, 259). See /; also pages 285-286. /; /; Command tests if all eigenvalues of |Phi(z)| lie outside the /; unit circle. This can be tested by looking at the eigvenvalues of /; the VAR companion matrix which writes a p order VAR as a VAR(1) /; where the data vector has been augmented by many lags. /; /; call subroutine varstab(beta,compmat,eigdata,modulus,iprint); /; /; beta => coefficient vector from varest /; compmat => companion matrix /; eigdaya => Eigenvalues of compmat /; modulus => sqrt(a**2 + b**2) where a & b are real and imag /; eigenvalues. All modulus values muist be , 1.0 /; iprint => 0 no printing /; 1 print eigdat and modulus /; 2 in addition print compmat /; /; Routine built 4 JaNUARY 2013 /; work1=beta; call deletecol(work1); np=nocols(work1); one=kindas(beta,1.0); if(norows(work1).eq.nocols(work1))then; compmat=work1; endif; if(norows(work1).lt.nocols(work1))then; compmat=matrix(np,np:); kk=np-norows(work1); work2=diagmat(vector(kk:)+1.); work3=matrix(kk,np-kk:); work2=catcol(work2,work3); if(kind(work1).eq.-16)work2=r8tor16(work2); compmat=catrow(work1,work2); endif; eigdata=afam(eig(compmat)); modulus=real(sqrt(eigdata*conj(eigdata))); i=ranker(one/modulus); modulus=modulus(i); eigdata=eigdata(i); if(iprint.ne.0)then; if(iprint.gt.1)call print(compmat); call tabulate(eigdata,modulus); if(modulus(1).lt. one) call print('Eigenvalue test indicates VAR model is stationary':); if(modulus(1).ge. one) call print('Eigenvalue test indicates VAR model not stationary':); call print(' ':); endif; return; end; ==