! ****************************************************************** ! matrix.mac ! Copyright(c) 2000 ! ! Created: 1/30/2013 10:10:50 AM ! Author : HOUSTON STOKES ! Last change: HS 3/21/2013 8:57:51 PM ! ****************************************************************** ==QUICK_S Quick Start showing OLS Three ways /; /; Simple OLS Example to get you going with b34s matrix command /; %b34slet dummy=1; b34sexec matrix; * we solve two variable y=a+b*x case ; * We solve first by matrix, then two ways to use summations; * Data from Theil (1978) page 9; * Data is income and consumption; income =vector(7:100.,105.,110.,108.,106.,109.,111.); consump=vector(7:89. , 93., 97., 98., 96.,100., 99.); bigx=matrix(7,2:); bigx(,1)=1.; bigx(,2)=income; call print(bigx,income,consump); coef=inv(transpose(bigx)*bigx)*transpose(bigx)*consump; call print('constant and slope',coef); * This is the general case, more cols can be added to bigx; call print('Theil (p 21) answers -5.90 & .952 for intercept & slope':); * This is summation method. Many steps laid out; /; term1 = sum(i=1,n) ((x(i)-xbar)(y(i)-ybar)) /; term2 = sum(i=1,n) ((x(i)-xbar)**2) /; slope = term1 / term2 Note: X must have variance!! /; intercept = ybar - slope*xbar xbar=mean(income); ybar=mean(consump); /; Uses do loop method that is slower but illustrates logic!! term1=0.0; term2=0.0; /; Turn off chatter call echooff; do i=1,7; term1=term1+((income(i)-xbar)*(consump(i)-ybar)); term2=term2+((income(i)-xbar)**2.); enddo; call echoon; call print(term1,term2,xbar,ybar); slope=term1/term2; inter=ybar-(slope*xbar); call print('This is slope ',slope:); call print('This is Intercept',inter:); call print(' ':); call print('Using Vector Concepts':); call print(' ':); /; Uses Vector concepts t1=(income-xbar)*(consump-ybar); t2=sumsq(income-xbar); s1=t1/t2; call print('This is slope ',s1:); call print('This is Intercept',ybar-(s1*xbar):); b34srun; == ==ACEFIT ACEFIT Vs GAMFIT on a Catagorial Model b34sexec options ginclude('b34sdata.mac') member(gam); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call echooff; call load(ace_ols); call acefit(y[cat] age[order] start_v[order ] numvert[order] :print); call ace_ols; call gamfit(y age[predictor,3] start_v[predictor,3] numvert[predictor,3] :link logit :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); /; Here age restricted call gamfit(y age[predictor,1] start_v[predictor,3] numvert[predictor,3] :link logit :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call names; b34srun; == ==ACEFIT_2 Best ACE Model against OLS, GAM and MARS /; /; Best ACE Model against OLS, GAM and MARS /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call olsq(cpeptide age bdeficit : print); ols_res=%res; call echooff; call acefit( cpeptide[order ] age[order] bdeficit[order] :maxit 20 :nterm 10 :ns 2 :tol .1e-8 :print); call names(all); call tabulate(%rsq,%ssres); call print(%y); call print(%yhat,%res); res1=%res(,1); res2=%res(,2); yhat1=%yhat(,1); yhat2=%yhat(,2); call graph(res1,res2 :heading 'ACE Model for ns=1,2' :nolabel); call graph(%y yhat1,yhat2 :heading 'ACE Model for ns=1,2' :nolabel); /; Get best model call print(%rss); call print(%y,%ty,%tx,%yhat); call ace_ols; ace_res=%res(,%best); /; Gam Models call gamfit(cpeptide age[predictor,3] bdeficit[predictor,3] :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); gam_res=%res; call mars(cpeptide age bdeficit :nk 40 :mi 2 :print ); mars_res=%res; call marspline(cpeptide age bdeficit :nk 40 :mi 2 :print ); mars2res=%res; Models=c8array(:'OLS','ACE','GAM','MARS','MARS2'); fit =array(:sumsq(ols_res),sumsq(ace_res), sumsq(gam_res),sumsq(mars_res),sumsq(mars2res)); call tabulate(models,fit, :heading 'Residual Sum of Squares for Various Models'); call graph(ols_res,ace_res,gam_res mars_res mars2res :nolabel :heading 'Test of various nonlinear Models'); call tabulate(ols_res,ace_res,gam_res mars_res mars2res); b34srun; == ==ACEFIT_3 Experimental AVAS Option vs ACE b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call olsq(cpeptide age bdeficit : print); call echooff; call acefit( cpeptide[order ] age[order] bdeficit[order] :avas :maxit 20 :nterm 10 :tol .1e-8 :print); call ace_ols; call acefit( cpeptide[order ] age[order] bdeficit[order] :maxit 20 :nterm 10 :ns 2 :tol .1e-8 :print); call ace_ols; call names(all); b34srun; == ==ACEFIT_4 ACE vs OLS vs GAM vs MARS on Gas Data b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call echooff; maxlag=6; call olsq(gasout gasout{1 to maxlag} gasin{1 to maxlag} :print); ols_res=%res; call acefit(gasout gasout[order]{1 to maxlag} gasin[order]{1 to maxlag} :print); call ace_ols; ace_res=%res(,%best); call gamfit(gasout gasout[predictor,3]{1 to maxlag} gasin[predictor,4]{1 to maxlag} :print); gam_res=%res; call marspline(gasout gasin{1 to 4} gasout{1 to maxlag} :nk 40 :mi 2 :print); mars_res=%res; call graph(ols_res,gam_res,ace_res,mars_res :nolabel); Models=c8array(:'OLS','ACE','GAM','MARS'); fit =array(:sumsq(ols_res),sumsq(ace_res), sumsq(gam_res),sumsq(mars_res)); call tabulate(models,fit); b34srun; == ==ACEFIT_5 ACE vs GAMFIT for Cat Model /; /; For NS=1 ACEFIT Has smaller e'p /; b34sexec options ginclude('b34sdata.mac') member(gam); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call echooff; call acefit(y[cat] age[order] start_v[order ] numvert[order] :tol .1e-9 :print); call ace_ols; call gamfit(y age[predictor,3] start_v[predictor,3] numvert[predictor,3] :link logit :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call names; call print(%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); b34srun; == ==ACEFIT_6 ACE vs GAM vs MARS vs OLS On Breiman Ozone Data /; /; Tests Breiman Ozone data with OLS, MARS, GAM, ACE /; b34sexec options ginclude('b34sdata.mac') member(b_ozone); b34srun; b34sexec matrix; call loaddata; call echooff; call load(ace_ols); call olsq(ozone vh wind humidity temp ibh dpg ibt vis doy :print); %yhat_ols=%yhat; %res_ols=%res; call marspline(ozone vh wind humidity temp ibh dpg ibt vis doy :mi 3 :nk 60 :print); %yhat_m =%yhat; %res_m =%res; call gamfit(ozone vh[predictor,3] wind[predictor,3] humidity[predictor,3] temp[predictor,3] ibh[predictor,3] dpg[predictor,3] ibt[predictor,3] doy[predictor,3] vis[predictor,3] :print); %yhat_gam =%yhat; %res_gam =%res; /; Does a search call acefit(ozone vh[order ] wind[order ] humidity[order ] temp[order ] ibh[order ] dpg[order ] ibt[order ] vis[order ] doy[order ] :print); call ace_ols; ibest=%best; %yhat_ace =%ybest; %res_ace = %res(,ibest); call graph(%y %yhat_ols %yhat_m %yhat_gam :nolabel); call graph( %res_ols %res_m %res_gam :nolabel); call print(' ':); call print('OLS ',sumsq(%res_ols):); call print('MARS ',sumsq(%res_m ):); call print('GAM ',sumsq(%res_gam):); call print('ACE ',sumsq(%res_ace):); call graph(%y %yhat_ace %yhat_m :nolabel); b34srun; == ==ACEFIT_7 Illustrates Out of sample Forecasting vs MARS /; /; ACE validation of Forecasting - Feeds data back in to prove forecast /; Out of sample Forecast done for ACE, MARS and GAM /; /; Data set used was studied in Faraway (2006) page 241 b34sexec options ginclude('b34sdata.mac') member(b_ozone); b34srun; b34sexec matrix; call loaddata; call echooff; iholdout =80; idoace =1; iacefore =1; idomars =1; idogam =1; /; ACE +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(idoace.ne.0)then; call acefit(ozone vh[order ] wind[order ] humidity[order ] temp[order ] ibh[order ] dpg[order ] ibt[order ] vis[order ] doy[order ] :savemodel :holdout iholdout :ns 1 :savex :print); %x_ace=%x; %yhatt=%yhat; /; First forecast the complete sample Check sum of squares if(iacefore.ne.0)then; call acefit(ozone vh[order ] wind[order ] humidity[order ] temp[order ] ibh[order ] dpg[order ] ibt[order ] vis[order ] doy[order ] :holdout iholdout :getmodel :forecast %x_ace :print); call print('%fore and %yhatt have to be the same':); call tabulate(%foreobs %fore,%yhatt,ozone); jj=integers(norows(ozone)-iholdout); %actual=ozone(jj); call print(' '); call print('Test Error Sum of squares both ways ':); call print('Error sum of squares using yhat ', sumsq(%actual-afam(%yhatt)):); call print('Error sum of squares using %fore ', sumsq(%actual-afam(%fore )):); call print(' ':); /; Future forecast reloading the data if(iholdout.ne.0)then; call acefit(ozone vh[order ] wind[order ] humidity[order ] temp[order ] ibh[order ] dpg[order ] ibt[order ] vis[order ] doy[order ] :holdout iholdout :getmodel :forecast %xfuture :print); jj=integers(norows(ozone)-iholdout+1,norows(ozone)); %actual=ozone(jj); %forace=%fore; call tabulate(%foreobs %fore,%actual); call graph(%forace,%actual :nolabel); endif; endif; endif; if(idomars.ne.0)then; call marspline(ozone vh wind humidity temp ibh dpg ibt vis doy :holdout iholdout :df 2. :nk 50 :mi 2 :savex :savemodel :print); call marspline(ozone vh wind humidity temp ibh dpg ibt vis doy :holdout iholdout :df 2. :nk 50 :mi 2 :savex :getmodel :forecast %xfuture :print); %formars=%fore; call print(' ':); ace_ess =sumsq(%actual-%forace ); mars_ess=sumsq(%actual-%formars); call print('MARS Out of Sample Sum of squares ',mars_ess :); call print('ACE Out of Sample Sum of squares ', ace_ess :); endif; if(idogam.ne.0)then; call load(gamfore); call load(polyval); call load(polyfit); call gamfit(ozone vh[predictor,3] wind[predictor,3] humidity[predictor,3] temp[predictor,3] ibh[predictor,3] dpg[predictor,3] ibt[predictor,3] vis[predictor,3] doy[predictor,3] :holdout iholdout :savex :print); call gamfore(%spline,%x,%xfuture,3,%coef,%forgam,%link,%vartype,%df,0); gam_ess=sumsq(%actual-%forgam); call print('GAM Out of Sample Sum of squares ',gam_ess :); endif; if(idogam.ne.0.and.idomars.ne.0.and.idoace.ne.0)then; call tabulate(%foreobs,%actual,%forgam,%forace,%formars); call graph( %actual,%forgam,%forace,%formars :nolabel); call print(' ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); ace_ess =sumsq(%actual-%forace ); mars_ess=sumsq(%actual-%formars); call print('MARS Out of Sample Sum of squares ',mars_ess :); call print('ACE Out of Sample Sum of squares ', ace_ess :); gam_ess=sumsq(%actual-%forgam); call print('GAM Out of Sample Sum of squares ',gam_ess :); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); endif; b34srun; == ==ACEFIT_8 Test of Mean Squared out of sample error ACE vs MARS /; /; ACE/MARS/OLS validation of Forecasting - Tested over a range /; /; Data set used was studied in Faraway (2006) page 241 b34sexec options ginclude('b34sdata.mac') member(b_ozone); b34srun; b34sexec matrix; call loaddata; call echooff; icount=0; ihold1=1; ihold2=80; mars_ess=array(ihold2-ihold1+1:); ols_ess= array(ihold2-ihold1+1:); ace_ess =array(ihold2-ihold1+1:); number =array(ihold2-ihold1+1:); do i=ihold1,ihold2; icount=icount+1; iholdout=i; /; /; OLS +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; call olsq(ozone vh wind humidity temp ibh dpg ibt vis doy :holdout iholdout); %forols=afam(vfam(%coef)*transpose(%xfuture)); /; ACE +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ call acefit(ozone vh[order ] wind[order ] humidity[order ] temp[order ] ibh[order ] dpg[order ] ibt[order ] vis[order ] doy[order ] :savemodel :holdout iholdout :ns 1 :savex /; :print ); call acefit(ozone vh[order ] wind[order ] humidity[order ] temp[order ] ibh[order ] dpg[order ] ibt[order ] vis[order ] doy[order ] :holdout iholdout :getmodel :forecast %xfuture /; :print ); jj=integers(norows(ozone)-iholdout+1,norows(ozone)); %actual=ozone(jj); %forace=%fore; call marspline(ozone vh wind humidity temp ibh dpg ibt vis doy :holdout iholdout :df 2. :nk 50 :mi 2 :savex :savemodel /; :print ); call marspline(ozone vh wind humidity temp ibh dpg ibt vis doy :holdout iholdout :df 2. :nk 50 :mi 2 :savex :getmodel :forecast %xfuture /; :print ); %formars=%fore; ols_ess(icount) =sumsq(%actual-%forols )/dfloat(norows(%actual)); ace_ess(icount) =sumsq(%actual-%forace )/dfloat(norows(%actual)); mars_ess(icount)=sumsq(%actual-%formars)/dfloat(norows(%actual)); number(icount)=iholdout; enddo; call tabulate(number,ols_ess,ace_ess,mars_ess); call graph(ols_ess,ace_ess,mars_ess :nolabel :file 'test.wmf' :heading 'Mean sum of squares for out of sample errors'); call print('Mean OLS Out of Sample Error ',mean(ols_ess):); call print('Mean ACE Out of Sample Error ',mean(ace_ess):); call print('Mean MARS Out of Sample Error ',mean(mars_ess):); b34srun; == ==ACEFIT_9 Wang-Murphy Simulated Data. b34sexec data noob=100 heading('Wang-Murphy Sim Data'); * 'Estimating Optimal Transformations for the Multiple Regression Using the ACE Algorithm' Journal of Data Science 2(2004) pp 329-346 ; /; ''' build error y x1 x2 x3 x4 x5 work; gen error=rn(); gen x1 = (2.*rec())-1.; gen x2 = (2.*rec())-1.; gen x3 = (2.*rec())-1.; gen x4 = (2.*rec())-1.; gen x5 = (2.*rec())-1.; gen y= dlog(4.0 + dsin(4*x1) +dabs(x2) + (x3*x3) + (x4*x4*x4) + x5 + (.1 * error)); b34srun; b34sexec matrix; call loaddata; call load(ace_ols ); call load(ace_plot); call load(gamplot); call echooff; call olsq(y x1 x2 x3 x4 x5 : print); ols_res=%res; ols_yhat=%yhat; call acefit( y[order ] x1[order] x2[order] x3[order] x4[order] x5[order] :maxit 20 :nterm 10 :ns 2 :tol .1e-8 :print :savex); res1=%res(,1); res2=%res(,2); yhat1=%yhat(,1); yhat2=%yhat(,2); call graph(res1,res2 :heading 'ACE Model for ns=1,2' :nolabel); call graph(%y yhat1,yhat2 :heading 'ACE Model for ns=1,2' :nolabel); /; Get best model call ace_ols; call ace_plot; ace_res=%res(,%best); /; Gam Models file='gam_3.fsv'; call gamfit(y x1 x2 x3 x4 x5 :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :punch_sur :punch_res :filename file :print); call gamplot(%names,%lag,file,ols_yhat,ols_res,0); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); gam_res=%res; call print(' ':); call print('---------------------------------------------':); call print('--------------- Two MARS Routines -----------':); call print('---------------------------------------------':); call mars(y x1 x2 x3 x4 x5 :nk 40 :mi 2 :print ); mars_res=%res; call marspline(y x1 x2 x3 x4 x5 :nk 40 :mi 2 :df 2. :print ); mars2res=%res; Models=c8array(:'OLS','ACE','GAM','MARS','MARS2'); fit =array(:sumsq(ols_res),sumsq(ace_res), sumsq(gam_res),sumsq(mars_res),sumsq(mars2res)); call tabulate(models,fit, :heading 'Residual Sum of Squares for Various Models'); call graph(ols_res,ace_res,gam_res mars_res mars2res :nolabel :heading 'Test of various nonlinear Models'); call print(' ':); call print('---------------------------------------------':); call print('---------------- PPREG with 20 trees --------':); call print('---------------------------------------------':); call ppreg(y x1 x2 x3 x4 x5 :print :m 20 :mu 1); call print(' ':); call print('---------------------------------------------':); call print('---------------- PPREG held to 1 tree -------':); call print('---------------------------------------------':); call ppreg(y x1 x2 x3 x4 x5 :print :m 1 :mu 1); call print(' ':); call print('---------------------------------------------':); call print('---------------- GAM ------------------------':); call print('---------------------------------------------':); call gamfit(y x1 x2 x3 x4 x5 :print); b34srun; == ==ACEFIT10 Wang US Pollution Example b34sexec data heading('Wang-Murphy Polution Data'); * Estimating Optimal Transformations for the Multiple Regression Using the ACE Algorithm Journal of Data Science 2(2004) pp 329-346 ; input so2 temp manuf pop wind precit days; label so2 ='mean concentration of sulphur dioxide'; label temp ='Average annual temp'; label manuf ='# of manufacturing enterises > 20 w'; label pop ='Polulation size (1970) census '; label wind ='average annual wind speed in MPH '; label precit='average annual precipitation in inches'; label days ='average days with precipitation'; datacards; 10 70.3 213 582 6 7.05 36 13 61 91 132 8.2 48.52 100 12 56.7 453 716 8.7 20.66 67 17 51.9 454 515 9 12.95 86 56 49.1 412 158 9 43.37 127 36 54 80 80 9 40.25 114 29 57.3 434 757 9.3 38.89 111 14 68.4 136 529 8.8 54.47 116 10 75.5 207 335 9 59.8 128 24 61.5 368 497 9.1 48.34 115 110 50.6 3344 3369 10.4 34.44 122 28 52.3 361 746 9.7 38.74 121 17 49 104 201 11.2 30.85 103 8 56.6 125 277 12.7 30.58 82 30 55.6 291 593 8.3 43.11 123 9 68.3 204 361 8.4 56.77 113 47 55 625 905 9.6 41.31 111 35 49.9 1064 1513 10.1 30.96 129 29 43.5 699 744 10.6 25.94 137 14 54.5 381 507 10 37 99 56 55.9 775 622 9.5 35.89 105 14 51.5 181 347 10.9 30.18 98 11 56.8 46 244 8.9 7.77 58 46 47.6 44 116 8.8 33.36 135 11 47.1 391 463 12.4 36.11 166 23 54 462 453 7.1 39.04 132 65 49.7 1007 751 10.9 34.99 155 26 51.5 266 540 8.6 37.01 134 69 54.6 1692 1950 9.6 39.93 115 61 50.4 347 520 9.4 36.22 147 94 50 343 179 10.6 42.75 125 10 61.6 337 624 9.2 49.1 105 18 59.4 275 448 7.9 46 119 9 66.2 641 844 10.9 35.94 78 10 68.9 721 1233 10.8 48.19 103 28 51 137 176 8.7 15.17 89 31 59.3 96 308 10.6 44.68 116 26 57.8 197 299 7.6 42.59 115 29 51.1 379 531 9.4 38.79 164 31 55.2 35 71 6.5 40.75 148 16 45.7 569 717 11.8 29.07 123 b34sreturn; b34srun; b34sexec matrix; call loaddata; call load(ace_ols ); call load(ace_plot); call load(gamplot); call echooff; call olsq(so2 temp manuf pop wind precit days : print); ols_res=%res; ols_yhat=%yhat; call acefit(so2[order] temp[order] manuf[order] pop[order] wind[order] precit[order] days[order] :maxit 20 :nterm 30 :ns 2 :tol .1e-16 :print :savex); res1=%res(,1); res2=%res(,2); yhat1=%yhat(,1); yhat2=%yhat(,2); call graph(res1,res2 :heading 'ACE Model for ns=1,2' :nolabel); call graph(%y yhat1,yhat2 :heading 'ACE Model for ns=1,2' :nolabel); /; Get best model call ace_ols; call ace_plot; ace_res=%res(,%best); /; Gam Models file='gam_3.fsv'; call gamfit(so2 temp manuf pop wind precit days :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :punch_sur :punch_res :filename file :print); call gamplot(%names,%lag,file,ols_yhat,ols_res,2); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); gam_res=%res; call mars(so2 temp manuf pop wind precit days :nk 40 :mi 2 :print ); mars_res=%res; call marspline(so2 temp manuf pop wind precit days :nk 40 :mi 2 :df 2. :print ); mars2res=%res; Models=c8array(:'OLS','ACE','GAM','MARS','MARS2'); fit =array(:sumsq(ols_res),sumsq(ace_res), sumsq(gam_res),sumsq(mars_res),sumsq(mars2res)); call tabulate(models,fit, :heading 'Residual Sum of Squares for Various Models'); call graph(ols_res,ace_res,gam_res mars_res mars2res :nolabel :heading 'Test of various nonlinear Models'); b34srun; == ==ACE_OLS Select best ACE Model /; /; Best ACE Model against OLS, GAM and MARS /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call olsq(cpeptide age bdeficit : print); ols_res=%res; call echooff; call acefit( cpeptide[order ] age[order] bdeficit[order] :maxit 20 :nterm 10 :ns 2 :tol .1e-8 :print); res1=%res(,1); res2=%res(,2); yhat1=%yhat(,1); yhat2=%yhat(,2); call graph(res1,res2 :heading 'ACE Model for ns=1,2' :nolabel); call graph(%y yhat1,yhat2 :heading 'ACE Model for ns=1,2' :nolabel); /; Get best model call print(%rss); call print(%y,%ty,%tx,%yhat); call ace_ols; ace_res=%res(,%best); /; Gam Models call gamfit(cpeptide age[predictor,3] bdeficit[predictor,3] :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); gam_res=%res; call mars(cpeptide age bdeficit :nk 40 :mi 2 :print ); mars_res=%res; call marspline(cpeptide age bdeficit :nk 40 :mi 2 :print ); mars2res=%res; Models=c8array(:'OLS','ACE','GAM','MARS','MARS2'); fit =array(:sumsq(ols_res),sumsq(ace_res), sumsq(gam_res),sumsq(mars_res),sumsq(mars2res)); call tabulate(models,fit, :heading 'Residual Sum of Squares for Various Models'); call graph(ols_res,ace_res,gam_res mars_res mars2res :nolabel :heading 'Test of various nonlinear Models'); call tabulate(ols_res,ace_res,gam_res mars_res mars2res); b34srun; == ==ACE_PLOT ACE Plots /; /; ACE Plots /; b34sexec options ginclude('b34sdata.mac') member(b_ozone); b34srun; b34sexec matrix; call loaddata; call echooff; call load(ace_ols ); call load(ace_plot); iholdout=10; call acefit(ozone vh[order ] wind[order ] humidity[order ] temp[order ] ibh[order ] dpg[order ] ibt[order ] vis[order ] :holdout iholdout :ns 1 :savex :print); call ace_ols; call ace_plot; b34srun; == ==ACEPLOT_2 GAM, MARSPLINE, ACEFIT Plus Plots & Font changes /; Study of SO4 and Latitude and Longitude /; Data Studied byDong Xiang at SAS Institute /; 'Fitting Generalized Additive Models with GAM Procedure' /; SAS paper 256-26 /; Illustrates fonts b34sexec options ginclude('b34sdata.mac') member(gam_6); b34srun; b34sexec matrix; call loaddata; call load(ace_ols ); call load(ace_plot); call load(gamplot); call echooff; call olsq(so4 latt long :print); %olsss=%rss; %olsyhat=%yhat; %olsres=%res; /; MARS + Suface Plots call marspline(so4 latt long :df 2. :nk 40 :mi 2 :savex :print :contrib array(2,2: min(latt) mean(long) max(latt) mean(long)) index(100) :surface array(2,2: min(latt) min(long) max(latt) max(long)) index(100,100) ); %marsss=%rss; %x_mars=%x; call graph(%xcrange %contrib :plottype xyplot :xlabel 'Latitude' :pgborder :nocontact :ylabelleft 'Longitude' 'CR' :markpoint 1 1 3 14 :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :colors black bblue :file 'mars_cont.wmf' :heading 'Leverage Plot of Latitude vs SO4 based on MARS Model'); %x_mars=%x; x=%surface; /; :pgunits used to label x and y axis! call graph(x :plottype meshstepc :file 'mars_so4.wmf' :rotation 20. :pspaceon :grcharset 'romanbld.chr' :grcharfont 7 :pgyscaleleft 'NT' :pgyscaleright 'I' :angle 20. :xlabel 'Latitude' :pgunits array(:min(latt) min(long) max(latt) max(long)) :ylabelleft 'Longitude' 'C9' :zlabelleft 'This is a test ' 'C9' :grid :d3axis :d3border /; :htitle 1.2 1.2 :heading 'SO4 = f(Latitude and Longitude based on MARS Model)'); call graph(x :plottype meshstepc :file 'mars_so4.wmf' :rotation 20. /; :pspaceon :pgyscaleleft 'NT' /; :grcharset 'romanbld.chr' :grcharfont 7 :angle 20. :xlabel 'Latitude' :pgunits array(:min(latt) min(long) max(latt) max(long)) :ylabelleft 'Longitude' 'CR' :zlabelleft 'This is a test ' 'CR' :grid :d3axis :d3border :heading 'SO4 = f(Latitude and Longitude based on MARS Model)'); call acefit(so4 latt long :print :savex :xx); call ace_ols; call ace_plot; %acess =%ssres(imin(%ssres)); file='gam.fsv'; call gamfit(so4 latt[predictor,3] long[predictor,3] :print :punch_sur :punch_res :filename file); %gamss=%rss; call gamplot(%names,%lag,file,%olsyhat,%olsres,2); call print(%olsss,%marsss,%acess,%gamss); b34srun; == ==ACF ACF(series,n) Autocorrelation Function b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; acf1=acf(gasout,24,se1,pacf1); acfsmall=acf(gasout,24:); call tabulate(acf1,acfsmall); acf1=acf(gasout,200); acfsmall=acf(gasout,200:); call graph(acf1,acfsmall :heading 'BJ vs Small sample formula -note sign differences'); acf1=acf(gasout,24,se1,pacf1); call graph(acf1,pacf1 :nokey :heading 'ACF & PACF of Gasout'); call graph(acf(dif(gasout),24) :Heading 'ACF of Gasout(1-B)'); call graph(acf(dif(gasout,2,1),24) :heading 'ACF of Gasout(1-B)**2'); acf2=acf(gasin,24,se2,pacf2); call graph(acf2,pacf2 :nokey :heading 'ACF & PACF of Gasin'); call graph(acf1,SE1 :nokey :heading 'ACF and SE of ACF of Gasout'); i=integers(24); call tabulate(i,acf1,acf2,se1,se2,pacf1,pacf2); call print('ACF, SE, PACF, Modified Q Prob Q for gasin':); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call tabulate(acf2,se2,pacf2,mq2,pmq2); call graph(acf2,pmq2); call graph(acf2 se2 :overlay acfplot /$ Un comment next line to get a hard copy /$ :file 'testacf.wmf' :heading 'Overlay plot of ACF of gasin'); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :heading 'ACF of Random series'); call graph(acf2,se2 :overlay acfplot :heading 'ACF of rn(1-B)'); call graph(acf3,se3 :overlay acfplot :heading 'ACF of rn(1-B)**2'); b34srun$ /$ Tests using bjiden command b34sexec bjiden nac =36 npac=36; var =gasin ; rauto gasin ; b34srun; == ==ACF_PLOT Illustrate ACF_Plot Subroutine b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call load(acf_plot); call acf_plot(gasout,24,namelist(gasout)); b34srun; == ==ADDCOL call addcol(matx,n,i) Adds i Cols to matx before n b34sexec matrix; n=3; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call addcol(test); call print('We add at the right',test); test=x; call addrow(test,2,4); call print('We add 4 cols after 1 and before old 2',test); b34srun; == ==ADDROW Illustrates Addrow Capability b34sexec matrix; n=3; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call addrow(test); call print('We add at the end',test); test=x; call addrow(test,2,4); call print('We add 4 rows after 2 and before old 3',test); b34srun; == ==AFAM Illustrates AFAM Command b34sexec matrix$ x=matrix(3,3:); call print(x); x1=matrix(3,3:1 2 3 4 5 6 7 8 9); call print(x1); v=vector(4:1 2 3 4); xx=matrix(2,2:v); call print(xx); ax=afam(x); call print(ax); av=afam(v); call print(v); b34srun; == ==AGGDATA Aggregate Data b34sexec matrix; id=10.; x=20.1; call aggdata(id,x,newx,newid); call print(id,x,newx,newid,%nelm,%nnzero,%varx); id=array(6:10. 10. 11. 11. 11. 12.); x= array(6:1 2 3 4 5 6); call tabulate(id,x); call aggdata(id,x,newx,newid); call tabulate(newx,newid,%nelm,%nnzero,%varx); b34srun; == ==ALIGN Align Series that have missing Data b34sexec matrix; n=10; x=rn(array(n:)); y=rn(x); call tabulate(x,y); i=integers(1,n,2); x(i)=missing(); call tabulate(x,y); call align(x,y); call tabulate(x,y); b34srun; == ==ALIGN_1 Time Series Align Example 1 /; /; Updates to variable time info /; b34sexec options ginclude('b34sdata.mac') member(c_s_house); b34srun; b34sexec matrix; call get(lspcs20r,lnffrate); call describe(lnffrate:); /; /; Save frequency and put in missing data prior to align /; ffhold=freq(lspcs20r); call tslineup(lspcs20r,lnffrate); call tabulate(%julian%,lspcs20r,lnffrate); /; /; /; Get dates set right /; /; call copytime(lspcs20r,%julian%); call align( %julian%,lspcs20r,lnffrate); call julian_to_tb(%julian%(1),ffhold,itbase,itstart); call settime(%julian%,itbase,itstart,ffhold); call copytime(%julian%, lspcs20r); call copytime(%julian%, lnffrate); /; /; see what we get /; call describe(lspcs20r:); call describe(lnffrate:); b34srun; == ==ALIGN_2 Time Series Align Example 2 /; /; Shows line up and purging time series data. /; Due to possible missing data inside the series the timestart /; and timebase have not been set. Howeber a date variable can /; added to preserve the date of each observation /; b34sexec matrix; call tsd(:get c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call tsd(:get c96c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call tsd(:get cd :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call names(:); /; do i=1,norows(%names%); /; call print(argument(%names%(i))); /; enddo; call names; call tabulate(c c96c cd); call tslineup(c c96c cd); call tabulate(c c96c cd); call align(c c96c cd); call tabulate(c c96c cd); call names; /; Using a date variable call clearall; call tsd(:get c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage :datename a1); call tsd(:get c96c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage :datename a2); call tsd(:get cd :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage :datename a3); call names(:); /; do i=1,norows(%names%); /; call print(argument(%names%(i))); /; enddo; call names; call tabulate( c a1 c96c a2 cd a3); call tslineup( c a1 c96c a2 cd a3); call tabulate( c a1 c96c a2 cd a3); call align( c a1 c96c a2 cd a3); dates=chardate(a1); call tabulate(dates,c,a1,c96c,a2,cd,a3 :title 'Lined up data with dates'); call names; year=fyear(a1); call graph(year,c c96c cd :plottype xyplot :Heading 'TSD Data'); b34srun; == ==ARGUMENT Run Time Replacement of command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call character(cc, 'gasout gasin{1 to 10}'); call print(cc); call testarg(argument('gasout gasin') :print); call olsq(argument('gasout gasin') :print); call names; call testarg(argument(cc) :print); call olsq(argument(cc) :print); call names; b34srun; == ==ARGUMENT2 ARGUMENT Used to pass arguments to Program b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; program testit; /; /; needs /; /; call character(reg,'lnq lnk lnl'); /; call character(plotvar,'lnq lnl lnk'); /; /; before being called /; call olsq(argument(reg) :l1 :minimax :print); call graph(argument(plotvar)); return; end; call character(reg,'lnq lnk lnl'); call character(plotvar,'lnq lnl lnk'); call testit; b34srun; == ==ARGUMENT3 More advanced use of ARGUMENT /$ argument b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call testarg(argument('GASOUT GASIN') :print); call olsq(argument('gasout gasin') :print); call olsq(argument('gasout gasin{1 to 6}') :print); call character(cc, 'gasout gasin{1 to 10}'); call print(cc); call testarg(argument(CC) :print); call olsq(argument(cc) :print); /$ /$ advanced features allowing generating y=x real time /$ x=10.; call character(c1,'X*4.'); call character(c2,'Y'); call character(c4,'y'); call names; call testarg(argument(c1),argument(c2)); call copy(argument(c1),argument(c2)); call print(argument(c1)); call print(argument(c2)); call print(argument(c4)); x=9.; call print('two ways to get same answer':); call copy(argument('x*2.'),argument('y')); call print(y); call copy(argument('X*2.'),argument('y ')); call print(y); /$ /$ Passing a command string to a routine /$ allows selective printing of known variables at run time. /$ /$ Note that the character string passed to tprint can be built at /$ runtime /$ subroutine tprint(cc); x=10; y=20; call print(argument(cc)); return; end; call character(cctest,'This is a test'); call tprint('x'); call tprint('y'); call names(all); b34srun; == ==ARGUMENT4 Illustrate passing names info into a subroutine /; Illustrate passing names info into a subroutine /; First we pass in the name of a global variable. /; Next we rename a local variable a name we pass in /; b34sexec options debugsubs(b34smat09,b34smat09a); b34srun; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; subroutine test(nn,xx); /; Illustrate name passing call names(all); call print(nn); /; This prints a global variable call print(argument(nn(1))); /; Renames a local variable n=namelist(argument(nn(3))); call copy(xx,argument(nn(3))); call graph(argument(n)); call graph(argument(nn(3))); call names(all); return; end; /; This name list two global variables plus one name 'funny' /; Funny does not exist but we want to use it inside the subroutine /; We pass in lgas and by use of the copy command copy this variable /; to a name we want that is saved in the n variable name.... /; From now on we use the argument command n1=namelist(gasout,gasin,funny); call makeglobal(gasout); call makeglobal(gasin); lgas=gasout; call names(all); call print(n1); call test(n1,lgas); b34srun; == ==ARGUMENT5 Illustrates that argument(h) same as eval(h:) /; argument(h) same as eval(h:) b34sexec matrix; x=9; h='X'; call print(argument(h)); call print(eval(h)); call print(eval(h:)); /; To get around augument(h)=999.; which is not allowed call copy(3.* 333.,argument(h)); call print(x); call copy(3.*333. ,eval(h:)); call print(x); b34srun; == ==ARMA Tests ARMA Command on Gasin Series b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ Model Discussed in Box-Jenkins and in Stokes (1997) /$ For raw gasin the setup :nar 3 => problems /$ ACF of raw series indicates have or nearly have a unit root!! /$ :nar 2 is OK call loaddata; * :nar 3 :nma 1 will fail as too complex ; call arma(gasin :nar 2 :nma 1 :forecast 296 24 :print); call graph(%res); call graph(%y,%yhat); acf1=acf(%res); call graph(acf1); call print(acf1); call arma(dif(gasin) :nar 3 :forecast 295 24 :print); call graph(%res); call graph(%y,%yhat); acf1 = acf(%res); acf2 = acf(dif(gasin)); acfraw = acf(gasin); call graph(acf1,acf2); call tabulate(acf1,acf2,acfraw); call df(gasin,df); call pp(gasin,pp); call print(df,pp); b34srun; == ==ARMA_1 Shows more Options of ARIMA b34sexec options ginclude('gas.b34'); b34srun; /$b34sexec reg residualp; /$model gasout = gasout{1}; b34srun; b34sexec matrix; * Model Discussed in Box-Jenkins and in Stokes (1997); call loaddata; call arma(gasout :maxit 2000 :relerr 0.0 :nar 8 :nma 0 :forecast 296 24 :print); call names(info); call print(%arparms,%maparms); call print(%rss,%const); /$ Tests AR1 model /$test=array(norows(gasout)+1:); /$test(1)=-9999.; /$call echooff; /$do i=2,norows(gasout)+1; /$test(i)=%const + (%arparms(1)*gasout(i-1)); /$enddo; /$ call tabulate(gasout,test); call tabulate(%resobs,%y,%res,%yhat); call print(%yvar,%arorder,%arparms); call graph(%res); call graph(%y,%yhat); call graph(acf(%res)); call tabulate(%foreobs,%fcast,%fconf,%fpsi); b34srun; == ==ARMA_10 One and Two Pass GARCH Tests b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; /$ Enders tests GARCHEST /$ Two pass methods have problems. Are sensitive to maxbc and model %b34slet garch =0; %b34slet garchest=0; %b34slet enders =0; %b34slet twopass1=1; %b34slet twopass2=0; %b34sif(&twopass1 .ne. 0)%then; /$ /$ Model has problems converging in second stage /$ Unless logs are taken of the second stage series /$ Problem is due to large values in RR in middle of the /$ series and at the end Altering :maxbc makes a difference /$ in this case !! /$ b34sexec matrix; call loaddata; dpi=dif(pi); call arma(dpi :nma 1 :nar 1 :print); acf1=acf(%res); rr=afam(%res)*afam(%res); call tabulate(%res,rr); call graph(rr); call graph(acf(rr)); /$ *************************************** /$ If we log the series we get convergence rr=dlog(rr); /$ *************************************** call arma(rr :nma 1 :nar 1 :print); acf2=acf(%res); call tabulate(acf1,acf2); b34srun; %b34sendif; %b34sif(&twopass2 .ne. 0)%then; /$ /$ Model has problems converging in second stage /$ As setup this is Enders 1 pass model /$ Variants are commented out /$ b34sexec matrix; call loaddata; call arma(pi :nar 1 :maorder idint(array(:1,4)) :warn :print); acf1=acf(%res); rr=afam(%res)*afam(%res); /$ ************************** /$ rr = dlog(rr); /$ ************************** call arma(rr /$ :tolss .1d-4 :tolbc .1d-4 :maxbc 20 :warn :maxit 20000 /$ Enders :nar 1 :nma 1 /$ Variant /$ :nma 5 :print); acf2=acf(%res); call tabulate(acf1,acf2); b34srun; %b34sendif; %b34sif(&enders .ne. 0)%then; b34sexec matrix ; call loaddata; * See Enders page 155 ; j=norows(pi); call olsq(pi pi{1} :print); arch = array(j:); res = array(j:); call garchest(res,arch, pi,func,10,n :maorder idint(array(:1,4)) :nar 1 :arparms array(:%coef(1)) :ngar 1 :ngma 1 :maxfun 2000 :maxg 2000 :maxit 10000 :cparms array(:%coef(2),%resvar) :print); call print(sumsq(goodrow(res))); call tabulate(res,arch); b34srun; %b34sendif; %b34sif(&garchest .ne. 0)%then; b34sexec matrix ; call loaddata; dpi=dif(pi); call print(dpi); call garchest(res,arch,dpi,func,10,n :nma 1 :ngar 1 :ngma 1 :noconst1 :maxfun 2000 :maxg 2000 :maxit 800 :print); call print(sumsq(goodrow(res))); call tabulate(res,arch); b34srun; %b34sendif; %b34sif(&garch .ne. 0)%then; b34sexec matrix display=col80medium; /$ Model Discussed in Enders page 155 call loaddata; dpi=dif(pi); j=norows(dpi); arch = array(j:); res = array(j:); archlog= array(j:); call echooff; program test; /$ Using built in garch subroutine to estimate a GARCH func=0.0; call garch(res,arch,dpi,func,10,n :ma array(:b2) idint(array(:1) ) :gma array(:a1) idint(array(:1) ) :gar array(:a2) idint(array(:1) ) :constant array(:b0 a0) ); return; end; call print(test); /$ tests b2=.1; a1=.1; a2=.1; b0=0.0; a0=.1 ; /$ /$ note b0=0.0 and not estimated /$ call cmaxf2(func :name test :parms b2 a2 a1 a0 :maxit 2000 :maxfun 2000 :maxg 2000 :ivalue array(:b2,a2,a1,a0) :lower array(:-.1d+30,.1d-16,.1d-16, .1d-16) :upper array(: .1d+30,.1d+30,.1d+30, .1d+30) :print); call print(sumsq(goodrow(res))); call tabulate(res,arch); b34srun; %b34sendif; == ==ARMA_11 Two Pass GARCH Using SCA Automatic Approach b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; /$ Uses Two pass method of running a GARCH model /$ Automatic commands in SCA used b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. acf pi. iarima pi. hold residuals(res) rr = res**2 acf rr iarima rr. hold residuals(res2) -- -- Using Seasional parameter ********************* -- acf pi. iarima pi. seasonal 4. hold residuals(res) rr = res**2 acf rr iarima rr. seasonal 4. hold residuals(res2) stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ b34sexec matrix; call loaddata; call load(rtest); /$ call autobj(pi :print :nac 24 :npac 24 :seasonal 4 /$ :printsteps :autobuild ); call rtest(%res,pi,48); rr=%res*%res; call autobj(rr :print :nac 24 :npac 24 :seasonal 4 /$ :printsteps :autobuild ); call rtest(%res,rr,48); b34srun; == ==ARMA_12 Shows AR(6) Model done three ways /; /; Shows AR model done two ways. Shows Modern B-J Code will /; track closely modern OLSQ code even though one solves /; beta =((X'X)**-1)*X'y while other uses a NLSQ zero finder. /; As noted by McCullough(1997) in his review of RATS this was not /; always the case. /; /; Improvements such as real*8 for the nonlinear solver used by B-J /; in their original paper and Linpack in the nonlinear solver are /; the reason for this imporvement. An addition improvement is real*8 /; data storage /; /; Shows OLSQ command, B-J Code and the IMSL ARMA code with /; Backforecasting turned off. /; b34sexec options ginclude('b34sdata.mac') member(retail); b34srun; b34sexec matrix; call loaddata; call olsq(applance applance{1 to 6} :print); call autobj(applance :nac 36 :ar index(1 2 3 4 5 6) :print :assumptions); /$ /$ Test IMSL Code /$ call arma(applance :nar 6 :maxit 8000 :maxbc 0 :itprint :print); b34srun; == ==ARMA_2 Tests ARMA Command on Real Money /$ Problem discussed in Stokes (1979) and Stokes-Neuburger (1979) b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; /$ Depending on if we log or not get Het Model !! /$ Usual ACF does not detect this !!!! diff2rm=dif(dlog(fmscom),2,1); /$ diff2rm=dif(fmscom,2,1); call graph(diff2rm); call arma(diff2rm :nar 3 :maxit 8000 :itprint :print); call graph(%res); call graph(%y,%yhat); acfres=acf(%res,30); acfy =acf(%y,30); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); * restricted model ; call arma(diff2rm :nar 1 :maxit 8000 :maorder idint(array(:3,4,7)) :itprint :print); call graph(%res); call graph(%y,%yhat); call graph(acf(%res)); call graph(%res); call graph(%y,%yhat); acfres=acf(%res,30); acfy =acf(%y,30); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; == ==ARMA_3 ARMA (using MM) of generated model b34sexec matrix; * We generate a series and use Method of Moments to get Coef; n=10000; nacf=30; call free(ma); ar= array(:-.9 ); nn=100; start=array(:.1); test1=genarma(ar,ma,1.0,start,.1,n,nn); call graph(test1); call arma(test1 :nar 1 maxit 8000 :itprint :print); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; == ==ARMA_4 ARMA of generated model shows refine b34sexec matrix; * We generate a series and use Method of Moments to get Coef; n=10000; nacf=30; call free(ma); ar= array(:-.9 ); nn=100; start=array(:.1); test1=genarma(ar,ma,1.0,start,.1,n,nn); call graph(test1); call arma(test1 :nar 4 maxit 8000 :itprint :refine 2. :print); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; == ==ARMA_5 Various ARMA Tests using Subroutines b34sexec matrix; * We generate series and use Method of Moments to get Coef; * MM Gets a good starting values for unrestricted models ; program testit; nn=100; test1=genarma(ar,ma,1.0,start,.1,n,nn); call graph(test1); call arma(test1 :nar nar :maxit 8000 :nma nma :refine 2. :print); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); return; end; n=10000; nacf=30; * Model is way too big !!!! ; * Refine removes excess paramaters ; nar=9; nma=0; call free(ma); call free(ar); if(nar.gt.0)ar= array(: .70, -.43 ); if(nma.gt.0)ma= array(:-.6 ); start=array(:.1 .1); call testit; * Correct Model ; nar=2; nma=1; call free(ma); call free(ar); if(nar.gt.0)ar= array(: .70, -.43 ); if(nma.gt.0)ma= array(: .2 ); start=array(:.1 .1); call testit; * Restricted Model ; call arma(test1 :arorder idint(array(:1 2 4)) :maxit 8000 :maorder idint(array(:2) ) :refine 2. :print); call tabulate(%cname,%corder,%coef,%se,%t); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; == ==ARMA_6 Shows Excessive Model that is revised later /$ /$ User attempts AR model with 50 terms /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ /$ Subroutine is inside routine in comment form /$ /$ 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 ***************'); /$ call arma(data :nar nar :nma nma :print :refine refine); /$ 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); /$ res2=afam(%res); coef2=%coef; se2=%se; t2=%t; /$ return; /$ end; call loaddata; call load(garch2p); * This setting is way too big but tests software ; nar=50; nma=0; gnar=1; gnma=0; call garch2p(gasout,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; == ==ARMA_7 Allows Extensive tests of ARMA (MM) and OLS b34sexec matrix ; * Tests ARMA Command for various arma(1,j) Models ; call echooff; * For Large Numbers of cases turn off gpaph ; * ncase=3000; ncase = 1 ; n=10000 ; nacf=50; coef=array(7:-.75,-.50,-.25,0.0,.25,.50,.75); call free(ma); * sets number of lags for OLSQ filter ; k=1; * sets what ma parameter to use - If zero turns off ; materm=7; * max ar for mm filter; maxar=9; do j=1,7; do i=1,ncase; iter = dfloat(i) ; ar=coef(j); if(materm.ne.0)then; ma=coef(materm); endif; const=1.0; start=.1; wnv=1.0; nout=2000; ar1=genarma(ar,ma,const,start,wnv,n,nout); call arma(ar1 :nar maxar :maxbc 400 :nonlls ); test2=acf(%res,nacf); call olsq(ar1 ar1{1 to k}); test1=acf(ar1,nacf); test3=acf(%res,nacf); call graph(test1,test2 test3 :heading 'Raw & 2 White Series'); * call print(i,j,%coef); enddo; enddo; b34srun ; == ==ARMA_8 Variance of AR(1) Coefficient b34sexec matrix; * We generate a series and following Hinich show that; * Coef SE is invariant to changes in input variance ; n=10000; call free(ma); ar= array(:.7 ); nn=10000; start=array(:.1); varnoise=1.; test1=genarma(ar,ma,0.0,start,varnoise,n,nn); call print('Variance of the series going in ',variance(test1)); call arma(test1 :nar 1 :maxit 8000 :itprint :print); varnoise=10.; test1=genarma(ar,ma,0.0,start,varnoise,n,nn); call print('Variance of the series going in ',variance(test1)); call arma(test1 :nar 1 :maxit 8000 :itprint :print); b34srun; == ==ARMA_9 Shows R**2 and ACF Relationshiop b34sexec matrix; * Uses Nelson (1976) Formula get R**2 as a f of ACF ; * Needs large samples; n=10000; call free(ma); ar= array(:-.8,.1 ); nn=1000; start=array(:.1,.1); ar2=genarma(ar,ma,0.0,start,.1,n,nn); aacfar2=acf(ar2); call graph(ar2); call arma(ar2 :nar 2 maxit 8000 :itprint :print); gamma=matrix(2,2:1.0,aacfar2(1),aacfar2(1),1.0); pp=vector(2:aacfar2(1),aacfar2(2)); call print(pp,gamma,%coef); rsq1=pp*inv(gamma)*pp; testrsq=1.0-(variance(%res)/variance(%y)); call print(rsq1,testrsq); /$ call tabulate(%res,%y); /$ call names(all); b34srun; == ==ARRAY Illustrates ARRAY Command b34sexec matrix$ x=array(3,3:); x=rn(x); call print(x); xfromi_4=array(2,2:1 2 3 4); xfromr_8=array(2,2:1. 2. 3. 4.); xd1=array(3:); xd1=rn(xd1); call print(xd1,xfromi_4,xfromr_8); /$ Character options call character(cc,'abcdefghi'); cx =array(3,3:cc); * place character*1 in character*1 with different dimensions; cx1 =c1array(3,3:cc); * place character*1 in character*8 ; call character(cc,'1234567812345678abcdefghABCDEFGH'); cx8 =c8array(2,2:cc); call print(cx,cx1,cx8); * recode cx8 into one row and character*1 ; * Two ways to do the same thing ; newcx8 = array(4:cx8); newcx8_1=c8array(4:cx8); * place character*8 into character*1 ; newcx8_2=c1array(32:cx8); * recode a character*1 array; newch1=c1array(norows(cc),1:cc); call print(newcx8,newcx8_1,newcx8_2,newch1); call names(all); b34srun; == ==AUTOBJ AUTOBJ Command tested on Gas Data b34sexec options ginclude('gas.b34'); b34srun; %b34slet dosca=0; b34sexec matrix; call loaddata; call load(rtest); /$ /$ This roottol setting forces no differencing /$ /$ call autobj(gasout :print :nac 24 :npac 24 /$ :roottol .99 :autobuild ); /$ This turns off differencing call autobj(gasout :print :nac 24 :npac 24 :nodif :autobuild ); call rtest(%res,gasout,48); /$ Default let program decide call autobj(gasout :print :nac 24 :npac 24 /$ :printsteps :spiketol 2.0 :autobuild ); call rtest(%res,gasout,48); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima gasout. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; == ==AUTOBJ_1 Identify Retail Data b34sexec options ginclude('b34sdata.mac') member(retail); b34srun; %b34slet dosca=0; b34sexec matrix; call loaddata; call load(rtest); call autobj(applance :autobuild :seasonal 12 :nac 36 :print :assumptions /$ /$ maxtry limits model /$ :printsteps :maxtry 2 /$ :forecast index(20,norows(applance)) ); call names(all); call tabulate(%cname,%corder,%coef,%se,%t); call print(%yvar,%numar,%numma,%numdif); if(%numdif.ne.0)call print(%diford); if(%numar.ne.0)call print(%narfact,%arord,%arparms,%arse); if(%numma.ne.0)call print(%nmafact,%maord,%maparms,%mase); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima applance. seasonal 12. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; == ==AUTOBJ_2 Illustrates Reading and writing saved Model /$ Illustrates saving a model and rereading back into B34S b34sexec options ginclude('gas.b34'); b34srun; B34SEXEC BJEST ; MODEL GASout$ MODELN P=(1,2,3) $ FORECAST NF=24 NT=(296) $ b34srun$ b34sexec matrix; call loaddata; call autobj(gasout :smodeln 'test.mod' :ar index(1 2 3 ) :print :nac 200 :npac 24 :forecast index(24 296) ); /$ call tabulate(%fcast,%foreobs,%fse %fpsi); b34srun; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call autobj(gasout :smodeln 'test.mod' :noest :print :forecast index(24 296) ); b34srun; == ==AUTOBJ_3 Estimation under user Control /; Estimation under user Control /; Two ways to perfdorm same function /; Matrix command allows graphs using rtest b34sexec options ginclude('gas.b34'); b34srun; B34SEXEC BJEST ; MODEL GASout$ MODELN P=(1,2,3) dif(1,1); FORECAST NF=24 NT=(296) $ b34srun$ b34sexec matrix; call loaddata; call load(rtest); call autobj(gasout :smodeln 'test.mod' :ar index(1 2 3) :dif index(1 1) :print :nac 24 :npac 12 :forecast index(24 296) ); call tabulate(%fcast,%foreobs,%fse %fpsi); call rtest(%res,gasout,48); b34srun; == ==AUTOBJ_4 Test of Rensel series /; /; Test problems from Box-Jenkins-Rensel (1994) page 255 /; b34sexec options ginclude('b34sdata.mac') member(bj_a); b34srun; %b34slet dosca =1; %b34slet dobjest=0; %b34sif(&dobjest.eq.1)%then; b34sexec bjest; model y; modeln p=(1) q=(1) avepa=.5; /; difference models b34sexec bjest; model y; modeln dif=(1,1) q=(1) ; b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(rtest); call autobj(y :autobuild :print); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima y. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; /; b34sexec options ginclude('b34sdata.mac') member(bj_b1); b34srun; %b34sif(&dobjest.eq.1)%then; /; difference models b34sexec bjest; model ibm; modeln dif=(1,1) q=(1) ; b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(rtest); call autobj(ibm :autobuild :print); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima ibm. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; /; b34sexec options ginclude('b34sdata.mac') member(bj_c ); b34srun; %b34sif(&dobjest.eq.1)%then; b34sexec bjest; model chem; modeln dif=(1,1) p=(1); b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(rtest); call autobj(chem :autobuild :print); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima chem. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; b34sexec options ginclude('b34sdata.mac') member(bj_d ); b34srun; %b34sif(&dobjest.eq.1)%then; b34sexec bjest; model chemv; modeln p=(1) avepa=.5; b34srun; /; difference models b34sexec bjest; model chemv; modeln dif=(1,1) q=(1) ; b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(rtest); call autobj(chemv :autobuild :print); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima chemv. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; b34sexec options ginclude('b34sdata.mac') member(bj_e ); b34srun; %b34sif(&dobjest.eq.1)%then; b34sexec bjest; model wolfer; modeln p=(1,2) avepa=.5; b34srun; /; model 2 b34sexec bjest; model wolfer; modeln p=(1,2,3) avepa=.5; b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(rtest); call autobj(wolfer :autobuild :print); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima wolfer. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; b34sexec options ginclude('b34sdata.mac') member(bj_f ); b34srun; %b34sif(&dobjest.eq.1)%then; b34sexec bjest; model chemyld; modeln p=(1,2) avepa=.5; b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(rtest); call autobj(chemyld :autobuild :print); b34srun; %b34sif(&dosca.eq.1)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. iarima chemyld. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dounix('rm sca.cmd','rm sca.out','rm sca.dat') dodos('erase sca.cmd','erase sca.out','erase sca.dat') $ b34srun$ %b34sendif; == ==AUTOBJ_5 Tests using Generated Data /$ /$ Generates Data and estimates. Used for speed tests /$ b34sexec matrix; call load(rtest); call echooff; nob=1000; do i=1,nob; ma=array(:-.6,-.3,0.,.19); ar=array(:.4); n=1000; start=array(:.08); test1=genarma(ar,ma,1.0,start,2.,n); /$ call graph(test1); call autobj(test1 :autobuild :startvalue .01 /$ :print :printsteps :nac 24 :npac 24); if(kind(%res).eq.-99)call print('Fail for dataset ',i); enddo; /$ call rtest(%res,test1,48); b34srun; == ==AUTOBJ_6 Moving Forecast of US Retail Data b34sexec options ginclude('b34sdata.mac') member(retail); b34srun; b34sexec matrix; call loaddata; call load(movebj); call print(movebj); call echooff; nout=1; iseas=12; ibegin=200; iprint=0; irdif=0; isdif=0; iwindow=0; call movebj(applance,iseas,ibegin,actual,fore,obs,nout,iprint, irdif,isdif,iwindow); call tabulate(obs,actual,fore); call graph(obs fore,actual :plottype xyplot :nolabel :heading '1 step ahead moving forecast'); nout=3; call movebj(applance,iseas,ibegin,actual,fore,obs,nout,iprint, irdif,isdif,iwindow); call tabulate(obs,actual,fore); call graph(obs fore,actual :plottype xyplot :nolabel :heading '3 step ahead moving forecast'); b34srun; == ==AUTOBJ_7 Estimates AR(p) Model two ways /; /; Shows AR model done two ways. Shows Modern B-J Code will /; track closely modern OLSQ code even though one solves /; beta =((X'X)**-1)*X'y while other uses a NLSQ zero finder. /; As noted by McCullough(1997) in his review of RATS this was not /; always the case. /; /; Improvements such as real*8 for the nonlinear solver used by B-J /; in their original paper and Linpack in the nonlinear solver are /; the reason for this imporvement. An addition improvement is real*8 /; data storage /; /; Shows OLSQ command, B-J Code and the IMSL ARMA code with /; Backforecasting /; turned off. /; b34sexec options ginclude('b34sdata.mac') member(retail); b34srun; b34sexec matrix; call loaddata; call olsq(applance applance{1 to 6} :print); call autobj(applance :nac 36 :ar index(1 2 3 4 5 6) :print :assumptions); /$ /$ Test IMSL Code /$ call arma(applance :nar 6 :maxit 8000 :maxbc 0 :itprint :print); b34srun; == ==AUTOCOV Tests AUTOCOV b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call load(autocov); call autocov(gasout,aa,norows(gasout)/2); aatest=acf(gasout,norows(gasout)/2); call tabulate(aa,aatest); call graph(aatest :heading 'ACF'); call graph(aa :heading 'Autocovariance'); b34srun; == ==BACKSPACE Backspace a unit b34sexec matrix; /$ /$ Notes: After the call copyf unit 6 has hit an end of file. /$ The call backspace(6); makes this file able to be /$ written. The call to echooff; is needed since /$ the call to rewind will be echoed in the output /$ file before the backspace is given and cause /$ problems!! /$ x=rn(matrix(4,4:)); xi=inv(x); call print(x,xi); call open(77,'b34sout.out'); call rewind(77); call echooff; call copyf(6,77); call backspace(6); call echoon; b34srun; == ==BAG Preliminary setup /; /; Implements bagging. Shows only 5 bags but the datasets in both the /; bag and oob datasets. /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; /; b34sexec matrix; call loaddata; call load(polyfit); call load(polyval); call load(gamfore ); call load(bag); call echooff; /; itype=0 => ols /; itype=1 => gam /; itype=2 => l1 /; itype=3 => minimax /; call print(catcol(y,x)); call olsq(lnq time lnl lnk lnrm2 :print :savex); corrbase=ccf(%y,%yhat); call print(' ':); call print('Correlation of y and yhat ',corrbase:); ntry=5; itype=0; iprint=0; iprintb=1; iprintc=1; iprintx=1; igraph=0; e=.66667; basedf=ARRAY(: 1. 3. 3. 3.); class_k=0; /; basedf=':alpha 0.'; /; do itype=4,4; do itype=0,3; call bag_mod(%y,%x,%names,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); enddo; b34srun; == ==BDS Tests BDS Statistic using LeBarron Data b34sexec options ginclude('b34sdata.mac') member(blake); b34srun; b34sexec matrix; call loaddata; call print('Results should be:' ' 2 3 4 5 ' ' -.086613 -1.6219 -1.8737 -1.2281'); call bds(blake,.5,5,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; == ==BDS2 BDS Tests using Patterson Data & Gas Data b34sexec options ginclude('b34sdata.mac') member(apdata); b34srun; b34sexec matrix; call loaddata; call bds(gnp,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; /$ /$ Gas Data Tests /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call bds(gasout,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; == ==BDS3 Sensitivity BDS tests b34sexec options ginclude('b34sdata.mac') member(apdata); b34srun; b34sexec matrix; call loaddata; call bds(gnp,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gnp,1.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gnp,2.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); e=.8; do i=1,30; call print('Runs with ',e); call bds(gnp,e,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); e=e+.01; enddo; b34srun; /$ /$ Gas Data Tests /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call bds(gasout,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gasout,1.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gasout,2.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; b34sexec options ginclude('b34sdata.mac') member(blake); b34srun; b34sexec matrix; call loaddata; call bds(blake,.5,5,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); eps=.45; delta=.01; m=10; for i=1,50; eps=eps+delta; call bds(blake,eps,m:); next i; b34srun; == ==BETAPROB Probability of beta distribution b34sexec matrix; * problem from IMSL page 914 ; pin=12.0; qin=12.0; x=.6; p=betaprob(x,pin,qin); call print('Probability x is less than 6.',p); call print('Answer should have been .8364'); tt=p-betaprob(.5,pin,qin); call print('Probability x is between .5 and .6',tt); call print('Answer should have been .3364'); b34srun; == ==BJ_IDEN List / Plot ACF and PACF b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(bj_iden); call echooff; call bj_iden(gasout,220,'Series => gasout',1,'raw_test.wmf'); call olsq(gasout gasout{1 to 12}); call bj_iden(%RES,220,'Series => Residuals of AR(12) gasout Model',1, 'resid_test.wmf'); b34srun; == ==BJ_IDEN2 Fractional Difference tests /; /; 1. Fractional difference for + and i of two series /; 2. use GHP test and ACF to inspect /; 3. Test how many obs needed for GPH test for positive and /; negative d to be detected. /; /; Note: If d set < 0 then the resulting series is differenced /; with d > 0 since original series was white noise!! /; b34sexec matrix; call loaddata; call load(gph :staging); call load(bj_iden); call echooff; * Testing with random numbers; n=10000; d=2.5/3.; x=rn(array(n:)); fx1=fracdif(x,d,100); call print('d set as ',d); call gph(fx1,.5,d_est,se,se2,1); call bj_iden(fx1,500,'Series => Fractional Diff series -2.5/3',1, 'f_diff_series1.wmf'); /; d=(-1.)*d; fx2=fracdif(x,d,100); call print('d set as ',d); call gph(fx2,.5,d_est,se,se2,1); call bj_iden(fx2,500,'Series => Fractional Diff series 2.5/3',1, 'f_diff_series1.wmf'); b34srun; == ==B_G_TEST Breusch-Godfrey (1978) Residual Test /; /; Test Case From Greene (2000) page 541 /; See Discussion in Greene (2004) page 269 concerning if the /; 0.0 should be placed in the data matrix OR obs dropped. /; /; Shows RATS Variant /; %b34slet runrats=0; b34sexec options ginclude('greene.mac') member(a13_1); b34srun; b34sexec matrix; call loaddata; call load(b_g_test); call echooff; call olsq(realnvst realgnp realint :print :savex); call print(' ':); do iorder=1,4; call B_G_test(iorder,%x,%res,gbtest,gbprob,1,0); enddo; call print('Greene(2000) page 541 gives lag (4) gets',12.068:); b34srun; %b34sif(&runrats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * See Rats Version 6 User Guide (2004) page 224 linreg realnvst / resids # constant realgnp realint linreg realnvst # constant realgnp realint resids{1} cdf(title='Breusch-Godfrey SC Test lag 1') chisqr %trsq 1 linreg realnvst # constant realgnp realint resids{1 to 2} cdf(title='Breusch-Godfrey SC Test lag 2') chisqr %trsq 2 linreg realnvst # constant realgnp realint resids{1 to 3} cdf(title='Breusch-Godfrey SC Test lag 3') chisqr %trsq 3 linreg realnvst # constant realgnp realint resids{1 to 4} cdf(title='Breusch-Godfrey SC Test lag 4') chisqr %trsq 4 b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==BESTREG_1 BESTREG and STEPWISE Problem 1 b34sexec options ginclude('b34sdata.mac') member(draper_s_b); b34srun; b34sexec matrix; call loaddata; iprint2=0; call olsq(y x1 x2 x3 x4 :print); call stepwise(y x1 x2 x3 x4 :print :printsteps); if(iprint2.ne.0) call print( %means %nvar %cov %scale %hist %iend %aov %coef %swept ); call bestreg (y x1 x2 x3 x4 :print); if(iprint2.ne.0) call print(%cov, %nvar, %nsize, %nbest, %ngood, %means, %ivarx, %crit, %ivarx, %indvar, %icoefx, %ntbest, %coef ); call print('Using Criterion of Adjusted R^2 ':); call print('_______________________________ ':); call bestreg (y x1 x2 x3 x4 :crit 2 :print ); call print('Using Criterion of Mallows C(p) ':); call print('_______________________________ ':); call bestreg (y x1 x2 x3 x4 :crit 3 :print ); call print('Using Criterion of Adjusted R^2 but limited to 3':); call print('________________________________________________':); /; Note: :crit -3 will attampt a math operation. The function sfam( ) /; forces generation of a temp call bestreg (y x1 x2 x3 x4 :crit sfam(-3) :print); b34srun; == ==BESTREG_2 BESTREG and STEPWISE Problem 2 /; Looks at a way too big problem b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; nlag=20; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call stepwise(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call bestreg(gasout gasout{1 to nlag} gasin{1 to nlag} :print); b34srun; == ==BESTREG_3 Looks at listing of coef /; shows coef variation b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; nlag=6; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call bestreg(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call names(all); call print(%coef); i=ranker(%coef(,1)); holdcoef=%coef(i,); call print(holdcoef); b34srun; == ==B_G_ALT Breusch-Godfrey (1978) Residual Test with dropping /; /; Test Case From Greene (2000) page 541 /; See Discussion in Greene (2004) page 269 concerning if the /; 0.0 should be placed in the data matrix OR obs dropped. /; /; Shows RATS Variant /; %b34slet runrats=0; b34sexec options ginclude('greene.mac') member(a13_1); b34srun; b34sexec matrix; call loaddata; call load(b_g_alt); call echooff; call olsq(realnvst realgnp realint :print :savex); call print(' ':); do iorder=1,4; call B_G_alt(iorder,%x,%res,gbtest,gbprob,1,0); enddo; b34srun; %b34sif(&runrats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * See Rats Version 6 User Guide (2004) page 224 linreg realnvst / resids # constant realgnp realint linreg realnvst # constant realgnp realint resids{1} cdf(title='Breusch-Godfrey SC Test lag 1') chisqr %trsq 1 linreg realnvst # constant realgnp realint resids{1 to 2} cdf(title='Breusch-Godfrey SC Test lag 2') chisqr %trsq 2 linreg realnvst # constant realgnp realint resids{1 to 3} cdf(title='Breusch-Godfrey SC Test lag 3') chisqr %trsq 3 linreg realnvst # constant realgnp realint resids{1 to 4} cdf(title='Breusch-Godfrey SC Test lag 4') chisqr %trsq 4 b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==BGARCH_A Diagonal constant Constant Correlation BGARCH Model /$ /$ Illustrates BGARCH with RATS /$ with a user FORTRAN model file which gives speed /$ and great power to try alternative models and the /$ BGARCH command which is very easy to use /$ /$ Model is bivariate diagonal constant correlation model /$ /$ See Tasy (2001) page 367 Example 9.20 /$ /$ dorange setup so all three programs get same answer /$ /$ Note: User may need to change include file name %b34slet ibatch =%b34sget(ib34sg,ibatch,1) $ b34sexec scaio readsca %b34sif(&ibatch.ne.4)%then; file('/usr/local/lib/b34slm/findat01.mad') %b34sendif; %b34sif(&ibatch.ne.6)%then; file('c:\b34slm\examples\findat01.mad') %b34sendif; dataset(d_HKJA); b34srun; /$ Option 1 uses bgarch /$ Option 2 uses fortran %b34slet dob34s1 = 1; /; /; If Fortran is called include must be set for platform used /; %b34slet dob34s2 = 0; %b34slet dorats = 0; %b34sif(&dob34s1.eq.1)%then; b34sexec matrix; call loaddata; count=0.0; call echooff; program test; zero=0.0d+00; call bgarch(res1,res2,arch1,arch2,data1,data2,func,7,nbad :ar11 array(:p6) index(6) :constant array(:zero,zero,a0,b0) :gma11 array(:a1) index(1) :gar11 array(:a2) index(1) :gma22 array(:b1) index(1) :gar22 array(:b2) index(1) :dorange index(8,469) :rho array(:rho)); count=count+1.0; call outdouble(10,1 , func); call outdouble(10,2 , count); call outdouble(10,3, p6); call outdouble(10,4, a0); call outdouble(10,5, b0); call outdouble(10,6, a1); call outdouble(10,7, a2); call outdouble(10,8, b1); call outdouble(10,9, b2); call outdouble(10,10, rho); return; end; call print(test); j=integers(1,469); data1 = ln_hk(j); data2 = ln_ja(j); arch1 = data1*0.0 ; arch2 = data1*0.0 ; res1 = data1 ; res2 = data2 ; /$ a0 = .1, a1 = .1, a2 = .4, b0 = .1, b1 = .2, b2 = .6 /$ p6 = .1, rho = 0.1 call cmaxf2(func :name test :parms p6 a0 b0 a1 a2 b1 b2 rho :ivalue array(:.1 .1 .1 .1 .4 .1 .6 .1) :maxit 300 :gradtol .1e-4 :lower array(:-.5 ,.1d-12,.1d-12,.1d-12,.1d-12,.1d-12,.1d-12,.1d-12) :upper array(:.1d+30,.1d+30,.1d+30,.1d+30,.1d+30,.1d+30,.1d+30,.1d+30) :print); /$ call tabulate(data1,data2,res1,res2,arch1,arch2); b34srun; %b34sendif; %b34sif(&dob34s2.eq.1)%then; /$ Place Fortran on unit 4 /$ Here Fortran cannot be written on the fly with the /$ Matrix Command BUT Fortran is easier to see!! b34sexec matrix; call loaddata; /$ /$ Load Fortran /$ pgmcards; /$3456789012345678901234567890 c c BLAS service routines. W2K and Unix hooks supplied include 'c:\b34slm\blashold.f' c include '/usr/local/lib/b34slm/blashold.f' c implicit real*8(a-h,o-z) parameter(nn=10000) dimension data1(nn) dimension data2(nn) dimension gdet(nn) dimension res1(nn) dimension res2(nn) dimension arch1(nn) dimension arch2(nn) dimension parm(100) call dcopy(nn,0.0d+00,0,gdet,1) call dcopy(nn,0.0d+00,0,data1,1) call dcopy(nn,0.0d+00,0,data2,1) call dcopy(nn,0.0d+00,0,res1 ,1) call dcopy(nn,0.0d+00,0,res2 ,1) call dcopy(nn,0.0d+00,0,arch1,1) call dcopy(nn,0.0d+00,0,arch2,1) open(unit=8,file='data.dat') open(unit=9,file='tdata.dat') read(8,*)nob read(8,*)(data1(ii),ii=1,nob) read(8,*)(data2(ii),ii=1,nob) read(9,*)npar read(9,*)(parm(ii),ii=1,npar) read(9,*) arch1(1) read(9,*) arch2(1) close(unit=9) c :parms p6 a0 a1 a2 b0 b1 b2 rho func=0.0d+00 call dcopy(469,data1,1,res1,1) call dcopy(469,data2,1,res2,1) c c top replicates RATS which sets initial values to c 0.0 .... c do i=8 ,469 c do i=1 ,469 if(i.gt.6)res1(i)= data1(i)-parm(1)*data1(i-6) res2(i)= data2(i) if(i.gt.1)arch1(i) = * parm(2)+parm(3)*res1(i-1)**2+parm(4)*arch1(i-1) if(i.gt.1)arch2(i) = * parm(5)+parm(6)*res2(i-1)**2+parm(7)*arch2(i-1) c if(i.ge.8)then part0=(dlog(arch1(i))+dlog(arch2(i))+dlog(1.0-parm(8)**2)) part1=((res1(i)**2/arch1(i)) + (res2(i)**2/arch2(i))) part2=(2.0d+00*parm(8)*res1(i)*res2(i))/dsqrt(arch1(i)*arch2(i)) func=func -(.5d+00*part0) * -(.5d+00*((part1-part2)/(1.0d+00 - parm(8)**2))) endif c enddo c close(unit=8) open(unit=8,file='testout') write(8,fmt='(e25.16)')func close(unit=8) stop end b34sreturn; /$ This section compiles Fortran and gets ready to go /$ Setup fortran parm=array(8:); call open(70,'_test.f'); call rewind(70); call rewind(4); call copyf(4,70); call close(70); maxlag=0 ; j=integers(469) ; data1=ln_hk(j) ; data2=ln_ja(j) ; arch1=array(norows(data1):); arch2=array(norows(data2):); * compile fortran and save data; /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f'); * call dounix('g77 _test.f -o_test'); call dounix('lf95 _test.f -o_test'); * call dounix('fortcl _test.f -o_test'); call copyout('_test.lst'); call open(72,'data.dat'); call rewind(72); call write(norows(data1),72); call write(data1,72,'(3e25.16)'); call write(data2,72,'(3e25.16)'); call close(72); count=0.0; call echooff; program test; call open(72,'tdata.dat'); call rewind(72); npar=8; call write(npar,72); call write(parm,72,'(e25.16)'); arch1(1)=0.0d+00 ; call write(arch1(1),72,'(e25.16)'); arch2(1)=0.0d+00 ; call write(arch2(1),72,'(e25.16)'); call close(72); call dodos('_test'); call dounix('./_test '); call open(71,'testout'); func=0.0; call read(func,71); call close(71); /$ These optional statements slow things down /$ but help us understand the model count=count+1.0; call outdouble(10,1 , func); call outdouble(10,2 , count); call outdouble(10,3, parm(1)); call outdouble(10,4, parm(2)); call outdouble(10,5, parm(3)); call outdouble(10,6, parm(4)); call outdouble(10,7, parm(5)); call outdouble(10,8, parm(6)); call outdouble(10,9, parm(7)); call outdouble(10,10, parm(8)); return; end; call print(test); call cmaxf2(func :name test :parms parm :ivalue array(:.1 .1 .1 .4 .1 .1 .6 .1) :maxit 300 /$ :gradtol .1e-4 :lower array(: -.5 ,.1d-12,.1d-12,.1d-12,.1d-12,.1d-12,.1d-12,.1d-12) :upper array(: .1d+30,.1d+30,.1d+30,.1d+30,.1d+30,.1d+30,.1d+30,.1d+30) :print); b34srun; %b34sendif; %b34sif(&dorats.eq.1)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ ** Example 9.1 (** Only the first 469 data points are used **) * all 0 491:1 * open data hkja.dat * data(org=obs) / r1 r2 * Book example 9.20 page 367 set r1 = ln_hk set r2 = ln_ja set h1 = 0.0 set h2 = 0.0 nonlin p6 a0 a1 a2 b0 b1 b2 rho frml a1t = r1(t)-p6*r1(t-6) frml a2t = r2(t) frml gvar1 = a0+a1*a1t(t-1)**2+a2*h1(t-1) frml gvar2 = b0+b1*a2t(t-1)**2+b2*h2(t-1) frml gdet = -0.5*(log(h1(t)=gvar1(t))+log(h2(t)=gvar2(t)) $ + log(1.0-rho**2)) frml garchln = gdet-0.5*((a1t(t)**2/h1(t))+(a2t(t)**2/h2(t)) $ -2*rho*a1t(t)*a2t(t)/sqrt(h1(t)*h2(t)))/(1.0-rho**2) smpl 8 469 compute a0 = .1, a1 = .1, a2 = .4, b0 = .1, b1 = .2, b2 = .6 compute p6 = .1, rho = 0.1 *nlpar(criterion=value,cvcrit=0.000001) maximize(method=bhhh,recursive,iterations=150) garchln set fv1 = gvar1(t) set resid = a1t(t)/sqrt(fv1(t)) set residsq = resid(t)*resid(t) *** Checking standardized residuals *** cor(qstats,number=12,span=4) resid *** Checking squared standardized residuals *** cor(qstats,number=12,span=4) residsq set fv2 = gvar2(t) set resi = a2t(t)/sqrt(fv2(t)) set residsq = resi(t)*resi(t) *** Checking standardized residuals *** cor(qstats,number=12,span=4) resi *** Checking squared standardized residuals *** cor(qstats,number=12,span=4) residsq *** standardized residuals *** * print 8 469 resid resi b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==BGARCH_B Constant Correlation Example 9.2, 9.22 page 369 /$ /$ Illustrates BGARCH with RATS /$ with a user FORTRAN model file which gives speed /$ and great power to try alternative models and the /$ BGARCH command which is very easy to use /$ %b34slet ibatch =%b34sget(ib34sg,ibatch,1) $ b34sexec scaio readsca %b34sif(&ibatch.ne.4)%then; file('/usr/local/lib/b34slm/findat01.mad') %b34sendif; %b34sif(&ibatch.ne.6)%then; file('c:\b34slm\examples\findat01.mad') %b34sendif; dataset(M_IBMLN2); b34srun; /$ See Tsay(2001) page 368 Example 9.2 Equation 9.22 /$ Note that B34S slightly "beats" rats /$ # 1 => use bgarch 131 sec /$ # 2 => use fortran 231 sec %b34slet dob34s1 = 1; /; /; If Fortran is called include must be set for platform used /; %b34slet dob34s2 = 0; %b34slet dorats = 0; /$ Uses BGARCH %b34sif(&dob34s1.eq.1)%then; b34sexec matrix; call loaddata; program test; /$ /$ Rats setup info /$ /$ c1 p11 p22 p12 c2 a0 a11 b11 b12 b0 a21 a22 b21 b22 rho /$ a1t=r1(t)-c1-p11*r1{1}-p22*r1{2}-p12*r2{2} /$ a2t=r2(t)-c2 /$ gvar1=a0+a11*a1t(t-1)**2+b11*h1(t-1)+b12*h2(t-1) /$ gvar2=b0+a21*a1t(t-1)**2+a22*a2t(t-1)**2+b21*h1(t-1)+b22*h2(t-1) /$ gdet=-0.5*(log(h1(t)=gvar1(t))+log(h2(t)=gvar2(t))+log(1.0-rho**2)) /$ garchln = gdet-0.5/(1.0-rho**2)*((a1t(t)**2/h1(t))+(a2t(t)**2/h2(t)) /$ -2*rho*a1t(t)*a2t(t)/sqrt(h1(t)*h2(t))) call bgarch(res1,res2,arch1,arch2,data1,data2,func,3,nbad :ar11 array(:p11 p22) index(1 2) :ar12 array(:p12) index(2) :gma11 array(:a11) index(1) :gar11 array(:b11) index(1) :gar12 array(:b12) index(1) :gma22 array(:a22) index(1) :gma21 array(:a21) index(1) :gar21 array(:b21) index(1) :gar22 array(:b22) index(1) :rho array(:rho) :dorange index(3,888) :constant array(:c1 c2 a0 b0)); count=count+1.0; call outdouble(10,1 , func); call outdouble(10,2 , count); call outdouble(10,3, c1); call outdouble(10,4, p11); call outdouble(10,5, p22); call outdouble(10,6, p12); call outdouble(10,7, c2); call outdouble(10,8, a0); call outdouble(10,9, a11); call outdouble(40,1, b11); call outdouble(40,2, b12); call outdouble(40,3, b0); call outdouble(40,4, a21); call outdouble(40,5, a22); call outdouble(40,6, b21); call outdouble(40,7, b22); call outdouble(40,8, rho); return; end; call print(test); /$ c1 = 1.4, c2 = 0.7, p11 = 0.1, p22 = 0.1, p12 = -0.1 /$ a0 = 3.0, a11=0.1, a21=0.02, a22=0.05 /$ b0=2.0, b11=.8, b12=.01, b21=.01, b22=.8, rho = 0.1 count=0.0; j=integers(1,888); data1=ibmln(j); data2=spln(j); call echooff; call cmaxf2(func :name test :parms c1 p11 p22 p12 c2 a0 a11 b11 b12 b0 a21 a22 b21 b22 rho :ivalue array(:1.4, .1, .1, -.1, .7 3.0, .1, .8, .01, 2.0, .02, .05,.01, .8, .1) :maxit 30000 :maxfun 30000 /$ /$ Rats Names /$ c1 p11 p22 p12 c2 /$ a0 a11 b11 b12 b0 /$ a21 a22 b21 b22 rho /$ :lower array(:.1d-12,.1d-12,.1d-12,-.2, .1d-12, .1d-12,.1d-12,.1d-12,-.06, .1d-12, .1d-12,.1d-12,-.1, .1d-12,.1d-12) :upper array(:.1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3) :print); b34srun; %b34sendif; %b34sif(&dob34s2.eq.1)%then; /$ Place Fortran on unit 4 /$ Here Fortran cannot be written on the fly with the /$ Matrix Command BUT Fortran is easier to see!! b34sexec matrix; call loaddata; /$ /$ Load Fortran /$ pgmcards; /$3456789012345678901234567890 c c BLAS service routines. W2K and Unix hooks supplied include 'c:\b34slm\blashold.f' c include '/usr/local/lib/b34slm/blashold.f' c implicit real*8(a-h,o-z) parameter(nn=10000) dimension data1(nn) dimension data2(nn) dimension res1(nn) dimension res2(nn) dimension arch1(nn) dimension arch2(nn) dimension parm(100) call dcopy(nn,0.0d+00,0,data1,1) call dcopy(nn,0.0d+00,0,data2,1) call dcopy(nn,0.0d+00,0,res1 ,1) call dcopy(nn,0.0d+00,0,res2 ,1) call dcopy(nn,0.0d+00,0,arch1,1) call dcopy(nn,0.0d+00,0,arch2,1) open(unit=8,file='data.dat') open(unit=9,file='tdata.dat') read(8,*)nob read(8,*)(data1(ii),ii=1,nob) read(8,*)(data2(ii),ii=1,nob) read(8,*)(res1(ii),ii=1,nob) read(8,*)(res2(ii),ii=1,nob) read(8,*)(arch1(ii),ii=1,nob) read(8,*)(arch2(ii),ii=1,nob) read(9,*)npar read(9,*)(parm(ii),ii=1,npar) close(unit=9) c func=0.0d+00 c do i=3 ,nob res1(i) =data1(i)-parm(1)-parm(2)*data1(i-1)-parm(3)*data1(i-2) * -parm(4)*data2(i-2) res2(i) =data2(i)-parm(5) arch1(i)=parm(6)+ parm(7)*res1(i-1)**2 * + parm(8)*arch1(i-1) + parm(9)*arch2(i-1) arch2(i)=parm(10)+parm(11)*res1(i-1)**2 + parm(12)*res2(i-1)**2 * +parm(13)*arch1(i-1) + parm(14)*arch2(i-1) c if(i.ge.4)then part0=(dlog(arch1(i))+dlog(arch2(i))+dlog(1.0-parm(15)**2)) part1=((res1(i)**2/arch1(i)) + (res2(i)**2/arch2(i))) part2=(2.0d+00*parm(15)*res1(i)*res2(i))/dsqrt(arch1(i)*arch2(i)) func=func -(.5d+00*part0) * -(.5d+00*((part1-part2)/(1.0d+00 - parm(15)**2))) endif enddo c rewind(unit=8) write(8,*)nob write(8,fmt='(3e25.16)')(data1(ii),ii=1,nob) write(8,fmt='(3e25.16)')(data2(ii),ii=1,nob) write(8,fmt='(3e25.16)')(res1(ii),ii=1,nob) write(8,fmt='(3e25.16)')(res2(ii),ii=1,nob) write(8,fmt='(3e25.16)')(arch1(ii),ii=1,nob) write(8,fmt='(3e25.16)')(arch2(ii),ii=1,nob) close(unit=8) open(unit=8,file='testout') write(8,fmt='(e25.16)')func close(unit=8) stop end b34sreturn; /$ This section compiles Fortran and gets ready to go /$ Setup fortran parm=array(15:); call open(70,'_test.f'); call rewind(70); call rewind(4); call copyf(4,70); call close(70); maxlag=0 ; j=integers(888) ; data1=ibmln(j) ; data2=spln(j) ; arch1=array(norows(data1):); arch2=array(norows(data2):); * compile fortran and save data; /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f'); * call dounix('g77 _test.f -o_test'); call dounix('lf95 _test.f -o_test'); * call dounix('fortcl _test.f -o_test'); call copyout('_test.lst'); call open(72,'data.dat'); call rewind(72); call write(norows(data1),72); call write(data1,72,'(3e25.16)'); call write(data2,72,'(3e25.16)'); call write(arch1,72,'(3e25.16)'); call write(arch2,72,'(3e25.16)'); call write(arch1,72,'(3e25.16)'); call write(arch2,72,'(3e25.16)'); call close(72); count=0.0; call echooff; program test; call open(72,'tdata.dat'); call rewind(72); npar=15; call write(npar,72); call write(parm,72,'(3e25.16)'); call close(72); call dodos('_test'); call dounix('./_test '); call open(71,'testout'); func=0.0; call read(func,71); call close(71); /$ These optional statements slow things down /$ but help us understand the model count=count+1.0; call outdouble(10,1 , func); call outdouble(10,2 , count); call outdouble(10,3, parm(1)); call outdouble(10,4, parm(2)); call outdouble(10,5, parm(3)); call outdouble(10,6, parm(4)); call outdouble(10,7, parm(5)); call outdouble(10,8, parm(6)); call outdouble(10,9, parm(7)); call outdouble(40,1, parm(8)); call outdouble(40,2, parm(9)); call outdouble(40,3, parm(10)); call outdouble(40,4, parm(11)); call outdouble(40,5, parm(12)); call outdouble(40,6, parm(13)); call outdouble(40,7, parm(14)); call outdouble(40,8, parm(15)); return; end; call print(test); /$ c1 = 1.4, c2 = 0.7, p11 = 0.1, p22 = 0.1, p12 = -0.1 /$ a0 = 3.0, a11=0.1, a21=0.02, a22=0.05 /$ b0=2.0, b11=.8, b12=.01, b21=.01, b22=.8, rho = 0.1 call cmaxf2(func :name test :parms parm :ivalue array(:1.4, .1, .1, -.1, .7 3.0, .1, .8, .01, 2.0, .02, .05,.01, .8, .1) :maxit 30000 :maxfun 30000 /$ /$ Rats Names /$ c1 p11 p22 p12 c2 /$ a0 a11 b11 b12 b0 /$ a21 a22 b21 b22 rho /$ :lower array(:.1d-12,.1d-12,.1d-12,-.2, .1d-12, .1d-12,.1d-12,.1d-12,-.06, .1d-12, .1d-12,.1d-12,-.1, .1d-12,.1d-12) :upper array(:.1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3) :print); b34srun; %b34sendif; %b34sif(&dorats.eq.1)%then; %b34slet dob34s = 0; %b34slet dorats = 1; %b34sif(&dorats.eq.1)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ ** Example 9.2: constant correlation coefficient ** * all 0 888:1 * open data m-ibmspln.dat * data(org=obs) / r1 r2 * Book 9.22 Page 369 set r1 = ibmln set r2 = spln set h1 = 0.0 set h2 = 0.0 nonlin c1 p11 p22 p12 c2 a0 a11 b11 b12 b0 a21 a22 b21 b22 rho frml a1t = r1(t)-c1-p11*r1{1}-p22*r1{2}-p12*r2{2} frml a2t = r2(t)-c2 frml gvar1 = a0+a11*a1t(t-1)**2+b11*h1(t-1)+b12*h2(t-1) frml gvar2 = b0+a21*a1t(t-1)**2+a22*a2t(t-1)**2+b21*h1(t-1)+b22*h2(t-1) frml gdet = -0.5*(log(h1(t)=gvar1(t))+log(h2(t)=gvar2(t))+log(1.0-rho**2)) frml garchln = gdet-0.5/(1.0-rho**2)*((a1t(t)**2/h1(t))+(a2t(t)**2/h2(t)) $ -2*rho*a1t(t)*a2t(t)/sqrt(h1(t)*h2(t))) smpl 4 888 compute c1 = 1.4, c2 = 0.7, p11 = 0.1, p22 = 0.1, p12 = -0.1 compute a0 = 3.0, a11=0.1, a21=0.02, a22=0.05 compute b0=2.0, b11=.8, b12=.01, b21=.01, b22=.8, rho = 0.1 * maximize(method=simplex,iterations=10) garchln maximize(method=bhhh,recursive,iterations=150) garchln set fv1 = gvar1(t) set resi1 = a1t(t)/sqrt(fv1(t)) set residsq = resi1(t)*resi1(t) *** Checking standardized residuals *** cor(qstats,number=20,span=4) resi1 *** Checking squared standardized residuals *** cor(qstats,number=20,span=4) residsq set fv2 = gvar2(t) set resi2 = a2t(t)/sqrt(fv2(t)) set residsq = resi2(t)*resi2(t) *** Checking standardized residuals *** cor(qstats,number=20,span=4) resi2 *** Checking squared standardized residuals *** cor(qstats,number=20,span=4) residsq *** Last few observations needed for forecasts *** set shock1 = a1t(t) set shock2 = a2t(t) print 885 888 shock1 shock2 fv1 fv2 b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==BGARCH_C Time Varrying GARCH Example 9.2 9.24 /$ /$ Job setup to run BGARCH for TV Bivariate GARCH /$ Fortran Implementation also shown /$ RATS implementation shown /$ /$ Default is "stable Model" /$ %b34slet ibatch =%b34sget(ib34sg,ibatch,1) $ /$ # 1 => bgarch /$ # 2 => fortran implementation of BGARCH Model %b34slet dob34s1= 1; /; /; If Fortran is called include must be set for platform used /; %b34slet dob34s2= 0; /$ /$ stable_m = 1 /$ Forces GARCH parameters GE 0.0 /$ Tsay RATS code allows "unstable" models due to /$ unconstrained estimator but gets a "better" F /$ /$ => stable_m =0 => -3678.3455 /$ => stable_m =1 => -3685.0870 %b34slet stable_m=1; %b34slet dorats = 0; b34sexec scaio readsca %b34sif(&ibatch.ne.4)%then; file('/usr/local/lib/b34slm/findat01.mad') %b34sendif; %b34sif(&ibatch.ne.6)%then; file('c:\b34slm\examples\findat01.mad') %b34sendif; dataset(M_IBMLN2); b34srun; %b34sif(&dob34s1.eq.1)%then; b34sexec matrix; call loaddata; program test; /$ /$ Rats setup info and results listed later in job /$ /$ set r1 = ibmln /$ set r2 = spln /$ set h1 = 45.0 /$ set h2 = 31.0 /$ set rho = 0.8 /$ nonlin c1 p1 p3 c2 a0 a1 b1 f1 a00 a11 b11 f11 d11 q0 q1 q2 /$ a1t = r1(t)-c1-p1*r1(t-1)-p3*r2(t-2) /$ a2t = r2(t)-c2 /$ gvar1 = a0+a1*a1t(t-1)**2+b1*h1(t-1)+f1*h2(t-1) /$ gvar2 = a00+a11*a2t(t-1)**2+b11*h2(t-1)+f11*h1(t-1)+d11*a1t(t-1)**2 /$ set up for + rho /$ rh1 = q0 + q1*rho(t-1) + q2*a1t(t-1)*a2t(t-1)/sqrt(h1(t-1)*h2(t-1)) /$ See Tsay page 372 /$ rh = exp(rh1(t))/(1+exp(rh1(t))) /$ *rh = (exp(rh1(t))-1.)/(1+exp(rh1(t))) /$ gdet = -0.5*(log(h1(t)=gvar1(t))+log(h2(t)=gvar2(t)) $ /$ +log(1.0-(rho(t)=rh(t))**2)) /$ garchln = gdet-0.5/(1.0-rho(t)**2)*((a1t(t)**2/h1(t))+ $ /$ (a2t(t)**2/h2(t)) $ /$ -2*rho(t)*a1t(t)*a2t(t)/sqrt(h1(t)*h2(t))) /$ smpl 4 888 /$ call bgarch(res1,res2,arch1,arch2,ibmln,spln,func,3,nbad :ar11 array(:p1) index(1) :ar12 array(:p3) index(2) :gar11 array(:b1) index(1) :gma11 array(:a1) index(1) :gar12 array(:f1) index(1) :gma22 array(:a11) index(1) :gar22 array(:b11) index(1) :gma21 array(:d11) index(1) :gar21 array(:f11) index(1) :rho array(:q0,q1,q2) :tvrho rho :dorange index(3,888) :constant array(:c1 c2 a0 a00)); count=count+1.0; call outdouble(10,1 , func); call outdouble(10,2 , count); call outdouble(10,3, c1); call outdouble(10,4, p1); call outdouble(10,5, p3); call outdouble(10,6, c2); call outdouble(10,7, a0); call outdouble(10,8, a1); call outdouble(10,9, b1); call outdouble(40,1, f1); call outdouble(40,2, a00); call outdouble(40,3, a11); call outdouble(40,4, b11); call outdouble(40,5, f11); call outdouble(40,6, d11); call outdouble(40,7, q0); call outdouble(40,8, q1); call outdouble(40,9, q2); /$ /$ Trap > 0 value and reset /$ if(func.gt.0.0)func=-10.d+9; return; end; call print(test); count=0.0; /$ c1 = 1.4, p1 = 0.1, p3 =-.1 , c2 = .07, a0 = 2.95 /$ a1 = .08 b1 = .87 f1 =-.03 a00= 2.05 a11=.05 /$ b11= .92 f11=-.06 d11=.04 q0 = -2.0 q1 = 3.0 /$ q2 = .1 j=integers(888) ; data1=ibmln(j) ; data2=spln(j) ; res1 =array(norows(data1):); res2 =array(norows(data1):); arch1=array(norows(data1):) + 45.; arch2=array(norows(data2):) + 31.; rho =array(norows(data2):) + .8 ; call echooff; call cmaxf2(func :name test :parms c1 p1 p3 c2 a0 a1 b1 f1 a00 a11 b11 f11 d11 q0 q1 q2 /$ /$ c1, p1, p3, c2, a0 /$ a1, b1, f1, a00, a11 /$ b11 ,f11, d11, q0, q1 /$ q2 /$ Rats Answers reported in Tsay (2001) /$ Note that Tsay allows GARCH parameters to be < 0 !!!! /$ This make problem unstable!!!!! /$ See f1 & f11 /$ /$ 1.3178 .076103 -.068349 .673403 2.79865 /$ .08364 .8642 -.01995 1.7101 .05401 /$ .9139 -.05811 .03711 -2.0239 3.983 /$ .08755 /$ Rats input values /$ :ivalue array(: 1.4, 0.1, -.1 , .07, 2.95, /$ .08, .87, -.03, 2.05, .05, /$ .92, -.06, .04, -2.0, 3.0, /$ .1) /$ Good Values that are close to rats input values except for /$ GARCH parameters which are not allowed to go < 0.0 %b34sif(&stable_m.eq.1)%then; :ivalue array(: 1.4, .08, -.07, .7, 2.95, .08, .87, .01, 2.05, .05, .92, .01, .04, -2.0, 3.0, .1) :lower array(:.1d-12, .1d-12, -.4, .1d-12, .1d-12, .1d-12, .1d-12, .1d-12 .1d-12, .1d-12, .1d-12, .1d-12, .1d-12, -6., .1d-12 .1d-12) %b34sendif; /$ stable_m = 0 case /$ This is poentially an unstable model - "Beats "Tsay result /$ Constrained Maximum Likelihood Estimation using CMAXF2 Command /$ Final Functional Value -3678.345535127345 /$ # of parameters 16 /$ # of good digits in function 15 /$ # of iterations 45 /$ # of function evaluations 65 /$ # of gradiant evaluations 47 /$ Scaled Gradient Tolerance 6.055454452393343E-06 /$ Scaled Step Tolerance 3.666852862501036E-11 /$ Relative Function Tolerance 3.666852862501036E-11 /$ False Convergence Tolerance 2.220446049250313E-14 /$ Maximum allowable step size 5944.190441094565 /$ Size of Initial Trust region -1.000000000000000 /$ /$ # Name Coefficient Standard Error T Value /$ 1 C1 1.3472441 0.20263348 6.6486745 /$ 2 P1 0.72382850E-01 0.26413476E-01 2.7403758 /$ 3 P3 -0.69406324E-01 0.30560697E-01 -2.2710976 /$ 4 C2 0.68647533 0.14197874 4.8350574 /$ 5 A0 2.9204391 0.17943325 16.275908 /$ 6 A1 0.80722164E-01 0.27743460E-02 29.095926 /$ 7 B1 0.86584291 0.42565271E-02 203.41534 /$ 8 F1 -0.20000000E-01 0.39225650E-02 -5.0987046 /$ 9 A00 1.8764756 0.57827853E-01 32.449340 /$ 10 A11 0.54890195E-01 0.73508203E-02 7.4672204 /$ 11 B11 0.91304590 0.11390199E-01 80.160663 /$ 12 F11 -0.60000000E-01 0.26368581E-02 -22.754353 /$ 13 D11 0.36389220E-01 0.19038667E-02 19.113323 /$ 14 Q0 -2.1158934 0.15332942E-01 -137.99657 /$ 15 Q1 4.1581938 0.22055508E-01 188.53312 /$ 16 Q2 0.64026890E-01 0.11224436E-01 5.7042413 /$ /$ /$ ********************************************************************* /$ /$ Rats Tsay setup as listed in Tsay(2001) /$ /$ MAXIMIZE - Estimation by BHHH /$ Convergence in 10 Iterations. /; Final criterion was 0.0000086 < 0.0000100 /$ Usable Observations 885 /$ Function Value -3679.63620302 /$ /$ Variable Coeff Std Error T-Stat Signif /$ ********************************************************************* /$ 1. C1 1.317852631 0.214784518 6.13570 0.00000000 /$ 2. P1 0.076103508 0.025996944 2.92740 0.00341807 /$ 3. P3 -0.068348759 0.033526878 -2.03863 0.04148739 /$ 4. C2 0.673403174 0.150878804 4.46321 0.00000807 /$ 5. A0 2.798653715 0.578651502 4.83651 0.00000132 /$ 6. A1 0.083639381 0.012840261 6.51384 0.00000000 /$ 7. B1 0.864244881 0.021486265 40.22313 0.00000000 /$ 8. F1 -0.019952391 0.008764116 -2.27660 0.02281010 /$ 9. A00 1.710072144 0.395688583 4.32176 0.00001548 /$ 10. A11 0.054012015 0.010054202 5.37208 0.00000008 /$ 11. B11 0.913870237 0.013326620 68.57480 0.00000000 /$ 12. F11 -0.058113856 0.014433037 -4.02645 0.00005663 /$ 13. D11 0.037118203 0.009038689 4.10659 0.00004015 /$ 14. Q0 -2.023943194 0.049564072 -40.83489 0.00000000 /$ 15. Q1 3.983172216 0.090162814 44.17755 0.00000000 /$ 16. Q2 0.087557384 0.018504587 4.73166 0.00000223 /$ /$ /$ This is stable_m = 1 case /$ Here BGARCH terms cannot get LE 0 /$ /$ Constrained Maximum Likelihood Estimation using CMAXF2 Command /$ Final Functional Value -3685.467969101541 /$ # of parameters 16 /$ # of good digits in function 15 /$ # of iterations 144 /$ # of function evaluations 186 /$ # of gradiant evaluations 146 /$ Scaled Gradient Tolerance 6.055454452393343E-06 /$ Scaled Step Tolerance 3.666852862501036E-11 /$ Relative Function Tolerance 3.666852862501036E-11 /$ False Convergence Tolerance 2.220446049250313E-14 /$ Maximum allowable step size 5476.340018662099 /$ Size of Initial Trust region -1.000000000000000 /$ /$ # Name Coefficient Standard Error T Value /$ 1 C1 1.2706486 0.21224026 5.9868406 /$ 2 P1 0.73266435E-01 0.27521738E-01 2.6621297 /$ 3 P3 -0.66693588E-01 0.33909348E-01 -1.9668201 /$ 4 C2 0.65233718 0.14745405 4.4240032 /$ 5 A0 3.0431493 0.77377981 3.9328363 /$ 6 A1 0.89153866E-01 0.20598487E-01 4.3281755 /$ 7 B1 0.84047127 0.35983712E-01 23.356992 /$ 8 F1 0.10000334E-12 0.12085356E-01 0.82747534E-11 /$ 9 A00 0.61756955 0.17958549 3.4388611 /$ 10 A11 0.81668061E-01 0.20730813E-02 39.394529 /$ 11 B11 0.89452196 0.19593245E-01 45.654609 /$ 12 F11 0.99999869E-13 0.42126005E-02 0.23738275E-10 /$ 13 D11 0.10000334E-12 0.51135749E-02 0.19556443E-10 /$ 14 Q0 -2.0278617 0.13194237E-01 -153.69299 /$ 15 Q1 3.9770302 0.25661101E-01 154.98283 /$ 16 Q2 0.10194031 0.35857797E-01 2.8429049 /$ /$ %b34sif(&stable_m.eq.0)%then; /$ /$ These values "beat Tsay" but model is not stable!!! /$ Stokes feels that GARCH mdoels should be estimated with /$ Constraints suggested by theory!! This is not possible with /$ older versions of RATS /$ :ivalue array(: 1.3, .08, -.07, .7, 2.8 , .08, .87, -.01, 1.7 , .05, .91, -.01, .04, -2.0, 4.1, .08) /$ These values suggested by Tsay cause problems /$ :ivalue array(: 1.4, 0.1, -.1 , .07, 2.95, /$ .08, .87, -.03, 2.05, .05, /$ .92, -.06, .04, -2.0, 3.0, /$ .1) :lower array(:.1d-12, .1d-12, -.4, .1d-12, .1d-12, .1d-12, .1d-12, -.02 .1d-12, .1d-12, .1d-12, -.06 .1d-12, -4., .1d-12 .1d-12) %b34sendif; :upper array(:.1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+1, .1d+3 .1d+3) :maxit 30000 :maxfun 30000 :maxg 10000 :print); b34srun; %b34sendif; %b34sif(&dob34s2.eq.1)%then; /$ Place Fortran on unit 4 /$ Here Fortran cannot be written on the fly with the /$ Matrix Command BUT Fortran is easier to see!! b34sexec matrix; call loaddata; /$ /$ Load Fortran /$ pgmcards; /$3456789012345678901234567890 c c BLAS service routines. W2K and Unix hooks supplied include 'c:\b34slm\blashold.f' c include '/usr/local/lib/b34slm/blashold.f' c implicit real*8(a-h,o-z) parameter(nn=10000) dimension data1(nn) dimension data2(nn) dimension res1(nn) dimension res2(nn) dimension arch1(nn) dimension arch2(nn) dimension rho(nn) dimension parm(100) call dcopy(nn,0.0d+00,0,data1,1) call dcopy(nn,0.0d+00,0,data2,1) call dcopy(nn,0.0d+00,0,res1 ,1) call dcopy(nn,0.0d+00,0,res2 ,1) call dcopy(nn,0.0d+00,0,arch1,1) call dcopy(nn,0.0d+00,0,arch2,1) call dcopy(nn,0.0d+00,0,rho,1) open(unit=8,file='data.dat') open(unit=9,file='tdata.dat') read(8,*)nob read(8,*)(data1(ii),ii=1,nob) read(8,*)(data2(ii),ii=1,nob) read(8,*)(res1(ii),ii=1,nob) read(8,*)(res2(ii),ii=1,nob) read(8,*)(arch1(ii),ii=1,nob) read(8,*)(arch2(ii),ii=1,nob) read(8,*)(rho(ii),ii=1,nob) read(9,*)npar read(9,*)(parm(ii),ii=1,npar) close(unit=9) c c c Rats Info c c parms c1 p1 p3 c2 a0 c a1 b1 f1 a00 a11 c b11 f11 d11 q0 q1 q2 c a1t = r1(t)-c1-p1*r1(t-1)-p3*r2(t-2) c a2t = r2(t)-c2 c gvar1 = a0+a1*a1t(t-1)**2+b1*h1(t-1)+f1*h2(t-1) c gvar2 = a00+a11*a2t(t-1)**2+b11*h2(t-1)+f11*h1(t-1)+d11*a1t(t-1)**2 c rh1 = q0 + q1*rho(t-1) + q2*a1t(t-1)*a2t(t-1)/sqrt(h1(t-1)*h2(t-1)) c rh = exp(rh1(t))/(1+exp(rh1(t))) c gdet = -0.5*(log(h1(t)=gvar1(t))+log(h2(t)=gvar2(t)) $ c +log(1.0-(rho(t)=rh(t))**2)) c garchln = gdet-0.5/(1.0-rho(t)**2)*((a1t(t)**2/h1(t))+ $ c (a2t(t)**2/h2(t)) $ c -2*rho(t)*a1t(t)*a2t(t)/sqrt(h1(t)*h2(t))) c func=0.0d+00 c do i=3 ,nob c res1(i) =data1(i)-parm(1)-parm(2)*data1(i-1)-parm(3)*data2(i-2) res2(i) =data2(i)-parm(4) arch1(i)=parm(5)+ parm(6)*res1(i-1)**2 * + parm(7)*arch1(i-1) + parm(8)*arch2(i-1) arch2(i)=parm(9)+ parm(10)*res2(i-1)**2 * + parm(11)*arch2(i-1) + parm(12)*arch1(i-1) * + parm(13)*res1(i-1)**2 test=1.d+30 if( (dabs(arch1(i-1)*arch2(i-1))).gt.0.0d+00) * test=dsqrt(dabs(arch1(i-1)*arch2(i-1))) rh1 =parm(14)+parm(15)*rho(i-1) if(test.ne..1d+30)rh1=rh1+(parm(16)*((res1(i-1)*res2(i-1)))/test) c c Tsay calls rho rh c if(rh1.gt. 709.782d+00)then rho(i)=1.0d+00 elseif(rh1.lt.-709.782d+00)then rho(i)=0.0d+00 else rho(i) = dexp(rh1)/(1.0d+00+dexp(rh1)) endif c c rho(i) = (dexp(rh1)-1.0)/(1+dexp(rh1)) c c gets what Tsay calls gdet c if(i.ge.4)then part0=0.0d+00 if(arch1(i).gt.0.0d+00) part0=part0+dlog(arch1(i)) if(arch2(i).gt.0.0d+00) part0=part0+dlog(arch2(i)) if(rho(i)**2.ne.1.0d+00 )part0=part0+dlog(1.0-(rho(i)**2)) part1=0.0d+00 part2=0.0d+00 if(arch1(i).ne.0.0d+00.and.arch2(i).ne.0.0d+00) * part1=((res1(i)**2/arch1(i)) + (res2(i)**2/arch2(i))) test=.1D-10 if(dabs((arch1(i)*arch2(i))).gt.0.0d+00) *test=dsqrt(dabs(arch1(i)*arch2(i))) part2=(2.0d+00*rho(i)*res1(i)*res2(i))/test c func=func -(.5d+00*part0) c if(rho(i)**2.ne.1.0d+00)then func=func-(.5d+00*((part1-part2)/(1.0d+00- (rho(i)**2)))) else func=dmin1(func,-1.d+10) endif c endif c enddo c rewind(unit=8) write(8,*)nob write(8,fmt='(3e25.16)')(data1(ii),ii=1,nob) write(8,fmt='(3e25.16)')(data2(ii),ii=1,nob) write(8,fmt='(3e25.16)')(res1(ii),ii=1,nob) write(8,fmt='(3e25.16)')(res2(ii),ii=1,nob) write(8,fmt='(3e25.16)')(arch1(ii),ii=1,nob) write(8,fmt='(3e25.16)')(arch2(ii),ii=1,nob) write(8,fmt='(3e25.16)')(rho(ii),ii=1,nob) close(unit=8) open(unit=8,file='testout') rewind(unit=8) write(8,fmt='(e25.16)')func write(8,fmt='(5e16.8)')(parm(ii),ii=1,16) close(unit=8) stop end b34sreturn; /$ This section compiles Fortran and gets ready to go /$ Setup fortran parm=array(16:); * parm= array(: 1.4, .08, -.07, .7, 2.95, .08, .87, .01, 2.05, .05, .92, .01, .04, -2.0, 3.0, .1); call open(70,'_test.f'); call rewind(70); call rewind(4); call copyf(4,70); call close(70); j=integers(888) ; data1=ibmln(j) ; data2=spln(j) ; res1 =array(norows(data1):); res2 =array(norows(data1):); arch1=array(norows(data1):) + 45.; arch2=array(norows(data2):) + 31.; rho =array(norows(data2):) + .8 ; call echooff; * compile fortran and save data; /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f'); * call dounix('g77 _test.f -o_test'); call dounix('lf95 _test.f -o_test'); * call dounix('fortcl _test.f -o_test'); call copyout('_test.lst'); /$ call copyout('_test.map'); call open(72,'data.dat'); call rewind(72); call write(norows(data1),72); call write(data1,72,'(3e25.16)'); call write(data2,72,'(3e25.16)'); call write(res1 ,72,'(3e25.16)'); call write(res2 ,72,'(3e25.16)'); call write(arch1,72,'(3e25.16)'); call write(arch2,72,'(3e25.16)'); call write(rho, 72,'(3e25.16)'); call close(72); count=0.0; call echooff; program test; call open(72,'tdata.dat'); call rewind(72); npar=16; call write(npar,72); call write(parm,72,'(3e25.16)'); call close(72); call dodos('_test'); /$ call copyout('j') call dounix('./_test '); call open(71,'testout'); func=0.0; call read(func,71); if(func.gt.0.0)then; call print(func,parm); func=-10.d+9 ; endif; call close(71); /$ These optional statements slow things down /$ but help us understand the model count=count+1.0; call outdouble(10,1 , func); call outdouble(10,2 , count); call outdouble(10,3, parm(1)); call outdouble(10,4, parm(2)); call outdouble(10,5, parm(3)); call outdouble(10,6, parm(4)); call outdouble(10,7, parm(5)); call outdouble(10,8, parm(6)); call outdouble(10,9, parm(7)); call outdouble(40,1, parm(8)); call outdouble(40,2, parm(9)); call outdouble(40,3, parm(10)); call outdouble(40,4, parm(11)); call outdouble(40,5, parm(12)); call outdouble(40,6, parm(13)); call outdouble(40,7, parm(14)); call outdouble(40,8, parm(15)); call outdouble(40,9, parm(16)); return; end; call print(test); /$ c1 = 1.4, p1 = 0.1, p3 =-.1 , c2 = .07, a0 = 2.95 /$ a1 = .08 b1 = .87 f1 =-.03 a00= 2.05 a11=.05 /$ b11= .92 f11=-.06 d11=.04 q0 = -2.0 q1 = 3.0 /$ q2 = .1 /$ /$ Rats setup /$ Note that Tsay allows f11 parm(12) to be < 0.0 a dangerous thing!! /$ Note that Tsay allows f1 parm(8) to be < 0.0 a dangerous thing!! /$ /$ a1t = r1(t)-c1-p1*r1(t-1)-p3*r2(t-2) /$ a2t = r2(t)-c2 /$ gvar1 = a0+a1*a1t(t-1)**2+b1*h1(t-1)+f1*h2(t-1) /$ gvar2 = a00+a11*a2t(t-1)**2+b11*h2(t-1)+f11*h1(t-1)+d11*a1t(t-1)**2 /$ set up for + rho /$ rh1 = q0 + q1*rho(t-1) + q2*a1t(t-1)*a2t(t-1)/sqrt(h1(t-1)*h2(t-1)) /$ See Tsay page 372 /$ rh = exp(rh1(t))/(1+exp(rh1(t))) /$ *rh = (exp(rh1(t))-1.)/(1+exp(rh1(t))) /$ gdet = -0.5*(log(h1(t)=gvar1(t))+log(h2(t)=gvar2(t)) $ /$ +log(1.0-(rho(t)=rh(t))**2)) /$ garchln = gdet-0.5/(1.0-rho(t)**2)*((a1t(t)**2/h1(t))+ $ /$ (a2t(t)**2/h2(t)) $ /$ -2*rho(t)*a1t(t)*a2t(t)/sqrt(h1(t)*h2(t))) call cmaxf2(func :name test :parms parm /$ /$ c1, p1, p3, c2, a0 /$ a1, b1, f1, a00, a11 /$ b11 ,f11, d11, q0, q1 /$ q2 /$ Rats Answers reported in Tsay (2001) /$ Note that Tsay allows GARCH parameters to be < 0 !!!! /$ This make problem unstable!!!!! /$ See f1 & f11 /$ /$ 1.3178 .076103 -.068349 .673403 2.79865 /$ .08364 .8642 -.01995 1.7101 .05401 /$ .9139 -.05811 .03711 -2.0239 3.983 /$ .08755 /$ Rats input values /$ :ivalue array(: 1.4, 0.1, -.1 , .07, 2.95, /$ .08, .87, -.03, 2.05, .05, /$ .92, -.06, .04, -2.0, 3.0, /$ .1) /$ Good Values that are close torats input values except for /$ GARCH parameters which are not allowed to go < 0.0 %b34sif(&stable_m.eq.1)%then; :ivalue array(: 1.4, .08, -.07, .7, 2.95, .08, .87, .01, 2.05, .05, .92, .01, .04, -2.0, 3.0, .1) :lower array(:.1d-12, .1d-12, -.4, .1d-12, .1d-12, .1d-12, .1d-12, .1d-12 .1d-12, .1d-12, .1d-12, .1d-12, .1d-12, -6., .1d-12 .1d-12) %b34sendif; %b34sif(&stable_m.eq.0)%then; /$ /$ These values "beat Tsay" but model is not stable!!! /$ Stokes feels that GARCH mdoels should be estimated with /$ Constraints suggested by theory!! This is not possible with /$ older versions of RATS /$ :ivalue array(: 1.3, .08, -.07, .7, 2.8 , .08, .87, -.01, 1.7 , .05, .91, -.01, .04, -2.0, 4.1, .08) /$ These values suggested by Tsay cause problems /$ :ivalue array(: 1.4, 0.1, -.1 , .07, 2.95, /$ .08, .87, -.03, 2.05, .05, /$ .92, -.06, .04, -2.0, 3.0, /$ .1) :lower array(:.1d-12, .1d-12, -.4, .1d-12, .1d-12, .1d-12, .1d-12, -.02 .1d-12, .1d-12, .1d-12, -.06 .1d-12, -4., .1d-12 .1d-12) %b34sendif; :upper array(:.1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+3, .1d+1, .1d+3 .1d+3) :maxit 300000 :maxfun 300000 :maxg 1000 :print); b34srun; %b34sendif; %b34sif(&dorats.eq.1)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ ** Use in Chapter 9: Example 9.2, page 372. ** * all 0 888:1 * open data m-ibmspln.dat * data(org=obs) / r1 r2 * Book 9.24 set r1 = ibmln set r2 = spln set h1 = 45.0 set h2 = 31.0 set rho = 0.8 nonlin c1 p1 p3 c2 a0 a1 b1 f1 a00 a11 b11 f11 d11 q0 q1 q2 frml a1t = r1(t)-c1-p1*r1(t-1)-p3*r2(t-2) frml a2t = r2(t)-c2 frml gvar1 = a0+a1*a1t(t-1)**2+b1*h1(t-1)+f1*h2(t-1) frml gvar2 = a00+a11*a2t(t-1)**2+b11*h2(t-1)+f11*h1(t-1)+d11*a1t(t-1)**2 frml rh1 = q0 + q1*rho(t-1) + q2*a1t(t-1)*a2t(t-1)/sqrt(h1(t-1)*h2(t-1)) * See Tsay page 372 ********* setup for + rho !!!!! frml rh = exp(rh1(t))/(1+exp(rh1(t))) * frml rh = (exp(rh1(t))-1.)/(1+exp(rh1(t))) frml gdet = -0.5*(log(h1(t)=gvar1(t))+log(h2(t)=gvar2(t)) $ +log(1.0-(rho(t)=rh(t))**2)) frml garchln = gdet-0.5/(1.0-rho(t)**2)*((a1t(t)**2/h1(t))+ $ (a2t(t)**2/h2(t)) $ -2*rho(t)*a1t(t)*a2t(t)/sqrt(h1(t)*h2(t))) smpl 4 888 compute c1 = 1.4, c2 = 0.7, p1 = 0.1, f1 = -.03, d11=.04, f11=-.06 compute p2 = 0.1, p3 = -0.1, p0 = 0.1, q0 = -2.0, q1 = 3.0, q2 = 0.1 compute a0 = 2.95, a1 = 0.08, b1 = 0.87, a00 = 2.05 compute a11 = 0.05, b11 = 0.92 *maximize(method=simplex,iterations=10) garchln nlpar(criterion=value,cvcrit=0.00001) maximize(method=bhhh,recursive,iterations=150) garchln set fv1 = gvar1(t) set resi1 = a1t(t)/sqrt(fv1(t)) set residsq = resi1(t)*resi1(t) *** Checking standardized residuals *** cor(qstats,number=20,span=4) resi1 *** Checking squared standardized residuals *** cor(qstats,number=20,span=4) residsq set fv2 = gvar2(t) set resi2 = a2t(t)/sqrt(fv2(t)) set residsq = resi2(t)*resi2(t) *** Checking standardized residuals *** cor(qstats,number=20,span=4) resi2 *** Checking squared standardized residuals *** cor(qstats,number=20,span=4) residsq *** Last few observations needed for forecasts *** set rhohat = rho(t) set shock1 = a1t(t) set shock2 = a2t(t) print 885 888 shock1 shock2 fv1 fv2 rhohat b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==BLUS BLUS Residual Analysis %b34slet dora =0; %b34slet dobig=1; b34sexec data heading('Theil(1971) Table 5.1'); * For detail see pages 214-216; * Matrix Command shows BLUS Calculation; * Code discussed in Stokes ( ) 3rd Edition ; build x1,x2, y; gen x1=kount(); gen x2=dsin(x1/2.0); gen y =x1+ 10.0*dsin(x1/2.)+act_e; input act_e; datacards; 1.046 -.508 -1.630 -.146 -.105 -.357 -1.384 .360 -.992 -.116 -1.698 -1.339 1.827 -.959 .424 .969 -1.141 -1.041 1.041 .535 b34sreturn; b34srun; /$ b34sexec list; b34srun; %b34sif(&dora.ne.0)%then; b34sexec regression residualp blus=both noint; comment('Illustrates BLUS analysis with Theil Data'); model y=x1 x2; ra resid=allblus vars(x1); b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(blus); program fulltest; iprint=1; call olsq(y x1 x2 :noint :print :savex); do itype=0,3; call blus(itype,%x,%res,ibase,bluse,bluse2,eigb,sumeig,sumsqb, %coef,blusbeta,ibad,x1,teststat,iprint); enddo; %b34sif(&dobig.ne.0)%then; n=3000; k=30; y=rn(array(n:)); x=rn(matrix(n,k:)); call olsq(y x :print :savex); do itype=0,3; call blus(itype,%x,%res,ibase,bluse,bluse2,eigb,sumeig,sumsqb, %coef,blusbeta,ibad,x(,1),teststat,iprint); call compress; enddo; %b34sendif; return; end; /$ call echoon; call echooff; call fulltest; b34srun; == ==BOOTI Genarate a bootstrap index vector b34sexec matrix; n=26; * do not used index since command of same name !! ; index1=booti(n); call print(index1); test=grid(1.0,20.,1.0); index2=booti(norows(test)); newx=test(index2); call tabulate(test,index2,newx); call print('Nonstandard calls':); index2p2=booti(norows(test),norows(test)+2); index2m3=booti(norows(test),norows(test)-3); call tabulate(index2,index2P2,index2m3); b34srun; == ==BOOST Boost & Boost2 tests /; /; Implements traditional "centered" boosting. For non-centered /; OLS boosting see BOOST3 and BOOST4 for forecasting /; b34sexec options ginclude('b34sdata.mac') member(efron_1); b34srun; /; b34sexec options ginclude('b34sdata.mac') member(efron_2); b34srun; /; /; 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 /; /; Modified boosting also available if iboost set = 1 /; b34sexec matrix; call loaddata; call load(center :staging); call load(center2 :staging); call load(boost); call echooff; /; iboost=0 => ols boost /; iboost=1 => modified OLS boost iboost=0; /; iboost=1; e=.5; ntry=100; /; itype=0 => ols /; itype=1 => mars /; itype=2 => gam /; itype=3 => l1 /; itype=4 => minimax itype=0; iprint=1; x=center2(catcol(age sex bmi bp s1 s2 s3 s4 s5 s6)); y=y-mean(y); /; Set up the base case. if(itype.eq.0)call olsq(y,x :noint :print); if(itype.eq.1)call marspline(y x :print :nk 20); if(itype.eq.2)call gamfit(y x[predictor,3] :print); if(itype.eq.3)call olsq(y,x :noint :print :l1); if(itype.eq.4)call olsq(y,x :noint :print :minimax); call print(ccf(%y,%yhat)); base1=ccf(%y,%yhat); 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); /; if(iprint.ne.0)call graph(y,yhat); 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; base=array(norows(fit):)+base1; if(itype.eq.0)call char1(cc1,'OLS' ); if(itype.eq.1)call char1(cc1,'MARS' ); if(itype.eq.2)call char1(cc1,'GAM' ); if(itype.eq.3)call char1(cc1,'L1' ); if(itype.eq.4)call char1(cc1,'MINIMAX'); cc=' Boosting based Correlation of y and yhat given eps ='; if(iboost.eq.1) cc=' Modified Boosting based Correlation of y and yhat given eps ='; call ir8tostr(e,cc2,'(f8.4)'); cc=catrow(cc1,cc,cc2); call graph(base,fit :heading cc :file 'boost.wmf' :nocontact :nolabel :pgborder); call print(fit); b34srun; == ==BOOST3 OLS BOOSTING Model - HHS Mods with Forecasting b34sexec options ginclude('b34sdata.mac') member(efron_1); b34srun; /; b34sexec options ginclude('b34sdata.mac') member(efron_2); b34srun; /; /; 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 /; b34sexec matrix; call loaddata; call load(center ); call load(center2 ); call load(boost); call echooff; /; itype=0 => ols /; itype=1 => mars not ready /; itype=2 => gam not ready /; itype=3 => L1 /; itype=4 => MINIMAX itype=0; iprint=0; e=.5 ; ntry=1000; x=catcol(age sex bmi bp s1 s2 s3 s4 s5 s6); /; Gets the base if(itype.eq.0)call olsq(y,x :print); if(itype.eq.1)call marspline(y x :print :nk 20); if(itype.eq.2)call gamfit(y x[predictor,3] :print); if(itype.eq.3)call olsq(y,x :print :l1); if(itype.eq.4)call olsq(y,x :print :minimax); call print(ccf(%y,%yhat)); base1=ccf(%y,%yhat); 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 outstring(1,3,'Correlation'); call outdouble(20,3,fit(i)); enddo; call tabulate(in,fit,beta1,beta2); /; Testing if can "forecast" using saved Model call boost4(yhat2,x,in,beta1,beta2,e); call tabulate(yhat,yhat2); base=array(norows(fit):)+base1; if(itype.eq.0)call char1(cc1,'OLS' ); if(itype.eq.1)call char1(cc1,'MARS' ); if(itype.eq.2)call char1(cc1,'GAM' ); if(itype.eq.3)call char1(cc1,'L1' ); if(itype.eq.4)call char1(cc1,'MINIMAX'); cc=' HHS Boosting based Correlation of y and yhat given eps ='; call ir8tostr(e,cc2,'(f8.4)'); cc=catrow(cc1,cc,cc2); call graph(base,fit :heading cc :file 'boost.wmf' :nocontact :nolabel :pgborder); call print(fit); b34srun; == ==BOOST4 OLS BOOSTING Model - HHS Mods with Forecasting b34sexec options ginclude('b34sdata.mac') member(efron_1); b34srun; /; b34sexec options ginclude('b34sdata.mac') member(efron_2); b34srun; /; /; 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 /; b34sexec matrix; call loaddata; call load(center ); call load(center2 ); call load(boost); call echooff; /; itype=0 => ols /; itype=1 => mars not ready /; itype=2 => gam not ready /; itype=3 => L1 /; itype=4 => MINIMAX itype=0; iprint=0; e=.5 ; ntry=1000; x=catcol(age sex bmi bp s1 s2 s3 s4 s5 s6); /; Gets the base if(itype.eq.0)call olsq(y,x :print); if(itype.eq.1)call marspline(y x :print :nk 20); if(itype.eq.2)call gamfit(y x[predictor,3] :print); if(itype.eq.3)call olsq(y,x :print :l1); if(itype.eq.4)call olsq(y,x :print :minimax); call print(ccf(%y,%yhat)); base1=ccf(%y,%yhat); 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 outstring(1,3,'Correlation'); call outdouble(20,3,fit(i)); enddo; call tabulate(in,fit,beta1,beta2); /; Testing if can "forecast" using saved Model call boost4(yhat2,x,in,beta1,beta2,e); call tabulate(yhat,yhat2); base=array(norows(fit):)+base1; if(itype.eq.0)call char1(cc1,'OLS' ); if(itype.eq.1)call char1(cc1,'MARS' ); if(itype.eq.2)call char1(cc1,'GAM' ); if(itype.eq.3)call char1(cc1,'L1' ); if(itype.eq.4)call char1(cc1,'MINIMAX'); cc=' HHS Boosting based Correlation of y and yhat given eps ='; call ir8tostr(e,cc2,'(f8.4)'); cc=catrow(cc1,cc,cc2); call graph(base,fit :heading cc :file 'boost.wmf' :nocontact :nolabel :pgborder); call print(fit); b34srun; == ==BOOTOLS Simple Example File for bootols b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix$ call loaddata; call echooff; call load(bootols); /; 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 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 Results 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$ == ==BOOTPLOT Plot Booted OLS Model %b34slet showplot=1; %b34slet showprint=1; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix$ call loaddata; call echooff; call load(bootols ); call load(bootplot); /; 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 /; 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 /; +++++++++++++++++++++++++++++++++++++++++++++++ call print(bootols)$ nlag=0$ call olsq(lnq lnl lnk lnrm1 time :print :savex)$ nboot=500; isave=1; lag=0; call bootols(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /$ call print(%hcoef,%hse,%hrsq)$ call print(bcoef,bse); /; Optional print of Coef and t from boot %b34sif(&showprint.ne.0)%then; call print(%hcoef,%hse,%hrsq); %b34sendif; /; Optional Graphs call names(all); %b34sif(&showplot.ne.0)%then; %ht = afam(%hcoef)/afam(%hse); call bootplot(%hcoef(,1),'LNL values', 'Boot Values of Ln(labor) Coef','lnl.wmf',1); call bootplot(%hcoef(,2),'LNK values', 'Boot Values of Ln(capital) Coef','lnk.wmf',1); call bootplot(%hcoef(,3),'LNRM1 values', 'Boot Values of Ln(realM1) Coef','lnrm1.wmf',1); call bootplot(%hcoef(,4),'Constant', 'Boot Values of Constant Coef','constant.wmf',1); call bootplot(%ht(,1),'LNL t values', 'Boot Values of Ln(labor) t ','lnl_t.wmf',1); call bootplot(%ht(,2),'LNK t values', 'Boot Values of Ln(capital) t ','lnk_t.wmf',1); call bootplot(%ht(,3),'LNRM1 t values', 'Boot Values of Ln(realM1) t ','lnrm1_t.wmf',1); call bootplot(%ht(,4),'Constant t values', 'Boot Values of Constant t ','const_t.wmf',1); call bootplot(%hrsq,'rsq values', 'Boot Values of R squared','rootrsq.wmf',1); %b34sendif; b34srun$ == ==BOOTL1 Example File for bootL1 b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix$ call loaddata; call echooff; call load(bootl1); /; 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 call print(bootl1)$ nlag=6$ call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print :savex :l1)$ 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 Results assuming Time Series Correction':); lag=nlag; call bootl1(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /$ call print(%hcoef,%hse,%hrsq)$ call print(bcoef,bse); b34srun$ == ==BOOTMM Example File for bootmm b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix$ call loaddata; call echooff; call load(bootmm); /; 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 call print(bootmm)$ nlag=6$ call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print :savex :minimax)$ 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 Results 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$ == ==BOOTOLS2 Illustrates Bootstrap of OLS Model b34sexec matrix; call load(dist_tab); * Illustrate bootstrap of OLS Model; * User sets nobs for sample size ; * k for size of problem ; * beta for coefficients ; * mult for amount of Noise ; * nboot for # of bootstraps ; call echooff; nobs=5000; k=3; * try 3.0 15. 30. here !! ; mult=15.0; beta=vector(k:1.0 2.0 3.0); nboot=1000; y=vector(nobs:); x=rn(matrix(nobs,k:)); y=1.0 + x*beta + mult*rn(y); call olsq(y,x :print); holdcoef=matrix(nboot,k+1:); holdt =matrix(nboot,k+1:); do i=1,nboot; back continue; j=booti(nobs); newy=y(j); newx=x(j,); /; /; Test if bootstrap is full rank; /; if(rcond(transpose(newx)*newx).le. .1e-13)go to back; call olsq(newy newx); holdcoef(i,)=%coef; holdt(i,) =%t; call outstring(2,3,'Estimation:'); call outinteger(40,3,i); enddo; /; call dist_tab(x,n,q,qvalue,number,iprint); /$ /$ x => input series /$ n => input # of quantile values /$ q => q /$ qvalue => qvalue /$ number => # in the group /$ iprint => NE 0 = print /$ do ii=1,k+1; call print(' ':); call print('Distribution for Coefficient ',ii:); testcoef=holdcoef(,ii); call describe(testcoef :print); call dist_tab(testcoef,20,q,gvalue,number,1); call print(' ':); call print('Distribution for t ',ii:); test_t = holdt(,ii); call describe(test_t :print); call dist_tab(test_t,20,q,gvalue,number,1); enddo; /; x1=holdcoef(,1); x2=holdcoef(,2); x3=holdcoef(,3); call graph(x1,x2,x3:heading 'Should be 1.0 2.0 3.0'); call print(mean(x1),mean(x2),mean(x3)); t1=holdt(,1); t2=holdt(,2); t3=holdt(,3); call graph(t1,t2,t3:heading 't scores of model'); b34srun; == ==BOOTLS2 Boot LS2 and GMM Models %b34slet dob34s1=0; %b34slet dob34s2=1; %b34slet dostata=0; %b34slet dorats =0; b34sexec options ginclude('micro.mac') member(griliches76); b34srun %b34sif(&dob34s1.ne.0)%then; b34sexec matrix; call loaddata; call echooff; call olsq(iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 med kww age mrt :print); iqyhat=%yhat; call olsq(lw iqyhat s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print); call olsq(lw iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print); call gamfit(lw iq s expr tenure rns[factor,1] smsa[factor,1] iyear_67[factor,1] iyear_68[factor,1] iyear_69[factor,1] iyear_70[factor,1] iyear_71[factor,1] iyear_73[factor,1] :print); call marspline(lw iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print :nk 40 :mi 2); call gamfit(lw80 iq s expr tenure rns[factor,1] smsa[factor,1] iyear_67[factor,1] iyear_68[factor,1] iyear_69[factor,1] iyear_70[factor,1] iyear_71[factor,1] iyear_73[factor,1] :print); call marspline(lw80 iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print :nk 40 :mi 2); b34srun; %b34sendif; %b34sif(&dob34s2.ne.0)%then; b34sexec matrix; call loaddata; call load(ls2); call echooff; call character(lhs,'lw'); call character(endvar,'iq'); call character(rhs,'iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant'); call character(ivar,'s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant med kww age mrt'); call olsq(argument(lhs) argument(rhs) :noint :print :savex); call ls2(%y,%x,catcol(argument(ivar)),%names,%yvar,1); /; if(%info.ne.0)then; /; call print('Rank issues. stop':); /; call stop; /; endif; call print(lhs,rhs,ivar,endvar); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); call graph(%y %yhatols %yhatls2,%yhatgmm :nocontact :pgborder :nolabel); /; +++++++++++++++++++++++++++++++++++++++++++++++++++ * Illustrate bootstrap of LS2 Model; * nboot for # of bootstraps; k=nocols(%x); nboot=200; holdcoef=matrix(nboot,k:); holdt =matrix(nboot,k:); do i=1,nboot; back continue; j=booti(norows(%x)); newy=%y(j); newx=%x(j,); newz=%z(j,); %zpx=transpose(newz)*newx; %zpz=transpose(newz)*newz; rank_zpx=rank(%zpx); rank_zpz=rank(%zpz); /; /; Test if bootstrap is full rank. 0-1 variables the issue! /; if(rcond(%zpz) .le. .1e-13)go to back; if(rcond(transpose(newx)*newx) .le. .1e-13)go to back; if(rcond(transpose(%zpx)*inv(%zpz)*%zpx).le. .1e-13)go to back; if(rcond(transpose(newx)*newz*inv(%zpz)*transpose(newz)*newx) .le. .1e-13)go to back; call ls2(newy,newx,newz,%names,%yvar,0); /; /; gmmest can fail in this example with many dummy variables due to rank /; issues on s if over 190 boots are attempted. /; /; call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,0); /; holdcoef(i,)=%ls2coef; holdt(i,) =%ls2_t_s; call outstring(2,3,'Estimation:'); call outinteger(40,3,i); enddo; /; call dist_tab(x,n,q,qvalue,number,iprint); /$ /$ x => input series /$ n => input # of quantile values /$ q => q /$ qvalue => qvalue /$ number => # in the group /$ iprint => NE 0 = print /$ do ii=1,k; call print(' ':); call print('Distribution for Coefficient ', %names(ii)); call print('+++++++++++++++++++++++++++++++++++++++':); testcoef=holdcoef(,ii); call describe(testcoef :print); /; call dist_tab(testcoef,20,q,gvalue,number,1); call print(' ':); call print('Distribution for t for variable',%names(ii)); test_t = holdt(,ii); call describe(test_t :print); /; call dist_tab(test_t,20,q,gvalue,number,1); enddo; /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; b34srun; %b34sendif; %b34sif(&dostata.ne.0)%then; b34sexec options open('statdata.do') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options open('stata.do') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall idata=28 icntrl=29$ stata$ * for detail on stata commands see Baum page 205 ; pgmcards$ * uncomment if do not use /e * log using stata.log, text global xlist s expr tenure rns smsa iyear_67 /// iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 bootstrap _b _se, reps(50): /// ivregress 2sls lw $xlist (iq=med kww age mrt) ivregress 2sls lw $xlist (iq=med kww age mrt) ivregress liml lw $xlist (iq=med kww age mrt) ivregress gmm lw $xlist (iq=med kww age mrt) ivreg lw $xlist (iq=med kww age mrt) bootstrap _b _se, reps(50):ivreg2 lw $xlist (iq=med kww age mrt) ivreg2 lw $xlist (iq=med kww age mrt) ivreg2 lw $xlist (iq=med kww age mrt), gmm2s robust overid, all * orthog(age mrt) gmm (lw-{xb:$xlist iq} +{b0}), /// instruments ($xlist med kww age mrt) onestep nolog exit,clear b34sreturn$ b34seend$ b34sexec options close(28); b34srun; b34sexec options close(29); b34srun; b34sexec options dounix('stata -b do stata.do ') dodos('stata /e stata.do'); b34srun; b34sexec options npageout writeout('output from stata',' ',' ') copyfout('stata.log') dodos('erase stata.do', /; 'erase stata.log', 'erase statdata.do') $ b34srun$ %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * instruments s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 $ med kww age mrt constant * OLS linreg lw # constant s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 iq * 2SLS linreg(inst) lw # constant s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 iq * GMM linreg(inst,optimalweights) lw # constant s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 iq b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==BOOTV1 Genarate a bootstrap from a vector b34sexec matrix; test=grid(1.0,20.0,1.); btest=bootv(test); call tabulate(test,btest); x=rn(matrix(4,4:)); newx=bootv(x); call print(x,newx); call print('Nonstandard call'); btestp5=bootv(test,norows(test)+5); btestm5=bootv(test,norows(test)-5); call tabulate(test,btestp5,btestm5); b34srun; == ==BOOTV2 Bootstrap a matrix b34sexec matrix; * Illustrate bootstrap of X matrix; nn=20; x=rn(matrix(nn,3:)); call print(x); j=booti(nn); call print(j); newx=x(j,); call print(newx); b34srun; == ==BOXCOX Box-Cox Transformation b34sexec matrix; x=grid(0.0001 100. .1); ll=.1; log10x=dlog10(x); lnx =dlog(x); bc =boxcox(x,ll); bc2=boxcox(x,x) ; call print('bc =(x**.1 -1)/.1' 'bc2=(x**x -1)/x '); /$ call tabulate(x,log10x,lnx,bc,bc2); call graph(log10x,lnx,bc :Heading 'log10, lb and BC of .0001 - 100'); b34srun; == ==BOXCOX_1 Box-Cox Regression on Greene(2000) p 451 /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ Very Hard problem. Greene solved by a search b34sexec options ginclude('greene.mac') member(a10_1); b34srun; b34sexec matrix; call loaddata; * Problem from Greene page 451 ; call olsq(m r y :print); call olsq(lm lr ly :print); call olsq(lm r y :print); program bc; call echooff; /$ needed for nl2sol lamda2=dmin1(lamda,10.); yhat=a+(beta*boxcox(r,lamda2))+(gamma*boxcox(y,lamda2)); res=lm-yhat; call outstring(3,3,'Coefficients'); call outstring(3,4,'a beta gamma lamda'); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); return; end; call print(bc); * Results in Greene (2000) page 451 ; call nllsq(lm,yhat :name bc :parms a beta gamma lamda :maxit 5000 :flam 1. :flu 10. :eps2 .0000004 /$ :eps2 .00004 :ivalue array(:%coef(3),%coef(1),%coef(2),0.0001) :print result residuals); * Now try nl2sol !!; res1=%res; res =%res; call nl2sol(res :name bc :parms a beta gamma lamda :ivalue array(:%coef(3),%coef(1),%coef(2),0.0001) :print :maxit 5000 :maxfun 5000 ); call graph(res1, %res :heading 'res1 => nllsq %res => nl2sol'); call print(sumsq(%res)); b34srun; == ==BOXCOX_2 MAXF2 used to minimise sumsq residuals /$ Illustrates ML estimation of Box-Cox Model /$ /$ First we do a search /$ Next we set at Greene (2000) values for lamda /$ b34sexec options ginclude('greene.mac') member(a10_1); b34srun; b34sexec matrix; call loaddata; * Problem from Greene page 452 ; call olsq(m r y :print); call olsq(lm lr ly :print); call olsq(lm r y :print); lamda =1.; program bc; call echooff; func=sumsq(afam(boxcox(m,lamda))-(a+(beta*afam(boxcox(r,lamda)) )+ (gamma*afam(boxcox(y,lamda))) )); call outstring(3,3,'Coefficients'); call outstring(3,4,'a beta gamma lamda'); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); func=-1.*func; call outdouble(26,6,func); return; end; call print(bc); rvec=array(:%coef(3),%coef(1),%coef(2),lamda); /$ rvec=array(:-11.,-.001,4.,-.035); call echooff; call maxf2(func :name bc :parms a beta gamma lamda :ivalue rvec :print); b34srun; b34sexec matrix; call loaddata; * Problem from Greene (2000) page 452 ; * By setting lamda at Greene value of -.35 get ; * Greene coefficients ; call olsq(m r y :print); call olsq(lm lr ly :print); call olsq(lm r y :print); lamda =-.35; program bc; call echooff; func=sumsq(afam(boxcox(m,lamda))-(a+(beta*afam(boxcox(r,lamda)) )+ (gamma*afam(boxcox(y,lamda))) )); call outstring(3,3,'Coefficients'); call outstring(3,4,'a beta gamma lamda'); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); func=-1.*func; call outdouble(26,6,func); return; end; call print(bc); rvec=array(:%coef(3),%coef(1),%coef(2) ); call echooff; call maxf2(func :name bc :parms a beta gamma :ivalue rvec :print); b34srun; == ==BOXCOX_3 Box-Cox Model that Maximized Likelihood Function /$ /$ Illustrates ML estimation of Box-Cox Model /$ /$ ML Estimation of Greene (2000) page 452 /$ b34sexec options ginclude('greene.mac') member(a10_1); b34srun; b34sexec matrix; call loaddata; * Problem from Greene page 452 ; * ML function from page 447 ; * Problem very very hard ; * ; call olsq(m r y :print) ; call olsq(lm lr ly :print) ; call olsq(lm r y :print) ; lamda =1.; func1=0.0; one=1.0; ndiv2=dfloat(norows(m))/2. ; n =dfloat(norows(m)) ; cc =ndiv2*(dlog(2.*pi())+1.0) ; count=0; program bc; call echooff; func1=sumsq(afam(boxcox(m,lamda))-(a+(beta*afam(boxcox(r,lamda)) )+ (gamma*afam(boxcox(y,lamda))) )); count=count+1; call outstring(3,3,'Coefficients') ; call outstring(3,4,'a beta gamma lamda epe '); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); call outdouble(26,6,func1); call outinteger(56,6,count); func=(lamda-one)*mlsum(m) -cc - (ndiv2*dlog(func1/n)); return; end; call print(bc); rvec=array(:%coef(3),%coef(1),%coef(2),lamda); call echooff; call maxf2(func :name bc :parms a beta gamma lamda :maxit 8000 :maxfun 2000 :maxg 2000 :ivalue rvec :print); b34srun; == ==BOXCOX_4 Box-Cox Model estimated using Rats /$ /$ Illustrates ML estimation of Box-Cox Model /$ /$ ML Estimation of Greene (2000) page 452 /$ Rats used for solution. See page 5-30 of Rats Guide /$ for setup. Rats, unlike the b34smodel in prior problem, /$ does not get Greene (2000) results. Note that exact from of /$ Likelihood function was as recommended in Rats manual. Hence /$ final functional value not quite same as Greene suggests /$ b34sexec options ginclude('greene.mac') member(a10_1); b34srun; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * nonlin a beta gamma lamda sigmasq frml rhsfrml = a+beta*%boxcox(r,lamda)+gamma*%boxcox(y,lamda) frml boxcox = (lamda-1.)*log(m) - .5*(log(sigmasq) + $ (%boxcox(m,lamda)-rhsfrml(T))**2/sigmasq) linreg m # constant r y compute sigmasq=%seesq,a=%beta(1)+%beta(2)+%beta(3)-1 compute beta = %beta(2) compute gamma = %beta(3) compute lamda = 1.0 compute iter = 9000,isiter= 9000 nlpar(subiterations=isiter) maximize(method=bhhh,iterations=iter) boxcox b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ == ==BPFILTER Baxter King Filter /$ /$ Baxter-King MA Filter is used to extract trend and deviations from /$ trend /$ /$ Illustrates passing gasout through Baxter-King MA filter /$ goodrow and catcol used to line up data for plots and /$ redefine the series !! /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; highfreq=6.; lowfreq=32.; nterms=20; call bpfilter(gasout,tr,dev,highfreq,lowfreq,nterms:); call tabulate(gasout,tr,dev,); x=goodrow(catcol(gasout,tr,dev)); gasout=x(,1); tr =x(,2); dev =x(,3); call tabulate(gasout,tr,dev); call graph(gasout,tr,dev); b34srun; == ==BPFILTER_2 Compares BP and HP Filters /$ /$ Illustrates Baxter king and Hodrick - Prescott Filters /$ /$ Note use of goodrow and catcol to control missing /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; highfreq=6.; lowfreq=32.; nterms=20; s=1600.; call hpfilter(gasout,hptrend,hpdev,s); call bpfilter(gasout,bptrend,bpdev,highfreq,lowfreq,nterms:); x=goodrow(catcol(gasout,hptrend,hpdev,bptrend,bpdev)); gasout =x(,1); hptrend =x(,2); hpdev =x(,3); bptrend =x(,4); bpdev =x(,5); call tabulate(gasout,hptrend,hpdev,bptrend,bpdev); call graph(gasout,hptrend,hpdev,bptrend,bpdev); b34srun; == ==BREAK1 Break Key in a Program Option # 1 b34sexec matrix; * Tests break; n=1; test continue; n=n+1; call print(n); call break; go to test; b34srun; == ==BREAK2 Break Key in a Program Option # 2 b34sexec matrix; * Tests break; n=1; test continue; n=n+1; call print(n); call break('We now illustrate option # 2'); go to test; b34srun; == ==BSDER Compute 1-D spline values/derivatives given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; ndata=5; i=integers(ndata); xdata=dfloat(i)/dfloat(ndata); f=dsqrt(xdata); xknot = bsnak(xdata,3); bscoef= bsint(xdata,f,xknot); ndata=101; j=integers(2,ndata); x=dfloat(j-1)/dfloat(ndata-1); actf=dsqrt(x); actder=(.5/dsqrt(x)); xhat=bsder(0,x,xknot,bscoef); xder=bsder(1,x,xknot,bscoef); error1=actf - xhat; error2=xder - actder; call print('Evaluation of Data and Derivative':); call tabulate(x,actf,xhat,actder,xder,error1,error2); b34srun; == ==BSDER2 Compute 2-D spline values/derivatives given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; kx=5; ky=3; i=integers(nxdata); j=integers(nydata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; f=array(nxdata,nydata:); do ii=1,nxdata; do jj=1,nydata; f(ii,jj)=(xdata(ii)**4.) + ((xdata(ii)**3.)*(ydata(jj)**2.)); enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); bscoef2=bsint2(xdata,ydata,f,xknot,yknot); nxvec=4; nyvec=4; i=integers(nxvec); j=integers(nyvec); xvec=dfloat(i-1)/3.; yvec=dfloat(j-1)/3.; xx=array(nxvec,nyvec:); yy=xx; ff=xx; ffder=ff; error=xx; f21=xx; do i=1,nxvec; do j=1,nyvec; xx(i,j) =xvec(i); yy(i,j) =yvec(j); ff(i,j) =(xvec(i)**4.) + (xvec(i)*yvec(j)); ffder(i,j)=bsder2(2,1,xvec(i),yvec(j),xknot,yknot,bscoef2); f21(i,j) =12.*xvec(i)*yvec(j); error(i,j)=f21(i,j)-ffder(i,j); enddo; enddo; xx =array(:xx); yy =array(:yy); ffder=array(:ffder); f21=array(:f21); error=array(:error); call tabulate(xx,yy,ffder,f21,error); b34srun; == ==BSDER3 Compute 3-D spline values/derivatives given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; kx=5; ky=2; kz=3; nxdata=21; nydata=6; nzdata=8; nxvec=4; nyvec=4; nzvec=2; i=integers(nxdata); j=integers(nydata); k=integers(nzdata); xdata=dfloat(i-11)/10. ; ydata=dfloat(j-1) /dfloat(nydata-1); zdata=dfloat(k-1) /dfloat(nzdata-1); xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); zknot=bsnak(zdata,kz); maxii=index(nxdata,nydata,nzdata:); f=array(maxii:); do ii=1,nxdata; do jj=1,nydata; do kk=1,nzdata; ii2=index(nxdata,nydata,nzdata:ii,jj,kk); f(ii2)=(xdata(ii)**4.) + ((xdata(ii)**3.)*ydata(jj)*(zdata(kk)**3.)); enddo; enddo; enddo; bscoef3=bsint3(xdata,ydata,zdata,f,xknot,yknot,zknot); i=integers(nxvec); j=integers(nyvec); k=integers(nzvec); xvec=2.*(dfloat(i-1)/3.)-1. ; yvec=dfloat(j-1)/3.0; zvec=dfloat(k-1); maxjj=index(nxvec,nyvec,nzvec:); fit =array(maxjj:); error =array(maxjj:); actual=array(maxjj:); xx =array(maxjj:); yy =xx; zz =xx; do ii=1,nxvec; do jj=1,nyvec; do kk=1,nzvec; ii2=index(nxvec,nyvec,nzvec:ii,jj,kk); fit(ii2)=bsder3(2,0,1,xvec(ii),yvec(jj),zvec(kk), xknot, yknot, zknot,bscoef3); actual(ii2)=18.*xvec(ii)*yvec(jj)*zvec(kk); xx(ii2)=xvec(ii); yy(ii2)=yvec(jj); zz(ii2)=zvec(kk); error(ii2)=actual(ii2)-fit(ii2); enddo; enddo; enddo; call print('Shows 2,0,1 derivative, actual and error':); call tabulate(xx,yy,zz,fit,actual,error); b34srun; == ==BSINT Compute 1-D spline interpolant given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; ndata=50; i=integers(ndata); xdata=dfloat(i-1)/dfloat(ndata-1); f=dsqrt(xdata); xknot = bsnak(xdata,8); bscoef= bsint(xdata,f,xknot); ndata=101; j=integers(2,ndata); x=dfloat(j-1)/dfloat(ndata-1); actf=dsqrt(x); actder=(.5/dsqrt(x)); xhat=bsder(0,x,xknot,bscoef); xder=bsder(1,x,xknot,bscoef); error1=actf - xhat; error2=xder - actder; call print('Evaluation of Data and Derivative':); call tabulate(x,actf,xhat,actder,xder,error1,error2); b34srun; == ==BSINT2 Compute 2-D spline interpolant given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; kx=5; ky=2; i=integers(nxdata); j=integers(nydata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; f=array(nxdata,nydata:); do ii=1,nxdata; do jj=1,nydata; f(ii,jj)=(xdata(ii)*xdata(ii)*xdata(ii)) + (xdata(ii)*ydata(jj)); enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); bscoef2=bsint2(xdata,ydata,f,xknot,yknot); nxvec=4; nyvec=4; i=integers(nxvec); j=integers(nyvec); xvec=dfloat(i-1)/3.; yvec=dfloat(j-1)/3.; xx=array(nxvec,nyvec:); yy=xx; ff=xx; ffhat=ff; error=xx; do i=1,nxvec; do j=1,nyvec; xx(i,j)=xvec(i); yy(i,j)=yvec(j); ff(i,j)=(xvec(i)*xvec(i)*xvec(i)) + (xvec(i)*yvec(j)); ffhat(i,j)=bsder2(0,0,xvec(i),yvec(j),xknot,yknot,bscoef2); error(i,j)=ff(i,j)-ffhat(i,j); enddo; enddo; xx=array(:xx); yy=array(:yy); ff=array(:ff); ffhat=array(:ffhat); error=array(:error); call tabulate(xx,yy,ff,ffhat,error); b34srun; == ==BSINT3 Compute 3-D spline interpolant given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; kx=5; ky=2; kz=3; nxdata=21; nydata=6; nzdata=8; nxvec=4; nyvec=4; nzvec=2; i=integers(nxdata); j=integers(nydata); k=integers(nzdata); xdata=dfloat(i-11)/10. ; ydata=dfloat(j-1) /dfloat(nydata-1); zdata=dfloat(k-1) /dfloat(nzdata-1); xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); zknot=bsnak(zdata,kz); maxii=index(nxdata,nydata,nzdata:); f=array(maxii:); do ii=1,nxdata; do jj=1,nydata; do kk=1,nzdata; ii2=index(nxdata,nydata,nzdata:ii,jj,kk); f(ii2)=(xdata(ii)**3.) + (xdata(ii)*ydata(jj)*zdata(kk)); enddo; enddo; enddo; bscoef3=bsint3(xdata,ydata,zdata,f,xknot,yknot,zknot); i=integers(nxvec); j=integers(nyvec); k=integers(nzvec); xvec=2.*(dfloat(i-1)/3.)-1. ; yvec=dfloat(j-1)/3.0; zvec=dfloat(k-1); maxjj=index(nxvec,nyvec,nzvec:); fit =array(maxjj:); error =array(maxjj:); actual=array(maxjj:); xx =array(maxjj:); yy =xx; zz =xx; do ii=1,nxvec; do jj=1,nyvec; do kk=1,nzvec; ii2=index(nxvec,nyvec,nzvec:ii,jj,kk); fit(ii2)=bsder3(0,0,0,xvec(ii),yvec(jj),zvec(kk), xknot, yknot, zknot,bscoef3); actual(ii2)=(xvec(ii)**3.)+(xvec(ii)*yvec(jj)*zvec(kk)); xx(ii2)=xvec(ii); yy(ii2)=yvec(jj); zz(ii2)=zvec(kk); error(ii2)=actual(ii2)-fit(ii2); enddo; enddo; enddo; call tabulate(xx,yy,zz,fit,actual,error); b34srun; == ==BSITG Compute 1-D spline integral given knots b34sexec matrix; * Test Example from IMSL(10) ; ndata=21; korder=5; i =integers(ndata); xdata =dfloat(i-11)/10.; f =xdata**3.; xknot =bsnak(xdata,korder); bscoef=bsint(xdata,f,xknot); a =0.0; b =1.0; val =bsitg(a,b,xknot,bscoef); * fi(x)= x**4./4.; exact =(b**4./4.)-(a**4./4.); error=exact-val; call print('Test of bsitg ***********************':); call print('Lower = ',a:); call print('Upper = ',b:); call print('Integral = ',val:); call print('Exact = ',exact:); call print('Error = ',error:); b34srun; == ==BSITG2 Compute 2-D spline integral given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; kx=5; ky=2; i=integers(nxdata); j=integers(nydata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; f=array(nxdata,nydata:); do ii=1,nxdata; do jj=1,nydata; f(ii,jj)=(xdata(ii)**3.) + (xdata(ii)*ydata(jj)); enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); bscoef2=bsint2(xdata,ydata,f,xknot,yknot); a=0.0; b=1.0; c=.5; d=1.0; val=bsitg2(a,b,c,d,xknot,yknot,bscoef2); exact=.25*((b**.4-a**.4)*(d-c)+(b*b-a*a)*(d*d-c*c)); error=val-exact; call print('Test of bsitg2 ***********************':); call print('Lower 1 = ',a:); call print('Upper 1 = ',b:); call print('Lower 2 = ',c:); call print('Upper 2 = ',d:); call print('Integral = ',val:); call print('Exact = ',exact:); call print('Error = ',error:); b34srun; == ==BSITG2_2 Matlab Test case b34sexec matrix; * Test Example from Mastering Matlab 5 page 251; call echooff; x=grid(0.0, pi()); y=grid(-1.*pi(),pi()); x1=x; y1=y; call meld(x,y); z=dsin(x) * dcos(y)+1.; call graph(x,y,z :plottype contour3 :d3axis :d3border); kx=5; ky=5; xknot=bsnak(x1 ,kx); yknot=bsnak(y1 ,ky); n1=norows(x1); n2=norows(y1); z1=array(n1*n2:); do ii=1,n1; do jj=1,n2; ii2 =index(n1,n2:ii,jj); z1(ii2)=(dsin(x1(ii)) * dcos(y1(jj))) + 1.; enddo; enddo; bscoef2=bsint2(x1 ,y1 ,z1 ,xknot,yknot); a=0.0; b=pi(); c=-1.*pi(); d=pi(); val=bsitg2(a,b,c,d,xknot,yknot,bscoef2); matlab=19.73921476256606; call print('Integrating sin(x)*cos(y)+1.':); call print('Lower 1 = ',a:); call print('Upper 1 = ',b:); call print('Lower 2 = ',c:); call print('Upper 2 = ',d:); call print('Integral = ',val:); call print('Matlab = ',matlab:); b34srun; == ==BSITG3 Compute 3-D spline integral given knots b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; nzdata=8; kx=5; ky=2; kz=3; i=integers(nxdata); j=integers(nydata); k=integers(nzdata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; zdata=dfloat(k-1)/dfloat(nzdata-1); iimax=index(nxdata,nydata,nzdata:); f=array(iimax:); do ii=1,nxdata; do jj=1,nydata; do kk=1,nzdata; ii3=index(nxdata,nydata,nzdata:ii,jj,kk); f(ii3)=(xdata(ii)**3.) + (xdata(ii)*ydata(jj)*zdata(kk)); enddo; enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); zknot=bsnak(zdata,kz); bscoef3=bsint3(xdata,ydata,zdata,f,xknot,yknot,zknot); a=0.0; b=1.0; c=.5; d=1.0; e=0.0; ff=.5; val=bsitg3(a,b,c,d,e,ff,xknot,yknot,zknot,bscoef3); g =.5*(b**4.-a**4.); h =(b-a)*(b+a); ri=g*(d-c); rj=.5*h*(d-c)*(d+c); exact=.5*(ri*(ff-e)+.5*rj*(ff-e)*(ff+e)); error=val-exact; call print('Test of bsitg3 ***********************':); call print('Lower 1 = ',a:); call print('Upper 1 = ',b:); call print('Lower 2 = ',c:); call print('Upper 2 = ',d:); call print('Lower 3 = ',e:); call print('Upper 3 = ',ff:); call print('Integral = ',val:); call print('Exact = ',exact:); call print('Error = ',error:); b34srun; == ==BSNAK Compute Not a Knot Sequence b34sexec matrix; * Test Example from IMSL(10) ; call echooff; n=20; i=integers(n); xx1=dfloat(i-1)/dfloat(n-1); x=1.0-(xx1*xx1); f=dsin(10.0*x*x*x); call free(xx); * study which knots do best; do korder=3,8; xknot1 =bsnak(x,korder); xknot2 =bsopk(x,korder); bscoef1=bsint(x,f,xknot1); bscoef2=bsint(x,f,xknot2); * Test using new data; ii=integers(100); xx=dfloat(ii-1)/99.; st1=bsder(0,xx,xknot1,bscoef1); st2=bsder(0,xx,xknot2,bscoef2); ff=dsin(10.*xx*xx*xx); dif1=dabs(ff-st1); dif2=dabs(ff-st2); ddmax1=dmax(dif1); ddmax2=dmax(dif2); call print('For korder ',korder:); call print('bsnak max error ',ddmax1:); call print('bsopk max error ',ddmax2:); enddo; b34srun; == ==BSOPK Compute optimal spline knot sequence b34sexec matrix; * Test Example from IMSL(10) ; call echooff; n=20; i=integers(n); xx1=dfloat(i-1)/dfloat(n-1); x=1.0-(xx1*xx1); f=dsin(10.0*x*x*x); call free(xx); * study which knots do best; do korder=3,8; xknot1 =bsnak(x,korder); xknot2 =bsopk(x,korder); bscoef1=bsint(x,f,xknot1); bscoef2=bsint(x,f,xknot2); * Test using new data; ii=integers(100); xx=dfloat(ii-1)/99.; st1=bsder(0,xx,xknot1,bscoef1); st2=bsder(0,xx,xknot2,bscoef2); ff=dsin(10.*xx*xx*xx); dif1=dabs(ff-st1); dif2=dabs(ff-st2); ddmax1=dmax(dif1); ddmax2=dmax(dif2); call print('For korder ',korder:); call print('bsnak max error ',ddmax1:); call print('bsopk max error ',ddmax2:); enddo; b34srun; == ==BUILDLAG Builds NEWY and NEWX for VAR Modeling b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(buildlag); x=catcol(gasin,gasout); nlag=2; ibegin=1; iend=10; call print(x); call buildlag(x,nlag,ibegin,iend,newx,newy); call print(newx,newy); b34srun; == ==CANCORR Canonical Correlation b34sexec options ginclude('b34sdata.mac') member(kmenta); b34srun; b34sexec matrix; call loaddata; call echooff; call load(cancorr); x=mfam(catcol(p,d,constant)); z=mfam(catcol(d,f,a,constant)); call cancorr(cc,x,z,a,lamda); call print( cc,x,z,a,lamda); test1=x*a; test2=z*lamda; call print('x*a and z*lamda':); call print(transpose(test1)*test1); call print(transpose(test2)*test2); b34srun; == ==CATS Cointegration Analysis using Johansen Method /; /; Rats job verifies the B34S cats routine /; %b34slet runrats=0; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(cats); call echooff; /; call 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. /; 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 = /; pi = alpha * transpose(beta) /; icon = 1 => have constant in model /; itrend = 1 => have trend in the model /; testtab = Test table /; iprint = 1 => print results /; ieprint = 1 => 0 to print steps /; /; Basic code implemented September 2009 by Houston H. Stokes /; big_x =catcol(y,z,w ); iprint =0; maxlag =1; icon =1; itrend =1; ieprint =0; /;call cats(big_x,maxlag,eigval,eigvec,ltrace,lmax,iprint, /; icon,itrend,idebug); /; one series setup/ /; big_x=matrix(100,1:y); do maxlag=1,3; call cats(big_x,maxlag,eigval,eigvec,ltrace,lmax, alpha,beta,pi,0,0,iprint,ieprint); call cats(big_x,maxlag,eigval,eigvec,ltrace,lmax, alpha,beta,pi,1,0,iprint,ieprint); call cats(big_x,maxlag,eigval,eigvec,ltrace,lmax, alpha,beta,pi,0,1,iprint,ieprint); call cats(big_x,maxlag,eigval,eigvec,ltrace,lmax, alpha,beta,pi,1,1,iprint,ieprint); enddo; b34srun; %b34sif(&runrats.ne.0)%then; /; /; Note that lag = k for rats is lag=k-1 for the B34S CATS program. /; Eigenvalues lamda(trace) and lamda(max) agree across programs. /; Normalization for Alpha and beta do not agree. /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec data set; rename w=w_new; rename z=z_new; rename y=y_new; b34srun; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * source(noecho) d:\r\johmle.src @johmle(lags=2) * * # y_new z_new w_new open copy c:\b34swork\coint.txt @johmle(lags=3) * * # y_new z_new w_new open copy c:\b34swork\coint.txt * b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==C1ARRAY Create a Character*1 Array b34sexec matrix; /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); * ; call char1(c1,'This is a damm long string what do you think'); call char1(c2,'This is '); call print(c1,c2); call char1(x ,'This is a damm long string what do you think' 'so it this ' 'But this is not'); call names(all); call print(c1,c2,x); b34srun; b34sexec matrix; /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ call character(cc8, '012'); call character(cc, '012':3); call character(cc0, '0' :1); call character(cc1, '1' :1); call names(all); call print(cc(2),cc0); if(cc(2).eq.cc0)call print('yes-error'); call print(cc(1),cc0); if(cc(1).eq.cc0)call print('yes-right1'); call print(cc(2),cc0); if(cc(2).ne.cc0)call print('yes-right2'); call print(cc(1),cc1); if(cc(1).ne.cc1)call print('yes-right3'); cc=array(:0.,1.,2.); call print(cc); if(cc(2).eq.0.)call print('yes-error'); if(cc(1).eq.0.)call print('yes-right1'); if(cc(2).ne.0.)call print('yes-right2'); if(cc(1).ne.1.)call print('yes-right3'); b34srun; == ==C8ARRAY Create a Character*8 Array b34sexec matrix; /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); b34srun; == ==C16TOC32 Complex*16 to Complex*32 /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); do i=1,ncase; x=rn(x); r16x=r8tor16(x); c16x= complex(x); c32x=qcomplex(r16x); call print('In real*16 real*8 complex*32 complex*16',r16x,x,c32x,c16x); ix=inv(x); ir16x=inv(r16x); ic16x=inv(c16x); ic32x=inv(c32x); call print('Inverse real*16 real*8 complex*32 complex*16', ir16x,ix,ic32x,ic16x); call print('errors of inverse' x*ix,r16x*ir16x,c16x*ic16x,c32x*ic32x); /$ Test inline inverse test1=kindas(r16x,1.0)/r16x; ir16x=inv(r16x); call print(test1,ir16x); test2=kindas(c16x,complex(1.0))/c16x; ic16x=inv(c16x); call print(test2,ic16x); test1=kindas(r16x,1.0)/r16x; call print(test1,ir16x); test2=kindas(c16x,complex(1.0))/c16x; call print(test2,ic16x); enddo; b34srun; == ==C1ARRAY_2 Character*1 array used to save long strings b34sexec matrix; * long names is a 2 d array; * Illustrates packing ; cc=c1array(3,20:); c1=c1array(20:'12345678901234567890'); c2=c1array(20:'hhhhhhhhhhhhhhhhhhhh'); c3=c1array(20:'hhhhhhhhhhgggggggggg'); cc(1,)=c1; cc(2,)=c2; cc(3,)=c3; call print(cc); call print('This is line 2',cc(2,)); b34srun; == ==C32TOC16 Complex*32 to Complex*16 /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); do i=1,ncase; x=rn(x); r16x=r8tor16(x); c16x= complex(x); c32x=qcomplex(r16x); call print('In real*16 real*8 complex*32 complex*16',r16x,x,c32x,c16x); ix=inv(x); ir16x=inv(r16x); ic16x=inv(c16x); ic32x=inv(c32x); call print('Inverse real*16 real*8 complex*32 complex*16', ir16x,ix,ic32x,ic16x); call print('errors of inverse' x*ix,r16x*ir16x,c16x*ic16x,c32x*ic32x); /$ Test inline inverse test1=kindas(r16x,1.0)/r16x; call print(test1,ir16x); test2=kindas(c16x,complex(1.0))/c16x; call print(test2,ic16x); enddo; b34srun; == ==CATCOL Test catcol command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); x1=rec(matrix(3,3:)); x2=rec(matrix(3,3:)); call print(x1,x2,catrow(x1,x2),catcol(x1,x2)); /$ Character tests call character(cc1,'Line 1 here'); call character(cc2,'Line 2 here'); catrow1=catrow(cc1,cc2); catcol1=catcol(cc1,cc2); call names(all); call print(catrow1,catcol1); b34srun; == ==CATROW Test catrow command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); x1=rec(matrix(3,3:)); x2=rec(matrix(3,3:)); call print(x1,x2,catrow(x1,x2),catcol(x1,x2)); /$ Character tests call character(cc1,'Line 1 here'); call character(cc2,'Line 2 here'); catrow1=catrow(cc1,cc2); catcol1=catcol(cc1,cc2); call names(all); call print(catrow1,catcol1); b34srun; == ==CCF Tests CCF Command b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec data set corr; b34srun; b34sexec matrix; /$ Illustrates and tests ccf function call loaddata; ccf1=ccf(gasin gasout,24); call graph(ccf1:heading 'CCF of Gasin-Gasout'); call print(ccf1); call names; ccf1=ccf(gasin,gasout,24,lags); * Same series passed to test of ACF and CCF give same answer; ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24); call tabulate(ccf1,ccf2,acf1,lags); call print('Correlation between gasin & gasout ',ccf(gasin,gasout):); call print('Correlation Matrix ',ccf(catcol(gasin,gasout))); call print('Correlation Matrix ',ccf(catcol(time,gasin,gasout))); /; matrix form x=catcol(gasin,gasout); call print(ccf(x)); b34srun$ == ==CCF2 Tests Stokes (1979) ACF of CCF Test b34sexec matrix; * We generate two series. One with autocorrelation; * There is no relationship between the series ; * Stokes (1997) CCF Diagnostic test is illustrated; call load(ccftest); n=100000; nccf=100; nacf=30; call free(ma); call free(ar); ar=array(2:.9, -.5); nn=1000; start=array(2:.1 .1); test1=genarma(ar,ma,1.0,start,.1,n,nn); test2=rn(array(norows(test1):)); ccf1=ccf(test1,test2,nccf,lags); i=integers(nccf+2,2*nccf+1); testccf=ccf1(i); acfccf=acf(testccf,nacf); acf2 =acf(test1, nacf); acf3 =acf(test2, nacf); call tabulate(acfccf,acf2,acf3); call tabulate(lags,ccf1); call character(title,'Cross Correlations WN Series & Non NW Series'); call ccftest(test1,test2,nccf,lags,title); call graph(acf2 acfccf,acf3 :nokey :plottype hist3d :Heading 'Red => NWN. Blue => WN. Green => CCF'); b34srun; == ==CCF3 Further CCF Tests b34sexec matrix; * We generate two series. One with autocorrelation; * There is no relationship between the series ; * Stokes (1997) CCF Diagnostic test is illustrated; * More Complex model is shown; call load(ccftest); n=1000; nccf=200; nacf=30; call free(ma); ar=array(:.7,-.5 ); nn=100; start=array(:1.0 .1 ); test1=genarma(ar,ma,0.0,start,1.,n,nn); test2=rn(array(norows(test1):)); ccf1=ccf(test1,test2,nccf,lags); i=integers(nccf+2,2*nccf+1); testccf=ccf1(i); acfccf=acf(testccf,nacf); acf2 =acf(test1, nacf); acf3 =acf(test2, nacf); call tabulate(acfccf,acf2,acf3); call tabulate(lags,ccf1); call character(title,'Cross Correlations WN Series & Non NW Series'); call ccftest(test1,test2,nccf,lags,title); call graph(acf2 acfccf,acf3 :nokey :plottype hist3d :Heading 'Red => NWN. Blue => WN. Green => CCF'); b34srun; == ==CCF4 Tests CCF of two White Noise Series b34sexec matrix; * We generate two series, both white noise. ; * There is no relationship between the series ; * Stokes (1997) CCF Diagnostic test is illustrated ; call load(ccftest); n=1000; nccf=200; nacf=30; call free(ma); ar=array(:-.9 ); nn=100; start=array(:.1); test1=genarma(ar,ma,1.0,start,.1,n,nn); test2=rn(array(norows(test1):)); /$ Note: test1 is replaced here with NW series !!!! test1=rn(array(norows(test2):)); ccf1=ccf(test1,test2,nccf,lags); i=integers(nccf+2,2*nccf+1); testccf=ccf1(i); acfccf=acf(testccf,nacf); acf2 =acf(test1, nacf); acf3 =acf(test2, nacf); call tabulate(acfccf,acf2,acf3); call tabulate(lags,ccf1); call character(title,'Cross Correlations WN Series & Non NW Series'); call ccftest(test1,test2,nccf,lags,title); call graph(acf2 acfccf,acf3 :nokey :plottype hist3d :Heading 'Red => NWN. Blue => WN. Green => CCF'); b34srun; == ==CCFTEST Plot CCF b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(ccftest); nn=norows(gasout)/4; call character(title,'Gasin - Gasout Raw Correlations'); call ccftest(gasin,gasout,nn,lags,title); b34srun; == ==CCFTEST1 Shows effect of autocorrelation on ccf b34sexec matrix; * Hard wired code for example; call load(ccftest); n=100; nccf=30; nacf=30; nlag=3; noise=1.; call free(ma); ar=array(: .9); nn=100; start=array(:.1); x=genarma(ar,ma,1.0,start,.1,n,nn); i=integers(nlag+1,norows(x)); y=array(norows(x):)+missing(); rr=noise*rn(x); y(i)= x(i-nlag)+rr(i); do ii=1,nlag; x(ii)=missing(); y(ii)=missing(); enddo; x=goodrow(x); y=goodrow(y); call names(all); call character(title,'Effect of Autocorrelation on cross correlations'); /$ call tabulate(x,y); call ccftest(x,y,nccf,lags,title); b34srun; == ==CCF_TEST Illustrates Distribution of CCF and Regression /$ Tests of the effect of Regression and correlation "hunting" /$ Statistical cautions mentioned by D. McClouskey %b34slet doccf=1; %b34slet doreg=1; %b34sif(&doccf.ne.0)then; b34sexec matrix; * Illustrates and tests ccf function distribution. ; * Character String building also illustrated. ; * 10,000,000 data points are used in calculations. ; nobs =1000; ncases=1000; x=rn(array(nobs:)); ccf1=array(ncases:); call echooff; do i=1,ncases; ccf1(i)=ccf(x rn(array(nobs:))); enddo; call graph(ccf1:heading 'CC values'); sccf1=ccf1; call sort(sccf1); se=dsqrt(1./dfloat(nobs)); call ir8tostr(se,chse,'(g16.8)'); call print(chse); call character(hh,'Sorted Correlations. SE = '); call expand(hh,chse,31,50); CALL GRAPH(SCCF1: heading hh); saccf1=dabs(sccf1); call sort(saccf1); call character(hh,'Sorted abs(Correlations). SE = '); call expand(hh,chse,31,50); CALL GRAPH(SACCF1: heading hh); call print('Sqrt (1/n) =',se:); call tabulate(sccf1,saccf1); call quantile(saccf1,.95,val95); call quantile(saccf1,.99,val99); call print('95% value ',val95); call print('99% value ',val99); b34srun$ %b34sendif; %b34sif(&doreg.ne.0)then; b34sexec matrix; * Illustrates and tests Regression t distribution. ; * Character String building also illustrated. ; * 1,000,000 data points are used in calculations. ; * Variable 1 is the constant ; iprint=0; nobs =10000; ncases=100; nright=4; y=rn(array(nobs:)); ccf1=array(ncases:); call echooff; tt=array(ncases,nright+1:); do i=1,ncases; x=rn(matrix(nobs,nright:)); if(iprint.eq.0)call olsq(y x); if(iprint.ne.0)call olsq(y x :print); tt(i,)=%t; enddo; if(iprint.ne.0)call print(tt); do i=1,nright+1; call inttostr(i,chse,'(i10)'); call character(hh,'Sorted t scores for Variable = '); call expand(hh,chse,31,40); tt2=tt(,i); call sort(tt2); call graph(tt2 :heading hh); enddo; ttotal=array(:tt); call graph( ttotal :heading 'Plot of all t scores'); sttotal=ttotal; call sort(sttotal); call graph(sttotal :heading 'Plot of all sorted t scores'); call print('Mean of the unchanging y vector ',mean(y)); b34srun$ %b34sendif; == ==CFFILTER Christiano-Fitzgerald Filter Example %b34slet ibatch =%b34sget(ib34sg,ibatch,1) $ %b34slet file1="'_b34sdat.dat'"$ %b34slet file2="'b34sdata.m'"$ %b34slet rmatlab=0; %b34slet rrats =0; b34sexec options ginclude('b34sdata.mac') member(cffilter); b34srun; b34sexec matrix; call loaddata; call echooff; call load(cffilter); /; Quarterly data: pl=6, pu=32 returns component with periods /; between 1.5 and 8 yrs. /; Monthly data: pl=2, pu=24 returns component with all periods /; less than 2 yrs. /; Yearly data: pl=2 pu=3 call cffilter(gdp,2,3,1,fx); call tabulate(gdp,fx,fgdp); b34srun; %b34sif(&rmatlab.gt.0)then; b34sexec options open(%b34seval(&file1)) unit(28) disp=unknown$ b34seend$ b34sexec options clean(28)$ b34seend$ b34sexec options open(%b34seval(&file2)) unit(29) disp=unknown$ b34seend$ b34sexec options clean(29)$ b34seend$ /$ Script File Copy Section b34sexec pgmcall$ matlab lowercase $ pgmcards$ fx=bandpass(gdp,2,3) [fx,fgdp] b34sreturn$ b34seend$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('matlab /r b34sdata /logfile matlab.out') dounix('matlab < b34sdata.m > matlab.out'); b34srun; b34sexec options dos('pause'); b34srun; b34sexec options writeout(' ', 'Output from Matlab ', ' '); b34srun; b34sexec options copyfout('matlab.out'); b34srun; b34sexec options dodos('erase matlab.out') dounix('rm matlab.out'); b34srun; %b34sendif; %b34sif(&rrats.ne.0)then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * @cffilter(pl=2,pu=3) gdp * * fx print * * gdp fgdp fx b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==CENTER Center a series or 2 D object b34sexec options ginclude('b34sdata.mac') member(efron_1); b34srun; b34sexec matrix; call loaddata; call load(center ); call echooff; y=center(y); call print('Test - Mean of centered variable ', mean(y)); call print('Test - Variance of centered variable ',variance(y)); xx=catcol(age,sex,bmi,bp,s1,s2,s3,s4,s5,s6); cxx=center(xx); mm=array(10:); vv=array(10:); do i=1,10; mm(i)=mean( cxx(,i)); vv(i)=variance(cxx(,i)); enddo; call print('Test = Mean of centered matrix ', mm); call print('Test = variance of centered matrix ', vv); b34srun; == ==CENTER2 Standardize a Series mean=0. Unit length. b34sexec options ginclude('b34sdata.mac') member(efron_1); b34srun; b34sexec matrix; call loaddata; call load(center ); call load(center2); call echooff; call print('Centering such that Mean=0. Variance = 1':); x=center(catcol(age sex bmi bp s1 s2 s3 s4 s5 s6)); call print(mean(x(,1)),variance(x(,1))); call print(mean(x(,2)),variance(x(,2))); call print(mean(x(,3)),variance(x(,3))); call print(mean(x(,4)),variance(x(,4))); call print(mean(x(,5)),variance(x(,5))); call print(mean(x(,6)),variance(x(,6))); call print(mean(x(,7)),variance(x(,7))); call print(mean(x(,8)),variance(x(,8))); call print(mean(x(,9)),variance(x(,9))); call print(mean(x(,10)),variance(x(,10))); call print(' ':); call print('Standardizing such that Mean=0 sumsq(series)=1':); x=center2(catcol(age sex bmi bp s1 s2 s3 s4 s5 s6)); call print(mean(x(,1)),variance(x(,1))); call print(mean(x(,2)),variance(x(,2))); call print(mean(x(,3)),variance(x(,3))); call print(mean(x(,4)),variance(x(,4))); call print(mean(x(,5)),variance(x(,5))); call print(mean(x(,6)),variance(x(,6))); call print(mean(x(,7)),variance(x(,7))); call print(mean(x(,8)),variance(x(,8))); call print(mean(x(,9)),variance(x(,9))); call print(mean(x(,10)),variance(x(,10))); x1=x(,1); call print('Testing x1 ',sumsq(x1)); b34srun; b34sexec options ginclude('b34sdata.mac') member(efron_2); b34srun; == ==CFFILTER2 Using gasout as a test case for b34s & Rats %b34slet rrats =1; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call echooff; call load(cffilter); /; Quarterly data: pl=6, pu=32 returns component with periods /; between 1.5 and 8 yrs. /; Monthly data: pl=2, pu=24 returns component with all periods /; less than 2 yrs. /; Yearly data: pl=2 pu=3 call cffilter(gasout,2,24,1,fgasout); call tabulate(gasout,fgasout); call graph(gasout,fgasout); b34srun; %b34sif(&rrats.ne.0)then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * @cffilter(pl=2,pu=24) gasout * * fx print * * gasout fx b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==CFREQ Cumulative Frequency of a Series b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(cfreq); call cfreq(gasout,sgasout,cc); call tabulate(gasout,sgasout,cc); b34srun; == ==CHARACTER Load Data into character*1 b34sexec matrix; /; char1 is same as character call print('Call 1 creates klass=0 character*1 scaler':); call print('Call 2 creates klass=5 character*1 array':); call character(t, ' ':1); call character(tt,' '); call names(all); call print(t,tt); b34srun; == ==CHAR1 Character command same as char1 b34sexec matrix; call print('Call 1 creates klass=0 character*1 scaler':); call print('Call 2 creates klass=5 character*1 array':); call char1(t, ' ':1); call char1(tt,' '); call names(all); call print(t,tt); b34srun; == ==CHAR_1 Illustrates Character Data b34sexec matrix; * call screenouton; * Current limit of character command is no longer 132 cols; * if we c=pass in a string ; call character(cc,'This is a character*1 array'); call print(cc); call character(cclong,'This is a much longer string that goes for more t han one line.'); call print(cclong); call character(cshort,'shortc'); call print(cshort); call names; call names(all); * shows character*8 to character*1. Here there is no 132 limit ; c=rtoch(array(3:)); c(1)='mary'; c(2)='sue'; c(3)='joan'; call character(cc,c); call print(c,cc); call names(all); * Changing Character*1 1d arrays to be 2d; cn=c1array(1,norows(cclong):cclong); call names(all); call print(cn); call print(transpose(cn)); b34srun; == ==CHAR_2 Illustrates Character Data with Arrays b34sexec matrix; * call screenouton; call character(cc,'This is a character*1 array'); junk=cc; call print(cc,junk); call character(cclong,'This is a much longer string that goes for more than one line.'); call print(cclong); call names; call names(all); call character(c,'x12x12x12'); call print(c); call names(all); cca=array(:c); call print(cca); call character(jj,'B234567890abcdefghijklmnopqrstuvwxyz'); cca2=array(:jj); call print(cca2); newca2=array(6,6:cca2); call print(newca2); * Two ways to load data ; newca3=array(6,12:cca2,cca2); newca4=array(:cca2,cca2); call names(all); call print(newca3,newca4); call print('Note how each letter is doubled',cca2,cca2); cc=array(3,3:c); call names; call names(all); call print(cc); b34srun; == ==CHAR_3 Character Data with Subscripts b34sexec matrix; call character(cc,'1234567890qwertyuiop'); i=integers(7); ccc=cc(i); i=i+3; cccp3=cc(i); call print(cc,ccc,cccp3); * get a large character work array; call character(clarge,rtoch(array(1000:))); call names(all); b34srun; == ==CHAR_4 Character*8 Data b34sexec matrix; cc=array(3:'Mary', 'Sue','Judy'); call print(cc); * Put in character data with analytical statements ; * cc is character*8 ; cc(1)='one'; cc(2)='two'; cc(3)='Three'; call print(cc); b34srun; == ==CHAR_5 Character*1 Processing b34sexec matrix; call echooff; x=rn(matrix(30,30:)); call character(ii,'Element (1, '); call character(ii2,' ':6); jj=integers(12,17); call names(all); do i=1,30; call inttostr(i,ii2,'(i6)'); ii(jj)=ii2(jj-11); call character(rp,')'); /$ ********************************************************** /$ Warning the statement /$ ii(18)=')'; /$ does not work since it will be redefined to be character*8 /$ and will be outside the 132 range /$ ********************************************************** ii(18)=rp; call print(ii,x(1,i) :line); next i; call names(all); b34srun; == ==CHAR_6 Character data in subroutines b34sexec matrix; x=12.; call print('Is this on two lines ',x); call print('Is this 12 on a line ',x:); call character(two,'two'); call print('Is this one ',two ); call print('Is this one ',two:); call print('Is this one':); call print('Is this one '); call print(two:); call print(two); subroutine test(a); call print('In routine test a= ',a:); return; end; * Passing as a string does not work ; call test('This passed to test'); * Pass as a character ; call character(jj,'some junk is here'); call print(jj:); * Passing as a character variable ; call test(jj); b34srun; /$ /$ Case when Character Data is changed when a variable is passed. /$ b34sexec matrix; subroutine test(a); call names(all); call print('In routine test a= ',a:); call character(a,'This is a very long string that is added'); return; end; call test('junk'); call character(jj,'some funny thinmgs are here'); call print(jj:); call test(jj); call print(jj:); b34srun; == ==CHAR_7 Creating Multi-Dimensional Character*1 Arrays b34sexec matrix; call char1(c1,'This is a long string, can you see it'); call char1(c2,'This is not big '); call print(c1,c2); call char1(x ,'This is a long string, can you see it' 'so is this ' 'But this is not'); call names(all); call print(c1,c2,x); b34srun; == ==CHAR_8 Creating and Testing Character*1 Data b34sexec matrix; /$ /$ Job shows creating char*1 and char*1 variables /$ and moving data between the variable types /$ cc8a='012'; call character(cc8, '012':8); call character(cc4, '012':4); call character(cc0, '0' :1); call character(cc1, '1' :1); call names(all); call print(cc4(2),cc0); if(cc4(2).eq.cc0)call print('yes-error'); call print(cc4(1),cc0); if(cc4(1).eq.cc0)call print('yes-right1'); call print(cc4(2),cc0); if(cc4(2).ne.cc0)call print('yes-right2'); call print(cc4(1),cc1); if(cc4(1).ne.cc1)call print('yes-right3'); cc=array(:0.,1.,2.); call print(cc); if(cc(2).eq.0.)call print('yes-error'); if(cc(1).eq.0.)call print('yes-right1'); if(cc(2).ne.0.)call print('yes-right2'); if(cc(1).ne.1.)call print('yes-right3'); b34srun; == ==CHAR_9 Advanced Character Processing b34sexec matrix; * Job illustrates character processing; * ; /$ place ; inside a character array call igetchari(59,semic); * Strings placed inside character*8 variables ; cc1='*'; cc2='**'; cc3='***'; * Build character*1 size 1, 2 and 3 ; * Note that the sizes of variables reflect # characters ; call character(c1,'*'); call character(c2,'**'); call character(c3,'***'); * Here we add more blanks ; call character(c1_2,'*':2); call character(c2_5,'**':5); call character(c3_8,'***':8); call names(all); s=sfam(c1(1)); call print(semic,cc1,cc2,cc3,s,sfam(c1),c2,c3,c1_2,c2_5,c3_8); c1(1)=s; call print(c1); call names(all); * Build a longer string and offset ; call character(astring,'ABCDEFG222222'); call names(all); call print(astring); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(ichar,ichar2,astring,newstr); call character(astring,'ABCDEFG'); call names(all); call print(astring); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(astring,ichar,ichar2,newstr); * Look at possible chartacters ; i=integers(0,255); call igetchari(i,newstr); call names(all); call tabulate(i,newstr); b34srun; == ==CHARDATE Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==CHARDATEMY Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); time = rtoch(array(n:)); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); time(i) =chartime(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday,time); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==CHARTIME Obtains Character Time processing b34sexec matrix; call echooff; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); time = rtoch(array(n:)); do i=1,n; base=base+.11; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); time(i) =chartime(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday,time); b34srun; == ==CHECKPOINT Saving Workspace /$ Illustrates various saving options /; /; For more examples see ==SAVE /; b34sexec matrix; x=rn(matrix(4,4:)); ix=inv(x); ixr16=inv(r8tor16(x)); call print(x,ix,ixr16); call checkpoint(:file 'test.psv' :ndigits16); call save( :file 'test2.psv' :ndigits32); b34srun; b34sexec matrix; call restore(:file 'test.psv'); call names(all); call print(x,ix,ixr16); call print('++++++++++++++++++++++++++++++++++++++':); call free(x,ix,ixr16); call restore(:file 'test2.psv'); call names(all); call print(x,ix,ixr16); b34srun; == ==CHISPROB Chi-Squared distribution b34sexec matrix; * Sample problem from IMSL page 919; df = 2.0; chisq = .15; p=chisqprob(chisq,df); call print('The probability that chi-squared with DF ',df, 'is less than ',chisq,' is ', p, 'The answer should be .0723'); chisq = 3.0; p=1.0 - chisqprob(chisq,df); call print('The probability that chi-squared with df',df, ' is greater than', chisq,' is ',p,' Answer should be .2231'); b34srun; == ==CHTOR Converts Character*8 to Real*8 b34sexec matrix; x=array(5:1 2 3 4 5); call print(x); cx=rtoch(x); call names; newx=chtor(cx); call tabulate(x,newx); c=c8array(:'sue','diana','houston'); rc=chtor(c); call print(c,rc rtoch(rc)); b34srun; == ==CHTOHEX Character to Hex conversionm b34sexec matrix; cc=c1array(128:); i=integers(0,127); call igetchari(i,cc); call igetichar(cc,iitest); call chtohex(cc,hexcc); call hextoch(hexcc,cctest); call tabulate(i,cc,iitest,hexcc,cctest); b34srun; == ==CHTOHEX2 Extended Charater to Hex Conversion b34sexec matrix; /$ Illustrates Character Handeling and Hex Conversion; /$ Looking at Printable Characters ; i=integers(33,127); call igetchari(i,cc); call names(all); call tabulate(i,cc); call igetichar(cc,iitest); call chtohex(cc,hexcc); /$ Repack this character*2 array saved as character*1; /$ Next two statments work the same /$ hexcc2= array(norows(hexcc)/2,2:hexcc); hexcc2=c1array(norows(hexcc)/2,2:hexcc); hex1=hexcc2(,1); hex2=hexcc2(,2); call hextoch(hexcc,cctest); xx=transpose(hexcc2); call print(xx,hexcc2); call hextoch(xx,cctest2); call names(all); /$ get hexcc2 in a printable variable; blank=c1array(norows(hex1):); call names(all); c8var=catcol(hex1, hex2,blank,blank, blank, blank,blank,blank); call names(all); /$ call print(c8var); c8var=c8array(norows(c8var):transpose(c8var)); call tabulate(i,cc,iitest,hex1,hex2,cctest,cctest2,c8var); b34srun; == ==CLUSTER Tests Cluster Routines %b34slet runr=0; %b34slet runsas=0; b34sexec options ginclude('b34sdata.mac') member(cluster); b34srun; b34sexec matrix; call loaddata; /; call olsq(y x1 x2 x3 x4 x5 x6 x7 x8 :print); /; call ranforest(y x1 x2 x3 x4 x5 x6 x7 x8 :reg :print); /; call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 :reg :print); centdat=matrix(4,8: 16.750 43.250 37.500 29.750 21.500 29.250 30.250 9.2500 27.222 31.111 47.444 62.167 13.722 21.889 38.889 10.444 31.500 29.500 51.000 82.000 17.500 16.000 14.500 8.5000 27.667 22.833 47.000 84.667 8.0000 13.167 41.500 12.667); call names(all); call cluster(x1 x2 x3 x4 x5 x6 x7 x8 :k_mean 4 :clusters centdat :print); call print(%iclus %sumw); call cluster(x1 x2 x3 x4 x5 x6 x7 x8 :h_cluster 4 :print); call print(%clevel %clson %crson /; %dist %iclus); b34srun; /; /; Data is in its own file /; Running R from a fixed script /; Uses r.bat file /; /; Unit 28 is the data %b34sif(&runr.ne.0)%then; b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; # windows() windows(record=T) source('rjob2.r') library(cluster) library(mgcv) require(graphics) x1 b=lm(y~x1+x2+x3+x4+x5+x6) summary(b) model<-kmeans(x1+x2+x3+x4+x5+x6+x7+x8,4) model names(model) model$cluster model$centers model$withinss model$size # plot(model) model3<-gam(y~x1+x2+x3+x4+x5+x6+x7+x8) # model3<-gam(y~s(x1)+s(x2)+s(x3)+s(x4)+s(x5)+s(x6)+s(x7)+s(x8)) summary(model3) # plot(model3) model2<-hclust(dist(x1+x2+x3+x4+x5+x6+x7+x8)) model2$merge model2$height model2$order plot(model2) # demo(graphics) # quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos(' r rjob' ) unix( ' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') /; dodos('erase rjob.r','erase rjob.r.Rout','erase rjob2.r') $ b34srun$ %b34sendif; %b34sif(&runsas.ne.0)%then; b34sexec options header$ b34srun$ b34sexec options open('testsas.sas') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=29 icntrl=29$ sas $ * sas commands next ; pgmcards$ proc fastclus maxclusters=4; var x1 x2 x3 x4 x5 x6 x7 x8; run; proc cluster method=ward outtree=tree; var x1 x2 x3 x4 x5 x6 x7 x8; run; proc tree; run; b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos('start /w /r sas testsas' ) dounix('sas testsas' ) $ b34srun$ b34sexec options npageout noheader writeout(' ','output from sas',' ',' ') writelog(' ','output from sas',' ',' ') copyfout('testsas.lst') copyflog('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==CLUSTER2 IMSL benchmark test cases b34sexec options ginclude('b34sdata.mac') member(iris2); b34srun; b34sexec matrix; call loaddata; cc=matrix(3,4: 5.006 3.428 1.462 .246 5.902 2.748 4.394 1.434 6.850 3.074 5.742 2.071); call cluster(x1 x2 x3 x4 :k_mean 3 :print :savex); call print(%iclus %sumw %clust_m %wss %ave_wss); call print('++++++++++++++++++++++++++++++++++':); call cluster(x1 x2 x3 x4 :h_cluster 5 :print); call print(%clevel %clson %crson /; %dist %iclus); b34srun; == ==CLUSTER3 Analysis of DNAS Microarray Data /; /; Replicate H-T-F (2009) Page 513 /; b34sexec options ginclude('h_t_f_data.mac') member(cancer); b34srun; b34sexec matrix; call loaddata; call echooff; call names(:); i=norows(%names%); nn=%names%(integers(2,i-2)); /; call print(label(argument(nn(1)))); tt=label(argument(nn)); /; call print(tt); /; call print(transpose(tt)); tt=transpose(tt); bigx = catcol(x_1 x_2 x_3 x_4 x_5 x_6 x_7 x_8 x_9 x_10 x_11 x_12 x_13 x_14 x_15 x_16 x_17 x_18 x_19 x_20 x_21 x_22 x_23 x_24 x_25 x_26 x_27 x_28 x_29 x_30 x_31 x_32 x_33 x_34 x_35 x_36 x_37 x_38 x_39 x_40 x_41 x_42 x_43 x_44 x_45 x_46 x_47 x_48 x_49 x_50 x_51 x_52 x_53 x_54 x_55 x_56 x_57 x_58 x_59 x_60 x_61 x_62 x_63 x_64 ); * call graph(bigx :plottype meshstepc :heading 'Cancer Data' :rotation 90. :grid :d3axis :d3border /; :file 'rawdata.wmf' ); * call graph(bigx :plottype meshc :heading 'Cancer Data' /; :file 'rawdata.wmf' :rotation 90. :grid :d3axis :d3border ); bigx=transpose(bigx); docase1=1; docase2=1; if(docase1.ne.0)then; i=3; /; /; Replicate results on page 513 /; call cluster(bigx :print :k_mean i ); call print(%iclus); ii=ranker(dfloat(%iclus)); newbigx=bigx(ii,); newtt2=tt(ii,); call compress; call graph(newbigx :plottype meshstepc :heading 'Data Clustered into 3 classes' :rotation 90. :grid :d3axis :d3border :angle 25. /; :file 'sorted_data.wmf' ); newlist=c8array(64:); do j=1,64; call pcopy(8,pointer(newtt2,j),64,pointer(newlist,j),1,-1); enddo; class=%iclus(ii); call print(' ':); call tabulate(ii,class,newlist :rjname); endif; /; /; Investigate the size of k /; if(docase2.ne.0)then; n1=2; n2=12; ntotal=n2-n1+1; nclass =array(ntotal:); sumclass=array(ntotal:); s_av_wss =array(ntotal:); icount=0; save_tss=array(11:); do i=n1,n2; icount=icount+1; nclass(icount)=dfloat(i); call cluster(bigx :k_mean i ); save_tss(icount)=%tss; call compress; enddo; call graph(nclass save_tss :plottype xyplot :nocontact :pgborder :grid /; :file 'n_class.wmf' :heading 'Total Sum of squares vs # of classes'); endif; b34srun; == ==CLUSTER4 Cluster Test Data b34sexec options ginclude('b34sdata.mac') member(cluster2); b34srun; /; Example suggested by Hsing-Chien Kao b34sexec list ; b34srun; b34sexec matrix; call loaddata; call cluster(x1 x2 x3 x4 x5 x6 x7 x8 :k_mean 4 :print :savex); /; call print(cc,%x); call print(%iclus %sumw); call print('++++++++++++++++++++++++++++++++++':); call cluster(x1 x2 x3 x4 x5 x6 x7 x8 :h_cluster 5 :print); call print(%clevel %clson %crson /; %dist %iclus); b34srun; == ==CMAXF1_2 Constrained Minimum testing CMAXF1 & CMACF2 b34sexec matrix; * Constrained Minimum tests both commands CMAXF1 and CMAXF2 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; * To test further set :nstart 100 ; program test; func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf1(func :name test :parms x1 x2 :lower ll :upper UU :nstart 12 :nsig 3 :print); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf2(func :name test :parms x1 x2 :lower ll :upper UU :print); b34srun; == ==CMAXF1_A Constrained Minimum testing CMAXF1 b34sexec matrix; * Constrained Minimum tests command CMAXF1 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; program test; func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf1(func :name test :parms x1 x2 :lower ll :upper UU :nstart 12 :nsig 3 :print); b34srun; == ==CMAXF1_B Constrained Minimum testing CMAXF1 b34sexec matrix; * Minimum of FUNC = 100.*(x2-x1*x1)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .500 .250 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf1(func :name test :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; == ==CMAXF2_1 Constrained Minimum b34sexec matrix; * Minimum of FUNC = 100.*(x2-x1*x1)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .500 .250 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf2(func :name test :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; == ==CMAXF2_2 Constrained Minimum Gradiant Supplied b34sexec matrix; * Minimum of FUNC = 100.*(x2-x1*x1)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .500 .250 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; program der; g(1)= (400.0*(x2-x1*x1)*x1) + (2.0*(1.0-x1)); g(2)= -200.0*(x2-x1*x1); return; end; call print(test,der); rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf2(func g :name test der :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; == ==CMAXF2_3 Constrained Minimum using CMAXF2 b34sexec matrix; * Minimum of FUNC = 100.*(x1*x1-x2)**2. + (1.-x1)**2. ; * where -2.0 le x1 le 2.0 ; * -1.0 le x2 le 2.0 ; * with answers 1. 1. and func = 0.0 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*((x1*x1-x2))**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2: 2. , 2.0); call echooff; call cmaxf2(func :name test :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; == ==CMAXF3_1 Constrained Minimum using CMAXF3 b34sexec matrix; * Minimum of FUNC = 100.*(x1*x1-x2)**2. + (1.-x1)**2. ; * where -2.0 le x1 le 2.0 ; * -1.0 le x2 le 2.0 ; * with answers 1.0 1.0 and func = 0.0 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x1*x1-x2)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2: 2. , 2.0); call echooff; call cmaxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 300 :lower ll :upper uu :print); b34srun; == ==CMAXF3_2 Constrained Minimum b34sexec matrix; * Constrained Minimum tests CMAXF3 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; program test; func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf3(func :name test :parms x1 x2 :lower ll :upper UU :maxit 300 :print); b34srun; == ==CMAXF3_3 Constrained Minimum using CMAXF3 b34sexec matrix; * Minimum of FUNC = 100.*(x1*x1-x2)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .5 .25 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x1*x1-x2)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 300 :lower ll :upper uu :print); b34srun; == ==CMAXSEARCH Maximize a constrained Function using a Search b34sexec matrix; * Minimum of FUNC = 100.*(x1*x1-x2)**2. + (1.-x1)**2. ; * where -2.0 le x1 le 2.0 ; * -1.0 le x2 le 2.0 ; * with answers 1.0 1.0 and func = 0.0 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x1*x1-x2)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2: 2. , 2.0); call echooff; call cmaxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 300 :lower ll :upper uu :print); call print(' ':); call print('++++++++++++++++++++++++++++++++++++++++++++++++':) call print(' ':); rvec=array(2:100.,100.); ll= array(2:-2.0,-1.0); uu= array(2: 2. , 2.0); call echooff; call cmaxsearch(func :name test :parms x1 x2 :ivalue rvec :maxit 30000 :printstart :itprint :lower ll :upper uu :print); call print('Function ',%func:); call tabulate(%nparm,%coef); call print(' ':); call print('++++++++++++++++++++++++++++++++++++++++++++++++':) call print(' ':); * Minimum of FUNC = 100.*(x2-x1*x1)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .500 .250 and func = .250 ; * can be found with the commands: ; program test2; func=(-1.0)*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf2(func :name test2 :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); rvec=array(2:-1.2, 1.0); ll =array(2:-2. ,-1.0); uu =array(2:.5 , 2.0); call echooff; call cmaxsearch(func :name test2 :parms x1 x2 :ivalue rvec :maxit 30000 :printstart :itprint :maxabt 12 :lower ll :upper uu :print); call print(' ':); call print('++++++++++++++++++++++++++++++++++++++++++++++++':) call print(' ':); b34srun; b34sexec matrix; * Constrained Minimum tests CMAXF3 & CMAXSEARCH ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; program test; func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf3(func :name test :parms x1 x2 :lower ll :upper UU :maxit 3000 :print); /; Test search approach rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxsearch(func :name test :parms x1 x2 :lower ll :upper UU :maxit 3000 :print); b34srun; == ==COINT2 Tests Cointegration of two series b34sexec options ginclude('b34sdata.mac') noheader macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint2); call load(coint3); /; call print(coint2); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; lagx=1; lagy=1; dflag=4; m=20; alpha=0.0; deg=3.; mi=2; nk=20; do method=0,3; call coint2(method,m,alpha,deg,mi,nk,y,z,xname,yname,dfx,dfy, adfx,adfy,lagx,lagy,speedx,speedy,tspeedx,tspeedy, dfx2,dfy2,adfx2,adfy2,dflag,resid0,resid1,resid2,1); if(method.eq.0.or.method.eq.2)call print(speedx,speedy,tspeedx,tspeedy); enddo; /; more tests call character(xname,'Enders w Series'); call character(yname,'Enders y Series'); call character(zname,'Enders z Series'); call echooff; lagx=1; lagy=1; lagz=1; dflag=4; m=20; alpha=0.0; deg=3.; mi=2; nk=20; do method=0,3; call coint3(method,m,alpha,deg,mi,nk,w,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,1); if(method.eq.0.or.method.eq.2)then; call print(speedx,speedy,speedz); call print(tspeedx,tspeedy,tspeedz); endif; enddo; b34srun; == ==COINT2LM Tests Cointegration of two series with L1 & MM b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix cbuffer=100000; call loaddata; call load(coint2LM); call print(coint2LM); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; lagx=1; lagy=1; dflag=4; call coint2LM(y,z,xname,yname,dfx,dfy, adfx,adfy,lagx,lagy,speedx,speedy,tspeedx,tspeedy, l1speedx,l1speedy,mmspeedx,mmspeedy, dfx2,dfy2,adfx2,adfy2,dflag,resid0,resid1,resid2,1); call print(speedx,speedy, tspeedx, tspeedy, l1speedx,l1speedy,mmspeedx,mmspeedy); b34srun; == ==COINT2M Tests Moving Cointegration of Two Series b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint2); call load(coint2m); call print(coint2,coint2m); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; number=60; lagx=1; lagy=1; call coint2m(y,z,xname,yname,number,lagx,lagy, speedx,speedy,tspeedx,tspeedy); call graph(speedx,tspeedx :nocontact :pgborder :nolabel :grid :heading 'Enders Y Series Moving Error Correction'); call graph(speedy,tspeedy :nocontact :pgborder :nolabel :grid :heading 'Enders Z Series Moving Error Correction'); call tabulate(speedx,speedy,tspeedx,tspeedy); b34srun; == ==COINT2M2 Tests Moving Coint. of Two Series with L1 & MM b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix cbuffer=100000; call loaddata; call load(coint2lm); call load(coint2m2); call print(coint2lm,coint2m2); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; number=60; lagx=1; lagy=1; dflag=4; /$ Shows simple call /$ call coint2m(y,z,xname,yname,number,lagx,lagy,speedx,speedy, /$ tspeedx,tspeedy); /$ call coint2m2(y,z,xname,yname,number,lagx,lagy,speedx,speedy, tspeedx,tspeedy,l1speedx,l1speedy,mmspeedx,mmspeedy, dfx,dfy,adfx,adfy,dfres1, dfres2,adfres1,adfres2,dflag); call graph(speedx,tspeedx :nocontact :pgborder :nolabel :heading 'Enders Y Series Moving Error Correction'); call graph(speedy,tspeedy :nocontact :pgborder :nolabel :heading 'Enders Z Series Moving Error Correction'); call graph(speedx,l1speedx,mmspeedx :nocontact :pgborder :nolabel :heading 'Enders Z Series Moving Error Correction'); call graph(speedy,l1speedy,mmspeedy :nocontact :pgborder :nolabel :heading 'Enders Z Series Moving Error Correction'); call graph(dfx,dfy,speedx,speedy :nocontact :pgborder :nolabel :heading 'Shows effecrt of DF test on Coint' ); call graph(speedx,speedy,tspeedx,tspeedy :nocontact :pgborder :nolabel :heading 'Shows effecrt of DF test on Coint'); call tabulate(speedx,speedy,tspeedx,tspeedy,dfx,dfy,dfres1,dfres2); call tabulate(speedx,speedy,tspeedx,tspeedy,adfx,adfy,adfres1,adfres2); call tabulate(speedx,l1speedx,mmspeedx,speedy,l1speedy,mmspeedy); b34srun; == ==COINT2ME Tests Moving Cointegration of Two Series - Extended /; /; Two methods of estimation used: OLS & GAM /; Last table shows significance of the speed of adjustment /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint2); call load(coint2me); call print(coint2,coint2me); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; number=60; lagx=1; lagy=1; dflag=4; /$ Shows simple call /$ call coint2m(y,z,xname,yname,number,lagx,lagy,speedx,speedy, /$ tspeedx,tspeedy); /$ do method=0,1; deg=3.; call coint2me(method,deg,y,z,xname,yname,number,lagx,lagy,speedx,speedy, tspeedx,tspeedy,dfx,dfy,adfx,adfy,dfres1, dfres2,adfres1,adfres2,dflag); if(method.eq.0)then; call graph(speedx,tspeedx :nocontact :pgborder :nolabel :grid :file 'coint2_X_Model.wmf' :heading 'Enders X Series OLS Moving Error Correction'); call graph(speedy,tspeedy :nocontact :pgborder :nolabel :grid :file 'coint2_Y_Model.wmf' :heading 'Enders Y Series OLS Moving Error Correction'); call graph(dfx,dfy,speedx,speedy :nocontact :pgborder :nolabel :grid :file 'coint2_dfx_dfy_Model.wmf' :heading 'Shows effect of DF test on Coint'); call graph(speedx,speedy,tspeedx,tspeedy :nocontact :grid :pgborder :nolabel :file 'coint2_speedX_Y.wmf' :heading 'Shows effect of DF test on Coint'); call print('Moving EC Model estimated with OLS' :); call print('Window size was ',number:); call tabulate(speedx,speedy,tspeedx,tspeedy,dfx,dfy,dfres1,dfres2); call tabulate(speedx,speedy,tspeedx,tspeedy,adfx,adfy,adfres1,adfres2); speedx1=speedx; speedy1=speedy; tspeedx1=tspeedx; tspeedy1=tspeedy; endif; call names(all); if(method.ne.0)then; call graph(speedx,tspeedx :nocontact :pgborder :nolabel :grid :file 'coint2_X Model.wmf' :heading 'Enders X Series GAM Moving Error Correction'); call graph(speedy,tspeedy :nocontact :pgborder :nolabel :grid :file 'coint2_Y Model.wmf' :heading 'Enders Y Series GAM Moving Error Correction'); call graph(dfx,dfy,speedx,speedy :nocontact :pgborder :nolabel :grid :heading 'Shows effect of DF test on Coint'); call graph(speedx,speedy,tspeedx,tspeedy :nocontact :grid :pgborder :nolabel :heading 'Shows effect of DF test on Coint'); call print(' ':); call print('Moving EC Model estimated with GAM. Degree was ',deg :); call print('Window size was ',number:); call tabulate(speedx,speedy,tspeedx,tspeedy,dfx,dfy,dfres1,dfres2); call tabulate(speedx,speedy,tspeedx,tspeedy,adfx,adfy,adfres1,adfres2); speedx2=speedx; speedy2=speedy; tspeedx2=tspeedx; tspeedy2=tspeedy; endif; enddo; call print('Note: OLS =1, GAM = 2':); call tabulate(speedx1,speedx2,,speedy1,speedy2, tspeedx1,tspeedx2,tspeedy1,tspeedy2); b34srun; == ==COINT3 Tests Cointegration of Three Series b34sexec options ginclude('b34sdata.mac') noheader macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint2); call load(coint3); /; call print(coint2); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; lagx=1; lagy=1; dflag=4; m=20; alpha=0.0; deg=3.; mi=2; nk=20; do method=0,3; call coint2(method,m,alpha,deg,mi,nk,y,z,xname,yname,dfx,dfy, adfx,adfy,lagx,lagy,speedx,speedy,tspeedx,tspeedy, dfx2,dfy2,adfx2,adfy2,dflag,resid0,resid1,resid2,1); if(method.eq.0.or.method.eq.2)call print(speedx,speedy,tspeedx,tspeedy); enddo; /; more tests call character(xname,'Enders w Series'); call character(yname,'Enders y Series'); call character(zname,'Enders z Series'); call echooff; lagx=1; lagy=1; lagz=1; dflag=4; m=20; alpha=0.0; deg=3.; mi=2; nk=20; do method=0,3; call coint3(method,m,alpha,deg,mi,nk,w,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,1); if(method.eq.0.or.method.eq.2)then; call print(speedx,speedy,speedz); call print(tspeedx,tspeedy,tspeedz); endif; enddo; b34srun; == ==COINT3_2 Rats Three Series Test /; /; See Rats Users Guide version 8 page UG-106 /; %b34slet runols =1; %b34slet runrats=1; b34sexec options ginclude('b34sdata.mac') member(hamilton2); b34srun; %b34sif(&runols.ne.0)%then; b34sexec matrix; call loaddata; call load(coint3); call load(cats); call load(coint_sw); call character(x1,'Hamilton uscpi Series'); call character(x2,'Hamilton italcpi Series'); call character(x3,'Hamilton Exchange Rate Series'); call echooff; iprint=1; lagx=1; lagy=1; lagz=1; dflag=4; m=20; alpha=0.0; deg=3.; mi=2; nk=20; method=0; call coint3(method,m,alpha,deg,mi,nk, uscpi,italcpi,exrat,x1,x2,x3,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); call print(speedx,speedy,speedz); call print(tspeedx,tspeedy,tspeedz); iprint=0; maxlag=12; iprint=1; /; /; 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 /; call coint_sw(catcol(uscpi italcpi exrat),10,res1,ec_coef,ec_vec, const,shock,iprint); if(iprint.eq.0)then; call print('Stock-Watson DOLS Estimation with maxlag = ',maxlag:); call print('Estimate of Cointegrating Vector ',ec_coef); call print('Estimate of constant ',const:); call graph(ec_vec,y,shock :nolabel :grid :pgborder :nocontact :heading 'Error Correction Vector' :file 'sw.wmf'); call graph(res1 :heading 'Residual from DOLS Model ' :grid :pgborder :nocontact); endif; /; call 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. /; 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 = /; pi = alpha * transpose(beta) /; icon = 1 => have constant in model /; itrend = 1 => have trend in the model /; testtab = Test table /; iprint = 1 => print results /; ieprint = 1 => 0 to print steps /; /; Basic code implemented September 2009 by Houston H. Stokes /; big_x =catcol(uscpi italcpi exrat); iprint =1; maxlag =6; icon =1; itrend =0; ieprint =0; call print('Testing uscpi':); call df(uscpi :adft 12 :print); call print('Testing italcpi':); call df(italcpi :adft 12 :print); call print('Testing exrat ':); call df(exrat :adft 12 :print); ppp = uscpi-exrat-italcpi; call graph(ppp :heading 'Figure 19.3 The real dollar-lira exchange rate' :nocontact :pgborder) call print('Testing ppp ' :print); call df(ppp :adf 12 :print); big_x=mfam(big_x); test=transpose(big_x)*big_x; call stop; call cats(big_x,maxlag,eigval,eigvec,ltrace,lmax, alpha,beta,pi,icon,itrend,iprint,ieprint); call stop; call print(' ':); call print('dif(uscpi))':); call describe(dif(uscpi,1,1) :print); call print(' ':); call print('dif(italcpi))':); call describe(dif(italcpi,1,1) :print); call print(' ':); call print('dif(exrat))':); call describe(dif(exrat,1,1) :print); b34srun; %b34sendif; %b34sif(&runrats.ne.0)%then; /$ user places RATS commands between /$ PGMCARDS$ /$ note: user RATS commands here /$ B34SRETURN$ /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * * COINTTST.PRG * Manual Example 6.8 * From Hamilton, Time Series Analysis, pp 582-599 * * Transform and normalize the data series * * set italcpi = 100*log(pc6it/pc6it(1973:1)) * set uscpi = 100*log(pzunew/pzunew(1973:1)) * set exrat = -100*log(exritl/exritl(1973:1)) * graph(header="Figure 19.2",key=attached, $ klabel=||"Italy CPI","US CPI","Ex Rate"||) 3 # italcpi # uscpi # exrat * * Dickey-Fuller tests on the variables * @dfunit(lags=12,trend) uscpi @dfunit(lags=12,trend) italcpi @dfunit(lags=12,trend) exrat * * Unit root tests on the hypothesized cointegrating vector * set ppp = uscpi-exrat-italcpi graph(header="Figure 19.3 The real dollar-lira exchange rate") # ppp @dfunit(lags=12) ppp * * Engle-Granger test * (Dickey-Fuller test with estimated cointegrating vector * @egtest(lags=12) # uscpi italcpi exrat * * Johansen maximum likelihood test * @johmle(lags=6,det=constant) # uscpi italcpi exrat b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==COINT3ME Tests Moving Cointegration of Three Series - Extended b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint3); call load(coint3me); call print(coint3,coint3me); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call character(zname,'Enders w Series'); call echooff; number=60; lagx=1; lagy=1; lagz=1; dflag=4; method=0; deg=3.; call coint3me(method,deg,y,z,w,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); if(method.eq.0)then; call graph(speedx,tspeedx :nocontact :pgborder :nolabel :grid :file 'coint3me_x.wmf' :heading 'Enders X Series OLS Moving Error Correction'); call graph(speedy,tspeedy :nocontact :pgborder :nolabel :grid :file 'coint3me_y.wmf' :heading 'Enders Y Series OLS Moving Error Correction'); call graph(speedz,tspeedz :nocontact :pgborder :nolabel :grid :file 'coint3me_z.wmf' :heading 'Enders Z series OLS Moving Error Correction'); call print('Moving EC Model estimated with OLS' :); call print('Window size was ',number:); call tabulate(speedx,speedy,speedz,tspeedx,tspeedy,tspeedz); endif; if(method.ne.0)then; call graph(speedx,tspeedx :nocontact :pgborder :nolabel :grid :file 'coint3me_x.wmf' :heading 'Enders X Series GAM Moving Error Correction'); call graph(speedy,tspeedy :nocontact :pgborder :nolabel :grid :file 'coint3me_y.wmf' :heading 'Enders Y Series GAM Moving Error Correction'); call graph(speedz,tspeedz :nocontact :pgborder :nolabel :grid :file 'coint3me_z.wmf' :heading 'Enders Z series GAM Moving Error Correction'); call print('Moving EC Model estimated with GAM. Degree was',deg:); call print('Window size was ',number:); call tabulate(speedx,speedy,speedz,tspeedx,tspeedy,tspeedz); endif; b34srun; == ==COINT3_A Tests COINT3 using RATS and B34S and Enders Setup /$ Testing Enders Section 5 !!!!!!!!!!!!!!! /$ Using exact setup as per Instructors manual!!!! /$ Note that B34S does not use same names since x y z are hard coded b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint3); call print(coint3); call character(xname,'Enders w Series'); call character(yname,'Enders y Series'); call character(zname,'Enders z Series'); call echooff; lagx=1; lagy=1; lagz=1; dflag=4; m=20; alpha=0.0; deg=3.; mi=2; nk=20; method=0; call coint3(method,m,alpha,deg,mi,nk, w,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,1); call print(speedx,speedy,speedz); call print(tspeedx,tspeedy,tspeedz); b34srun; /$ user places RATS commands between /$ PGMCARDS$ /$ note: user RATS commands here /$ B34SRETURN$ /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * set dy = y - y(t-1) set dz = z - z(t-1) set dw = w - w(t-1) linreg w / residw # constant y z system 1 to 3 variables dy dz dw lags 1 to 1 det constant residw{1} end(system) estimate(outsigma=vsigma) * * Using other RATS instructions for same problem * Note that first equation agress with book. Second * equation does not !!!! * * Estimate three stage 1 models -- last one used * linreg y / rry # constant z w linreg z / rrz # constant y w linreg w / rrw # constant y z diff y / ydiff diff z / zdiff diff w / wdiff linreg ydiff # constant rrw{1} ydiff{1} zdiff{1} wdiff{1} linreg zdiff # constant rrw{1} ydiff{1} zdiff{1} wdiff{1} linreg wdiff # constant rrw{1} ydiff{1} zdiff{1} wdiff{1} * b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run ') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ == ==COINT_SW Stock-Watson DOLS Analysis b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint_sw); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call character(zname,'Enders w Series'); call echooff; iprint=0; maxlag=4; call coint_sw(catcol(y,z,w),10,res1,ec_coef,ec_vec, const,shock,iprint); if(iprint.eq.0)then; call print('Stock-Watson DOLS Estimation with maxlag = ',maxlag:); call print('Estimate of Cointegrating Vector ',ec_coef); call print('Estimate of constant ',const:); call graph(ec_vec,y,shock :nolabel :grid :pgborder :nocontact :heading 'Error Correction Vector'); call graph(res1 :heading 'Residual from DOLS Model ' :grid :pgborder :nocontact); b34srun; == ==COMB Combination of N objects taken M at a time b34sexec matrix; n=6; call echooff; do m=1,4; jj=comb(n,m); call print('N ',n,'M ',m,'# ',jj); test=idint(matrix(jj,m:)); do kk=1,jj; test(kk,)=comb(n,m,kk); enddo; call print(test); enddo; b34srun; == ==COMB_2 Illustrates BOUNDS Analysis using comb b34sexec matrix; /$ Bounds analysis - Code template. Data is in xold(n,upperi) /$ Want to keep first loweri-1 including constant in col 1 in model /$ Want to see how other variables change "focus" coefficients. /$ upperi outer limit on xold index /$ loweri lower limit on xold => we always use col 1-(loweri-1) /$ ********************************************** /$ build test data ** User call data routine here /$ User sets n, upperi loweri /$ If n=300 will not get significance due to low single / noise /$ ratio. If n = 30000 we can get significance!! This shows /$ effect of sample size on the estimation. The range of the /$ coef will tighten up! n=300; upperi=10; loweri=4; xold=rn(matrix(n,upperi:)); xold(,1)=1.0; b=vector(upperi:)+2.; b(1)=1.0; y=vector(n:); y=xold*b + 100.* rn(y); /$ ********************************************** /$ start analysis oldcoef=vector(loweri-1:); maxcoef=vector(loweri-1:); mincoef=vector(loweri-1:); call olsq(y xold :noint :print); i=integers(loweri-1); oldcoef(i)=%coef(i); maxcoef(i)=%coef(i); mincoef(i)=%coef(i); call echooff; nn=upperi-loweri+1; do num_in=1,(upperi-loweri+1); kk=loweri-1+num_in; newx=matrix(n,kk:); /$ load the data that does not change newx(,i)=xold(,i); /$ num_in = number in each eq /$ numpass = number of combinations given num_in numpass=comb((upperi-loweri+1),num_in); /$ estimation block jjin=integers(loweri,kk); do ii=1,numpass; iv=comb(nn,num_in,ii) + loweri-1; /$ This can be turned on /$ call print(iv); /$ Code is slower than a vectorized setup but more clear do jjcopy=1,norows(iv); j1=jjin(jjcopy); j2=iv(jjcopy); newx(,j1)=xold(,j2); enddo; /$ If want to test t, l1, minimax then in place of %coef /$ use another vector /$ Can turn on here if want to see the output at every step /$ call olsq(y newx :noint :print); call olsq(y newx :noint); do kk=1,norows(maxcoef); if(%coef(kk).gt.maxcoef(kk))maxcoef(kk)=%coef(kk); if(%coef(kk).lt.mincoef(kk))mincoef(kk)=%coef(kk); enddo; enddo; /$ End estimation block *************************** call print(' '); call print('Coef Distribution given # in was ',num_in:); call tabulate(mincoef,oldcoef,maxcoef); enddo; b34srun; == ==COMB_3 Bounds analysis on real Data B34SEXEC OPTIONS GINCLUDE('berndt.mac') MACRO = cigad $ B34Seend$ b34sexec matrix; call loaddata; /$ Bounds analysis - Code template. Data is in xold(n,upperi) /$ Want to keep first loweri-1 including constant in col 1 in model /$ Want to see how other variables change "focus" coefficients. /$ upperi outer limit on xold index /$ loweri lower limit on xold => we always use col 1-(loweri-1) /$ ********************************************** /$ build test data ** User call data routine here /$ User sets n, upperi loweri , includes intercept /$ We save the data in a b34s file /$ ****************** All OLS Turned on ************************* n=49; upperi=9; loweri=4; xold(,1)=1.0; xold(,2)=vfam(rprice); xold(,3)=vfam(realad); xold(,4)=vfam(time); xold(,5)=vfam(f); xold(,6)=vfam(l); xold(,7)=vfam(astock); xold(,8)=vfam(df); xold(,9)=vfam(incpc); y=vfam(salespc); /$ This saves coef in another form nn=upperi-loweri+1; Lcoef1=vector(nn:); Lcoef2=vector(nn:); Lcoef3=vector(nn:); Ucoef1=vector(nn:); Ucoef2=vector(nn:); Ucoef3=vector(nn:); /$ ********************************************** /$ start analysis oldcoef=vector(loweri-1:); maxcoef=vector(loweri-1:); mincoef=vector(loweri-1:); call olsq(y xold :noint :print); i=integers(loweri-1); oldcoef(i)=%coef(i); maxcoef(i)=%coef(i); mincoef(i)=%coef(i); call echooff; nn=upperi-loweri+1; do num_in=1,(upperi-loweri+1); kk=loweri-1+num_in; newx=matrix(n,kk:); /$ load the data that does not change newx(,i)=xold(,i); /$ num_in = number in each eq /$ numpass = number of combinations given num_in numpass=comb((upperi-loweri+1),num_in); /$ estimation block jjin=integers(loweri,kk); do ii=1,numpass; iv=comb(nn,num_in,ii) + loweri-1; /$ This can be turned on /$ call print(iv); /$ Code is slower than a vectorized setup but more clear do jjcopy=1,norows(iv); j1=jjin(jjcopy); j2=iv(jjcopy); newx(,j1)=xold(,j2); enddo; /$ If want to test t, l1, minimax then in place of %coef /$ use another vector /$ Can turn on here if want to see the output at every step /$ All Models turned on call olsq(y newx :noint :print); /$ call olsq(y newx :noint); do kk=1,norows(maxcoef); if(%coef(kk).gt.maxcoef(kk))maxcoef(kk)=%coef(kk); if(%coef(kk).lt.mincoef(kk))mincoef(kk)=%coef(kk); enddo; enddo; /$ End estimation block *************************** call print(' '); call print('Coef Distribution given # in was ',num_in:); call tabulate(mincoef,oldcoef,maxcoef); /$ ********************** coef save *************************** lcoef1(num_in)=mincoef(1); lcoef2(num_in)=mincoef(2); lcoef3(num_in)=mincoef(3); ucoef1(num_in)=maxcoef(1); ucoef2(num_in)=maxcoef(2); ucoef3(num_in)=maxcoef(3); /$ ************************************************************* enddo; call tabulate(lcoef1,ucoef1,lcoef2,ucoef2,lcoef3,ucoef3); call makedata(lcoef1,ucoef1,lcoef2,ucoef2,lcoef3,ucoef3 :file 'bounds.b34'); b34srun; b34sexec options include('bounds.b34'); b34srun; b34sexec list; b34srun; == ==COMPILER Return Compiler used b34sexec matrix; test=compiler(); if(test.eq.0)call print('Linux LF95 Compiler used.'); if(test.eq.1)call print('Windows LF95 Compiler used.'); if(test.eq.2)call print('Windows Intel IA32 Compiler used.'); b34sreturn; == ==COMPLEX Make a Complex Number from Real*8 b34sexec matrix; r=.3; ii=.4; cc=complex(r,ii); x=rec(matrix(4,4:)); cx =complex(x); cx2=complex(x,dsqrt(dabs(x))); call names; call print(r,ii,cc,x,cx,cx2); call print('real*16 cases ************************':); r =r8tor16(r); ii=r8tor16(ii); cc=qcomplex(r,ii); x=r8tor16(rec(matrix(4,4:))); cx =qcomplex(x); cx2=qcomplex(x,dsqrt(dabs(x))); call names; call print(r,ii,cc,x,cx,cx2); b34srun; == ==COMPRESS Illustrates COMPRESS b34sexec matrix; * Math with matrix and vectors ; * For bigger problems, change n; * Note how CALL COMPRESS saves space; * Further problems done to test system; * If the matrix procedure should lock unexpectedly as arrays get bigger and bigger, use compress to compact. Compress is not automatic since it takes time; do i=1,2; if(mod(i,2).ne.0)call compress(:off); if(mod(i,2).eq.0)call compress(:on); call compress(:info); n=3; right=integers(1,((n*n)-1))+10; call print('Right ',right); x=matrix(n,n:right,-7); x2=x*2.; v=vector(n:integers(1,n)); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)' ,x*2.) ; call print('Scaler times Matrix (3.*x)' ,3.*x) ; call names(all); call compress; call names(all); call print('Vector plus matrix (v+x)' ,v+x) ; call print('Matrix plus vector (x+v)' ,x+v) ; call print('Matrix plus matrix (x+x2)' ,x+x2) ; call print('Matrix plus scaler (x+2.)' ,x+2.) ; call print('Scaler plus matrix (3.+x)' ,3.+x) ; call print('Vector minus matrix (v-x)' ,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)' ,x-x2) ; call print('Matrix minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus matrix (3.-x)' ,3.-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=x*2.; call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*2.)' ,x*2.) ; call print('Scaler times Array(2) (3.*x)' ,3.*x) ; call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+2.)' ,x+2.) ; call print('Scaler plus Array(2) (3.+x)' ,3.+x) ; call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus Array(2) (3.-x)' ,3.-x) ; enddo; b34srun; == ==COMPRESS_2 Compress called inside go to loop /$ Illustrates call compress inside a LOOP /$ /$ Job for i=1 space is saved /$ /$ Note difference in space use /$ b34sexec matrix; call echooff; subroutine doit(n); x=rn(matrix(n,n:)); c=inv(x); return; end; do i=1,2; if(mod(i,2).ne.0)call compress(:off); if(mod(i,2).eq.0)call compress(:on); call compress(:info); count=1.; top continue; call compress; call doit(100); count=count+1.0; if(count.le.100.)go to top; call names(all); enddo; b34srun; == ==COMPRESS_3 Speed testing with a compress inside a dowhile /$ /$ Tests Compression speed using a dowhile /$ /$ Run with docomp=0 and docomp=1 see # temp go up speed up /$ /$ Running under b34s2 slows due to screen writes!! /$ /$ User can experiment with nn to see effect of partial compression /$ b34sexec matrix; sum=0.0; add=1.; count=1.; tol=.1e-10; nn=1; docomp=1; call echooff; subroutine test(nn,docomp,add,tol,count,sum); dowhile(add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; if(docomp.ne.0)then; call compress(nn); call outstring(3,1,'count without compression from Sub'); call outdouble(3,2, count); call outdouble(3,3,sum,'(g25.16)'); endif; if(docomp.eq.0)then; call outstring(3,4,'count with compression from Sub'); call outdouble(3,5, count); call outdouble(3,6,sum,'(g25.16)'); endif; enddowhile; return; end; /$ Stand alone code ********************** dowhile(add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; call compress(nn); call outstring(3,7,'count with compression'); call outdouble(3,8, count); call outdouble(3,9,sum,'(g25.16)'); enddowhile; call print('Results with compression':); call print('Sum was ',sum:); call print('Count was ',count); call names(all); docomp=0; sum=0.0; add=1.0; count=1.0; call echooff; /$ Stand alone code ********************** dowhile(add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; call outstring(3,10,'count without compression'); call outdouble(3,11, count); call outdouble(3,12,sum,'(g25.16)'); enddowhile; call print('Results without compression':); call print('Sum was ',sum:); call print('Count was ',count); call names(all); docomp=1; sum=0.0; add=1.0; count=1.0; call test(nn,docomp,add,tol,count,sum); call print('Results with compression and a subroutine call':); call print('Sum was ',sum:); call print('Count was ',count); call names(all); docomp=0; sum=0.0; add=1.0; count=1.0; call test(nn,docomp,add,tol,count,sum); call print('Results without compression and a subroutine call':); call print('Sum was ',sum:); call print('Count was ',count); call names(all); b34srun; == ==CONSTRAIN Illustrates CONSTRAIN with MELD b34sexec matrix; i=array(:1. 2. 3.); j=array(:4.,5.,6.); k=array(:7.,8.,9.); call tabulate(i,j,k); call meld(i,j,k); f=i**2.+j**2.+k**2.; call tabulate(i,j,k,f); call constrain(i,j,k,f:var i :lower 2.); call tabulate(i,j,k,f); call constrain(i,j,k,f:var k :upper 8.); call tabulate(i,j,k,f); b34srun; == ==CONTRACT Remove a substring from an array b34sexec matrix; call character(cc,'This is a test'); call print(cc); call ilocatestr(cc,istart,iend); i=integers(istart,iend); subs=cc(i); call print(subs); call contract(cc,istart,iend); oldnewcc=cc; call print(cc); call character(new,'aaaissaa'); call expand(cc,new,1,8); call print(oldnewcc,cc); * we want aabb at 5-8 in cc; * We do not want to expand; call character(cc,'This is a test'); call character(new,'aabb'); call contract(cc,5,8); call expand(cc,new,5,8); call print(cc); b34srun; == ==CONTRIB Advanced routine do MARS contrib analysis /; /; Generation of contrib charts automatically /; /; Job can be easily modified /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call load(marsdiag :staging); call load(marsinfo :staging); call load(contrib); /; call print(contrib); m=6; _knots=20; _mi=2; _df=2.0; /; set left hand side call character(l_hand_s,'gasout'); /; Set right hand side call character(_args,'gasout{1 to m} gasin{1 to m}'); /; Few settings needed after this line except for message /; if iopt=1 call olsq( argument(l_hand_s) argument(_args) :diag :print); olscoef=%coef; /; call marspline(argument(l_hand_s) argument(_args) :mathform :print :nk _knots :mi _mi :df _df :savemodel :xx :savex ); /; Analysis by observation of variables. call marsdiag(%xx,c_sums,r_sums,2,2,'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; iopt=1; iols=1; ihp=0 ; isave=3; iversion=1; igrid=1; ishow=1; fsv_info='Basic GASOUT MARS Model Estimated'; /; 1234567890123456789012 message=', vector values used ]'; call contrib(iopt,message,_medians,iversion,isave,ihp, iols,olscoef,igrid,ishow,fsv_info); b34srun; == ==CONTRIB_1 OLS MARSPLINE GAM PPREG Random Forest /; /; Test of OLS MARSPLINE GAM PPREG Random Forest On Boston Housing Data /; See Hastie-Tibshirani-Friedman (2009, 587-604) /; /; Illustrates different types of forecasts /; b34sexec options ginclude('b34sdata.mac') member(bostonh); b34srun; /; b34sexec list; b34sr b34sexec matrix; call loaddata; call echooff; call load(contrib); /; start ------------------------------------------ call contribi; /; /; specific settings /; _mi=2; _m=30; iols=4; isave=1; _mtry=4; _mtree=20; _alpha=.3; call character(fsv_info,'bostonh Test Case'); call character(l_hand_s,'medv'); call character(_args, 'crim zn indus nox rm age dis rad tax ptratio b lstat'); _argsg=_args; call contribl; call contribd; b34srun; == ==CONTRIB_A Automatic Contribution analysis /; Illustrates nonlinear tests on a famous model /; MARS does not find nonlinearity given settings /; we look only at GAM and OLS b34sexec options copyf(4,6,1,999999,1,80,0,1); datacards; NIST/ITL StRD Dataset Name: Misra1a (Misra1a.dat) File Format: ASCII Starting Values (lines 41 to 42) Certified Values (lines 41 to 47) Data (lines 61 to 74) Procedure: Nonlinear Least Squares Regression Description: These data are the result of a NIST study regarding dental research in monomolecular adsorption. The response variable is volume, and the predictor variable is pressure. Reference: Misra, D., NIST (1978). Dental Research Monomolecular Adsorption Study. Data: 1 Response Variable (y = volume) 1 Predictor Variable (x = pressure) 14 Observations Lower Level of Difficulty Observed Data Model: Exponential Class 2 Parameters (b1 and b2) y = b1*(1-exp[-b2*x]) + e Starting values Certified Values Start 1 Start 2 Parameter Standard Deviation b1 = 500 250 2.3894212918E+02 2.7070075241E+00 b2 = 0.0001 0.0005 5.5015643181E-04 7.2668688436E-06 Residual Sum of Squares: 1.2455138894E-01 Residual Standard Deviation: 1.0187876330E-01 Degrees of Freedom: 12 Number of Observations: 14 b34sreturn; b34seend; b34sexec data heading('MISTRA1 Data'); input y x; datacards; 10.07E0 77.6E0 14.73E0 114.9E0 17.94E0 141.1E0 23.93E0 190.8E0 29.61E0 239.9E0 35.18E0 289.0E0 40.02E0 332.8E0 44.82E0 378.4E0 50.76E0 434.8E0 55.05E0 477.3E0 61.01E0 536.8E0 66.40E0 593.1E0 75.47E0 689.1E0 81.78E0 760.0E0 b34sreturn; b34srun; b34sexec list; b34srun; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix b34sexec matrix; call loaddata; * b1 = 500 250 2.3894212918E+02 2.7070075241E+00 ; * b2 = 0.0001 0.0005 5.5015643181E-04 7.2668688436E-06 ; ans=matrix(2,2: 2.3894212918E+02, 2.7070075241E+00, 5.5015643181E-04, 7.2668688436E-06); testss = 1.2455138894E-01; program test; call echooff; yhat = b1*(kindas(x,1.0)-dexp(kindas(x,-1.)*b2*x)); r=yhat-y; call outstring(3, 3,'b1 b2'); call outdouble(14,3,b1); call outdouble(34,3,b2); return; end; program der; j(,1)= kindas(x,1.) - dexp(kindas(x,-1.0)*(b2*x)); j(,2)= (b1*x)/dexp(b2*x); return; end; j=matrix(norows(y),2:); call print(test,der); call real16info; * Note: start # 1 fails to converge for maxit = 20; * Note: :diff needed to get nllsq to get close to answer !! ; * Note: real*8 and real*16 results gives as a test. real*16 not needed; call nllsq(y,yhat :name test :parms b1 b2 :ivalue array(: 500. .0001) /$ :ivalue array(: 250. .0005) :diff array(: .0000001 .0000001) :maxit 5000 :eps2 .1e-15 :print result); call print('NLLSQ Starting Values 1 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nl2sol(r :name test :parms b1 b2 :ivalue array(: 500. .0001) /$ :ivalue array(: 250. .0005) :print); call print('NL2SOL Starting Values 1 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nllsq(y,yhat :name test :parms b1 b2 /$ :ivalue array(: 500. .0001) :ivalue array(: 250. .0005) :diff array(: .0000001 .0000001) :maxit 5000 :eps2 .1e-15 :print result); call print('NLLSQ Starting Values 2 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nl2sol(r j :name test der :parms b1 b2 :ivalue array(: 500. .0001) /$ :ivalue array(: 250. .0005) :print); call print('NL2SOL with der - Starting Values 1 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); /$ Real*16 ans =r8tor16(ans); testss=r8tor16(testss); x=r8tor16(x); y=r8tor16(y); j=r8tor16(j); call nllsq(y,yhat :name test :parms b1 b2 :ivalue array(: 500. .0001) /$ :ivalue array(: 250. .0005) :diff array(: .0000001 .0000001) :maxit 6000 :eps2 .1e-15 :print result); call print('NLLSQ Starting Values 1 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nl2sol(r :name test :parms b1 b2 :ivalue array(: 500. .0001) /$ :ivalue array(: 250. .0005) :print); call print('NL2SOL Starting Values 1 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nllsq(y,yhat :name test :parms b1 b2 /$ :ivalue array(: 500. .0001) :ivalue array(: 250. .0005) :diff array(: .0000001 .0000001) :maxit 5000 :eps2 .1e-16 :print result); call print('NLLSQ Starting Values 2 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nl2sol(r j :name test der :parms b1 b2 :ivalue array(: 500. .0001) /$ :ivalue array(: 250. .0005) :rfctol .1e-15 :xctol .1e-15 :xftol .1e-15 :maxit 3000 :maxfun 3000 :print); call print('NL2SOL with der - Starting Values 1 on Misrala':); call lre(ans(,1),11,%coef,lretest,bits :print); call print('SE of Coef':); call lre(ans(,2),11,%SE, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); b34srun; b34sexec matrix; call echooff; call loaddata; call load(contrib); call contribi; /; /; specific settings /; _mi=1; _m=10; _alpha=.3; do_ppexp=1; iols=-2; call character(fsv_info,'1. Misrala Model'); call character(l_hand_s,'y'); call character(_args, 'x'); call character(_argsg, 'x[predictor,6]'); call contribd; b34srun; == ==CONTRIB2_A OLS, MARS and GAM Leverage Plots /; /; This setup makes direct calls to olsq, gamfit, marspline & ppreg /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call load(contrib); call contribi; m=6; _knots=20; _mi=2; _df=2.0; iopt=0; iols=3; ihp=0 ; isave=3; iversion=1; igrid=1; ishow=1; fsv_info='Basic GASOUT MARS Model Estimated'; /; 1234567890123456789012 message=', vector values used ]'; /; set left hand side call character(l_hand_s,'gasout'); /; Set right hand side call character(_args,'gasout{1 to m} gasin{1 to m}'); call character(_args2,'gasout[predictor,3]{1 to m} gasin[predictor,3]{1 to m}'); /; Few settings needed after this line except for message /; if iopt=1 call olsq( argument(l_hand_s) argument(_args) :diag :print); olscoef=%coef; /; call marspline(argument(l_hand_s) argument(_args) :mathform :print :nk _knots :mi _mi :df _df :savemodel :xx :savex ); /; Analysis by observation of variables. call marsdiag(%xx,c_sums,r_sums,2,2,'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(_args2) :dist gauss :print :savex :punch_sur); %gamcoef=%coef; %xgam=%x; _m=50; call ppreg(argument(l_hand_s) argument(_args) :savemodel :modname %test :print :m 4 ); ppr_yhat=%yhat; call contrib2(iopt,message,_medians,iversion,isave,ihp, iols,olscoef,igrid,ishow,fsv_info,%spline, %xgam,%gamcoef,%link,%vartype,%df,6,%test); b34srun; == ==CONTRIB2_B OLS, MARS and GAM Leverage Plots /; /; This setup makes direct calls to olsq, gamfit, marspline & ppreg /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; /; /; Illustrates OLS MARS an GAM Leverage Plots /; b34sexec matrix; call loaddata; call echooff; call load(contrib); call contribi; call olsq(lpeptide age bdeficit :print); call gamfit(lpeptide age[predictor,3] bdeficit[predictor,3] :dist gauss :print :savex :punch_sur); m=6; _knots=20; _mi=2; _df=2.0; iopt=0; iols=3; ihp=0 ; isave=3; iversion=1; igrid=1; ishow=1; fsv_info='Basic bdeficit MARS Model Estimated'; /; 1234567890123456789012 /; Needed if iopt=1 message=', vector values used ]'; /; set left hand side call character(l_hand_s,'lpeptide'); /; Set right hand side _args for MARS and OLS args2 for GAM call character(_args, 'age bdeficit'); call character(_args2,'age[predictor,3] bdeficit[predictor,3]'); /; Few settings needed after this line except for message /; if iopt=1 call olsq( argument(l_hand_s) argument(_args) :diag :print); olscoef=%coef; /; call marspline(argument(l_hand_s) argument(_args) :mathform :print :nk _knots :mi _mi :df _df :savemodel :xx :savex ); /; Analysis by observation of variables. call marsdiag(%xx,c_sums,r_sums,2,2,'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(_args2) :dist gauss :print :savex :punch_sur); %gamcoef=%coef; %xgam=%x; _m=50; call ppreg(argument(l_hand_s) argument(_args) :savemodel :modname %test :print :m 4 ); ppr_yhat=%yhat; call contrib2(iopt,message,_medians,iversion,isave,ihp, iols,olscoef,igrid,ishow,fsv_info,%spline, %xgam,%gamcoef,%link,%vartype,%df,6,%test); b34srun; == ==CONTRIB2_C SO4 as a function of Latitude & Longitude /; /; This setup makes direct calls to olsq, gamfit, marspline & ppreg /; /; Study of SO4 and Latitude and Longitude /; Data Studied by Dong Xiang at SAS Institute /; 'Fitting Generalized Additive Models with GAM Procedure' /; SAS paper 256-26 b34sexec options ginclude('b34sdata.mac') member(gam_6); b34srun; b34sexec matrix; call loaddata; call load(contrib); call contribi; call echooff; /; Show surface3 plots surface =0; contriba=1; if(surface.ne.0)then; call olsq(so4 latt long :print); %olsss=%rss; %olsyhat=%yhat; %olsres=%res; /; MARS + Suface Plots call marspline(so4 latt long :df 2. :nk 40 :mi 2 :savex :print :contrib array(2,2: min(latt) mean(long) max(latt) mean(long)) index(100) :surface array(2,2: min(latt) min(long) max(latt) max(long)) index(100,100) ); %marsss=%rss; %x_mars=%x; call graph(%xcrange %contrib :plottype xyplot :xlabel 'Latitude' :pgborder :nocontact :ylabelleft 'Contribution of Latitude to SO4' :markpoint 1 1 3 14 :colors black bblue :file 'mars_cont.wmf' :heading 'Leverage Plot of Latitude vs SO4 based on MARS Model'); %x_mars=%x; x=%surface; /; :pgunits used to label x and y axis! call graph(x :plottype meshstepc :file 'mars_so4.wmf' :rotation 20. :angle 20. :xlabel 'Latitude' :pgunits array(:min(latt) min(long) max(latt) max(long)) :ylabelleft 'Longitude' :zlabelleft 'SO4' :grid :d3axis :d3border :heading 'SO4 = f(Latitude and Longitude based on MARS Model)'); call acefit(so4 latt long :print :savex :xx); call ace_ols; call ace_plot; %acess =%ssres(imin(%ssres)); file='gam.fsv'; call gamfit(so4 latt[predictor,3] long[predictor,3] :print :punch_sur :punch_res :filename file); %gamss=%rss; call gamplot(%names,%lag,file,%olsyhat,%olsres,0); call print(%olsss,%marsss,%acess,%gamss); endif; /; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% if(contriba.ne.0)then; iopt=0; iols=3; ihp=0 ; isave=3; iversion=1; igrid=1; ishow=1; _df=2.; _mi=1; _knots=20; _m=10; fsv_info='SO4 and Latitude and Longitude'; /; 1234567890123456789012 message=', vector values used ]'; /; set left hand side call character(l_hand_s,'so4'); /; Set right hand side call character(_args,'latt long'); call olsq( argument(l_hand_s) argument(_args) :diag :print); olscoef=%coef; call marspline(argument(l_hand_s) argument(_args) :mathform :print :nk _knots :mi _mi :df _df :savemodel :xx :savex ); /; Analysis by observation of variables. call marsdiag(%xx,c_sums,r_sums,2,2,'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(_args) :dist gauss :print :savex :punch_sur); %gamcoef=%coef; %xgam=%x; call ppreg(argument(l_hand_s) argument(_args) :savemodel :modname %test :print :m _m ); ppr_yhat=%yhat; call contrib2(iopt,message,_medians,iversion,isave,ihp, iols,olscoef,igrid,ishow,fsv_info,%spline, %xgam,%gamcoef,%link,%vartype,%df,6,%test); endif; b34srun; == ==CONTRIB2_D Ratkowsky3.dat OLS, MARS, GAM, PPREG & PPEXP b34sexec options copyf(4,6,1,999999,1,80,0,1); datacards; NIST/ITL StRD Dataset Name: Ratkowsky3 (Ratkowsky3.dat) File Format: ASCII Starting Values (lines 41 to 44) Certified Values (lines 41 to 49) Data (lines 61 to 75) Procedure: Nonlinear Least Squares Regression Description: This model and data are an example of fitting sigmoidal growth curves taken from Ratkowsky (1983). The response variable is the dry weight of onion bulbs and tops, and the predictor variable is growing time. Reference: Ratkowsky, D.A. (1983). Nonlinear Regression Modeling. New York, NY: Marcel Dekker, pp. 62 and 88. Data: 1 Response (y = onion bulb dry weight) 1 Predictor (x = growing time) 15 Observations Higher Level of Difficulty Observed Data Model: Exponential Class 4 Parameters (b1 to b4) y = b1 / ((1+exp[b2-b3*x])**(1/b4)) + e Starting Values Certified Values Start 1 Start 2 Parameter Standard Deviation b1 = 100 700 6.9964151270E+02 1.6302297817E+01 b2 = 10 5 5.2771253025E+00 2.0828735829E+00 b3 = 1 0.75 7.5962938329E-01 1.9566123451E-01 b4 = 1 1.3 1.2792483859E+00 6.8761936385E-01 Residual Sum of Squares: 8.7864049080E+03 Residual Standard Deviation: 2.8262414662E+01 Degrees of Freedom: 9 Number of Observations: 15 b34sreturn; b34seend; b34sexec data heading('Ratkowsky # 2 Data'); input y x; datacards; 16.08E0 1.0E0 33.83E0 2.0E0 65.80E0 3.0E0 97.20E0 4.0E0 191.55E0 5.0E0 326.20E0 6.0E0 386.87E0 7.0E0 520.53E0 8.0E0 590.03E0 9.0E0 651.92E0 10.0E0 724.93E0 11.0E0 699.56E0 12.0E0 689.96E0 13.0E0 637.56E0 14.0E0 717.41E0 15.0E0 b34sreturn; b34srun; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix b34sexec matrix; call loaddata; * b1 = 100 700 6.9964151270E+02 1.6302297817E+01; * b2 = 10 5 5.2771253025E+00 2.0828735829E+00; * b3 = 1 0.75 7.5962938329E-01 1.9566123451E-01; * b4 = 1 1.3 1.2792483859E+00 6.8761936385E-01; ans=matrix(4,2: 6.9964151270E+02, 1.6302297817E+01, 5.2771253025E+00, 2.0828735829E+00, 7.5962938329E-01, 1.9566123451E-01, 1.2792483859E+00, 6.8761936385E-01); testss = 8.7864049080E+03; call cls(-1); program test; call echooff; yhat = b1 / ((1.+dexp(b2-b3*x))**(1./b4)); r=y-yhat; call outstring(3, 2,'b1 b2'); call outdouble(14,2,b1); call outdouble(34,2,b2); call outstring(3, 3,'b3 b4'); call outdouble(14,3,b3); call outdouble(34,3,b4); return; end; call print(test); * bad starting values go to a problem with dexp range; * diff setting gets it to work !! ; call nllsq(y,yhat :name test :parms b1 b2 b3 b4 :ivalue array(: 100. 10. 1. 1.) /$ :ivalue array(: 700. 5. .75 1.3) :diff array(: .001 .001 .001 .001) :maxit 1000 :print result); call graph(%res); call print('NLLSQ on RATKOWSKY3 start # 1':); call lre(ans(,1),15,%coef,lretest,bits :print); call print('SE ':); call lre(ans(,2),15,%se, lretest,bits :print); call print('Residual sum of squares':); call lre(testss,15,%fss, lretest,bits :print); call print(' ':); call nllsq(y,yhat :name test :parms b1 b2 b3 b4 /$ :ivalue array(: 100. 10. 1. 1.) :ivalue array(: 700. 5. .75 1.3) :maxit 1000 :print result); call print('NLLSQ on RATKOWSKY3 start # 2':); call lre(ans(,1),15,%coef,lretest,bits :print); call print('SE ':); call lre(ans(,2),15,%se, lretest,bits :print); call print('Residual sum of squares':); call lre(testss,15,%fss, lretest,bits :print); call print(' ':); call nl2sol(r :name test :parms b1 b2 b3 b4 :ivalue array(: 100. 10. 1. 1.) /$ :ivalue array(: 700. 5. .75 1.3) :maxit 1000 :print); call print('NL2SOL on RATKOWSKY3 start # 1':); call lre(ans(,1),15,%coef,lretest,bits :print); call print('SE ':); call lre(ans(,2),15,%se, lretest,bits :print); call print('Residual sum of squares':); call lre(testss,15,%fss, lretest,bits :print); call print(' ':); call nl2sol(r :name test :parms b1 b2 b3 b4 /$ :ivalue array(: 100. 10. 1. 1.) :ivalue array(: 700. 5. .75 1.3) :maxit 1000 :print); call print('NL2SOL on RATKOWSKY3 start # 1':); call lre(ans(,1),15,%coef,lretest,bits :print); call print('SE ':); call lre(ans(,2),15,%se, lretest,bits :print); call print('Residual sum of squares':); call lre(testss,15,%fss, lretest,bits :print); call print(' ':); b34srun; /; See how PPREG does against a known model!! b34sexec matrix; call loaddata; call load(contrib); call echooff; call contribi; /; /; specific settings /; _mi=1; _m=10; do_ppexp=1; _jj=6; _fei=.1e-4; _nei = 1; _trm=.1; _mm=24; _alpha=.3; call character(fsv_info,'26. Ratkowsky3 Growth Model'); call character(l_hand_s,'y'); call character(_args, 'x'); call character(_argsg, 'x[predictor,3]'); call contribl; call contribd; b34srun; == ==CONTRIBD List and run a contrib analysis b34sexec options ginclude('stattest.mac') member(MISRA1A); b34srun; b34sexec matrix; call echooff; call loaddata; call load(contrib); call contribi; /; /; specific settings /; _mi=1; _m=10; do_ppexp=1; call character(fsv_info,'1. Misrala Model'); call character(l_hand_s,'y'); call character(_args, 'x'); call character(_argsg, 'x[predictor,3]'); call contribl; call contribd; b34srun; == ==CONTRIBL List and run a contrib analysis b34sexec options ginclude('stattest.mac') member(MISRA1A); b34srun; b34sexec matrix; call echooff; call loaddata; call load(contrib); call contribi; /; /; specific settings /; _mi=1; _m=10; _alpha=.3; do_ppexp=1; call character(fsv_info,'1. Misrala Model'); call character(l_hand_s,'y'); call character(_args, 'x'); call character(_argsg, 'x[predictor,3]'); call contribl; call contribd; b34srun; == ==COPY Copy an object b34sexec matrix; x=2.; call copy(x,y); call print(y); vpax=vpa(rn(array(5:))); call copy(vpax,vpay); call print(vpax,vpay); i=integers(6); i8=i4toi8(i); call copy(i8,i8copy); call print(i,i8,i8copy); b34srun; == ==COPY_2 Advanced use of call copy( ) b34sexec matrix; /; shows passing a name to a routine at execution; /; User wants the name my_x_dat & my_Y_dat for the /; random walk series!! These sure look like economic series n=10000; data1= cusum(rn(array(n:))); data2= cusum(rn(array(n:))); subroutine test(data1,data2,name1,name2); call copy(data1,argument(name1)); call copy(data2,argument(name2)); call graph(argument(name1),argument(name2) :Heading 'This Model is Spurious!!' :nokey); call describe(argument(name1),argument(name2)); call olsq(argument(name1),argument(name2) :print); return; end; name1='my_y_dat'; name2='my_x_dat'; call test(data1,data2,name1,name2); b34srun; == ==COPY_3 More Complex Copy commands between levels b34sexec matrix; x=1.; call makeglobal(x); call setlevel(now); code=99.0; /; Put from local level to level 9 call copy(code,codeat9,9); call names(all); call print(level(code)); call print(level(x)); call print(level(codeat9)); /; get from level 9 call copy(codeat9,testcode,-9); call print('Is testcode 99?',testcode); do i=1,2; xx=33.; call setlevel(up); call setlevel(now); call names(all); call setlevel(up); call setlevel(now); call setlevel(down); call setlevel(down); enddo; call setlevel(base); call names(all); b34srun; b34sexec matrix; call setlevel(110); x=1.; call makeglobal(x); call setlevel(now); i=1; xx=33.; call names(all); call copy(xx,xxnew,102); call names(all); call setlevel(102); /;call print('can we see this??',level()); call names(all); call print(xxnew); xx=99.; call print(level()); i=989; call copy(i,iat1,1); call names(all); call setlevel(200); call print('iat1 should be 989',iat1); call print(level()); call names(all); call stop; b34srun; == ==COPYF Copy from a file to a file /$ Running Matlab script under B34S Matrix b34sexec options; pgmcards; x=rand(6) xi=inv(x); x*xi yy=[1 2 3 2 1] plot(yy) pause quit b34sreturn; b34srun; b34sexec matrix; call open(77,'test.m'); call rewind(77); call rewind(4); call copyf(4,77); call close(77); call dodos('start /w matlab /r test /logfile test.out':); call dounix('matlab < test.m > test.out'); call dodos('pause'); call copyout('test.out'); b34srun; == ==CROLLEDOFF b34sexec matrix; call print('Default Settings':); call real16info; call crolledoff; call real16info; call crolledon; call real16info; b34srun; == ==CROLLEDON b34sexec matrix; call print('Default Settings':); call real16info; call crolledoff; call real16info; call crolledon; call real16info; b34srun; == ==COPYLOG Illustrates COPYLOG b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; n=5; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call copylog('testdata'); call copyout('testdata'); b34srun; == ==COPYOUT Illustrates COPYOUT Command b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; n=5; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call copylog('testdata'); call copyout('testdata'); b34srun; == ==COPYOUT2 Calls RATS under MATRIX Command /$ /$ Illustrates calling rats under b34s MATRIX /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; newgaso(3)=missing(); call makerats(gasin,newgasi,gasout,newgaso :file 'full.por'); call print(mean(gasin)); call open(70,'rats.in'); call character(cc,'all 3000'); call write(cc,70); call character(cc,"open data 'full.por'"); call write(cc,70); call character(cc,'data(format=portable)'); call write(cc,70); call character(cc,'table'); call write(cc,70); call character(cc,'print'); call write(cc,70); call rewind(70); call close(70); /$ Note : since command writes output !!! /$call dodos('start /w rats386 rats.in rats.out',:); call dodos('start /w /r rats32s rats.in /run',:); call dounix('rats rats.in rats.out',:); call copyout('rats.out'); b34srun; == ==CPERIOD Normalized Cumulative Periodogram b34sexec options ginclude('gas.b34'); b34srun; /$ /$ Job tests c_period Command /$ See Box-Jenkins-Reinsel (2008, 347-350 /$ b34sexec matrix; call loaddata; call load(cperiod); idrop=0; call cperiod(gasout,'gasout',c_period,c_p_freq,idrop); x=rn(gasout); call cperiod(x, 'ran()',c_period,c_p_freq, idrop); b34srun$ == ==CSPECTRAL Call CSPECTRAL Command => Cross Spectral Analysis b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; * For sample output See Stokes (1997) page 424; call cspectral(gasin,gasout,sinx,siny,cosx,cosy,px,py,sx,sy, rp,ip,cs,qs,a,k,ph,freq:1 2 3 4 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call tabulate(freq2,period,sinx,siny,cosx,cosy,px,py,sx,sy); call tabulate(freq2,period,rp,ip,cs,qs,a,k,ph); call graph(freq2,a :heading 'Amplitude':plottype xyplot); call graph(freq2,k :heading 'Coherence':plottype xyplot); call graph(freq2,ph:heading 'Phase':plottype xyplot); b34srun; == ==COPYTIME Copied time info from series1 to series2 b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call describe(m1dp :print); xx=m1dp*2.; call describe(xx :print); call copytime(m1dp,xx); call describe(xx :print); call copytime(m1dp,xx,10); call describe(xx :print); b34srun; == ==CSPLINE Calculate a cubic spline for 1 D data b34sexec matrix; n=11; ntest=(n*2)-1; * problem from IMSL for csint and csakm; x=grid(0.0, 1.0,(1.0/dfloat(n-1) )); f=dsin(15.*x); x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); ftest =dsin(15.*x2); testder=2.*x2*dcos(x2*x2); maxerr1=array(15:); maxerr2=array(15:); spline1 =cspline(x,f :type csint); spline2 =cspline(x,f :type csakm); fit1 =csplineval(spline1,x2); fit2 =csplineval(spline2,x2); err1=fit1-ftest; err2=fit2-ftest; call tabulate(x2,ftest,fit1,err1,fit2,err2); * Problem for cscon ; * Results tested for csint; x=array(9: 0.0 .1 .2 .3 .4 .5 .6 .8 1.); f=array(9: 0.0 .9 .95 .9 .1 .05 .05 .2 1.); spline1=cspline(x,f :type cscon); spline2=cspline(x,f :type csint); call print('Note: Break points in Col. 1':); call print('cscon results ',spline1); call print('csint results ',spline2); fit1=csplineval(spline1,x2); fit2=csplineval(spline2,x2); call tabulate(fit1,fit2); call graph(fit1,fit2); * Problem for csscv; n=300; x=grid(0.0, 3.0,(1.0/dfloat(n-1) )); f=1.0/(.1+(3.0*(x-1.0))**4.) ; call i_rnset(1234579); f = f+ (2.*rec(x :imsl10)) -1.; spline=cspline(x,f :type csscv :equal); testx=array(10:); do i=1,10; testx(i)=90.*dfloat(i-1)/dfloat(n-1); enddo; sval = csplineval(spline,testx) ; actual= 1.0/(.1+(3.0*(testx-1.0))**4.) ; error = sval-actual; call tabulate(testx,actual,sval,error); b34srun; == ==CSPLINEDER Calculate spline derivative given spline value b34sexec matrix; n=11; ntest=(n*2); * problem from IMSL for csint; x=array(n:); x2=array(ntest:); do i=1,n; x(i)=dfloat(i-1)/10.; enddo; do i=1,ntest; x2(i)=dfloat(i-1)/20.; enddo; /$x=grid(0.0, 1.0,(1.0/dfloat(n-1) )); /$ x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); f = dsin(15.*x); f2 = dsin(15.*x2); df =15.0 *dcos(15.*x2); ddf=-225.*dsin(15.*x2); spline =cspline(x,f :type csint); cf =csplineder(spline,x2,0); ff =csplineval(spline,x2); cdf1 =csplineder(spline,x2,1); cddf1 =csplineder(spline,x2,2); err=cf-f2; /$ tests two ways to get same thing err0=ff-cf; /$ err1= df-cdf1; err2=ddf-cddf1; call tabulate(x2,cf,f2,err,df,cdf1,err1,ddf,cddf1,err2); b34srun; == ==CSPLINEFIT Fit a 1 D Cubic Spline using alternative models b34sexec matrix; n=21; ntest=(n*2)-1; * problem from IMSL; x=3.0*grid(0.0, 1.0,(1.0/dfloat(n-1) )); f=dsin(x*x); x2=3.0*grid(0.0,1.0,(1.0/dfloat(ntest-1))); ftest =dsin(x2*x2); testder=2.*x2*dcos(x2*x2); maxerr1=array(15:); maxerr2=array(15:); do i=1,15; fit =csplinefit(x,f,x2,0 :type i); fitder=csplinefit(x,f,x2,1 :type i); maxerr1(i)=dmax(dabs(ftest-fit)) ; maxerr2(i)=dmax(dabs(testder-fitder)); enddo; type=integers(15); call print('maxerr1 is fit error. maxerr2 = derivative error'); call tabulate(type,maxerr1,maxerr2); b34srun; == ==CSPLINEITG Calculate integral of a cubic spline b34sexec matrix; * problem from IMSL ; n=10; ntest=(n*2)-1; * problem from IMSL for csint and csakm; x =grid(0.0, 1.0,(1.0/dfloat(n-1) )); x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); f = x*x; fi = x*x*x/3.; spline =cspline(x,f :type csint); lower=0.0; upper=.5; cfi=csplineitg(lower,upper,spline); exact=upper*upper*upper/3.; err=cfi-exact; call Print('Problem # 1 ':); call print('Lower range ',lower:); call print('Upper range ',upper:); call print('Integral ',cfi:); call print('Exact ',exact:); call print('Error ',err); upper=.2; cfi=csplineitg(lower,upper,spline); exact=upper*upper*upper/3.; err=cfi-exact; call print('Problem # 2 ':) call print('Lower range ',lower:); call print('Upper range ',upper:); call print('Integral ',cfi:); call print('Exact ',exact:); call print('Error ',err); b34srun; == ==CSPLINEVAL Calculate spline value given spline b34sexec matrix; n=11; ntest=(n*2)-1; * problem from IMSL for csint and csakm; x=grid(0.0, 1.0,(1.0/dfloat(n-1) )); f=dsin(15.*x); x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); ftest =dsin(15.*x2); testder=2.*x2*dcos(x2*x2); maxerr1=array(15:); maxerr2=array(15:); spline1 =cspline(x,f :type csint); spline2 =cspline(x,f :type csakm); fit1 =csplineval(spline1,x2); fit2 =csplineval(spline2,x2); err1=fit1-ftest; err2=fit2-ftest; call tabulate(x2,ftest,fit1,err1,fit2,err2); b34srun; == ==CSV Read and write CSV file /; Test csv command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; people=c8array(:'houston','diana','will','bobby'); ii=dfloat(integers(10)); call csv(:writefile 'mycsv.csv' :comment 'This is a test write' :var gasout gasin people ii); x=rn(matrix(10,5:)); call echooff; do i=1,nocols(x); call print(i,mean(x(,i))); enddo; /; call print(x); call csv(:writefile 'mycsv2.csv' :comment 'This is a test matrix' :var x ); call cleardat; call names; call csv(:readfile 'mycsv.csv'); call names; call print(%series); n= norows(%series); call tabulate(gasout,gasin,people,ii); call print(mean(gasout),mean(gasin)); do i=1,n; if(kind(eval(%series(i))).eq.8)then; g=goodrow(eval(%series(i))); call copy(g,argument(%series(i))); call print(' ':); call describe( eval(%series(i):)); call graph( eval(%series(i):)); endif; enddo; /; reading matrix call cleardat; call names; call csv(:readfile 'mycsv2.csv'); call names; /; Tests with alternative file saving of missing data x=rn(array(5:)); y=rn(array(10:)); call csv(:writefile 'mycsv3.csv' :var x y :nsmissing ); call csv(:writefile 'mycsv4.csv' :var x y :missing ); call cleardat; call csv(:readfile 'mycsv3.csv' ); call tabulate(X,Y); call cleardat; call csv(:readfile 'mycsv4.csv' ); call tabulate(X,Y); b34srun; == ==CSV2 CSV File Processing /; Writes with names and header but adds lines only b34sexec matrix; n=10; k=3; x=rn(array(n,k:)); call csv(:writefile 'test.csv' :var x); x=x*10.; call csv(:writefile 'test.csv' :var x :add :nonames :nodatestamp); b34srun; /; Writes without names b34sexec matrix; n=10; k=3; x=rn(array(n,k:)); call csv(:writefile 'test2.csv' :var x :nodatestamp :nonames ); x=x*10.; call csv(:writefile 'test2.csv' :var x :add :nonames :nodatestamp); b34srun; /; Test reads b34sexec matrix; call csv(:readfile 'test.csv'); call names(all); /; /; Two ways to print /; do i=1,norows(%series); call print(argument(%series(i))); enddo; /; /; Note use of padding to put a blank after the name /; call character(cc,%series :9); call print(cc); call tabulate(argument(cc)); b34srun; /; Reading a noname file using call read b34sexec matrix; n=20; k=3; call open(71,'test2.csv'); tdata=array(k,n:); call read(tdata,71); call close(71); tdata=transpose(tdata); call print(tdata); b34srun; == ==CSV3 Loading Data from Matrix to Stata /; /; read in Stata with /; insheet double using c:\b34swork\mycsv2.cvs /; b34sexec matrix; x=rn(matrix(1000,200:)); call csv(:writefile 'mycsv2.csv' :var x :nodatestamp); b34srun; == ==CSVTOB34S Uses CSV to load data in B34S /; Test csv command input into basic b34s /; ++++++++++++++++++++++++++++++++++++++++++++++++++ /; part of testing /; ++++++++++++++++++++++++++++++++++++++++++++++++++ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; /; people=c8array(:'houston','diana','will','bobby'); /; ii=dfloat(integers(10)); tlgasout=log(gasout); testtest=log(gasout)/2.; call csv(:writefile 'mycsv.csv' :comment 'This is a test write' /; :var gasout gasin people ii); :var gasout gasin tlgasout testtest); b34srun; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; Reading mycsv.csv into the basic b34s - 99 series limit /; Shows two ways to proceed: 1. User controls what is passed /; 2. All series passed /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ b34sexec matrix; call echooff; call csv(:readfile 'mycsv.csv'); call names; call print(%series); n= norows(%series); itest=0; if(itest.ne.0)then; do i=1,n; if(kind(eval(%series(i))).eq.8)then; g=goodrow(eval(%series(i))); call copy(g,argument(%series(i))); call print(' ':); call describe( eval(%series(i):)); call graph( eval(%series(i):)); endif; enddo; endif; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; this command allows the user to set exactly what series to load /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ call makedata(gasin :file 'csvdata.b34' :heading 'user data'); /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; these commands pass all the series in the cvs file to B34S /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ call load(catname :staging); if(n.gt.98)then; call epprint('ERROR: Number of series passed > 98':); call epprint(' ----------------------------':); call stop; endif; call catname(%series,' ',%series,0); call makedata(argument(%series) :heading 'csvdata2 data' :file 'csvdata2.b34'); /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ b34srun; b34sexec options include('csvdata.b34' ); b34srun; b34sexec options include('csvdata2.b34'); b34srun; == ==CSVTOB34S2 Alternative CSV to B34S /; +++++++++++++++++++++++++++++++++++++++++++ /; This job does not test the number of series /; +++++++++++++++++++++++++++++++++++++++++++ /; ++++++++++++++++++++++++++++++++++++++++++++++++++ /; part of testing /; ++++++++++++++++++++++++++++++++++++++++++++++++++ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; /; people=c8array(:'houston','diana','will','bobby'); /; ii=dfloat(integers(10)); tlgasout=log(gasout); testtest=log(gasout)/2.; call csv(:writefile 'mycsv.csv' :comment 'This is a test write' /; :var gasout gasin people ii); :var gasout gasin tlgasout testtest); b34srun; /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ %B34SLET IN ="'mycsv.csv'" $ %B34SLET OUT ="'myb34s.b34'" $ b34sexec matrix; call csv(:readfile %b34seval(&in)); %_n=norows(%series); %_c=c8array(%_n*2:); %_i=integers(1,%_n); %_j=integers(1,2*%_n,2); %_c(%_j)=%series(%_i); call makedata(argument(%_c) :file %b34seval(&out)); b34srun; b34sexec options include(%b34seval(&out) ); b34srun; == ==CUSUM Cumulative Sum Function b34sexec matrix; n=10; a=dfloat(integers(n)); ccusum=cusum(a); ccusumsq=cusumsq(a); call tabulate(a,ccusum,ccusumsq); call print(sum(a),sumsq(a)); b34srun; == ==CUSUMSQ Cumulative Sum of Squares function b34sexec matrix; n=10; a=dfloat(integers(n)); ccusum=cusum(a); ccusumsq=cusumsq(a); call tabulate(a,ccusum,ccusumsq); call print(sum(a),sumsq(a)); b34srun; == ==CWEEK Character form of Week Day /$ Tests Y2K capability of B34S /$ /$ day month year read in and converted to julian /$ /$ julian = # of days since 1 Jan 1960 /$ /$ b34s data step looks at day ahead and behind /$ /$ dates in 1400's, 1800's 1900's 2000's and 2100's tested /$ /$ ******************************************************* /$ b34sexec options sasdateon; b34srun; b34sexec data heading('Y2K test') idvar=cdate1; input day month year ; build dayinyr dbehind1 dbehind2 dahead1 cweekd iweekd dahead2 qt cdate1 cdate2 julian julianp1 julianm1; character cdate1 cdate2 dbehind1 dbehind2 dahead1 dahead2 cweekd; gen julian = juldaydmy(day,month,year); gen dayinyr = julian - juldaydmy(1,1,getyear(julian))+1.; gen cdate1 = chardate(julian); gen cdate2 = chardatemy(julian); gen julianp1=julian+1.; gen julianm1=julian-1.; gen dbehind1= chardate(julianm1); gen dbehind2= chardatemy(julianm1); gen dahead1 = chardate(julianp1); gen dahead2 = chardatemy(julianp1); gen qt = getqt(julian); gen iweekd = iweek(julian); gen cweekd = cweek(julian); datacards; 9 9 1999 31 12 1999 1 1 2000 2 1 2000 3 1 2000 28 2 2000 29 2 2000 1 3 2000 31 12 2000 1 1 1850 31 12 1899 1 1 2001 5 1 2100 1 5 1492 1 1 1999 2 1 1999 1 2 1999 1 1 1960 b34sreturn; b34seend; b34sexec list ; b34srun; b34sexec list; var julian julianp1 julianm1; b34srun; /$ /$ Data passed to Matrix to see it it prints OK /$ b34sexec matrix; call loaddata; call names; call tabulate(day month year julian dayinyr dbehind1 dbehind2 dahead1 dahead2 qt); call tabulate(day month year julian julianm1 julianp1 cdate1 cdate2); tj =chardate(julian); tjm1 =chardate(julianm1); tjp1 =chardate(julianp1); iiweekd =iweek(julian); ccweekd =cweek(julian); julian =idint(julian); julianm1=idint(julianm1); julianp1=idint(julianp1); call print('This tests calculations within MATRIX of julian data'); call tabulate(day month year julian julianm1 julianp1 tj tjm1 tjp1); call tabulate(day,month,year,julian,iiweekd,ccweekd,iweekd,cweekd); b34srun; == ==CUMFCST Cumulative Forecast b34sexec data heading('cumfcst Test'); input obs y fcst _TCUMF ; label obs = 'Observation #'; label y = 'Actual Data '; label fcst = 'Forecast value'; label _tcumf = 'Test value '; datacards; 1 440 . . 2 2200 . . 3 2640 1980 . 4 2200 1980 1980 5 880 1980 1980 6 4400 1980 1980 7 440 1980 1980 8 2200 1980 1980 9 0 1980 . 10 440 1980 3960 11 1760 1709 1980 12 1320 1747 1709 13 2640 1780 1747 14 2640 1809 1780 15 1760 1834 1809 16 2640 1856 1834 17 2640 1875 1856 18 5280 1890 1875 19 1760 1904 1890 20 440 1916 1904 21 0 1926 . 22 0 1926 . 23 1320 1926 5767 24 3520 1476 1926 25 2200 1539 1476 26 880 1595 1539 27 3080 1646 1595 28 0 1691 . 29 880 1691 3337 30 1760 1520 1691 31 0 1578 . 32 4840 1578 3099 33 0 1442 . 34 440 1442 3021 35 0 1345 . 36 1760 1345 2787 37 440 1272 1345 38 2200 1349 1272 39 4400 1421 1349 40 0 1487 . 41 440 1487 2908 42 440 1378 1487 43 6600 1448 1378 44 880 1512 1448 45 0 1571 . 46 1760 1571 3083 47 440 1437 1571 48 0 1502 . 49 4840 1502 2940 50 440 1388 1502 51 2640 1458 1388 52 440 1521 1458 53 1760 1579 1521 54 1760 1632 1579 55 0 1679 . 56 0 1679 . 57 880 1679 4989 58 3960 1348 1679 59 2640 1420 1348 60 440 1487 1420 61 880 1548 1487 b34sreturn; b34srun; b34sexec matrix; call loaddata; call echooff; subroutine crfcst(y, fcst, %crfcst); /; /; Shows logic of "hardwired" cumfcst command /; /; y = actual data that may contain 0.0 values /; fcst = forecast of actual data /; %crfcst = cumlulative forecast /; /; Routine built by William Lattyak November 2010 /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ fcst=fcst(integers(1,norows(y))); _zsum=0.; _tfcst=recode(fcst,missing(),0.); %crfcst=_tfcst; %crfcst=%crfcst*0.; %crfcst=recode(%crfcst,0.,missing()); _ibegin=0; do %iiii=1,norows(fcst); if ((sfam(y(%iiii)) .ne. 0.0) .and. (sfam(_tfcst(%iiii)) .ne. 0.0))then; if(_ibegin .eq. 0) then; _zsum=sfam(missing()); _ibegin=1; endif; %crfcst(%iiii)=_zsum; _zsum=0.; endif; _zsum=_zsum + _tfcst(%iiii); enddo; return; end; fcst2=fcst; call crfcst(y,fcst, test1); call cumfcst(y,fcst2,test2); call tabulate(y,fcst,test1,test2,_tcumf :title 'test1 = subroutine value. test2 = internal command'); b34srun; == ==DABS Illustrate DABS Command b34sexec matrix; ints=integers(20); ints=ints-10; reals =dfloat(ints); aints =dabs(ints); areal8 =dabs(reals); areal16=dabs(r8tor16(reals)); areal4 =dabs(r8tor4(reals)); vpareal=dabs(vpa(reals)); call tabulate(ints,aints,reals,areal8,areal16,areal4,vpareal); b34srun; == ==DARCOS Arc cosine of real*8 variable b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); x16=r8tor16(x); x_vpa=vpa(x); asin=darsin(x); acos=darcos(x); atan=datan(x); asin16=darsin(x16); acos16=darcos(x16); atan16=datan(x16); vpaasin=darsin(x_vpa); vpaacos=darcos(x_vpa); vpaatan= datan(x_vpa); call tabulate(x,asin, acos, atan, asin16,acos16,atan16 vpaasin,vpaacos,vpaatan); b34srun; == ==DARSIN Arc sin of real*8 variable b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); x16=r8tor16(x); x_vpa=vpa(x); asin=darsin(x); acos=darcos(x); atan=datan(x); asin16=darsin(x16); acos16=darcos(x16); atan16=datan(x16); vpaasin=darsin(x_vpa); vpaacos=darcos(x_vpa); vpaatan= datan(x_vpa); call tabulate(x,asin, acos, atan, asin16,acos16,atan16 vpaasin,vpaacos,vpaatan); b34srun; == ==DATAFREQ Data Frequency b34sexec matrix; * IMSL test cases for one-way Frequency analysis; x=array(:0.77, 1.74, 0.81, 1.20, 1.95, 1.20, 0.47, 1.43, 3.37, 2.20, 3.00, 3.09, 1.51, 2.10, 0.52, 1.62, 1.31, 0.32, 0.59, 0.81, 2.81, 1.87, 1.18, 1.35, 4.75, 2.48, 0.96, 1.89, 0.90, 2.05); call datafreq(x,table1 :equal 10 midpts1); call tabulate(table1,midpts1); xlow=.5; xhigh=4.5; call datafreq(x,table2 :equaluser 10 midpts2 xlow xhigh); call names(all); call tabulate(table2,midpts2); cutpts=array(:.5 1.0 1.5 2.0 2.5 3.0 3.5 4.0 4.5); call datafreq(x,table3 :usercutoff cutpts); call tabulate(table3,cutpts); classmk=array(:.25 .75 1.25 1.75 2.25 2.75 3.25 3.75 4.25 4.75); clhw=.25; call datafreq(x,table4 :userclass classmk clhw); call tabulate(table4,classmk); test =array(6: 1 1 3 4 4 6); cut =dfloat(integers(1,16)); call tabulate(test,cut); call datafreq(test,freqc :count cut); call tabulate(test,freqc, cut); b34srun; == ==DATAN Arc tan of real*8 variable b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); x16=r8tor16(x); x_vpa=vpa(x); asin=darsin(x); acos=darcos(x); atan=datan(x); asin16=darsin(x16); acos16=darcos(x16); atan16=datan(x16); vpaasin=darsin(x_vpa); vpaacos=darcos(x_vpa); vpaatan= datan(x_vpa); call tabulate(x,asin, acos, atan, asin16,acos16,atan16 vpaasin,vpaacos,vpaatan); b34srun; == ==DATAN2 Arc tan of two real*8 variable b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); y=array(norows(x):)+2.; x16=r8tor16(x); y16=r8tor16(y); xvpa=vpa(x); yvpa=vpa(y); asin=darsin(x); acos=darcos(x); atan=datan(x); atan2=datan2(x,y); atan2_16=datan2(x16,y16); atan2vpa=datan2(xvpa,yvpa); call tabulate(x,y,asin,acos,atan,atan2,atan2_16,atan2vpa); b34srun; == ==DATAREAD Three simple setups for a read /; As an alternative see call csv command /; Shows a simple read b34sexec matrix; datacards; 3 4 x1 x2 x3 x4 11 22 33 44 55 66 77 88 99 10 11 12 b34sreturn; call dataread(:unit 4); call names; call tabulate(x1 x2 x3 x4); b34srun; /; Note that is :noob and :nvar are set, first card not needed b34sexec matrix; datacards; x1 x2 x3 x4 11 22 33 44 55 66 77 88 99 10 11 12 b34sreturn; call dataread(:unit 4 :precision real8 :noob 3 :nvar 4); call names; call tabulate(x1 x2 x3 x4); b34srun; /; Reading from a file b34sexec matrix; call open(77,'test2.txt'); c=c1array(4,12: ' x1 x2 x3 ' ' 11. 22. 33.' ' 44. 55. 66.' ' 77. 88. 99.'); /; build test file do i=1,4; call write(c(i,),77); enddo; call close(77); /; Now read test file call dataread(:file 'test2.txt' :noob 3 :nvar 3); call tabulate(x1,x2,x3); b34srun; == ==DATAREAD2 Read Data into Matrix Command /; Shows three reads b34sexec matrix; datacards; 3 4 x1 x2 x3 x4 11 22 33 44 55 66 77 88 99 10 11 12 3 4 y1 y2 y3 y4 11 22 33 joe 55 66 77 sam 99 10 11 tom b34sreturn; call dataread(:unit 4 :precision real8); call names; call tabulate(x1 x2 x3 x4); /; Testing means call rewind(4); call dataread(:unit 4 :precision real8 :means); call print(%means,%vnames); /; Read next 4 obs call dataread(:unit 4 :character namelist(y4)); call tabulate(y1 y2 y3 y4); call rewind(4); call names(all); /; now reading first 4 in real*16 oldx1=x1; oldx2=x2; oldx3=x3; oldx4=x4; call rewind(4); call print('Reading data into real*16':); call print('_________________________':); call dataread(:unit 4 :precision real16 :means); call tabulate(x1 x2 x3 x4); call print(%means,%vnames); call names(all); call rewind(4); call names(all); /; Reading in vpa oldx1=x1; oldx2=x2; oldx3=x3; oldx4=x4; call print('Reading data into VPA':); call print('_____________________':); call dataread(:unit 4 :precision vpa :means ); call tabulate(x1 x2 x3 x4); call print(%means); call names(all); b34srun; /; Using Option # 2 b34sexec matrix; datacards; 11 22 33 44 55 66 77 88 99 10 11 12 11 22 33 joe 55 66 77 sam -9 -8 -7 tom b34sreturn; /; /; doing two reads; /; call dataread(:unit 4 :names namelist(x1 x2 x3 x4) :precision real8 :noob 3); call tabulate(x1 x2 x3 x4); call dataread(:unit 4 :character namelist(y4) :names namelist(y1 y2 y3 y4) :noob 3); call tabulate(y1 y2 y3 y4); b34srun; /; Create a file and read it back b34sexec matrix; call echooff; noob=100; nvar=3; x=rn(array(noob,nvar:)); call print(x); call open(77,'test.txt'); do i=1,noob; call write(x(i,),77); enddo; call close(77); call dataread(:file 'test.txt' :noob noob :names namelist(x1 x2 x3) :precision real16); call tabulate(x2,x2,x3); call print(mean(x(,1)), mean(x(,2)), mean(x(,3))); call print(mean(x1 ), mean(x2 ), mean(x3 )); call open(77,'test2.txt'); c=c1array(3,12: ' 11. 22. 33.' ' 44. 55. 66.' ' 77. 88. 99.'); do i=1,3; call write(c(i,),77); enddo; call close(77); call dataread(:file 'test2.txt' :noob 3 :format '(3f4.0)' :names namelist(x1 x2 x3) :precision real8); call tabulate(x1,x2,x3); b34srun; == ==DATAVIEW View Data Under User Control b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(dataview); call load(data_acf); call load(cperiod); call dataview(gasout,namelist(gasout)); b34srun; == ==DATA_ACF ACF & PACF of a series b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(data_acf); call load(do_spec); call character(cc,'ACF & PACF of GASOUT'); call data_acf(gasout,cc,60); weights=array(:1 2 3 2 1); call character(cc,'Spectral Analysis of Gasout'); call do_spec(gasout,cc,weights); b34srun; == ==DATA2ACF ACF & PACF of a series /; /; Same as data_acf except argument for file /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(data2acf); call load(do2spec); call character(cc,'ACF & PACF of GASOUT'); call data2acf(gasout,cc,60,'acf_plot.wmf'); weights=array(:1 2 3 2 1); call character(cc,'Spectral Analysis of Gasout'); call do2spec(gasout,cc,weights,'gas_spec.wmf'); b34srun; == ==DATA3ACF ACF & PACF of a series /; /; Same as data_acf except argument for file /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(data3acf); call character(cc,'GASOUT'); call data3acf(gasout,cc,60,'acf_plot.wmf'); b34srun; == ==DATENOW Date now in form dd:mm:yy b34sexec matrix; call print('Date now is ',datenow():); call print('Time now is ',timenow():); b34srun; == ==DBLE Real*4 to Real*8 b34sexec matrix; x=dfloat(integers(20)); xreal4=sngl(x); xreal8=dble(xreal4); call names(all); call tabulate(x,xreal4,xreal8); b34srun; == ==DCONJ Conjugate of a complex number b34sexec matrix; cc=complex(dfloat(integers(10)),dsqrt(dfloat(integers(10)))); call tabulate(cc,dconj(cc) :title 'Complex*16 Case'); cc=c16toc32(cc); call tabulate(cc,dconj(cc) :title 'Complex*32 Case'); b34srun; == ==DCOS Illustrates Cosine b34sexec matrix; n=10.; test=grid(0.0,pi()*n,.1); cc =dcos(test); ss =dsin(test); tt =dtan(test); cc16=dcos(r8tor16(test)); ss16=dsin(r8tor16(test)); tt16=dtan(r8tor16(test)); call tabulate(test,cc,ss,tt,cc16,ss16,tt16); call graph(test,cc,ss:heading 'Cosine & Sine' :plottype xyplot); b34srun; == ==DCOSH Hyperbolic Cosine of real*8 value b34sexec matrix; x=dfloat(integers(-10,10)); dcosh2 =dcosh(x); dsinh2 =dsinh(x); dtanh2 =dtanh(x); dcosh216=dcosh(r8tor16(x)); dsinh216=dsinh(r8tor16(x)); dtanh216=dtanh(r8tor16(x)); call tabulate(x,dcosh2,dsinh2,dtanh2,dcosh216,dsinh216,dtanh216); b34srun; == ==DDOT Inner product and related commands b34sexec matrix; n=10; x=rn(vector(n:)); y=rn(x); call print(x,y); call print(x*y,ddot(x,y),afam(x)*afam(y),ddot(x,y:), sum(afam(x)*afam(y))); * Complex case ; cx=complex(x,y); cy=complex(y,x); call print(cx,cy); call print(cx*cy,dconj(cx)*cy,zdotu(cx,cy),zdotc(cx,cy), afam(cx)*afam(cy),dconj(afam(cx))*afam(cy), zdotu(cx,cy:),zdotc(cx,cy:), sum( afam(cx) *afam(cy)), sum(dconj(afam(cx))*afam(cy)) ); b34srun; == ==DELETECOL Illustrates deletecolw Capability b34sexec matrix; n=6; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call deletecol(test); call print('We delete at the right',test); test=x; call deletecol(test,2,4); call print('We delete 4 cols after 1 ',test); b34srun; == ==DELETEROW Illustrates deleterow Capability b34sexec matrix; n=6; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call deleterow(test); call print('We delete at the end',test); test=x; call deleterow(test,2,4); call print('We remove 4 rows after 1 ',test); /; Use with 1 d objects call print('Use with D1 objects':); d1=x(,1); call print(d1); test=d1; call deleterow(test); call print('We delete at the end',test); test=d1; call deleterow(test,2,4); call print('We remove 4 rows after 1 ',test); b34srun; == ==DERF Error Function b34sexec matrix; x=grid(.1, 5., .2); derf1 =derf(x); derf1c =derfc(x); test =derf1 + derf1c; derf1_16 =derf(r8tor16(x)); derf1c16 =derfc(r8tor16(x)); test16 =derf1_16+derf1c16; call tabulate(x,derf1,derf1c,test,derf1_16 derf1c16,test16); b34srun; == ==DERFC Inverse Error Function b34sexec matrix; x=grid(.1, 5., .2); derf1 =derf(x); derf1c =derfc(x); test =derf1 + derf1c; derf1_16 =derf(r8tor16(x)); derf1c16 =derfc(r8tor16(x)); test16 =derf1_16+derf1c16; call tabulate(x,derf1,derf1c,test,derf1_16 derf1c16,test16); b34srun; == ==DERIVATIVE Derivative of a vector using Quadratic method. b34sexec matrix; * model is f(x) = 10. -.5*x + .01*x**2 ; x=afam(grid(.01,10.,.01)); fx=10. -.5*x + .01*x**2.; dd=derivative(fx,x); call graph(fx,dd :Heading 'Linear case'); test=-.5+.02*x; call tabulate(x,fx,dd,test); * model is f(x) = 10. -.5*x + .01*x**3 ; x=afam(grid(.01,10.,.01)); fx=10. -.5*x + .01*x**3.; dd=derivative(fx,x); call graph(fx,dd :Heading 'Non-linear case'); test=-.5+.03*x; call tabulate(x,fx,dd,test); b34srun; == ==DESCRIBE Calculate Moment 1-4 and 6 of a series /; rats tests results %b34slet runrats=0; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; x=rn(array(1000:)); call describe(x :print); * Show variables created in named storage ; call names(all); call describe(gasin :print); call describe(gasout :print); /; /; Illustrate no variance series /; x=array(1000:)+12345.; call describe(x :print); b34srun; %b34sif(&runrats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * stats gasin stats gasout b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==DESCRIBE2 Normality testing b34sexec matrix; n=100000; x =rn(array(n:)); rec=rec(array(n:)); xx =x**3.; call describe(x :print); call describe(rec:print); call describe(xx :print); b34srun; == ==DES Code / Decode Example b34sexec matrix; /$ 12345678901234567890123456789012 call character(line1,'This is a test of the system '); call character(line2,'This is line # 2 of code test'); call chtohex(line1,hexline1); call chtohex(line2,hexline2); call print(hexline1,hexline2); hexline1=c1array(4,16:hexline1); hexline2=c1array(4,16:hexline2); call print(hexline1,hexline2); in=catrow(hexline1,hexline2); call print(in); call character(key,'0101010101010101'); out=c1array(norows(in)*2,nocols(in):); in=transpose(in); do i=1,nocols(in); call des(in(,i),work ,key,0); out(,i)=work; enddo; call print(out); test=c1array(nocols(in),norows(in):); do i=1,nocols(in); call des(out(,i),work,key,1); call hextoch(work,work2); call print(work2); test(i,)=work2; enddo; call names(all); call print(test); newtest=submatrix(test,1,norows(test),1,nocols(test)/2); call print(c1array(norows(newtest)*nocols(newtest):transpose(newtest))); b34srun; == ==DESTEST Numerical Recipes Test Cases b34sexec matrix; /$ Problems from Numerical Recipes Example Book (Fortran) /$ Cambridge University Press 1985 page 78-84 /$ /$ Tests B34S Character Handxeling Capability /$ datacards; /$ DES Validation, as per NBS publication 500-20 *** Initial Permutation and Expansion test: *** start 64 encode 0101010101010101 95F8A5E5DD31D900 8000000000000000 0101010101010101 DD7F121CA5015619 4000000000000000 0101010101010101 2E8653104F3834EA 2000000000000000 0101010101010101 4BD388FF6CD81D4F 1000000000000000 0101010101010101 20B9E767B2FB1456 0800000000000000 0101010101010101 55579380D77138EF 0400000000000000 0101010101010101 6CC5DEFAAF04512F 0200000000000000 0101010101010101 0D9F279BA5D87260 0100000000000000 0101010101010101 D9031B0271BD5A0A 0080000000000000 0101010101010101 424250B37C3DD951 0040000000000000 0101010101010101 B8061B7ECD9A21E5 0020000000000000 0101010101010101 F15D0F286B65BD28 0010000000000000 0101010101010101 ADD0CC8D6E5DEBA1 0008000000000000 0101010101010101 E6D5F82752AD63D1 0004000000000000 0101010101010101 ECBFE3BD3F591A5E 0002000000000000 0101010101010101 F356834379D165CD 0001000000000000 0101010101010101 2B9F982F20037FA9 0000800000000000 0101010101010101 889DE068A16F0BE6 0000400000000000 0101010101010101 E19E275D846A1298 0000200000000000 0101010101010101 329A8ED523D71AEC 0000100000000000 0101010101010101 E7FCE22557D23C97 0000080000000000 0101010101010101 12A9F5817FF2D65D 0000040000000000 0101010101010101 A484C3AD38DC9C19 0000020000000000 0101010101010101 FBE00A8A1EF8AD72 0000010000000000 0101010101010101 750D079407521363 0000008000000000 0101010101010101 64FEED9C724C2FAF 0000004000000000 0101010101010101 F02B263B328E2B60 0000002000000000 0101010101010101 9D64555A9A10B852 0000001000000000 0101010101010101 D106FF0BED5255D7 0000000800000000 0101010101010101 E1652C6B138C64A5 0000000400000000 0101010101010101 E428581186EC8F46 0000000200000000 0101010101010101 AEB5F5EDE22D1A36 0000000100000000 0101010101010101 E943D7568AEC0C5C 0000000080000000 0101010101010101 DF98C8276F54B04B 0000000040000000 0101010101010101 B160E4680F6C696F 0000000020000000 0101010101010101 FA0752B07D9C4AB8 0000000010000000 0101010101010101 CA3A2B036DBC8502 0000000008000000 0101010101010101 5E0905517BB59BCF 0000000004000000 0101010101010101 814EEB3B91D90726 0000000002000000 0101010101010101 4D49DB1532919C9F 0000000001000000 0101010101010101 25EB5FC3F8CF0621 0000000000800000 0101010101010101 AB6A20C0620D1C6F 0000000000400000 0101010101010101 79E90DBC98F92CCA 0000000000200000 0101010101010101 866ECEDD8072BB0E 0000000000100000 0101010101010101 8B54536F2F3E64A8 0000000000080000 0101010101010101 EA51D3975595B86B 0000000000040000 0101010101010101 CAFFC6AC4542DE31 0000000000020000 0101010101010101 8DD45A2DDF90796C 0000000000010000 0101010101010101 1029D55E880EC2D0 0000000000008000 0101010101010101 5D86CB23639DBEA9 0000000000004000 0101010101010101 1D1CA853AE7C0C5F 0000000000002000 0101010101010101 CE332329248F3228 0000000000001000 0101010101010101 8405D1ABE24FB942 0000000000000800 0101010101010101 E643D78090CA4207 0000000000000400 0101010101010101 48221B9937748A23 0000000000000200 0101010101010101 DD7C0BBD61FAFD54 0000000000000100 0101010101010101 2FBC291A570DB5C4 0000000000000080 0101010101010101 E07C30D7E4E26E12 0000000000000040 0101010101010101 0953E2258E8E90A1 0000000000000020 0101010101010101 5B711BC4CEEBF2EE 0000000000000010 0101010101010101 CC083F1E6D9E85F6 0000000000000008 0101010101010101 D2FD8867D50D2DFE 0000000000000004 0101010101010101 06E7EA22CE92708F 0000000000000002 0101010101010101 166B40B44ABA4BD6 0000000000000001 *** Inverse Permutation and Expansion test *** continue 64 encode 0101010101010101 8000000000000000 95F8A5E5DD31D900 0101010101010101 4000000000000000 DD7F121CA5015619 0101010101010101 2000000000000000 2E8653104F3834EA 0101010101010101 1000000000000000 4BD388FF6CD81D4F 0101010101010101 0800000000000000 20B9E767B2FB1456 0101010101010101 0400000000000000 55579380D77138EF 0101010101010101 0200000000000000 6CC5DEFAAF04512F 0101010101010101 0100000000000000 0D9F279BA5D87260 0101010101010101 0080000000000000 D9031B0271BD5A0A 0101010101010101 0040000000000000 424250B37C3DD951 0101010101010101 0020000000000000 B8061B7ECD9A21E5 0101010101010101 0010000000000000 F15D0F286B65BD28 0101010101010101 0008000000000000 ADD0CC8D6E5DEBA1 0101010101010101 0004000000000000 E6D5F82752AD63D1 0101010101010101 0002000000000000 ECBFE3BD3F591A5E 0101010101010101 0001000000000000 F356834379D165CD 0101010101010101 0000800000000000 2B9F982F20037FA9 0101010101010101 0000400000000000 889DE068A16F0BE6 0101010101010101 0000200000000000 E19E275D846A1298 0101010101010101 0000100000000000 329A8ED523D71AEC 0101010101010101 0000080000000000 E7FCE22557D23C97 0101010101010101 0000040000000000 12A9F5817FF2D65D 0101010101010101 0000020000000000 A484C3AD38DC9C19 0101010101010101 0000010000000000 FBE00A8A1EF8AD72 0101010101010101 0000008000000000 750D079407521363 0101010101010101 0000004000000000 64FEED9C724C2FAF 0101010101010101 0000002000000000 F02B263B328E2B60 0101010101010101 0000001000000000 9D64555A9A10B852 0101010101010101 0000000800000000 D106FF0BED5255D7 0101010101010101 0000000400000000 E1652C6B138C64A5 0101010101010101 0000000200000000 E428581186EC8F46 0101010101010101 0000000100000000 AEB5F5EDE22D1A36 0101010101010101 0000000080000000 E943D7568AEC0C5C 0101010101010101 0000000040000000 DF98C8276F54B04B 0101010101010101 0000000020000000 B160E4680F6C696F 0101010101010101 0000000010000000 FA0752B07D9C4AB8 0101010101010101 0000000008000000 CA3A2B036DBC8502 0101010101010101 0000000004000000 5E0905517BB59BCF 0101010101010101 0000000002000000 814EEB3B91D90726 0101010101010101 0000000001000000 4D49DB1532919C9F 0101010101010101 0000000000800000 25EB5FC3F8CF0621 0101010101010101 0000000000400000 AB6A20C0620D1C6F 0101010101010101 0000000000200000 79E90DBC98F92CCA 0101010101010101 0000000000100000 866ECEDD8072BB0E 0101010101010101 0000000000080000 8B54536F2F3E64A8 0101010101010101 0000000000040000 EA51D3975595B86B 0101010101010101 0000000000020000 CAFFC6AC4542DE31 0101010101010101 0000000000010000 8DD45A2DDF90796C 0101010101010101 0000000000008000 1029D55E880EC2D0 0101010101010101 0000000000004000 5D86CB23639DBEA9 0101010101010101 0000000000002000 1D1CA853AE7C0C5F 0101010101010101 0000000000001000 CE332329248F3228 0101010101010101 0000000000000800 8405D1ABE24FB942 0101010101010101 0000000000000400 E643D78090CA4207 0101010101010101 0000000000000200 48221B9937748A23 0101010101010101 0000000000000100 DD7C0BBD61FAFD54 0101010101010101 0000000000000080 2FBC291A570DB5C4 0101010101010101 0000000000000040 E07C30D7E4E26E12 0101010101010101 0000000000000020 0953E2258E8E90A1 0101010101010101 0000000000000010 5B711BC4CEEBF2EE 0101010101010101 0000000000000008 CC083F1E6D9E85F6 0101010101010101 0000000000000004 D2FD8867D50D2DFE 0101010101010101 0000000000000002 06E7EA22CE92708F 0101010101010101 0000000000000001 166B40B44ABA4BD6 *** Key Permutation tests: *** continue 56 encode 8001010101010101 0000000000000000 95A8D72813DAA94D 4001010101010101 0000000000000000 0EEC1487DD8C26D5 2001010101010101 0000000000000000 7AD16FFB79C45926 1001010101010101 0000000000000000 D3746294CA6A6CF3 0801010101010101 0000000000000000 809F5F873C1FD761 0401010101010101 0000000000000000 C02FAFFEC989D1FC 0201010101010101 0000000000000000 4615AA1D33E72F10 0180010101010101 0000000000000000 2055123350C00858 0140010101010101 0000000000000000 DF3B99D6577397C8 0120010101010101 0000000000000000 31FE17369B5288C9 0110010101010101 0000000000000000 DFDD3CC64DAE1642 0108010101010101 0000000000000000 178C83CE2B399D94 0104010101010101 0000000000000000 50F636324A9B7F80 0102010101010101 0000000000000000 A8468EE3BC18F06D 0101800101010101 0000000000000000 A2DC9E92FD3CDE92 0101400101010101 0000000000000000 CAC09F797D031287 0101200101010101 0000000000000000 90BA680B22AEB525 0101100101010101 0000000000000000 CE7A24F350E280B6 0101080101010101 0000000000000000 882BFF0AA01A0B87 0101040101010101 0000000000000000 25610288924511C2 0101020101010101 0000000000000000 C71516C29C75D170 0101018001010101 0000000000000000 5199C29A52C9F059 0101014001010101 0000000000000000 C22F0A294A71F29F 0101012001010101 0000000000000000 EE371483714C02EA 0101011001010101 0000000000000000 A81FBD448F9E522F 0101010801010101 0000000000000000 4F644C92E192DFED 0101010401010101 0000000000000000 1AFA9A66A6DF92AE 0101010201010101 0000000000000000 B3C1CC715CB879D8 0101010180010101 0000000000000000 19D032E64AB0BD8B 0101010140010101 0000000000000000 3CFAA7A7DC8720DC 0101010120010101 0000000000000000 B7265F7F447AC6F3 0101010110010101 0000000000000000 9DB73B3C0D163F54 0101010108010101 0000000000000000 8181B65BABF4A975 0101010104010101 0000000000000000 93C9B64042EAA240 0101010102010101 0000000000000000 5570530829705592 0101010101800101 0000000000000000 8638809E878787A0 0101010101400101 0000000000000000 41B9A79AF79AC208 0101010101200101 0000000000000000 7A9BE42F2009A892 0101010101100101 0000000000000000 29038D56BA6D2745 0101010101080101 0000000000000000 5495C6ABF1E5DF51 0101010101040101 0000000000000000 AE13DBD561488933 0101010101020101 0000000000000000 024D1FFA8904E389 0101010101018001 0000000000000000 D1399712F99BF02E 0101010101014001 0000000000000000 14C1D7C1CFFEC79E 0101010101012001 0000000000000000 1DE5279DAE3BED6F 0101010101011001 0000000000000000 E941A33F85501303 0101010101010801 0000000000000000 DA99DBBC9A03F379 0101010101010401 0000000000000000 B7FC92F91D8E92E9 0101010101010201 0000000000000000 AE8E5CAA3CA04E85 0101010101010180 0000000000000000 9CC62DF43B6EED74 0101010101010140 0000000000000000 D863DBB5C59A91A0 0101010101010120 0000000000000000 A1AB2190545B91D7 0101010101010110 0000000000000000 0875041E64C570F7 0101010101010108 0000000000000000 5A594528BEBEF1CC 0101010101010104 0000000000000000 FCDB3291DE21F0C0 0101010101010102 0000000000000000 869EFD7F9F265A09 *** Test of right-shifts in Decryption *** continue 56 decode 8001010101010101 95A8D72813DAA94D 0000000000000000 4001010101010101 0EEC1487DD8C26D5 0000000000000000 2001010101010101 7AD16FFB79C45926 0000000000000000 1001010101010101 D3746294CA6A6CF3 0000000000000000 0801010101010101 809F5F873C1FD761 0000000000000000 0401010101010101 C02FAFFEC989D1FC 0000000000000000 0201010101010101 4615AA1D33E72F10 0000000000000000 0180010101010101 2055123350C00858 0000000000000000 0140010101010101 DF3B99D6577397C8 0000000000000000 0120010101010101 31FE17369B5288C9 0000000000000000 0110010101010101 DFDD3CC64DAE1642 0000000000000000 0108010101010101 178C83CE2B399D94 0000000000000000 0104010101010101 50F636324A9B7F80 0000000000000000 0102010101010101 A8468EE3BC18F06D 0000000000000000 0101800101010101 A2DC9E92FD3CDE92 0000000000000000 0101400101010101 CAC09F797D031287 0000000000000000 0101200101010101 90BA680B22AEB525 0000000000000000 0101100101010101 CE7A24F350E280B6 0000000000000000 0101080101010101 882BFF0AA01A0B87 0000000000000000 0101040101010101 25610288924511C2 0000000000000000 0101020101010101 C71516C29C75D170 0000000000000000 0101018001010101 5199C29A52C9F059 0000000000000000 0101014001010101 C22F0A294A71F29F 0000000000000000 0101012001010101 EE371483714C02EA 0000000000000000 0101011001010101 A81FBD448F9E522F 0000000000000000 0101010801010101 4F644C92E192DFED 0000000000000000 0101010401010101 1AFA9A66A6DF92AE 0000000000000000 0101010201010101 B3C1CC715CB879D8 0000000000000000 0101010180010101 19D032E64AB0BD8B 0000000000000000 0101010140010101 3CFAA7A7DC8720DC 0000000000000000 0101010120010101 B7265F7F447AC6F3 0000000000000000 0101010110010101 9DB73B3C0D163F54 0000000000000000 0101010108010101 8181B65BABF4A975 0000000000000000 0101010104010101 93C9B64042EAA240 0000000000000000 0101010102010101 5570530829705592 0000000000000000 0101010101800101 8638809E878787A0 0000000000000000 0101010101400101 41B9A79AF79AC208 0000000000000000 0101010101200101 7A9BE42F2009A892 0000000000000000 0101010101100101 29038D56BA6D2745 0000000000000000 0101010101080101 5495C6ABF1E5DF51 0000000000000000 0101010101040101 AE13DBD561488933 0000000000000000 0101010101020101 024D1FFA8904E389 0000000000000000 0101010101018001 D1399712F99BF02E 0000000000000000 0101010101014001 14C1D7C1CFFEC79E 0000000000000000 0101010101012001 1DE5279DAE3BED6F 0000000000000000 0101010101011001 E941A33F85501303 0000000000000000 0101010101010801 DA99DBBC9A03F379 0000000000000000 0101010101010401 B7FC92F91D8E92E9 0000000000000000 0101010101010201 AE8E5CAA3CA04E85 0000000000000000 0101010101010180 9CC62DF43B6EED74 0000000000000000 0101010101010140 D863DBB5C59A91A0 0000000000000000 0101010101010120 A1AB2190545B91D7 0000000000000000 0101010101010110 0875041E64C570F7 0000000000000000 0101010101010108 5A594528BEBEF1CC 0000000000000000 0101010101010104 FCDB3291DE21F0C0 0000000000000000 0101010101010102 869EFD7F9F265A09 0000000000000000 *** Data permutation test: *** continue 32 encode 1046913489980131 0000000000000000 88D55E54F54C97B4 1007103489988020 0000000000000000 0C0CC00C83EA48FD 10071034C8980120 0000000000000000 83BC8EF3A6570183 1046103489988020 0000000000000000 DF725DCAD94EA2E9 1086911519190101 0000000000000000 E652B53B550BE8B0 1086911519580101 0000000000000000 AF527120C485CBB0 5107B01519580101 0000000000000000 0F04CE393DB926D5 1007B01519190101 0000000000000000 C9F00FFC74079067 3107915498080101 0000000000000000 7CFD82A593252B4E 3107919498080101 0000000000000000 CB49A2F9E91363E3 10079115B9080140 0000000000000000 00B588BE70D23F56 3107911598080140 0000000000000000 406A9A6AB43399AE 1007D01589980101 0000000000000000 6CB773611DCA9ADA 9107911589980101 0000000000000000 67FD21C17DBB5D70 9107D01589190101 0000000000000000 9592CB4110430787 1007D01598980120 0000000000000000 A6B7FF68A318DDD3 1007940498190101 0000000000000000 4D102196C914CA16 0107910491190401 0000000000000000 2DFA9F4573594965 0107910491190101 0000000000000000 B46604816C0E0774 0107940491190401 0000000000000000 6E7E6221A4F34E87 19079210981A0101 0000000000000000 AA85E74643233199 1007911998190801 0000000000000000 2E5A19DB4D1962D6 10079119981A0801 0000000000000000 23A866A809D30894 1007921098190101 0000000000000000 D812D961F017D320 100791159819010B 0000000000000000 055605816E58608F 1004801598190101 0000000000000000 ABD88E8B1B7716F1 1004801598190102 0000000000000000 537AC95BE69DA1E1 1004801598190108 0000000000000000 AED0F6AE3C25CDD8 1002911498100104 0000000000000000 B3E35A5EE53E7B8D 1002911598190104 0000000000000000 61C79C71921A2EF8 1002911598100201 0000000000000000 E2F5728F0995013C 1002911698100101 0000000000000000 1AEAC39A61F0A464 *** S-Box test: *** continue 19 encode 7CA110454A1A6E57 01A1D6D039776742 690F5B0D9A26939B 0131D9619DC1376E 5CD54CA83DEF57DA 7A389D10354BD271 07A1133E4A0B2686 0248D43806F67172 868EBB51CAB4599A 3849674C2602319E 51454B582DDF440A 7178876E01F19B2A 04B915BA43FEB5B6 42FD443059577FA2 AF37FB421F8C4095 0113B970FD34F2CE 059B5E0851CF143A 86A560F10EC6D85B 0170F175468FB5E6 0756D8E0774761D2 0CD3DA020021DC09 43297FAD38E373FE 762514B829BF486A EA676B2CB7DB2B7A 07A7137045DA2A16 3BDD119049372802 DFD64A815CAF1A0F 04689104C2FD3B2F 26955F6835AF609A 5C513C9C4886C088 37D06BB516CB7546 164D5E404F275232 0A2AEEAE3FF4AB77 1F08260D1AC2465E 6B056E18759F5CCA EF1BF03E5DFA575A 584023641ABA6176 004BD6EF09176062 88BF0DB6D70DEE56 025816164629B007 480D39006EE762F2 A1F9915541020B56 49793EBC79B3258F 437540C8698F3CFA 6FBF1CAFCFFD0556 4FB05E1515AB73A7 072D43A077075292 2F22E49BAB7CA1AC 49E95D6D4CA229BF 02FE55778117F12A 5A6B612CC26CCE4A 018310DC409B26D6 1D9D5C5018F728C2 5F4C038ED12B2E41 1C587F1C13924FEF 305532286D6F295A 63FAC0D034D9F793 All done ****************************************** end b34sreturn; * Tests Character data options in B34S; call echooff; top continue; help=c1array(72:); call print(' ':); call read(help,4); call print(help:); code=' '; call read(code,4); if(code.eq.'end ')go to done; ncase=0; call read(ncase,4); code=' '; call read(code,4); decode=1; if(code.eq.'encode')decode=0; call print('Encode (=0) Decode (=1)',decode:); call print('# of cases processed ',ncase :); call char1(key, rtoch(array(2:))); call char1(in, rtoch(array(2:))); call char1(out, rtoch(array(2:))); call char1(string,rtoch(array(7:))); i1=integers(2,17); i2=i1+17; i3=i2+17; hold=c1array(ncase,75:); do i=1,ncase; call read(string,4); call character(key,string(i1)); call character(in, string(i2)); call character(out,string(i3)); call des(in,get,key,decode); isgood=' O. K.'; blank=c1array(1:); t1 =c8array(2:out); tt1=c8array(2:get); if(t1(1).ne.tt1(1).or.t1(2).ne.tt1(2))isgood=' Error'; isgood=c1array(8:isgood); hold(i,)=c1array(75:key,blank,in,blank,out,blank,get,isgood); enddo; /$ 12345678901234567890123456789012345678901234567890 /$ 16 32 48 call print(' key in Answer Get ':); call print(hold); go to top; done continue; b34srun; == ==DET Calculates determinate b34sexec matrix; x=matrix(3,3:0.1 1. 2. 9. 8. 7. 5. 4. 0.2); call print(x,inv(x),det(x),det(r8tor16(x)),det(r8tor4(x))); cx=complex(x,dsqrt(x)); call print(cx,inv(cx),det(cx),det(c16toc32(cx))); call print(rcond(x),rcond(r8tor16(x)),rcond(r8tor4(x))); /$ /$ High Accuracy printing /$ call fprint(:clear :display rcond(r8tor16(x)) '(g48.32)' :print); call print(rcond(cx),rcond(c16toc32(cx))); call fprint(:clear :display rcond(c16toc32(cx)) '(g48.32)' :print); b34srun; == ==DEXP Natural Log b34sexec matrix; x=grid(.1 709. 1.); log10x=dlog10(x); lnx =dlog(x); testx1=10.**log10x; testx2=dexp(lnx); testbig=dexp(x); testback=dlog(testbig); call tabulate(x,log10x,lnx,testx1,testx2,testbig,testback); b34srun; == ==DF Dickey Fuller Test b34sexec options ginclude('gas.b34'); b34srun; /$ Dickey Fuller tests are done from BJ and from Matrix /$ Note carefully that DF NE adf(0) b34sexec bjiden; var= gasout; rauto gasout; bispec df adf(1,2,3); b34srun; b34sexec matrix; call loaddata; call echooff; call print('Dickey Fuller Tests on Gasout'); call df(gasout,d :print); n=30; adf=array(n+1:); adft=array(n+1:); lag=array(n+1:); padf=array(n+1:); padft=array(n+1:); do i=0,n; j=i+1; call df(gasout,a1:adf i); adf(j)=a1; padf(j)=%dfprob; call df(gasout,a2:adft i); adft(j)=a2; padft(j)=%dfprob; lag(j)=dfloat(i); enddo; call print('Dickey-Fuller tests':); call tabulate(lag,adf,padf,adft,padft); b34srun; /; test case b34sexec matrix; n=10000; x=rn(array(n:)); root=cusum(x); call df(x,d :print); call df(root,d :print); call pp(x,d :print); call pp(root,d :print); b34srun; == ==DF1 Tests DF Test Table /$ Can set ncase as 1000 or more if desired /$ try 10000 with n=250 /$ /$ /$ Job establishes critical values for DF test /$ /$ Unit root and noise generated /$ b34sexec matrix; call echooff; ncase=1000; n=250; unit=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); call df(unit, d); call df(unit, d1 :adf 4); call df(unit, d2 :adft 4); call df(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase:); call print('# observations ',n:); Call Print('DF Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root adf Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root adf Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); /$ For a discussion of why we cannot use these methods /$ for Case # 4 in some cases see Hamilton page 497 ; b34srun; == ==DF2 Negative unit root /$ /$ /$ Job establishes critical values for DF test /$ "unit root with negative" <= /$ /$ DF test does not detect ########### /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12332.; call echooff; ncase=1000; n=500; unit=array(n:); hold=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); jj=integers(1,n); hold(jj)=(-1.)**dfloat(jj); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); unit=afam(unit)*afam(hold); call df(unit, d); call df(unit, d1 :adf 4); call df(unit, d2 :adft 4); call df(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase,' # observations ',n); Call Print('DF Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root adf Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root adf Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); * For a discussion of why we cannot use these methods for Case # 4 in some cases see Hamilton page 497 ; b34srun; == ==DF3 Tests DF test performance /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12331.; call echooff; ncase=100; n=100000; unit=array(n:); call print('Sample Size = ',n); call print(' ':); call print('Data for Unit root Series':); do i=1,ncase; noise=rn(unit); unit=cusum(noise); call df(unit, d :print); call df(unit, d1 :adf 4 :print); call df(unit, d2 :adft 4 :print); enddo; call print('Data for Random Series':); do i=1,ncase; noise=rn(unit); call df(noise,d :print); call df(noise,d1 :adf 4 :print); call df(noise,d2 :adft 4 :print); enddo; b34srun; == ==DF4 Investigates DF Test Tables b34sexec matrix; * Test DF table ; iprint=0; x=grid(-5.0,5.0,.01); call df(x,prob25 :table 25); call df(x,prob50 :table 50); call df(x,prob100 :table 100); call df(x,prob250 :table 250); call df(x,prob300 :table 300); call df(x,prob500 :table 500); call df(x,prob600 :table 600); call print('Regular DW':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call names(all); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'DF Test'); call df(x,prob25 :table2 25); call df(x,prob50 :table2 50); call df(x,prob100 :table2 100); call df(x,prob250 :table2 250); call df(x,prob300 :table2 300); call df(x,prob500 :table2 500); call df(x,prob600 :table2 600); call print('Augmented DF':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test'); call df(x,prob25 :table4 25); call df(x,prob50 :table4 50); call df(x,prob100 :table4 100); call df(x,prob250 :table4 250); call df(x,prob300 :table4 300); call df(x,prob500 :table4 500); call df(x,prob600 :table4 600); call print('Augmented DW with Trend':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test with Trend'); * Test DF table ; x=grid(-30.0,30.0,.1); call df(x,prob25 :table 25 :zform); call df(x,prob50 :table 50 :zform); call df(x,prob100 :table 100 :zform); call df(x,prob250 :table 250 :zform); call df(x,prob300 :table 300 :zform); call df(x,prob500 :table 500 :zform); call df(x,prob600 :table 600 :zform); call print('Regular DW':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'DF Test zform'); call df(x,prob25 :table2 25 :zform); call df(x,prob50 :table2 50 :zform); call df(x,prob100 :table2 100 :zform); call df(x,prob250 :table2 250 :zform); call df(x,prob300 :table2 300 :zform); call df(x,prob500 :table2 500 :zform); call df(x,prob600 :table2 600 :zform); call print('Augmented DF':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test Z form'); call df(x,prob25 :table4 25 :zform); call df(x,prob50 :table4 50 :zform); call df(x,prob100 :table4 100 :zform); call df(x,prob250 :table4 250 :zform); call df(x,prob300 :table4 300 :zform); call df(x,prob500 :table4 500 :zform); call df(x,prob600 :table4 600 :zform); call print('Augmented DW with Trend':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test with Trend Z form'); b34srun; == ==DF_TABLE Uses Monti Carlo Methods to Generate the DF Table /$ /$ Job establishes critical values for DF test /$ Unit root and noise generated /$ b34sexec matrix; call echooff; ncase=10000; n=500; unit=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); call df(unit, d); call df(unit, d1 :adf 4); call df(unit, d2 :adft 4); call df(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase:); call print('# observations ',n:); Call Print('DF Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root adf Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root adf Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); /$ For a discussion of why we cannot use these methods /$ for Case # 4 in some cases see Hamilton page 497 ; b34srun; == ==DF_GLS Elliot-Rothenberg-Stock DF_GLS Test b34sexec matrix; call load(df_gls); call print(df_gls); /$ /$ 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 /$ /$ ********************************************************** /$ /$ 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; n=1000; x=rn(array(n:)); root=cusum(x); call graph(x); call graph(root); call echooff; do i=1,4; call print(' ':); call print('Non unit root case':); call DF_GLS(x,i,notrend,trend,notrendx,trendx,iprint); call print(' ':); call print('----------------':); call print(' ':); call print('Unit root case':); call DF_GLS(root,i,notrend,trend,notrendx,trendx,iprint); enddo; b34srun; == ==DFLOAT Integer to real*8 b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; == ==DGAMMA Gamma Function b34sexec matrix; * Note that we avoid integer values ; x=grid(1.01,170.01,.5); g =dgamma(x); x2=(-1.0)*x; g2=dgamma(x2); call tabulate(x,g,x2,g2); b34srun; == ==DGDAGI_2 Studies with Normal Distribution b34sexec matrix; * Calculate cumulative Normal ; program test; f=(1./dsqrt(2.*pi()))*dexp((-.5)*x*x); return; end; call print(test); call echooff; a=-1.; b=1. ; do i=1,6; call dqdag(f x :name test :lower a :upper b :errabs 0.0 :errrel .001 :rule i :maxsub 500 :print); enddo; call dqdagi(f x :name test :upper 1. :errabs 0.0 :errrel .001 :maxsub 500 :print); b34srun; == ==DIAG Obtain Diagonal Elements b34sexec matrix; n=5; x=rn(matrix(n,n:)); call print(X,'Diagonal ',diag(x)); cx=complex(x,x*2.); call print(cx,'Diagonal ',diag(cx)); b34srun; == ==DIAGMAT Illustrates DIAGMAT Command b34sexec matrix$ x=vector(6:1 2 3 4 5 6); dm=diagmat(x); call print(x); cx=complex(vector(6:1 2 3 4 5 6),2.*vector(6:1 2 3 4 5 6)); dm=diagmat(cx); call print(cx); b34srun; == ==DIF Tests Difference Command b34sexec matrix; n=8; c=array(n:integers(1,n)); dc=dif(c); cc=rn(array(n:)); dcc=dif(cc); d2d1cc=dif(cc,2,1); call tabulate(c,dc,cc,dcc,d2d1cc); n=2000; nn2=200000; xx=rn(array(n:)); xx2=rn(array(nn2:)); call print('Dif. of White Noise has acf(1)=-.5':); call tabulate(acf(xx,20),acf(dif(xx),20), acf(dif(xx2),20)); call print('Seasonal Differencing effects':); call tabulate(acf(xx,20),acf(dif(xx,1,12),20), acf(dif(xx2,1,12),20)); call print('Seasonal and First Difference Effects':); call tabulate(acf(dif(dif(xx ,1,12)),20) , acf(dif(dif(xx2,1,12)),20)); b34srun; == ==DIF1 Advanced tests using difference b34sexec matrix; * Goal is to illustrate effect of differending on ACF and spectrum; n=4000; c=rn(array(n:)); c1=dif(c,1,1); c12=dif(c,1,12); acf1=acf(c, dmax1(1,n/50),se1,pacf1); acf2=acf(c1, dmax1(1,n/50),se2,pacf2); acf3=acf(c12,dmax1(1,n/50),se3,pacf3); call graph(acf1 :heading 'ACF of rn series'); call graph(acf1,pacf1 :heading 'ACF & PACF of rn series'); call graph(acf2 :heading 'ACF of rn(1-b) series'); call graph(acf2,pacf2 :heading 'ACF & PACF of rn(1-b) series'); call graph(acf3 :heading 'ACF of rn(1-b**12) series'); call graph(acf3,pacf3 :heading 'ACF & PACF of rn(1-b**12) series'); call spectral(c, sinx,cosx,px,sc, freq :1 2 3 2 1); call spectral(c1, sinx,cosx,px,sc1, freq1 :1 2 3 2 1); call spectral(c12,sinx,cosx,px,sc12,freq12:1 2 3 2 1); call graph(freq, sc :heading 'Spectrum of rn series' :plottype xyplot); call graph(freq1, sc1 :heading 'Spectrum of rn(1-b) series' :plottype xyplot); call graph(freq12,sc12 :heading 'Spectrum of rn(1-b**12) series' :plottype xyplot); b34srun; == ==DIF2 Illustrates Differencing a col of an array b34sexec matrix; x=rn(array(10,4:)); call print(x); x1=dif(x(,1)); newx=x; newx(1,)=array(4:)+missing(); newx=goodrow(newx); newx(,1)=x1; call print(x,newx); b34srun; == ==DINT Integer part pf real*8 in a real*8 b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; == ==DNINT Integer part of real*8 in a real*8 b34sexec matrix; r8g=grid(.1,6.,.3) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; r8dint=dint(r8g) ; r8dnint=dnint(r8g) ; call names(all) ; call tabulate(r8g,i4idint,i4idnint,r8dint,r8dnint); b34srun; == ==DISPLAYB Displays a buffer b34sexec matrix; call character(cc,'This is a test'); call displayb(cc); call character(cc2,'This is a test with numbers 1 2 3 # $ % 7 && 8 &'); call displayb(cc2); * Put in reals we know what they are; x(1)=0.0; x(2)=1.0; * Hide an integer in a real; i1=1; i2=2; call ilcopy(4,i1,1,1,x,1,1); call ilcopy(4,i2,1,1,x,1,3); call displayb(x); b34srun; == ==DISPLAYB2 Displays Buffer - Advanced use /$ /$ Shows moving a real*16 value in a real*8 work array /$ Uses a real*8 array to look at bits!! /$ b34sexec matrix; x=array(2:); y=10.0; y=r8tor16(y); yy=y; y=r8tor16(12.8); call print('is yy 10.? ',yy); call pcopy(2,pointer(y),1,pointer(x), 1,8); call pcopy(2,pointer(x),1,pointer(yy),1,8); call print('is yy 12.8.? ',yy); call displayb(x); call names(all); call displayb(yy); b34srun; == ==DIST_TAB Distribution Table b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(dist_tab); call echooff; call describe(gasin :print); call dist_tab(gasin,20,q,qvalue,number,1); b34srun; b34sexec data; input x; datacards; 0.77, 1.74, 0.81, 1.20, 1.95, 1.20, 0.47, 1.43, 3.37, 2.20, 3.00, 3.09, 1.51, 2.10, 0.52, 1.62, 1.31, 0.32, 0.59, 0.81, 2.81, 1.87, 1.18, 1.35, 4.75, 2.48, 0.96, 1.89, 0.90, 2.05 b34sreturn; b34srun; b34sexec matrix; call loaddata; call load(dist_tab); * IMSL test data answers Smaller Empirical Larger Quantile Datum Quantile Datum 0.01 0.32 0.32 0.32 0.05 0.32 0.40 0.47 0.10 0.52 0.53 0.59 0.15 0.59 0.71 0.77 0.20 0.81 0.81 0.81 0.25 0.81 0.88 0.90 0.30 0.96 1.03 1.18 0.35 1.18 1.20 1.20 0.40 1.20 1.24 1.31 0.45 1.31 1.35 1.35 0.50 1.43 1.47 1.51 0.55 1.62 1.63 1.74 0.60 1.74 1.82 1.87 0.65 1.89 1.90 1.95 0.70 1.95 2.02 2.05 0.75 2.10 2.12 2.20 0.80 2.20 2.42 2.48 0.85 2.81 2.88 3.00 0.90 3.00 3.08 3.09 0.95 3.37 3.99 4.75 0.99 4.75 4.75 4.75 ; call echooff; call describe(x :print); call dist_tab(x,20,q,qvalue,number,1); b34srun; == ==DIVIDE Divide with an error return b34sexec matrix; top=array(6:)+1.0; bot=array(6:1. 0. 2. 0. 3. 0.); call print('divide',divide(top,bot) ); call print('divide',divide(top,bot,0.0)); call print('divide',divide(10.,bot) ); call print('divide',divide(10.,bot,0.0)); call print('divide',divide(top,10.) ); call print('divide',divide(top,10.,0.0)); top=r8tor16(top); bot=r8tor16(bot); call print('divide',divide(top,bot) ); call print('divide',divide(top,bot,r8tor16(0.0) )); call print('divide',divide(r8tor16(10.),bot)); call print('divide',divide(r8tor16(10.),bot,r8tor16(0.0))); call print('divide',divide(top,r8tor16(10.) )); call print('divide',divide(top,r8tor16(10.),r8tor16(0.0))); b34srun; == ==DLGAMMA Log Gamma Function b34sexec matrix; x=array(:1.,10.,100.,1000.,10000.,100000.,1000000.); g=dlgamma(x); call tabulate(x,g); b34srun; == ==DLOG Natural Log /; /; Comprehensive Log tests /; b34sexec matrix; x=grid(0.0001 100. 10.); x_16=r8tor16(x); x_4 =r8tor4(x); log10x =dlog10(x); log10x16=dlog10(x_16); log10x4 =dlog10(x_4); log10xv =log10(vpa(x)); lnx =dlog(x_16); lnx16 =dlog(x_16); lnx4 =dlog(x_4); lnxvpa =log(vpa(x)); testx1=10.**log10x; testx2=dexp(lnx); testx3=kindas(log10x16,10.)**log10x16; testx4=dexp(lnx16); testx5=kindas(log10xv,10.)**log10xv; testx6=exp(lnxvpa); testx7=exp(lnx4); testx8=sngl(10.)**log10x4; call tabulate(x,log10x,log10x16,lnx,lnx16,testx1,testx2,testx3,testx4); call tabulate(x,log10x,log10xv,lnx,lnxvpa,testx5,testx6); call tabulate(x,log10x4,lnx4,testx7,testx8); * Complex case; cx=complex(x,dsqrt(x)); cx32=c16toc32(cx); lncx =dlog(cx); lncx32 =dlog(cx32); testcx =exp(lncx); testcx32 =exp(lncx32); call tabulate(cx,lncx,testcx,lncx32,testcx32); b34srun; == ==DLOG10 Log 10 /; /; Comprehensive Log tests /; b34sexec matrix; x=grid(0.0001 100. 10.); x_16=r8tor16(x); x_4 =r8tor4(x); log10x =dlog10(x); log10x16=dlog10(x_16); log10x4 =dlog10(x_4); log10xv =log10(vpa(x)); lnx =dlog(x_16); lnx16 =dlog(x_16); lnx4 =dlog(x_4); lnxvpa =log(vpa(x)); testx1=10.**log10x; testx2=dexp(lnx); testx3=kindas(log10x16,10.)**log10x16; testx4=dexp(lnx16); testx5=kindas(log10xv,10.)**log10xv; testx6=exp(lnxvpa); testx7=exp(lnx4); testx8=sngl(10.)**log10x4; call tabulate(x,log10x,log10x16,lnx,lnx16,testx1,testx2,testx3,testx4); call tabulate(x,log10x,log10xv,lnx,lnxvpa,testx5,testx6); call tabulate(x,log10x4,lnx4,testx7,testx8); * Complex case; cx=complex(x,dsqrt(x)); cx32=c16toc32(cx); lncx =dlog(cx); lncx32 =dlog(cx32); testcx =exp(lncx); testcx32 =exp(lncx32); call tabulate(cx,lncx,testcx,lncx32,testcx32); b34srun; == ==DLOG_TEST Effect of dlog( ) and dif( ) on low frequency /; Effect of log and difference on the low frequency in a series /; Looks at HP Filter b34sexec matrix; call load(acf_plot); n=600; nacf=min1(300,n/10); x=rn(array(n:)); test=array(n:)+.1d-16; unit_r=cusum(x); dif_unit=dif(unit_r); /; fix any negative numbers where(unit_r.lt.test)unit_r=test; log_r =dlog(unit_r); call deleterow(unit_r,1,1); call deleterow(log_r, 1,1); s=1600.; call hpfilter(unit_r,unit_rt,unit_rhp); call graph(unit_r,log_r,dif_unit unit_rhp :nolabel); call acf_plot(unit_r ,nacf ,'Unit_r') ; call acf_plot(log_r , nacf,'log_r') ; call acf_plot(dif_unit, nacf,'dif_unit'); call acf_plot(unit_rhp, nacf,'unit_rhp'); call df(unit_r ,d :print); call df(log_r , d :print); call df(dif_unit, d :print); call df(unit_rhp,d :print); call spectral(unit_r,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call graph(freq2,sx:heading 'Spectrum of unit_r' :plottype xyplot); call spectral(log_r,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call graph(freq2,sx:heading 'Spectrum of log_r' :plottype xyplot); call spectral(dif_unit,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call graph(freq2,sx:heading 'Spectrum of dif_unit' :plottype xyplot); call spectral(unit_rhp,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call graph(freq2,sx:heading 'Spectrum of HP(unit_R)' :plottype xyplot); acfunitr=acf(unit_r ,24); acflog_r=acf(log_r ,24); acfdif =acf(dif_unit,24); acf_hp =acf(unit_rhp,24); call tabulate(acfunitr,acflog_r,acfdif,acf_hp); b34srun; == ==DMAX Illustrate DMAX Command b34sexec matrix; * Command finds max element ; n=20; reals=rec(array(n:))*100.; ints=idint(reals); maxint=dmax(ints); maxreal=dmax(reals); call print(ints,maxint,reals,maxreal); /; reals(2)=missing(); call print('dmax( reals)', dmax( reals:)); call print('Real*16 case':); call print('dmax(r8tor16(reals))',dmax(r8tor16(reals):)); call print('Real*4 case':); call print('dmax(r8tor4(reals))', dmax(r8tor4( reals):)); call print('VPA case':); call print('dmax(vpa(reals))' , dmax(vpa( reals))); b34srun; == ==DMAX1 Illustrate DMAX1 Command b34sexec matrix; * Command finds max of two vectors; n=20; reals1=rec(array(n:))*100.; ints1=idint(reals1); reals2=rec(array(n:))*100.; ints2=idint(reals2); maxint=dmax1(ints1,ints2) ; maxreal=dmax1(reals1,reals2); maxreal2=dmax1(r8tor16(reals1),r8tor16(reals2)); call tabulate(ints1,ints2,maxint,reals1,reals2,maxreal,maxreal2); x=array(6:1. 2. 3. 4. 5. 6.); bigx=dmax1(x,3.); minx=dmin1(x,3.); vbigx=dmax1(vpa(x),vpa(3.)); vminx=dmin1(vpa(x),vpa(3.)); call tabulate(x,bigx,minx,vbigx,vminx); b34srun; == ==DMIN Illustrate DMIN Command b34sexec matrix; * Command finds min element ; n=20; reals=rec(array(n:))*100.; ints=idint(reals); minint=dmin(ints); minreal=dmin(reals); call print(ints,minint,reals,minreal); /; reals(2)=missing(); call print('dmin( reals)', dmin( reals:)); call print('Real*16 case':); call print('dmin(r8tor16(reals))',dmin(r8tor16(reals):)); call print('Real*4 case':); call print('dmin(r8tor4(reals))', dmin(r8tor4( reals):)); call print('VPA case':); call print('dmin(vpa(reals))' , dmin(vpa( reals))); b34srun; == ==DMIN1 Illustrate DMIN1 Command b34sexec matrix; * Command finds min of two vectors; n=20; reals1=rec(array(n:))*100.; ints1=idint(reals1); reals2=rec(array(n:))*100.; ints2=idint(reals2); minint=dmin1(ints1,ints2) ; minreal=dmin1(reals1,reals2); minreal2=dmin1(r8tor16(reals1),r8tor16(reals2)); call tabulate(ints1,ints2,minint,reals1,reals2,minreal,minreal2); x=array(6:1. 2. 3. 4. 5. 6.); bigx=dmax1(x,3.); minx=dmin1(x,3.); vbigx=dmax1(vpa(x),vpa(3.)); vminx=dmin1(vpa(x),vpa(3.)); call tabulate(x,bigx,minx,vbigx,vminx); b34srun; == ==DMOD Illustrate DMOD Command in simple cases b34sexec matrix; ints=integers(20); reals=dfloat(ints); imods=dmod(ints,3); rmod =dmod(reals,3.0); call tabulate(ints,imods,reals,rmod); call print('Real*16 cases':); rmod =dmod(r8tor16(reals),r8tor16(3.0)); call tabulate(ints,imods,reals,rmod); b34srun; == ==DMOD_2 Remander of real*8, real*16 and integer*4 variables b34sexec matrix; call print('Tests with real data'); real=grid(1.0,30.,1.); remand2=dmod(real,2.0); remand3=dmod(real,3.); two=array(30:) + 2.0; three=array(30:)+3.0; remand22=dmod(real,two); remand33=dmod(real,three); tt=dmod(5.0,real); call tabulate(real,remand2,remand3,remand22,remand33,tt); call print('Tests with integer data'); int=integers(30); remand2=dmod(int,2); remand3=dmod(int,3); two=idint(array(30:))+2; three=idint(array(30:))+3; remand22=dmod(int,two); remand33=dmod(int,three); tt=dmod(5,int); call tabulate(int,remand2,remand3,remand22,remand33,tt); call print('Tests with real*16 data'); real=r8tor16(grid(1.0,30.,1.)); remand2=dmod(real,r8tor16(2.0)); remand3=dmod(real,r8tor16(3.)); two=array(30:) + 2.0; three=array(30:)+3.0; two=r8tor16(two); three=r8tor16(three); remand22=dmod(real,two); remand33=dmod(real,three); tt=dmod(r8tor16(5.0),real); call tabulate(real,remand2,remand3,remand22,remand33,tt); b34srun; == ==DMFGET Obtain Series froma DMF file /; /; Note: DMFGET = GETDMF /; DMFPUT = MAKEDMF /; /; see also use of DMFMERGE and ALIGN use /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call echooff; call loaddata; call names(all); call olsq(lnq lnk lnl lnrm1 :print); people=namelist(houston,diana,will,melissa,bobby); call dmfput(lnq,lnl,lnk,lnrm1,lnrm2 %res %y %yhat people :file 'testdmf.dmf' :header 'RES (1972) data' :member test_dat :print); nrow=10; ncol=8; x=rn(matrix(nrow,ncol:)); call print(x); means=array(ncol:); do i=1,ncol; means(i)=mean(x(,i)); enddo; call print(means); call dmfput(x :print :file 'testdmf.dmf' :add :header 'Random Matrix Data'); call dmfget(:browse :browsename :file 'testdmf.dmf'); call cleardat; call dmfget(:file 'testdmf.dmf'); call names(all); call dmfget(:file 'testdmf.dmf' :member data1 :print); call names(all); test=catcol(m1col__1,m1col__3); call print(' ':); call print('mean(test(,1)),mean(test(,2))':); call print( mean(test(,1)),mean(test(,2))); test=catcol(lnq,lnl,lnk); call print(' ':); call print('mean(lnq),mean(lnl),mean(lnk)':); call print( mean(lnq),mean(lnl),mean(lnk)); b34srun; b34sexec options open('testdmf.dmf') unit=62; b34srun; b34sexec dmf infmt=formatted inunit=62$ browse listnames$ b34srun$ b34sexec data file('testdmf.dmf') dmfmember(test_dat) filef= dmf; b34srun; b34sexec list iend=10; b34srun; b34sexec data file('testdmf.dmf') dmfmember(data1 ) filef= dmf; b34srun; b34sexec list; b34srun; == ==DMFPUT Place series in a DMF file /; /; Note: DMFGET = GETDMF /; DMFPUT = MAKEDMF /; /; see also use of DMFMERGE and ALIGN use /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call echooff; call loaddata; call names(all); call olsq(lnq lnk lnl lnrm1 :print); people=namelist(houston,diana,will,melissa,bobby); call dmfput(lnq,lnl,lnk,lnrm1,lnrm2 %res %y %yhat people :file 'testdmf.dmf' :header 'RES (1972) data' :member test_dat :print); nrow=10; ncol=8; x=rn(matrix(nrow,ncol:)); call print(x); means=array(ncol:); do i=1,ncol; means(i)=mean(x(,i)); enddo; call print(means); call dmfput(x :print :file 'testdmf.dmf' :add :header 'Random Matrix Data'); call dmfget(:browse :browsename :file 'testdmf.dmf'); call cleardat; call dmfget(:file 'testdmf.dmf'); call names(all); call dmfget(:file 'testdmf.dmf' :member data1 :print); call names(all); test=catcol(m1col__1,m1col__3); call print(' ':); call print('mean(test(,1)),mean(test(,2))':); call print( mean(test(,1)),mean(test(,2))); test=catcol(lnq,lnl,lnk); call print(' ':); call print('mean(lnq),mean(lnl),mean(lnk)':); call print( mean(lnq),mean(lnl),mean(lnk)); b34srun; b34sexec options open('testdmf.dmf') unit=62; b34srun; b34sexec dmf infmt=formatted inunit=62$ browse listnames$ b34srun$ b34sexec data file('testdmf.dmf') dmfmember(test_dat) filef= dmf; b34srun; b34sexec list iend=10; b34srun; b34sexec data file('testdmf.dmf') dmfmember(data1 ) filef= dmf; b34srun; b34sexec list; b34srun; == ==DMFMERGE1 Illustrates obsmerge b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call names(all); call olsq(lnq lnk lnl lnrm1 :print); call makedmf(lnq,lnl,lnk,lnrm1,lnrm2 :file 'file1.dmf'); call makedmf(p k l m1 m2 :file 'file2.dmf'); call getdmf(:browse :file 'file1.dmf'); call dmfmerge(:file1 'file1.dmf' :member1 data1 :file2 'file2.dmf' :member2 data1 :file3 'file3.dmf' :member3 cdata :obsmerge :print); call cleardat; call getdmf(:file 'file3.dmf' :print); call names(all); call cleardat; call getdmf(:file 'file3.dmf' :series namelist(p k) :print); call print('mean of p ',mean(p)); call print('mean of p ',mean(k)); call names(all); b34srun; == ==DMFMERGE2 Illustrates Sortmerge b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call names(all); call olsq(lnq lnk lnl lnrm1 :print); id1=dfloat(integers(1,norows(lnq))); call makedmf(id1 lnq,lnl,lnk,lnrm1,lnrm2 :file 'file1.dmf'); x1=rn(array(10:)); x2=rn(array(10:)); x3=rn(array(10:)); x4=rn(array(10:)); id2=dfloat(integers(norows(x1))); call tabulate(id1 id2 lnq lnk x1 x2 x3 x4); call makedmf(id2 x1 x2 x3 x4 :file 'file2.dmf'); call getdmf(:browse :file 'file1.dmf'); call getdmf(:browse :file 'file2.dmf'); call dmfmerge(:file1 'file1.dmf' :member1 data1 :file2 'file2.dmf' :member2 data1 :file3 'file3.dmf' :member3 cdata :file1by id1 :file2by id2 :sortmerge :print); call cleardat; call getdmf(:file 'file3.dmf' :print); call names(all); call tabulate(id1 id2 lnq lnk x1 x2 x3 x4); /; /; use align & %series to align data on the fly /; call print(%series); call align(argument(%series)); call print('Series now aligned to remove Missing Data':); call tabulate(id1 id2 lnq lnk x1 x2 x3 x4); call cleardat; call getdmf(:file 'file3.dmf' :print :series namelist(lnq lnl lnk)); call print(%series); b34srun; == ==DODOS Calling MATLAB from Matrix /$ Matlab command file b34sexec options open('test.m') unit=77 disp=unknown; b34srun; b34sexec options clean(77); b34srun; b34sexec options copyf(4,77); pgmcards; x=rand(6) xi=inv(x); x*xi yy=[1 2 3 2 1] plot(yy) pause quit b34sreturn; b34srun; b34sexec options close(77); b34srun; b34sexec matrix; /$ /$ Note : /$ call system('matlab /r test /logfile junk':); call dodos('pause'); call copyout('junk'); b34srun; == ==DODOS_2 Multiple RATS calls from matrix /; /; Illustrates making a portable file and calling rats from /; matrix command a number of times in a row /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call makerats(gasin,gasout :file 'full.por'); call print(mean(gasin) mean(gasout)); call cleardat; call getrats('full.por'); call print(mean(gasin) mean(gasout)); call names; /$ call tabulate(obsnum,gasin,gasout); b34srun; b34sexec options open('rats.in') unit=77 disp=unknown; b34srun; b34sexec options clean(77); b34srun; b34sexec options copyf(4,77); pgmcards; allocate 2000 open data full.por data(format=portable) table linreg gasout # constant gasin{1 to 4} gasout{1 to 4} end b34sreturn; b34srun; b34sexec options rewind(77); b34srun; b34sexec options close(77); b34srun; b34sexec options open('full.por') unit=77 disp=unknown; b34srun; b34sexec options close(77); b34srun; /$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dounix('rats rats.in rats.out')$ B34SRUN$ /$ b34sexec options npageout /$ WRITEOUT('OUTPUT FROM RATS',' ',' ') /$ COPYFOUT('rats.out') /$ dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') /$ dounix('rm rats.in','rm rats.out','rm rats.dat') /$ $ /$ B34SRUN$ b34sexec matrix; /$ /$ Note : /$ do i=1,5; call dodos('start /w /r rats32s rats.in /run' :); call dounix('rats rats.in rats.out' :); call print('+++++++++++ copy ',i,' +++++++++++'); call print('+++++++++++++++++++++++++++++++++++':); if(i.eq.1)then; call copyout('rats.in'); endif; call copyout('rats.out'); enddo; b34srun; == ==DOIT Used to test call suspend( ); program doit; /; testing of call suspend(doit,'c:\b34slm\examples\matrix.mac'); call print('this is from program doit'); x=rn(matrix(3,3:)); call print(x,inv(x),x*inv(x)); call print('Program doit returns.'); return; end; == ==DOS Gets into DOS b34sexec matrix; * for other forms, see SYSTEM command help file; call system; b34srun; == ==DOT_PRODUCT Speed testing of dot_product( ) sum( ) /; /; Does not seem to make too much difference /; b34sexec options real16info ; b34srun; b34sexec matrix; call echooff; subroutine dotspeed(part1,part2,n,k); x=rn(matrix(n,n:)); y=rn(matrix(n,n:)); call compress; call dot_blas; call real16info; call timer(base1); do i=1,k; test=inv(x)*y; enddo; call timer(base2); part1=base2-base1; call compress; /; /; tests fortran dot_product and sum( ) /; call dot_product; call real16info; call timer(base3); do i=1,k; test=inv(x)*y; enddo; call timer(base4); part2=base4-base3; return; end; nn=12; size =array(nn:); blas =array(nn:); dot_p =array(nn:); do i=1,nn; size1=100*i; call dotspeed(part1,part2,size1,1); size(i) =size1; blas(i) =part1; dot_p(i)=part2; enddo; call print(' '); call tabulate(size,blas,dot_p); b34srun; == ==DOWHILE Simple dowhile loop b34sexec matrix; sum=0.0; add=1.; count=1.; tol=.1e-6; call echooff; dowhile (add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; enddowhile; call print('Sum was ',sum:); call print('Count was ',count); b34srun; == ==DOWHILE_2 Multiple Dowhile loop b34sexec matrix; sum=0.0; add=1.; ccount=1.; count=1.; tol=.1e-12; /$ outer dowhile does things 2 times call outstring(2,2,'We sum until we can add nothing!!'); call outstring(2,4,'Tol set as '); call outdouble(20,4,tol); call echooff; dowhile(ccount.ge.1..and.ccount.le.3.); sum=0.0; add=1.; count=1.; dowhile(add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; call outdouble(2,6,add); add=sum-oldsum; /$ This section cleans temps if(dmod(count,10.).eq.0.)call compress; enddowhile; ccount=ccount+1.; call print('Outer loop count was ',ccount:); call print('Sum was ',sum:); call print('Count was ',count:); enddowhile; b34srun; == ==DOWHILE_3 Subroutine Implementation b34sexec matrix; call echooff; subroutine test(tol); sum=0.0; add=1.; count=1.; call outstring(2,2,'We sum until we can add nothing!!'); call outstring(2,4,'Tol set as '); call outdouble(20,4,tol); dowhile (add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; call outdouble(20,6,add); call compress(300); enddowhile; call print('tol was ',tol:); call print('Sum was ',sum:); call print('Count was ',count:); return; end; call test(.1e-6); call test(.1e-8); b34srun; == ==DO_SPEC Plot Periodogram and Spectrum b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(do_spec); call load(data_acf); weights=array(:1 2 3 2 1); call character(cc,'Analysis of Gasout'); call do_spec(gasout,cc,weights); call data_acf(gasout,cc,60); rr=rn(array(4000:)); call character(cc,'Analysis of a Random Series with 4000 obs'); call do_spec(rr,cc,weights); call data_acf(rr,cc,60); d1=dif(rr); call character(cc,'Analysis of a (1-B)*Random Series with 4000 obs'); call do_spec(d1,cc,weights); call data_acf(d1,cc,60); b34srun; == ==DO2SPEC Plot Periodogram and Spectrum with file name b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(do2spec); call load(data2acf); weights=array(:1 2 3 2 1); call character(cc,'Analysis of Gasout'); call do2spec(gasout,cc,weights,'gas_spec.wmf'); call data2acf(gasout,cc,60, 'gas_acf.wmf'); rr=rn(array(4000:)); call character(cc,'Analysis of a Random Series with 4000 obs'); call do2spec(rr,cc,weights,'random_spec.wmf'); call data2acf(rr,cc,60, 'random_acf.wmf'); d1=dif(rr); call character(cc,'Analysis of a (1-B)*Random Series with 4000 obs'); call do2spec(d1,cc,weights,'dif_ran_spec.wmf'); call data2acf(d1,cc,60, 'dif_ran_acf.wmf'); b34srun; == ==DO_TEST1 Tests DO loop in MATRIX Language b34sexec matrix; call print('Simple do loop'); call echooff; do i=1,10; call print('This is in the simple loop',i); enddo; subroutine testit(i); j=i*2; call print('In testit we run a loop',i,j); do kk=1,i; call print('This is in the simple loop in the subroutine. kk=',kk); enddo; return; end; do kk=1,5; call print('This is in the main program'); call testit(kk); enddo; call print('All Done'); b34srun; == ==DO_TEST2 Further Do loop tests / illustrations b34sexec matrix; call echooff; call print('This is the usual do loop'); do i=1,10; call print('This is i ',i); enddo; call print('This jumps 2'); do i=1,10,2; call print('This is i ',i); enddo; call print('This illustrates computed Arguments'); jj=1; kk=10; do kk1=jj,kk; call print('This is kk1',kk1); enddo; call print('This illustrates arguments that are computed'); do kk2=jj*2,kk/2; call print('This is kk2',kk2); enddo; b34srun; == ==DO_TEST3 Further DO Loop Tests b34sexec matrix; * This program illustrates various DO LOOP setups; * This is NOT the fastest way to program !! ; * Simple do loop; call echooff; do i=1,10; call print('This is line 1!!!!!!!!'); call print('This is in the simple loop',i); if(i.ge.2.and.i.lt.6)then; call print('I is ge 2 and lt 6',' i= ',i); endif; if(i.eq.9)call print('I was 9 in this pass'); enddo; call print('Two nested do loops in base program'); do i=1,10; do j=i,10; call print('i and j',i,j); enddo; enddo; subroutine test(i); call print('In subroutine test. I was ',i); do k=1,5; do j=1,5; call print('in test k, j',k,j); enddo; enddo; call print('leaving test'); return; end; call print('We call a subroutine in a do loop and do a loop'); do i=1,10; call print('Calling test. i was ',i); call test(i); enddo; call print('All Done'); b34srun; == ==DO_TEST4 DO Loops and GO to Statements and IFs b34sexec matrix; call echooff; do i=1,300; if(i.ge.7)go to n; call print('I should be less than 7',i); n continue; if(i.gt.98.and.i.lt.101)call print('I gt 98 & lt 101',i); enddo; b34srun; == ==DO_TEST5 Illustrates Minitoring a Do loop as it runs b34sexec matrix; * Simple do loop with full screen monitoring; * Program can be terminated with break key ; program junk; call echooff; call cls; do i=1,10; call outstring(1,4,'This is i'); call outinteger(40,4,i); do j=i,20; call outstring(1,5,'This is j'); call outinteger(40,5,j); call print('i and j',i,j); x=i*j; enddo; j=0; call break('End of loop # 1'); enddo; return; end; call junk; b34srun; == ==DO_TEST6 Slows speed of DO SOLVE and Copy - Simple Case b34sexec matrix; /$ If N is too big this will blow up /$ Tests speed of calculations. Set n for tests n=2000; ar1=array(N:); test=array(10:); test(1)=.1; test(2)=.99; b=1.1; call timer(base1); /$ solve(ar1=2.*test(t) :range 1, norows(test)); /$ solve(ar1=2.*test(t) :range norows(test)-9, norows(test)); /$ solve(ar1=2.*test(t-1) :range 2, 10); solve(ar1=2.*b :range 2, n); call timer(base2); call echooff; do i=1,n; ar1(i)=2.*b; enddo; call timer(base3); call setcol(ar1,1,2.*b); call timer(base4); call print('Speed differences between SOLVE, Do Loop and Setcol', 'solve ',base2-base1,'do loop ',base3-base2,' Eq ', base4-base3); call names; b34srun; == ==DO_TEST7 Speed Differences SOLVE DO GENARMA b34sexec matrix; /$ If b is too big this will blow up /$ Shows speed differences between DO and solve /$ genarma is the correct way to proceed with this problem /$ n=1000; ar1=array(N:); ar2=ar1; ar1(1)=1.1; ar2(1)=ar1(1); b=.8; call echooff; call timer(base1); /$ next Line tests array problems /$ solve(ar1=b*ar1(t-10)+ rn(b) :range 1, norows(ar1)); solve(ar1=b*ar1(t-1) + rn(b) :range 2, n); call timer(base2); do i=2,n; ar2(i)=b*ar2(i-1)+rn(b) ; enddo; call timer(base3); ar=array(:b); ma=array(:-.5,-.25); start=array(:1.1); ar3=genarma(ar,ma,1.0,start,1.,n); call timer(base4); call print(' For n =',n,'Solve time',base2-base1, 'Do time',base3-base2, 'Genarma time',base4-base3); call graph(ar1,ar2,ar3); /$ call print(ar1); b34srun; == ==DQAND Multiple integration of a function b34sexec matrix; * This is a big problem. Note maxsub 100000 ; program test; f=dexp(-1.*(x(1)*x(1)+x(2)*x(2)+x(3)*x(3) )); return; end; /$ We solve 6 problems. As constant => inf and => pi()**1.5 lowerv=array(3:); upperv=array(3:); x =array(3:); call print(test); call echooff; j=integers(3); do i=1,6; cc=dfloat(i)/2.0; lowerv(j)=(-1.)*cc; upperv(j)= cc; call dqand(f x :name test :lower lowerv :upper upperv :errabs .0001 :errrel .001 :maxsub 100000 :print); enddo; call print('Limit answer ',pi()**1.5 :); b34srun; == ==DQDAG Integrate a function using Gauss-Kronrod rules b34sexec matrix; program test; f=x*dexp(x); return; end; call print(test); call echooff; do i=1,6; call dqdag(f x :name test :lower 0.0 :upper 2.0 :errabs 0.0 :errrel .001 :rule i :maxsub 500 :print); enddo; b34srun; == ==DQDAGI Integrate a function over infinite/semi-infinite interval. b34sexec matrix; program test; f=dlog(x)/(1.+(10.*x)**2.); return; end; call print(test); call echooff; call dqdagi(f x :name test :lower 0.0 :errabs 0.0 :errrel .001 :maxsub 500 :print); exact = -1.*pi()*dlog(10.)/20. ; error=%result-exact; call print('Exact ',exact:); call print('Error ',error:); call tabulate(%alist %blist %rlist %elist); b34srun; == ==DQDAGP Integrete a function with singularity points given b34sexec matrix; program test; f=x**3.*dlog(dabs((x*x-1.0)*(x*x-2.0))); return; end; call print(test); call echooff; call dqdagp(f x :name test :breakp array(:1. dsqrt(2.)) :lower 0.0 :upper 3.0 :errabs 0.0 :errrel .001 :maxsub 500 :print); exact = 61.0*dlog(2.0)+77./4.*dlog(7.0) - 27.; error=dabs(%result-exact); call print('Exact ',exact:); call print('Error ',error:); call tabulate(%alist %blist %rlist %elist); b34srun; == ==DQDAGS Integrate a function with end point singularities b34sexec matrix; program test; f=dlog(x)/dsqrt(x); return; end; call print(test); call echooff; call dqdags(f x :name test :lower 0.0 :upper 1.0 :errabs 0.0 :errrel .001 :maxsub 500 :print); exact = -4.0; error=dabs(%result-exact); call print('Exact ',exact:); call print('Error ',error:); call tabulate(%alist %blist %rlist %elist); b34srun; == ==DQDNG Integrate a smooth function using a nonadaptive rule. b34sexec matrix; program test; f=x*dexp(x); return; end; call print(test); call echooff; call dqdng(f x :name test :lower 0.0 :upper 2.0 :errabs 0.0 :errrel .001 :print); exact=1.0+dexp(2.0); error=%result-exact; call print('Exact error ',error); b34srun; == ==DROPFIRST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; == ==DROPLAST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; == ==DSIN Illustrates Cosine / sin functions b34sexec matrix; n=10.; test=grid(0.0,pi()*n,.1); cc =dcos(test); ss =dsin(test); tt =dtan(test); cc16=dcos(r8tor16(test)); ss16=dsin(r8tor16(test)); tt16=dtan(r8tor16(test)); call tabulate(test,cc,ss,tt,cc16,ss16,tt16); call graph(test,cc,ss:heading 'Cosine & Sine' :plottype xyplot); b34srun; == ==DSINH Hyperbolic sine of real*8 value b34sexec matrix; x=dfloat(integers(-10,10)); dcosh2 =dcosh(x); dsinh2 =dsinh(x); dtanh2 =dtanh(x); dcosh216=dcosh(r8tor16(x)); dsinh216=dsinh(r8tor16(x)); dtanh216=dtanh(r8tor16(x)); call tabulate(x,dcosh2,dsinh2,dtanh2,dcosh216,dsinh216,dtanh216); b34srun; == ==DSQRT dsqrt function => Square Root of real and Complex dat b34sexec matrix; call screenouton; a=array(4:1,-2,3,-6); ac=complex(a,a*2.); ar=grid(1.,10.,1.); sqrtar=dsqrt(ar); test1=sqrtar*sqrtar; sqrtar4=dsqrt(sngl(ar)); test1r4=sqrtar4*sqrtar4; sqrtar16=dsqrt(r8tor16(ar)); test1r16=sqrtar16*sqrtar16; call tabulate(ar,sqrtar,test1,sqrtar4,test1r4,sqrtar16,test1r16); sqrtac=dsqrt(ac); test2=sqrtac*sqrtac; call print(ac,sqrtac); call tabulate(ac,sqrtac,test2); b34srun; == ==DTAN Illustrates tan function b34sexec matrix; n=10.; test=grid(0.0,pi()*n,.1); cc =dcos(test); ss =dsin(test); tt =dtan(test); cc16=dcos(r8tor16(test)); ss16=dsin(r8tor16(test)); tt16=dtan(r8tor16(test)); call tabulate(test,cc,ss,tt,cc16,ss16,tt16); b34srun; == ==DTANH Hyperbolic tangent of real*8 value b34sexec matrix; x=dfloat(integers(-10,10)); dcosh2 =dcosh(x); dsinh2 =dsinh(x); dtanh2 =dtanh(x); dcosh216=dcosh(r8tor16(x)); dsinh216=dsinh(r8tor16(x)); dtanh216=dtanh(r8tor16(x)); call tabulate(x,dcosh2,dsinh2,dtanh2,dcosh216,dsinh216,dtanh216); b34srun; == ==DTWODQ Two Dimensional Interated Integral /$ Fixed inner bounds test case first %b34slet prob1=1; %b34slet prob2=1; %b34sif(&prob1.eq.1)%then; b34sexec matrix; program test1; f=y*dcos(x+y*y); return; end; program test2; g=1.0; * g=(-2.)*x; return; end; program test3; h=3.0; * h=5.*x; return; end; call print(test1,test2,test3); call echooff; call dtwodq(f x y g h :name test1 test2 test3 :lower 0.0 :upper 1.0 :errabs .000 :errrel .001 :rule 6 :print); call print(' ':); call print('***************************':); call print('IMSL thinks result is -.514':); call print('results ',%result:); call print('error ',%error:); call tabulate(%alist,%blist,%rlist,%elist); b34srun; %b34sendif; %b34sif(&prob2.eq.1)%then; b34sexec matrix; program test1; f=y*dcos(x+y*y); return; end; program test2; * g=1.0; g=(-2.)*x; return; end; program test3; * h=3.0; h=5.*x; return; end; call print(test1,test2,test3); call echooff; call dtwodq(f x y g h :name test1 test2 test3 :lower 0.0 :upper 1.0 :errabs .001 :errrel .00 :rule 6 :print); call print(' ':); call print('***************************':); call print('IMSL thinks result is -.083':); call print('results ',%result:); call print('error ',%error:); call tabulate(%alist,%blist,%rlist,%elist); b34srun; %b34sendif; == ==EIG Eig (eigenval) => Eigenvalue Analysis b34sexec matrix; * Test case for Real Matrix from IMSL Math (10) pp 295-297; * eig => matlab notation; * eigenval => speakeasy notation; a=matrix(3,3:8.,-1.,-5.,-4., 4.,-2.,18.,-5.,-7.); call print('A Matrix',a); call print('eig(a)',eig(a)); e=eig(a,evec); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of General Martix A',sum(e), 'Trace of General Matrix A',trace(a), 'Product of the eigenvalues of Martix A',prod(e), 'Determinant of Matrix A',det(a) 'Test Factorization evec*diagmat(e)*inv(evec)' evec*diagmat(e)*inv(evec)); * real*16 case; r16a=r8tor16(a); call print('eig(r16a)',eig(r16a)); r16e=eig(r16a,r16evec); call print(r16e,r16a,r16evec); call print('Eigenvalues of r16a', r16e, 'Sum of the eigenvalues of General Martix A',sum(r16e), 'Trace of General Matrix A',trace(r16a), 'Product of the eigenvalues of Martix A',prod(r16e), 'Determinant of Matrix A',det(r16a) 'Test Factorization evec*diagmat(e)*inv(evec)' r16evec*diagmat(r16e)*inv(r16evec)); * Complex Case See IMSL Math (10) pp 302-304 ; r=matrix(4,4:5., 5.,-6.,-7., 3., 6.,-5.,-6., 2., 3.,-1.,-5., 1., 2.,-3.,0.0); i=matrix(4,4:9., 5.,-6.,-7., 3.,10.,-5.,-6., 2., 3., 3.,-5., 1., 2.,-3., 4.); ca=complex(r,i); call print('CA Complex Matrix',ca); call print('eig(ca)',eig(ca)); ce=eig(ca,cevec); call print('Eigenvectors of CA',cevec); call print('Eigenvalues of ca', ce, 'Sum of the eigenvalues of General Martix CA',sum(ce), 'Trace of General Matrix CA',trace(ca), 'Product of the eigenvalues of Martix CA',prod(ce), 'Determinant of Matrix CA',det(ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' cevec*diagmat(ce)*inv(cevec) ); * Complex*32 case; c32ca=c16toc32(ca); call print('CA Complex Matrix',c32ca); call print('eig(c32ca)',eig(c32ca)); c32ce=eig(c32ca,c32cevec); call print('Eigenvectors of c32CA',c32cevec); call print('Eigenvalues of c32ca', c32ce, 'Sum of the eigenvalues of General Martix CA',sum(c32ce), 'Trace of General Matrix CA',trace(c32ca), 'Product of the eigenvalues of Martix CA',prod(c32ce), 'Determinant of Matrix CA',det(c32ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' c32cevec*diagmat(c32ce)*inv(c32cevec) ); * Example from Limdep 7.0 Manual page 376 ; * Eigenalysis of Klein Model 1 ; r=matrix(3,3:.172,-.051,-.008,1.511,.848,.743,-.287,-.161,.818); call print(r,eigenval(r)); * Matlab Page 11-35 ; * V = Lamda*inv(v); a=matrix(3,3:0.0, -6., -1., 6., 2., -16., -5., 20., -10.); lamda=eigenval(a,v); dd=diagmat(lamda); call print('A',a, 'Lamda',lamda, 'V', v, 'V*lamda*inv(v)',v*diagmat(lamda)*inv(v)); call print('Now Get MATLAB result'); lamda2=eig(a,v2:lapack); call print(lamda2,v2); b34srun; == ==EIG_10 Tests of Accuracy b34sexec matrix; * Eigen value tests; * Note Eigen values of; * ( 1 1 1 1 e 0 0 0 0 e 0 0 0 0 e 0 0 0 0 e); * are 4+ e**2, and e^2, e^2, e^2 ; * Matrix is rank 0ne, not invertable; * See Handbook of Econometrics Volume 1 Chapter 12; * Paper by Quandt ; subroutine getx(x,order,e); /$ /$ Tests eigenvalue code on a known problem /$ /$ Eigen value tests; /$ Note Eigen values of; /$ ( 1 1 1 1 /$ e 0 0 0 /$ 0 e 0 0 /$ 0 0 e 0 /$ 0 0 0 e); /$ are 4+ e**2, and e^2, e^2, e^2 ; /$ Matrix is rank 0ne, not invertable; /$ See Handbook of Econometrics Volume 1 Chapter 12; /$ Paper by Quandt ; /$ x=matrix(order+1,order:); x(1,)=1.0; call print(pointer(x)); call pcopy(order,pointer(e),0,pointer(x,2),order+2,8); a=transpose(x)*x; call print(x,a); call print('e**2',e**2.); call print('Eigenvalues',eig(a)); call print('Eigenvalues',eig(a:lapack)); call print('Eigenvalues',seig(a)); return; end; e=.1e-3; do j=1,6; e=e/10.; do i=2,6; call getx(x,i,e); enddo; enddo; b34srun; == ==EIG_2 EISPACK vs LAPACK vs LAPACK b34sexec matrix; * Test case for Real Matrix from IMSL Math (10) pp 295-297; * eig => matlab notation; * eigenval => speakeasy notation; a=matrix(3,3:8.,-1.,-5.,-4., 4.,-2.,18.,-5.,-7.); call print('A Matrix real case',a); call print('eigen from Eispack ',eig(a) ); call print('eigen from Lapack ',eig(a:) ); e=eig(a,evec); call print('Test of eispack',a,e, 'Eispack eigenvectors ' evec 'Test of Factorization' evec*diagmat(e)*inv(evec)); e2=eig(a,evec2,evec22 :lapack); call print('Test of lapack ',a,e2, 'Lapack eigenvectors' 'Normalized to have euclian norm = 1. Largest real',evec2 'test factorization for right hand side' evec2*diagmat(e2)*inv(evec2) 'Using right eigenvectors we test if a*evec2 = evec * lamda' complex(a,0.0)*evec2,evec2*diagmat(e2) 'Using the left eigenvectors. We test if' 'evec22**h * a = lamda * evec22**h' transpose(dconj(evec22))*complex(a,0.0), diagmat(e2)*transpose(dconj(evec22)) 'test factorization for left hand side' inv(transpose(dconj(evec22)))*diagmat(e2)*transpose(dconj(evec22))); e3=eig(a,evec3,evec33 :lapack2); call print('Test of lapack2 ',a,e3, 'Lapack eigenvectors' 'Normalized to have euclian norm = 1. Largest real',evec3 'test factorization for right hand side' evec3*diagmat(e3)*inv(evec3) 'Using right eigenvectors we test if a*evec2 = evec * lamda' complex(a,0.0)*evec3,evec3*diagmat(e3) 'Using the left eigenvectors. We test if' 'evec33**h * a = lamda * evec33**h' 'Using the left eigenvectors. We test if' 'evec33**h * a = lamda * evec33**h' transpose(dconj(evec33))*complex(a,0.0), diagmat(e3)*transpose(dconj(evec33)) 'test factorization for left hand side' inv(transpose(dconj(evec33)))*diagmat(e3)*transpose(dconj(evec33))); * Complex Case See IMSL Math (10) pp 302-304 ; r=matrix(4,4:5., 5.,-6.,-7., 3., 6.,-5.,-6., 2., 3.,-1.,-5., 1., 2.,-3.,0.0); i=matrix(4,4:9., 5.,-6.,-7., 3.,10.,-5.,-6., 2., 3., 3.,-5., 1., 2.,-3., 4.); ca=complex(r,i); call print('CA Complex Matrix',ca); ce =eig(ca,cevec ); ce2=eig(ca,cevec2:lapack ); ce3=eig(ca,cevec3:lapack2); call print('ce => EISPACK' 'ce2 => zgeev / zgeev' 'ce3 => zgeevx/ zgeevx' 'Eigenvalues of ca', ca,ce2,ce3 'Sum of the eigenvalues of ce General Martix A',sum(ce), 'Sum of the eigenvalues of ce2 General Martix A',sum(ce2), 'Sum of the eigenvalues of ce3 General Martix A',sum(ce3), 'Trace of General Matrix A',trace(ca), 'Product of the eigenvalues ce of Martix A',prod(ce), 'Product of the eigenvalues ce2 of Martix A',prod(ce2), 'Product of the eigenvalues ce3 of Martix A',prod(ce3), 'Determinant of Matrix A',det(ca) 'Test Factorization evec*diagmat(e)*inv(evec)' 'LAPACK vs EISPACK' cevec *diagmat(ce) *inv(cevec) cevec2*diagmat(ce2)*inv(cevec2) cevec3*diagmat(ce3)*inv(cevec3)); call print('We print the three right hand eigenvalues of ca' cevec,cevec2,cevec3); ce2=eig(ca,cevec2,left2 :lapack); ce3=eig(ca,cevec3,left3 :lapack2); call print('Look at right and left eigenvectors' cevec2,left2 cevec3,left3); b34srun; == ==EIG_3 Symmetric Eigenvalue Analysis b34sexec matrix; * Test case for Real symmetric Matrix from IMSL Math (10) pp 309-311; a=matrix(3,3:7.,-8.,-8.,-8.,-16.,-18.,-8.,-18.,13.); call print('A Matrix',a); e=seig(a); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of Symmetric Martix A',sum(e), 'Trace of Symmetric Matrix A',trace(a), 'Product of the eigenvalues of Symmetric Martix A',prod(e), 'Determinant of Symmetrix Matrix A',det(a)); ee=seig(a,evec); call print(ee,evec); call print('Test transpose(evec)*evec ', transpose(evec)*evec , ' ' 'Note: a*evec = evec*diagmat(ee)' a*evec,evec*diagmat(ee), 'Test evec*transpose(evec) ', evec*transpose(evec)) ; call print('Using EISPACK and LAPACK Test results':); e =eig(a,evec); e2=eig(a,evec2:lapack); call print('Eispack',evec, 'Test of eigenvalues note that diagonal matrix but not 1 on diag' transpose(evec)*evec 'Do we get a' evec*diagmat(e)*inv(evec) ' ' 'Test of LAPACK',evec2 'Do we get a' evec2*diagmat(e)*inv(evec2) evec2*transpose(evec2) transpose(evec2)*evec2); b34srun; == ==EIG_4 Shows Speed tests /$ As setup will solve 75 by 75 system /$ Illustrates speed gains ffrom seigenval /$ Also illustrates how costly Eigenvectors are /$ To calculate. All General matrix eigenvectors /$ use complex matrix path!!!! If only /$ Eigenvalues are needed, EISPACK RG is used /$ /$ All eigenvalues are tested against trace() and det() /$ b34sexec matrix; n=75; nn=namelist(sym,gen,gena,gen2,complex1,complex2); s=rn(matrix(n,n:)); s=transpose(s)*s; call timer(base1); e=seigenval(s); call timer(base2); call print('Eigenvalues of Symmetric Matrix using SEIGENVAL took', (base2-base1)); time(1)=base2-base1; call print('Eigenvalues of s using SEIGENVAL', e, 'Sum of the eigenvalues of Symetric Martix S',sum(e), 'Trace of General Matrix S',trace(s), 'Product of the eigenvalues of Martix S',prod(e), 'Determinant of Matrix S',det(s)); call timer(base1); e=eigenval(s); call timer(base2); call print('Eigenvalues of Symmetric using EIGENVAL took', (base2-base1)); time(2)=base2-base1; call print('Eigenvalues of s using EIGENVAL', e, 'Sum of the eigenvalues of Symetric Martix S',sum(e), 'Trace of General Matrix S',trace(s), 'Product of the eigenvalues of Martix S',prod(e), 'Determinant of Matrix S',det(s)); a=rn(matrix(n,n:)); call timer(base1); e=eigenval(a); call timer(base2); call print('Eigenvalues of Real*8 Gen Matrix using EIGENVAL took', (base2-base1)); time(3)=base2-base1; call timer(base1); e=eigenval(a,vec); call timer(base2); time(4)=base2-base1; call print('Eigenvalues and Vectors of Real*8 Gen Matrix using EIGENVAL took',(base2-base1)); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of General Martix A',sum(e), 'Trace of General Matrix A',trace(a), 'Product of the eigenvalues of Martix A',prod(e), 'Determinant of Matrix A',det(a)); ca=complex(a,2.0*a); call timer(base1); ce=eigenval(ca); call timer(base2); time(5)=base2-base1; call timer(base1); ce=eigenval(ca,cevec); call timer(base2); time(6)=base2-base1; call print('Eigenvalues of Real*8 Gen Matrix using EIGENVAL took', (base2-base1)); call print('Eigenvalues of ca', ce, 'Sum of the eigenvalues of General Martix CA',sum(ce), 'Trace of General Matrix CA',trace(ca), 'Product of the eigenvalues of Martix CA',prod(ce), 'Determinant of Matrix CA',det(ca),' '); call print('Sym => Symmetrix Matrix using SEIGENVAL', 'Gen => Symmetric Matrix using EIGENVAL', 'Gena => Real*8 General Matrix ', 'Gen2 => Real*8 General Matrix Eigenvalues and Vectors', 'Complex1 => Complex*16 Matrix Eigenvalues only', 'Complex2 => Complex*16 Matrix both Eigenvalues & Vectors' ' '); call tabulate(nn,time); b34srun; == ==EIG_5 Rosser Test Case b34sexec matrix; * Rosser test matrix from matlab ; test1=matrix(8,8: 611., 196.,-192., 407., -8., -52.,-49., 29., 196., 899., 113.,-192., -71., -43., -8., -44., -192., 113., 899., 196., 61., 49., 8., 52., 407.,-192., 196., 611., 8., 44., 59., -23., -8., -71., 61., 8., 411.,-599., 208.,208., -52., -43., 49., 44.,-599., 411., 208.,208., -49., -8., 8., 59., 208., 208., 99.,-911., 29., -44., 52., -23., 208., 208.,-911., 99.); call print(test1,eig(test1), eig(test1:lapack) eig(test1:lapack2) seigenval(test1)); b34srun; == ==EIG_6 Bad Eigenvalue Problem b34sexec matrix; * Example from Matlab 4-36 - General Matrix; * Matrix is Defective => Cannot diagonalize ; * Schur decomposition works ; a=matrix(3,3: 6., 12., 19., -9., -20., -33., 4., 9., 15.); e =eigenval(a,vec1); call print(a,e,vec1); e2=eig(a,vec2:lapack); call print(a,e2,vec2); call schur(a,s,u); call print(a,s,u); is_ident=u*transpose(u); is_a =u*s*transpose(u); call print(is_ident,is_a); b34srun; == ==EIG_7 Speed Tests b34sexec matrix; * ispeed1 on pd matrix ; * ispeed2 on general matrix; * ispeed3 on complex general matrix; * up 400 has been run ; igraph=0; ispeed1=1; ispeed2=1; ispeed3=1; upper=650; mesh=25; /$ PD Results if(ispeed1.ne.0)then; call echooff; icount=0; n=0; top continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done; x=rec(matrix(n,n:)); x=transpose(x)*x; * x=complex(x,dsqrt(dabs(x))); call compress; call timer(base10); e=seig(x); call timer(base20); call compress; call timer(base110); e=seig(x,evec); call timer(base220); call compress; call timer(base11); e=eig(x); call timer(base22); call compress; call timer(base111); e=eig(x:lapack2); call timer(base222); call compress; call timer(base1); e=eig(x,evec); call timer(base2); call compress; call timer(base3); e=eig(x,evec,evec2 :lapack2); call timer(base4); call compress; call timer(base5); e=eig(x,evec:lapack2); call timer(base6); size(icount) = dfloat(n); sm1(icount) =base20-base10; sm2(icount) =base220-base110; eispack1(icount) =(base22-base11); lapack1(icount) =(base222-base111); eispack2(icount) =(base2-base1); lapack2a(icount) =(base4-base3); lapack2b(icount) =(base6-base5); call free(x,xinv1,ii); go to top; done continue; call print('EISPACK vs LAPACK on PD Matrix ':); call print('lapack2a gets both right and left eigenvectors':); call tabulate(size,sm1 sm2,eispack1,lapack1,eispack2,lapack2a,lapack2b); if(igraph.eq.1) call graph(size sm1,sm2,eispack1,lapack1,eispack2,lapack2a,lapack2b :plottype xyplot :nokey :heading 'Real*8 PD Matrix Results'); endif; if(ispeed2.ne.0)then; call echooff; icount=0; n=0; top2 continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done2; x=rec(matrix(n,n:)); * x=transpose(x)*x; * x=complex(x,dsqrt(dabs(x))); call compress; call timer(base11); e=eig(x); call timer(base22); call compress; call timer(base111); e=eig(x:lapack2); call timer(base222); call compress; call timer(base1); e=eig(x,evec); call timer(base2); call compress; call timer(base3); e=eig(x,evec,evec2 :lapack2); call timer(base4); call compress; call timer(base5); e=eig(x,evec:lapack2); call timer(base6); size(icount) = dfloat(n); eispack1(icount) =(base22-base11); lapack1(icount) =(base222-base111); eispack2(icount) =(base2-base1); lapack2a(icount) =(base4-base3); lapack2b(icount) =(base6-base5); call free(x,xinv1,ii); go to top2; done2 continue; call print('EISPACK vs LAPACK on General Matrix ':); call print('lapack2a gets both right and left eigenvectors':); call tabulate(size,eispack1,lapack1,eispack2,lapack2a,lapack2b); if(igraph.eq.1) call graph(size ,eispack1,lapack1,eispack2,lapack2a,lapack2b :plottype xyplot :nokey :heading 'Real*8 General Matrix Results'); endif; if(ispeed3.ne.0)then; call echooff; icount=0; n=0; top3 continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done3; x=rec(matrix(n,n:)); x=complex(x,dsqrt(dabs(x))); call compress; call timer(base11); e=eig(x); call timer(base22); call compress; call timer(base111); e=eig(x:lapack2); call timer(base222); call compress; call timer(base1); e=eig(x,evec); call timer(base2); call compress; call timer(base3); e=eig(x,evec,evec2 :lapack2); call timer(base4); call compress; call timer(base5); e=eig(x,evec:lapack2); call timer(base6); size(icount) = dfloat(n); eispack1(icount) =(base22-base11); lapack1(icount) =(base222-base111); eispack2(icount) =(base2-base1); lapack2a(icount) =(base4-base3); lapack2b(icount) =(base6-base5); call free(x,xinv1,ii); go to top3; done3 continue; call print('EISPACK vs LAPACK on a Complex General Matrix ':); call print('lapack2a gets both right and left eigenvectors':); call tabulate(size,eispack1,lapack1,eispack2,lapack2a,lapack2b); if(igraph.eq.1) call graph(size ,eispack1,lapack1,eispack2,lapack2a,lapack2b :plottype xyplot :nokey :heading 'Complex*16 Results'); endif; b34srun; == ==EIG_8 Simple Tests Eispack vs LAPACK b34sexec matrix; * Exercises Eigenvalue calculations ; * IMSL test case ; A = matrix(3,3: 8.0, -1.0,-5.0, -4.0, 4.0,-2.0, 18.0, -5.0,-7.0); e =eig(a,evec); call print('Test Eispack',a,evec*diagmat(e)*inv(evec)); e2 =eig(a,evecr,evecl :lapack); call print('test eispack vs lapack':); call print(a,e,evec,e2,evecr,evecl); call print('test right' evecr*diagmat(e2)*inv(evecr) 'test left' inv(transpose(dconj(evecl)))*diagmat(e2)*transpose(dconj(evecl))); ca=complex(a,a*a); e =eig(ca,evec); call print('Test Eispack',ca,evec*diagmat(e)*inv(evec)); e2 =eig(ca,evecr,evecl :lapack); call print('test eispack vs lapack':); call print(ca,e,evec,e2,evecr,evecl); call print('test right' evecr*diagmat(e2)*inv(evecr) 'test left' inv(transpose(dconj(evecl)))*diagmat(e2)*transpose(dconj(evecl))); b34srun; == ==EIG_9 Eigen Analysis with links to Matlab b34sexec matrix; * IMSL test case ; A = matrix(3,3: 8.0, -1.0,-5.0, -4.0, 4.0,-2.0, 18.0, -5.0,-7.0); e =eig(a,evec); e2 =eig(a,evec2 :lapack); call print('test eispack vs lapack':); call print(a,e,evec,e2,evec2); call makematlab(a :file 'adat.m'); call load(rmatlab); call rmatlab; call getmatlab(e3 :file 'e3.dat'); call getmatlab(evec3 :file 'evec3.dat'); * call print('Matlab Answers',e3,evec3); /$ Running Matlab script under B34S Matrix /$ Tasks: 1. Pass Data from B34S to Matlab /$ 2. Do work in Matlab /$ 3. Bring data back from Matlab to B34S /$ not implemented /$ user needs to type quit in matlab to get /$ back to b34s /$ /$ Matlab Commands /$ pgmcards; a=getb34s('adat.m'); [evec3,e3]=eig(a) % makeb34s('e3.dat',e3); % makeb34s('evec3.dat',evec3); % quit b34sreturn; b34srun; == ==ENDDO Ending a do or for loop b34sexec matrix; sum=0.0; call echooff; do i=1,10; sum=sum+dfloat(i); enddo; call print('Sum was ',sum); b34srun; == ==ENDDOWHILE End of a dowhile statement b34sexec matrix; sum=0.0; add=1.; count=1.; tol=.1e-6; call echooff; dowhile (add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; enddowhile; call print('Sum was ',sum:); call print('Count was ',count); b34srun; == ==EPPRINT Print to Error and Output File b34sexec matrix; call epprint('Note: This message will be in the log and output file'); b34srun; == ==EPRINT Print to error file b34sexec matrix; call eprint('Note: This message will be in the log'); b34srun; == ==EPSILON Positive value such that 1.+x NE 1. b34sexec matrix; i=1; x=1.; y=sngl(x); call print('Largest integer ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); x=.1d+00; y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; spx(j)=spacing(x); spy(j)=spacing(y); nearpr8(j)=nearest(x, 1.); nearmr8(j)=nearest(x,-1.); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8 and Real*4'); call tabulate(testnum,spx,spy,nearpr8,nearmr8,nearpr4,nearmr4); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; == ==ERASE Erase a file b34sexec matrix; call get_file(cc); call print('File found was ',cc); call erase(cc); b34srun; == ==ERRORTRAP Error trap examples b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasout{1 to 6} gasin{1 to 6} :print); call print('+++++++++ all done ++++++++++++++++++++':); call errorget(i1,i2); call print(i1,i2); call errortrapon; call errorget(i1,i2); call print(i1,i2); call errortrapoff; call errorget(i1,i2); call print(i1,i2); call errorset(99,98); call errorget(i1,i2); call print(i1,i2); call errortrapoff; call errortrapon; call print('bad call':); call olsq(gasout basout{1 to 6} gasin{1 to 6} :print); call errorget(i1,i2); call print('error was ',i2); b34srun; == ==ESACF_1 Tests ESACF /; Tests IACF and esacf with B34S /; Uses Wei Data set (Lynx) b34sexec options ginclude('b34sdata.mac') member(wei_w7); b34srun; b34sexec matrix; call loaddata; call load(iacf :staging); call echooff; call print('+++++++++++++++++++++++++++++':); call print('Test Case From Wei page 130 ':); acf1=acf(lnpelts,20,se,pacf); call iacf(lnpelts,iacf1,20); call tabulate(acf1,pacf,iacf1 :title 'ACF PACF IACF'); call esacf(lnpelts,5,9 :print); b34srun; == ==ESACF_2 Tests on Chem Problem /; /; Wei(2006) Page 132 /; B34S/SCA show slight Wei accuracy issues /; %b34slet dosca=1; b34sexec options ginclude('b34sdata.mac') member(bj_c); b34srun; b34sexec matrix; call loaddata; call load(iacf :staging); call echooff; call print('+++++++++++++++++++++++++++++':); call print('Test Case From Wei page 132 ':); call print('Note that SCA and B34S get same answers but Wei differs':); acf1=acf(chem,20,se,pacf); call iacf(chem,iacf1,20); call tabulate(acf1,pacf,iacf1 :title 'ACF, PACF IACF'); call esacf(chem,5,9 :print); call print(' ':); call print('See what autobj gets ':); call print(' ':); call autobj(chem :print :nac 24 :npac 24 :autobuild ); call print(' ':); call print('Box-Jenkins-Reinsel (1994) page 196 ':); call print('Alternative Models ':); call autobj(chem :print :nac 24 :npac 24 :ar index(1 2) ); call autobj(chem :print :nac 24 :npac 24 :dif index(2 1) :ma index(1 2)); b34srun; %b34sif(&dosca.ne.0)%then; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. --- iarima chem eacf chem acf chem iacf chem stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out') $ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dodos('erase sca.cmd','erase sca.out','erase sca.dat') dounix('rm sca.cmd','rm sca.out','rm sca.dat') $ b34srun$ == ==ESACF_3 More Extensive ESACF Test %b34slet dosas=1; %b34slet dosca=1; /; Tests IACF and esacf with B34S and SAS and SCA /; Uses Wei Data set (Lynx) then an AR(3) dataset b34sexec options ginclude('b34sdata.mac') member(wei_w7); b34srun; b34sexec matrix; call loaddata; call load(iacf :staging); call echooff; call print('+++++++++++++++++++++++++++++':); call print('Test Case From Wei page 130 ':); acf1=acf(lnpelts,20,se,pacf); call iacf(lnpelts,iacf1,20); call tabulate(acf1,pacf,iacf1 :title 'ACF, PACF IACF'); call esacf(lnpelts,5,9 :print); call print(%esacf); /; Generates EAR coefficients for q=0 and q=1 itestar=1; if(itestar.ne.0)then; call print('test ar coef for g=0 ++++++++':); do i=1,7; tttt=lnpelts-mean(lnpelts); call olsq(tttt tttt{1 to i} :qr :noint :print); rr=%res; imiss=integers(i); tttt(imiss)=missing(); tttt=goodrow(tttt); call olsq(tttt tttt{1 to i} rr{1} :qr :noint :print); enddo; call print('++++++++++++++++++++++++++++':); call print(' ':); endif; /; Generate Data AR(3) n=10000; call free(ma); ar= array(:.7 ); nn=100; start=array(:.1); varnoise=1.; ar1 =genarma(ar,ma,0.0,start,varnoise,n,nn); call arma(ar1 :nar 1 :maxit 8000 :itprint :print); call iacf(ar1 ,iacf1,10); acf1=acf(ar1 ,10); call tabulate(acf1,iacf1 :title 'AR(1) Model acf and IACF'); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++':); call esacf(ar1 ,5,9 :print); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('SAS Test Case from Dickey & Broklebank page 78'); call print('Base Model: y(t)-.3*y(t-1)-.340*y(t-2)+.120*y(t-3)':); call print('Inverse Model: y(t)=e(t)-.3*e(t-1)-.34*e(t-2)+120*e(e-3)':); call print('base=(1+.3^2+.34^2+.120^2)':); call print('lag1=(-.3 +(.3*.34)-(.340*.120))': ); call print('lag2=(-.340-(.3*.120))':); call print('lag1/base = -0.19574':); call print('lag2/base = -0.3082 ':); call print(' ':); /; ar(3) test case call free(ma); ar= array(:.3, .34,-.120); nn=100; start=array(:.1 .1 .1 ); varnoise=1.; ar3 =genarma(ar,ma,0.0,start,varnoise,n,nn); call arma(ar3 :nar 3 :maxit 8000 :itprint :print); call iacf(ar3 ,iacf1,10); call print('IACF ar(3) ',iacf1); acf1=acf(ar3 ,10); call print('ACF ar(3) ',acf1); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++':); call esacf(ar3,6,12 :print); /; call esacf(ar3,5,5 ); call print(%esacf,%ex_ar); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++':); call makedata(ar1,ar3 :file 'ar3.b34'); b34srun; %b34sif(&dosca.ne.0)%then; b34sexec options include('ar3.b34'); b34srun; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. --- iarima ar1. eacf ar1. scan ar1. acf ar1. iacf ar1. iarima ar3. eacf ar3. scan ar3. acf ar3. iacf ar3. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out') $ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dodos('erase sca.cmd','erase sca.out','erase sca.dat') dounix('rm sca.cmd','rm sca.out','rm sca.dat') $ b34srun$ /; Lynx b34sexec options ginclude('b34sdata.mac') member(wei_w7); b34srun; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. --- iarima lnpelts. eacf lnpelts. acf lnpelts. iacf lnpelts. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out') $ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dodos('erase sca.cmd','erase sca.out','erase sca.dat') dounix('rm sca.cmd','rm sca.out','rm sca.dat') $ b34srun$ %b34sendif; %b34sif(&dosas.ne.0)%then; b34sexec options include('ar3.b34'); b34srun; b34sexec options open('testsas.sas') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=29 icntrl=29$ sas $ * sas commands next ; pgmcards$ proc arima; identify var=ar1 nlag=2 ; identify var=ar1 nlag=9 ; identify var=ar1 nlag=10; run; proc arima; identify var=ar3 nlag=2 ; identify var=ar3 nlag=9 ; identify var=ar3 nlag=10; run; endsas; b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos('start /w /r sas testsas' ) dounix('sas testsas' ) $ b34srun$ b34sexec options npageout noheader writeout(' ','output from sas',' ',' ') writelog(' ','output from sas',' ',' ') copyfout('testsas.lst') copyflog('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==EVAL Evaluate a variable pointer b34sexec matrix; test1=10.; pp='TEST1'; call print(eval(pp)); b34srun; == ==EVAL_2 Advanced Eval Use b34sexec matrix; /$ illustrate namelist to argument x=namelist(x1 x2 x3); y =rn(array(10:)); x1=rn(array(10:)); x2=rn(array(10:)); x3=rn(array(10:)); call olsq(y,x1,x2,x3:print); /$ : not needed here xnew=eval(x(1)); do i=2,norows(x); xnew=catcol(xnew,eval(x(i))); enddo; call olsq(y,xnew :print); /$ : needed here to get names! call olsq(y,eval(x(1):),eval(x(2):),eval(x(3):) :print); b34srun; == ==EVAL_4 Use of Argument( ) same as eval(:) for a name /; Illustrate passing names info into a subroutine /; First we pass in the name of a global variable. /; Next we rename a local variable a name we pass in /; b34sexec options debugsubs(b34smat09,b34smat09a); b34srun; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; subroutine test(nn,xx); /; Illustrate name passing call names(all); call print(nn); /; This prints a global variable call print(argument(nn(1))); /; Renames a local variable n=namelist(argument(nn(3))); call copy(xx,argument(nn(3))); call graph(argument(n)); call graph(argument(nn(3))); call names(all); return; end; /; This name list two global variables plus one name 'funny' /; Funny does not exist but we want to use it inside the subroutine /; We pass in lgas and by use of the copy command copy this variable /; to a name we want that is saved in the n variable name.... /; From now on we use the argument command n1=namelist(gasout,gasin,funny); call makeglobal(gasout); call makeglobal(gasin); lgas=gasout; call names(all); call print(n1); call test(n1,lgas); b34srun; == ==EVAL_3 eval(name:) vs argument( ) /; argument(h) same as eval(h:) only for a name /; argument allows much more to be passed b34sexec matrix; x=9; h='X'; call print(argument(h)); call print(eval(h)); call print(eval(h:)); /; To get around augument(h)=999.; which is not allowed call copy(3.* 333.,argument(h)); call print(x); call copy(3.*333. ,eval(h:)); call print(x); b34srun; == ==EVAL_ARG Tests of ARGUMENT and EVAL /; Key argument and eval tests b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call character(cc, 'gasout gasin{1 to 10}'); call print(cc); call testarg(argument('gasout gasin') :print); call olsq(argument('gasout gasin') :print); call names; call testarg(argument(cc) :print); call olsq(argument(cc) :print); call names; b34srun; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; program testit; /; /; needs /; /; call character(reg,'lnq lnk lnl'); /; call character(plotvar,'lnq lnl lnk'); /; /; before being called /; call olsq(argument(reg) :l1 :minimax :print); call graph(argument(plotvar)); return; end; call character(reg,'lnq lnk lnl'); call character(plotvar,'lnq lnl lnk'); call testit; b34srun; /$ argument b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call testarg(argument('GASOUT GASIN') :print); call olsq(argument('gasout gasin') :print); call olsq(argument('gasout gasin{1 to 6}') :print); call character(cc, 'gasout gasin{1 to 10}'); call print(cc); call testarg(argument(CC) :print); call olsq(argument(cc) :print); /$ /$ advanced features allowing generating y=x real time /$ x=10.; call character(c1,'X*4.'); call character(c2,'Y'); call character(c4,'y'); call names; call testarg(argument(c1),argument(c2)); call copy(argument(c1),argument(c2)); call print(argument(c1)); call print(argument(c2)); call print(argument(c4)); x=9.; call print('two ways to get same answer':); call copy(argument('x*2.'),argument('y')); call print(y); call copy(argument('X*2.'),argument('y ')); call print(y); /$ /$ Passing a command string to a routine /$ allows selective printing of known variables at run time. /$ /$ Note that the character string passed to tprint can be built at /$ runtime /$ subroutine tprint(cc); x=10; y=20; call print(argument(cc)); return; end; call character(cctest,'This is a test'); call tprint('x'); call tprint('y'); call names(all); b34srun; /; Illustrate passing names info into a subroutine /; First we pass in the name of a global variable. /; Next we rename a local variable a name we pass in /; b34sexec options debugsubs(b34smat09,b34smat09a); b34srun; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; subroutine test(nn,xx); /; Illustrate name passing call names(all); call print(nn); /; This prints a global variable call print(argument(nn(1))); /; Renames a local variable n=namelist(argument(nn(3))); call copy(xx,argument(nn(3))); call graph(argument(n)); call graph(argument(nn(3))); call names(all); return; end; /; This name list two global variables plus one name 'funny' /; Funny does not exist but we want to use it inside the subroutine /; We pass in lgas and by use of the copy command copy this variable /; to a name we want that is saved in the n variable name.... /; From now on we use the argument command n1=namelist(gasout,gasin,funny); call makeglobal(gasout); call makeglobal(gasin); lgas=gasout; call names(all); call print(n1); call test(n1,lgas); b34srun; /; argument(h) same as eval(h:) b34sexec matrix; x=9; h='X'; call print(argument(h)); call print(eval(h)); call print(eval(h:)); /; To get around augument(h)=999.; which is not allowed call copy(3.* 333.,argument(h)); call print(x); call copy(3.*333. ,eval(h:)); call print(x); b34srun; == ==EXITDO Jump out of a Do loop b34sexec matrix; call echooff; do j=1,4; do i=1,10; if(i.eq.8)exitdo; if(i.ge.0)then; call print('at 1 in if i was ',i:); if(i.ge.4)exitif; call print('at 2 in if Should never be gt 3 i was ',i:); endif; call print('in do loop ',i); enddo; enddo; b34srun; == ==EXITIF Jump out of a IF loop b34sexec matrix; call echooff; do j=1,4; do i=1,10; if(i.eq.8)exitdo; if(i.ge.0)then; call print('at 1 in if i was ',i:); if(i.ge.4)exitif; call print('at 2 in if Should never be gt 3 i was ',i:); endif; call print('in do loop ',i); enddo; enddo; b34srun; == ==EXP Natural Log b34sexec matrix; x=grid(0.0001 100. .1); log10x=dlog10(x); lnx =dlog(x); testx1=10.**log10x; testx2=exp(lnx); call tabulate(x,log10x,lnx,testx1,testx2); * Complex case; cx=complex(x,dsqrt(x)); lncx =dlog(cx); testcx =exp(lncx); call tabulate(cx,lncx,testcx); b34srun; == ==EXPAND Expand a character Array b34sexec matrix; call character(cc,'This is a test'); call print(cc); call ilocatestr(cc,istart,iend); i=integers(istart,iend); subs=cc(i); call print(subs); call contract(cc,istart,iend); oldnewcc=cc; call print(cc); call character(new,'aaaissaa'); call expand(cc,new,1,8); call print(oldnewcc,cc); * we want aabb at 5-8 in cc; * We do not want to expand; call character(cc,'This is a test'); call character(new,'aabb'); call contract(cc,5,8); call expand(cc,new,5,8); call print(cc); b34srun; == ==EXTRACT Tests Extract b34sexec matrix; call character(cc2,'abcdefghijklmnop'); do i=1,10; j=10; newc=extract(cc2,i,j); call print(cc2,i,j,newc); enddo; cc8=namelist(mary sue judy Diana); cc82=extract(cc8,2,3); call print('col 2-3'); call tabulate(cc8,cc82); do i=1,8; newc=place(cc2,1,i); call print(cc2,newc,i); enddo; b34srun; == ==FACT Factorial b34sexec matrix; x=integers(20); call tabulate(x,fact(x)); b34srun; == ==FDAYHMS Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==FFT fft function = FFT of Real / Complex data b34sexec matrix; call screenouton; * Example from IMSL (10) Math Page 707-709; n=7.; ifft=grid(1.,n,1.); xfft=dcos((ifft-1.)*2.*pi()/n); rfft=fft(xfft); /; /; Test FFTPACK - alternative call not turned on /; /; rfft=fft(xfft :tfftpack); /; bfft=fft(rfft:back); call tabulate(xfft,rfft,bfft); * Complex Case See IMSL(10) Math Page 715-717; cfft=complex(0.0,1.); hfft=(complex(2.*pi())*cfft/complex(n))*complex(3.0); xfft=dexp(complex(ifft-1.)*hfft); cfft=fft(xfft); bfft=fft(cfft:back); call tabulate(xfft,cfft,bfft); * Simple Real Problem IMSL (10) Math 710-12; ffxin=array(7:); ffxin=ffxin+1.0; ffxout=fft(ffxin); bffxout=fft(ffxout:back); bffxout2=bffxout/dfloat(norows(bffxout)); call tabulate(ffxin,ffxout,bffxout,bffxout2); * Simple Problem IMSL (10) Math 718-720 ; fft2=fft(ifft); bfft2=fft(fft2:back); bfft2_2=bfft2/dfloat(norows(fft2)); call tabulate(ifft,fft2,bfft2,bfft2_2); fft2=fft(complex(ifft)); bfft2=fft(fft2:back); bfft2_2=bfft2/complex(dfloat(norows(fft2))); call tabulate(ifft,fft2,bfft2,bfft2_2); b34srun; == ==FFT_1 Example from Matlab Page 6-32 6-33 b34sexec matrix; /$ Test Problem of FFT from MATLAB page 6-32 x=array(8:4., 3., 7., -9., 1., 0., 0., 0.); call print(x,fft(x)); b34srun; == ==FFT_2 High and Low Pass b34sexec matrix; * Uses FFT to High and Low Pass Random Series; /$ /$ Illustrate with random numbers /$ n=296; test=rn(array(n:)); spec=spectrum(test,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); cfft=fft(complex(test,0.0)); * low pass ; nlow1 =1; nlow2 =64; nhigh1=51; nhigh2=150; fftlow =cfft*complex(0.0,0.0); ffthigh =cfft*complex(0.0,0.0); i=integers(nlow1,nhigh1); fftlow(i) = cfft(i); i=integers(nlow2,nhigh2); ffthigh(i) = cfft(i); call tabulate(cfft,fftlow,ffthigh); low =afam(real(fft(fftlow :back)))*(1./dfloat(norows(test))); high=afam(real(fft(ffthigh :back)))*(1./dfloat(norows(test))); call tabulate(low,high,fft(ffthigh:back)); spec=spectrum(low,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after Low Pass'); spec=spectrum(high,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after High Pass'); b34srun; == ==FFT_3 Simple Band Pass Filter b34sexec matrix; * Uses FFT to Band Pass Random Series; /$ /$ Illustrate with random numbers /$ /$ Middle Frequencies are passed. Spectrum is inspected /$ before and after filter is applied. /$ n=400; nlow=64; nupper=192; x=rn(array(n:)); spec=spectrum(x,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); cfft =fft(complex(x,0.0)); fftnew =cfft*complex(0.0,0.0); i=integers(nlow,nupper); fftnew(i) = cfft(i); nseries=afam(real(fft(fftnew :back)))*(1./dfloat(norows(x))); call tabulate(x,nseries); call graph(freq,spectrum(nseries,freq) :plottype xyplot :heading 'Spectrun of filtered Random Series'); b34srun; == ==FILTER Tests Filter Subroutine b34sexec matrix; /$ Uses FFT to High and Low Pass Random Series /$ /$ Illustrate with random numbers /$ call load(filter); n=500; test=rn(array(n:)); spec=spectrum(test,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); call filter(test,newtest,1,200); spec=spectrum(newtest,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after Low Pass'); call filter(test,high,201,500); spec=spectrum(high,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after High Pass'); b34srun; == ==FILTERC Tests Filterc Subroutine b34sexec matrix; /$ Uses FFT to High and Low Pass Random Series /$ /$ Illustrate with random numbers /$ call load(filterc); n=500; test=rn(array(n:)); spec=spectrum(test,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); call filterc(test,newtest,1,200); spec=spectrum(newtest,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after Low Pass'); call filterc(test,high,201,500); spec=spectrum(high,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after High Pass'); b34srun; == ==FIND Finds location of a character b34sexec matrix; cc=namelist(mary sue joan); wherea=find(cc,'a'); wherea2=find(cc,'A'); call tabulate(wherea,cc,wherea2); call character(cc2,'abcdefghijklmnop'); call print('Where is a?',cc2,find(cc2,'a')); call print('Where is b?',cc2,find(cc2,'b')); b34srun; == ==FLOAT Integer to real*4 b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; == ==FLS Flexible Least Squares /; ======================================================== /; Model 1 is the FLS test case with known answers /; Model 2 is a perfect OLS model analyzed with FLS methods /; Model 3 is the RES data studied using FLS methods /; Model 4 is the Gas furnace data /; ======================================================== %b34slet tcase1=1; %b34slet tcase2=1; %b34slet tcase3=1; %b34slet tcase4=1; %b34sif(&tcase1.ne.0)%then; b34sexec data heading('FLS test data') noob=30; build y x1 x2 true1 true2; /; do i=1,ncap /; ai=dfloat(i) /; pi=(datan(1.0d+00))*4.0d+00 /; trueb(1,i)=.5d+00*dsin((2.0d+00*pi/30.0d+00)*ai) /; trueb(2,i)=dcos((2.0d+00*pi/30.0d+00)*ai) /; enddo /; /; x(1,1)=1.0d+00 /; x(2,1)=1.0d+00 /; /; do i=2,ncap /; ai=dfloat(i) /; x(1,i)=dsin(10.0d+00+(ai))+.01d+00 /; x(2,i)=dcos(10.0d+00+(ai)) /; enddo gen x1=sin(10.0+kount())+.01; gen x2=cos(10.0+kount()); gen true1=.5*sin(kount()*(2.*timespi(1.)/30.)); gen true2= cos(kount()*(2.*timespi(1.)/30.)); /; gen if(kount().eq.1)then; gen x1=1.; gen x2=1.; gen endif; gen y=x1*true1+x2*true2+(0.0*rn()); /; b34srun; /; b34sexec list; b34srun; /; b34sexec reg noint; model y = x1 x2; b34srun; b34sexec matrix; call echooff; call loaddata; call load(flsgraph); call olsq(y x1 x2 :noint :print ); call fls( y x1 x2 :noint :savex :print); call flsfront(.2,10.,1.,'Test of Basic Model 1',%y,%x, 0,%me,%de,%wm,%tmat,10.,180.,10.,0.0); call flsgraph; /; call tabulate(%y %yhat %yhatfls %resid %resfls); /; call print(%bfls); call ppreg( y x1 x2 :print); call gamfit(y x1 x2 :print); /; /; High order gam fits the model! /; call gamfit(y x1[predictor,9.] x2[predictor,9.] :print); b34srun; %b34sendif; /; /; good model /; %b34sif(&tcase2.ne.0)%then; b34sexec matrix; call echooff; call load(flsgraph); call print('Good Model'); n=500; k=3; x=rn(matrix(n,k:)); beta=vector(k:)+10.0; y=x*beta + (10.*rn(vector(n:))); call olsq(y x :noint :print); call fls( y x :noint :print :savex); call flsfront(.2,90.,.1,'Test of Basic Model 2',%y,%x, 0,%me,%de,%w,%tmat,10.,180.,10.,0.0); call flsgraph; call tabulate(%y %yhat %yhatfls %resid %resfls); call print(%bfls); b34srun; %b34sendif; %b34sif(&tcase3.ne.0)%then; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call echooff; call load(flsgraph); time=time-1929.; call olsq(lnq lnl lnk lnrm2 time :print ); call fls(lnq lnl lnk lnrm2 time :print :pweight 1.e+0 :savex); call flsfront(.2,90.,.1,'Test of Basic Model 3',%y,%x, 3,%me,%de,%w,%tmat,10.,180.,10.,0.0); call flsgraph; /; call tabulate(%y %yhat %yhatfls %resid %resfls); /; call print(%bfls); call echoon; call print('Testing Orthogonality':); call print(ccf(lnl, %resfls),ccf(lnk, %resfls), ccf(lnrm2,%resfls),ccf(time,%resfls), ccf(lnl, %res ),ccf(lnk, %res), ccf(lnrm2,%res ),ccf(time,%res)); call echooff; b34srun; %b34sendif; %b34sif(&tcase4.ne.0)%then; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call echooff; call loaddata; call load(flsgraph); n=6; call olsq(gasout gasout{1 to n} gasin{1 to n} :print); call fls(gasout gasout{1 to n} gasin{1 to n} :print :pweight 1.e+0 :savex); call flsfront(.2,10.,.1,'Test of Basic Model 4',%y,%x, 3,%me,%de,%w,%tmat,10.,180.,10.,0.0); call flsgraph; call tabulate(%y %yhat %yhatfls %resid %resfls); call print(%bfls); b34srun; %b34sendif; == ==FLSGRAPH Graph FLS Model Coefficients and Residuals b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call echooff; call loaddata; call load(flsgraph); n=6; call olsq(gasout gasout{1 to n} gasin{1 to n} :print); call fls(gasout gasout{1 to n} gasin{1 to n} :print :pweight 1.e+0 :savex); iscale=0; call flsfront(.2,10.,.01,'Test of Basic Model 4',%y,%x iscale,me,%de,%w,%tmat,10., 180., 10., 0.); call flsgraph; call tabulate(%y %yhat %yhatfls %resid %resfls); call print(%bfls); b34srun; == ==FLSFRONT Graph FLS Model Frontier b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call echooff; call loaddata; call load(flsgraph); n=6; call olsq(gasout gasout{1 to n} gasin{1 to n} :print); call fls(gasout gasout{1 to n} gasin{1 to n} :print :pweight 1.e+0 :savex); iscale=0; call flsfront(.2,10.,.01,'Test of Basic Model 4',%y,%x,iscale, %me,%de,%w,%tmat,10.,180.,10.,0.0); call flsgraph; call tabulate(%y %yhat %yhatfls %resid %resfls); call print(%bfls); b34srun; == ==FORMS Illustrate the FORMS Command Capability b34sexec matrix; /$ /$ Use this job as a template /$ call echooff; subroutine testform(ii,int4,r4,check,menu,string,menu2,r8,string2); nfields=18; ioff=3; /$ /$ type codes string 1 integer 2 real 3 cycling 4 /$ push 5 double 6 vert 7 long string 8 /$ check 9 check discript 10 /$ idfield=integers(nfields); icol =index( 2 40 2 40 2 40 2 40 2 40 2 40 2 40 2 40 10 50); irow =index( 1 1 2 2 3 3 6 6 10 10 13 13 14 14 15 15 18 18)+ioff; iwidth=index(20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 10 10); itype =index( 1001 2 1001 3 10 9 1001 7 1001 1 1001 4 1001 6 1001 8 5 5); /$ /$ Defines Exit box /$ idbox =index(1); icolbox=index( 3); irowbox=index(17+ioff); iwbox =index(68); ihbox =index(3); /$ /$ Allocte a 3 by 40 character*1 array to hold character info /$ cc =c1array(3,40:); call character(hold,'Do ARIMA Model'); cc(1,)=hold; call character(hold,'Do Regression Model'); cc(2,)=hold; call character(hold,'Do Nonlinear Model'); cc(3,)=hold; call character(fmt,'(g16.8)'); call forms(:start :formdefine S idfield icol irow iwidth itype :formhelp index(2 21+ioff 68) :formdefinebox idbox icolbox irowbox iwbox ihbox :commandn 'Test Form # 1 - Shows all Options' ); call forms(:cont :formputstring 1 'This is int*4' :formputstring 3 'This is a real*4' :formputstring 5 'Check Box' :formputstring 7 'Vertical Menu Box' :formputstring 9 'String' :formputstring 10 ' ' :formputstring 11 'Cycling Menu' :formputstring 13 'Real*8 number' :formputstring 15 'Long String' :formputstring 16 ' ' 60 :formputinteger 2 index(-9) :formputcheckbox index(6 0 5) :formputhelp 2 'Enter an integer*4 here' :formrangeinteger 2 index(-99999 99999) :formputhelp 4 'Enter an real*4 here' :formputreal 4 .1 fmt :formrangereal 4 array(:-999.,999.) :formputhelp 8 'This is a vertical menu - we show 2' :formputmenu 8 cc 1 :formverticalmenu 8 2 999 :formputmenu 12 cc 1 :formputhelp 10 'Enter a short string here' :formputhelp 12 'Click to cycle' :formputdouble 14 99.9 fmt :formrangedouble 14 array(:-999.,999.) :formputhelp 14 'This is a real*8 input menu' :formputhelp 16 'This is a long string menu' /$ /$ Exit group type 5 push /$ :formputbutton 17 'Run' 21 :formputhelp 17 'Run the Menu' :formattribute 17 'N' 'byellow' ' ' :formputhelp 18 'Escape without running' :formputbutton 18 'Escape' 23 :formattribute 18 'N' 'bred' ' ' /$ :formshowedit ii /$ :forminfolist /$ /$ pull out data into b34s matrix command names /$ :formgetinteger 2 int4 :formgetreal 4 r4 :formgetcheckbox 6 check :formgetmenu 8 menu :formgetstring 10 string :formgetmenu 12 menu2 :formgetdouble 14 r8 :formgetstring 16 string2 ); call forms(:final); return; end; call testform(ii,int4,r4,check,menu,string,menu2,r8,string2); /$ forminfolist data /$ call print('nfield_1 ',nfield_1:); /$ call print('nbox_1 ',nbox1 :); /$ call tabulate(ntab_1 ifx_1 ify_1 ifwid_1 iftype_1 ifiden_1); if(ii.eq.21)then; call print('ii =',ii:); call print('int =',int4:); call print('r4 =',r4:); call print('check =',check:); call print('menu =',menu:); call print('string =',string ); call print('menu2 =',menu2:); call print('r8 =',r8:); call print('string2=',string2); endif; if(ii.eq.23)call print('Menu terminated at user request'); b34srun; == ==FORMS_1 Shows Tabbed Menu b34sexec matrix; call echooff; subroutine testform(ii,int4,r4,check,menu,string,menu2,r8,string2); nfields=18; /$ type codes string 1 integer 2 real 3 cycling 4 /$ push 5 double 6 vert 7 long string 8 /$ check 9 check discript 10 idfield=integers(nfields); icol =index( 2 40 2 40 2 40 2 40 2 40 2 40 2 40 2 40 10 50); irow =index( 1 1 2 2 3 3 6 6 1 1 3 3 5 5 6 6 16 16); iwidth=index(20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 10 10); itype =index( 1001 2 1001 3 10 9 1001 7 1001 1 1001 4 1001 6 1001 8 5 5); idbox =index(1 2); icolbox=index(3 3); irowbox=index(15 15); iwbox =index(68 68); ihbox =index( 3 3); cc =c1array(3,40:); call character(hold,'Do ARIMA Model'); cc(1,)=hold; call character(hold,'Do Regression Model'); cc(2,)=hold; call character(hold,'Do Nonlinear Model'); cc(3,)=hold; call character(fmt,'(g16.8)'); call forms(:start :formdefine t idfield icol irow iwidth itype :formhelp index(2 20 68) :formdefinebox idbox icolbox irowbox iwbox ihbox :formdefinetabs t array(2:'first','second') index(8,16) index(1,2) :commandn 'Test Form # 1 - Shows Tabbed form with global' ); call forms(:cont :formputstring 1 'This is int*4' :formputstring 3 'This is a real*4' :formputstring 5 'Check Box' :formputstring 7 'Vertical Menu Box' :formputstring 9 'String' :formputstring 10 ' ' :formputstring 11 'Cycling Menu' :formputstring 13 'Real*8 number' :formputreal 4 .1 fmt :formputdouble 14 99.9 fmt :formrangedouble 14 array(:-999.,999.) :formrangereal 4 array(:-999.,999.) :formrangeinteger 2 index(-99999 99999) :formputstring 15 'Long String' :formputstring 16 ' ' 60 :formputbutton 17 'Run' 21 :formputbutton 18 'Escape' 23 :formattribute 17 'N' 'byellow' ' ' :formattribute 18 'N' 'bred' ' ' :formputinteger 2 index(-9) :formputcheckbox index(6 0 5) :formputhelp 2 'Enter an integer*4 here' :formputhelp 4 'Enter an real*4 here' :formputhelp 8 'This is a vertical menu - we show 2' :formputmenu 8 cc 1 :formverticalmenu 8 2 999 :formputmenu 12 cc 1 :formputhelp 10 'Enter a short string here' :formputhelp 12 'Click to cycle' :formputhelp 14 'This is a real*8 input menu' :formputhelp 16 'This is a long string menu' :formputhelp 17 'Run the Menu' :formputhelp 18 'Escape without running' :formshowedit ii /$ :forminfolist :formgetinteger 2 int4 :formgetreal 4 r4 :formgetcheckbox 6 check :formgetmenu 8 menu :formgetstring 10 string :formgetmenu 12 menu2 :formgetdouble 14 r8 :formgetstring 16 string2 ); call forms(:final); return; end; call testform(ii,int4,r4,check,menu,string,menu2,r8,string2); /$ forminfolist data /$ call print('nfield_1 ',nfield_1:); /$ call print('nbox_1 ',nbox1 :); /$ call tabulate(ntab_1 ifx_1 ify_1 ifwid_1 iftype_1 ifiden_1); if(ii.eq.21)then; call print('ii =',ii:); call print('int =',int4:); call print('r4 =',r4:); call print('check =',check:); call print('menu =',menu:); call print('string =',string ); call print('menu2 =',menu2:); call print('r8 =',r8:); call print('string2=',string2); endif; if(ii.eq.23)call print('Menu terminated at user request'); b34srun; == ==FORMS_2 Tests Loading a Production File b34sexec matrix; call forms(:start :formload 'iighco6.ifd' S); call forms(:cont :forminfolist); call names(all); call print('# of Fields ',nfield_1:); call print('# of Boxes ',nbox_1 :); call print('# of Tabs ',ntab_1 :); call tabulate(ifx_1,ify_1,ifwid_1,iftype_1,ifiden_1); b34srun; == ==FORMS_3 Shows Forms and Menu Application b34sexec matrix; /$ /$ This test file based on CCF_stody in matmenu.mac /$ call echooff; call load(ccftest); call load(acf_plot); nccf=30; nlag=3; nccf=30; n=100; r8=.1; noise=1.; subroutine getdat(n,nccf,nlag,r8,noise,igo); nfields=12; ioff=3; /$ type codes string 1 integer 2 real 3 cycling 4 /$ push 5 double 6 vert 7 long string 8 /$ check 9 check discript 10 idfield=integers(nfields); icol =index( 20 20 4 60 4 60 4 60 4 60 6 60 ); irow =index( 1 2 4 4 6 6 8 8 10 10 18 18) + ioff; iwidth=index( 40 40 40 8 40 3 40 16 40 16 10 10); itype =index( 1001 1001 1001 2 1001 2 1001 6 1001 6 5 5); idbox =index(1); icolbox=index( 3); irowbox=index(17+ioff); iwbox =index(68); ihbox =index(3); call character(fmt,'(g16.8)'); call forms(:start :formdefine S idfield icol irow iwidth itype :formhelp index(2 21+ioff 68) :formdefinebox idbox icolbox irowbox iwbox ihbox :commandn 'CCF and ACF Relationships' ); call forms(:cont :formputstring 1 'Study Effect of ACF On CCF' :formputstring 2 'Illustrate Transfer Function ID' :formputstring 3 'Input # of observations' :formputstring 5 'Input # of terms in CCF' :formputstring 7 'Input ar(1) in range -.999 - .999' :formputstring 9 'Input noise multiplier' :formputinteger 4 n :formrangeinteger 4 index( 60 999999999) :formputinteger 6 nccf :formrangeinteger 6 index(2 999) :formputdouble 8 r8 fmt :formrangedouble 8 array(:-1., 1.) :formputdouble 10 noise fmt :formrangedouble 10 array(:0.0 100.) :formputbutton 11 'Run' 21 :formputbutton 12 'Escape' 23 :formattribute 11 'N' 'byellow' ' ' :formattribute 12 'N' 'bred' ' ' :formputhelp 4 'Enter an integer*4 here' :formputhelp 6 'Enter an integer*4 here' :formputhelp 8 'Enter an real*8 here' :formputhelp 10 'Enter an real*8 here' :formputhelp 11 'Run the Menu' :formputhelp 12 'Escape without running' :formshowedit ii /$ :forminfolist :formgetinteger 4 n :formgetinteger 6 nccf :formgetdouble 8 r8 :formgetdouble 10 noise ); call forms(:final); igo=0; if(ii.eq.21)igo=1; if(ii.eq.23)igo=0; return; end; again continue; call free(ma); call menu(jgo :menutype menutwo :heading 'Continue selection' :text 'Menu' :text 'Forms' :prompt 'Type of I/O ' ); if(jgo.eq.2)then; call getdat(n,nccf,nlag,r8,noise,igo); if(igo.eq.0)go to done; endif; if(jgo.eq.1)then; /$ /$ This is the older and easier menu approach call menu(n :menutype inputint :prompt '# of cases of for CCF example' ); call menu(nccf :menutype inputint :prompt '# of ccf to calculate' ); call menu(nlag :menutype inputint :prompt 'Enter lag as a positive number' ); call menu(r8 :menutype inputreal8 :prompt 'Enter ar(1) parameters in range -.999 - .999' ); call menu(noise :menutype inputreal8 :prompt 'Noise. Usual setting 1.0' ); /$ endif; ar=array(: r8); nn=100; start=array(:.1); x=genarma(ar,ma,1.0,start,.1,n,nn); i=integers(nlag+1,norows(x)); y=array(norows(x):)+missing(); rr=noise*rn(x); y(i)= x(i-nlag)+rr(i); do ii=1,nlag; x(ii)=missing(); y(ii)=missing(); enddo; x=goodrow(x); y=goodrow(y); call names(all); call character(title,'Effect of Autocorrelation on cross correlations'); /$ call tabulate(x,y); call acf_plot(x,nccf,'X Series'); call acf_plot(y,nccf,'Y Series'); call ccftest(x,y,nccf,lags,title); j=2; call menu(j :menutype menutwo :heading 'Continue selection' :text 'stop' :text 'go' :prompt 'Continue? ' ); if(j.eq.2)go to again; done continue; b34srun; == ==FORMULA Illustrates use of Formula + Solve b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; * Shows use of formulas in simple case; * Here the analytic statement works same way as formula; * Formula allows resursive solutions ; * Formula solved one row at a time ; call loaddata; test1=gasout*2.; call print(mean(test1)); formula double = gasout(t)*2.; call names; call print(double); solve(test2=double(t) :range 1, norows(gasout) :block double); call print(mean(test2)); b34srun; == ==FORPLOT Forecast Plot using GRAPHP b34sexec matrix; call load(forplot); y=rn(array(20:)); yhat=rn(array(4:)); error=dfloat(integers(4))/2.; se =error+yhat; se2 =yhat - error; call character(title,'Test Forecast Plot'); call load(forplot); /$ Graph using graph call graph(y :pgborder :heading 'graph command' :htitle 2. 2. :nocontact :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :colors black bred ); /$ Foreplot using graphp call forplot(y,yhat,se,se2,title,' '); /$ Foreplot using graphp call character(title,'Test Forecast Plot with Missing Data'); y(3)=missing(); call character(fileout,'plottest.wmf'); call forplot(y,yhat,se,se2,title,fileout); b34srun; == ==FORTRAN Illustrates Fortran Call b34sexec matrix; call open(70,'_test.f'); call rewind(70); /$ 1234567890 call character(test," write(6,*)'This is a test # 2'" " n=1000 " " write(6,*)n " " do i=1,n " " write(6,*) sin(float(i)) " " enddo " " stop " " end "); call write(test,70); call close(70); /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f'); * call dounix('g77 _test.f -o_test'); call dounix('lf95 _test.f -o_test'); * call dounix('fortcl _test.f -o_test'); call dodos('_test > testout':); call dounix('./_test > testout':); call open(71,'testout'); call character(test2,' '); call read(test2,71); call print(test2); testd=0.0; n=0; call read(n,71); testd=array(n:); call read(testd,71); call print(testd); call close(71); call dodos('erase testout'); call dodos('erase _test.f'); call dounix('rm testout'); call dounix('rm _test.f'); b34srun; == ==FORTRAN_2 Illustrates hard coded GARCH In Fortran /$ Tests RATS vs GARCHEST vs FORTRAN /$ In the FORTRAN SETUP see line arch(1)=0.0 /$ If line is commented out => GARCHEST = FORTRAN /$ If line is not commented out FORTRAN = RATS /$ This illustrates the effect of starting values!!!!!! /$ Also illustrates Fortran as a viable alternative when there /$ are very special models to be run that are recursive in /$ nature b34sexec options ginclude('b34sdata.mac') member(lee4); b34srun; %b34slet dorats=0; /$ Using garchest %b34slet dob34s1=1; /$ Using Fortran %b34slet dob34s2=1; /$ ********************************************************** %b34sif(&dob34s1.ne.0)%then; b34sexec matrix ; call loaddata ; * The data has been generated by GAUSS by following settings $ * a1 = GMA = 0.09 $ * b1_n = GAR = 0.5 ( When Negative) $ * b1 = GAR = 0.01 $ call echooff ; maxlag=0 ; y=doo1 ; y=y-mean(y) ; v=variance(y) ; arch=array(norows(y):) + dsqrt(v); * GARCH on a TGARCH Model ; call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.1) :ngma 1 :gmaparms array(:.1) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :steptol .1d-14 :cparms array(2:.1,.1) :print ); b34srun; %b34sendif; /$ Fortran %b34sif(&dob34s2.ne.0)%then; b34sexec matrix ; call loaddata ; * The data has been generated by GAUSS by following settings $ * a1 = GMA = 0.09 $ * b1_n = GAR = 0.5 ( When Negative) $ * b1 = GAR = 0.01 $ * call echooff ; /$ Setup fortran call open(70,'_test.f'); call rewind(70); /$ We now save the Fortran Program in a Character object /$ Will get overflows call character(fortran, /$23456789012345678901234567890 " implicit real*8(a-h,o-z) " " parameter(nn=10000) " " dimension data1(nn) " " dimension res1(nn) " " dimension res2(nn) " " dimension parm(100) " " call dcopy(nn,0.0d+00,0,data1,1)" " call dcopy(nn,0.0d+00,0,res2 ,1)" " open(unit=8,file='data.dat') " " open(unit=9,file='tdata.dat') " " read(8,*)nob " " read(8,*)(data1(ii),ii=1,nob) " " read(9,*)npar " " read(9,*)(parm(ii),ii=1,npar) " " read(9,*) res2(1) " " close(unit=9) " " " " do i=1,nob " " res1(i)=data1(i)-parm(3) " " enddo " " " " func=0.0d+00 " " do i=2,nob " " res2(i) =parm(1)+(parm(2)* res2(i-1) ) +" " * (parm(4)*(res1(i-1)**2) ) " " if(dabs(res2(i)).le.dmach(3))then " " func= 1.d+40 " " go to 100 " " endif " " func=func+(dlog(dabs(res2(i))))+ " " * ((res1(i)**2)/res2(i)) " " enddo " " func=-.5d+00*func " " 100 continue " " close(unit=8) " " open(unit=8,file='testout') " " write(8,fmt='(e25.16)')func " " close(unit=8) " " stop " " end "); /$ Fortran Object written here call write(fortran,70); call close(70); maxlag=0 ; y=doo1 ; y=y-mean(y) ; * compile fortran and save data; /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f'); * call dounix('g77 _test.f -o_test'); * call dounix('lf95 _test.f -o_test'); call dounix('fortcl _test.f -o_test'); call open(72,'data.dat'); call rewind(72); call write(norows(y),72); call write(y,72,'(3e25.16)'); call close(72); v=variance(y) ; arch=array(norows(y):) + dsqrt(v); i=2; j=norows(y); count=0.0; call echooff; program test; call open(72,'tdata.dat'); call rewind(72); npar=4; call write(npar,72); call write(parm,72,'(e25.16)'); /$ /$ If below line is commented out => GARCHEST = FORTRAN /$ If below line is not commented out FORTRAN = RATS /$ arch(1)=0.0d+00 ; call write(arch(1),72,'(e25.16)'); call close(72); call dodos('_test'); call dounix('./_test '); call open(71,'testout'); func=0.0; call read(func,71); call close(71); count=count+1.0; call outdouble(10,5 ,func); call outdouble(10,6 ,count); call outdouble(10,7, parm(1)); call outdouble(10,8, parm(2)); call outdouble(10,9, parm(3)); call outdouble(10,10,parm(4)); return; end; ll =array(4: -.1e+10, .1e-10,.1e-10,.1e-10); uu =array(4: .1e+10, .1e+10,.1e+10,.1e+10); * parm=array(:.0001 .0001 .0001 .0001); * parm(1)=v; * parm(3)=mean(y); rvec=array(4: .1 .1, .1, .1); parm=rvec; * call names(all); call cmaxf2(func :name test :parms parm :ivalue rvec :maxit 2000 :maxfun 2000 :maxg 2000 :lower ll :upper uu :print); *call dodos('erase testout'); call dodos('erase _test.exe'); *call dounix('rm testout'); call dounix('rm _test'); b34srun; %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * The data has been generated by GAUSS by following settings * a1 = GMA = 0.09 * b1_n = GAR = 0.5 ( When Negative) * b1 = GAR = 0.01 compute gstart=2,gend=1000 declare series u ;* Residuals declare series h ;* Variances declare series s ;* SD * set rt = doo1 set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1 nonlin(parmset=constraint) a1>=0.0 b1>=0.0 * GARCH ************ Not correct model frml at = rt(t)-p0 frml g1 = a0 + a1*at(t-1)**2 + b1*h(t-1) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 2 1000 compute p0 = 0.1 compute a0 = 0.1, a1 = 0.1, b1 =0.1 * maximize(parmset=base+constraint,method=simplex, $ * recursive,iterations=100) logl maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl b34sreturn; b34srun; b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==FORTRAN_3 Calling and running Fortran programs from B34S b34sexec matrix ; datacards; ! ****************************************************************** ! TEST.F ! Copyright(c) Econometric Software and Consulting 2000 ! ! Created: 3/3/2008 2:48:16 PM ! Author : HOUSTON STOKES ! Last change: HS 3/3/2008 3:25:56 PM ! ****************************************************************** real*8 x(3),xd(3),r8y(3),r8yd(3),diff1,diff2,diff3,diff4,diff5 real*4 y(3) character*80 cwork1,cwork2,cwork3,cwork4 c numbers taken from c Bennett, L., L. Swartzendruber, and H. Brown, c NIST (1994). c Superconductivity Magnetization Modeling. c c c cwork1 real*8 x c cwork2 real*4 x c cwork3 real*8 y c cwork4 real*4 y c cwork1='34.834702d-0 34.393200d-0 34.152901d-0' cwork2='34.834702e-0 34.393200e-0 34.152901e-0' cwork3='33.979099d-0 33.845901d-0 33.732899d-0' cwork4='33.979099e-0 33.845901e-0 33.732899e-0' c itestchar=1 c xd(1)= 34.834702d-0 xd(2)= 34.393200d-0 xd(3)= 34.152901d-0 x(1)= 34.834702e-0 x(2)= 34.393200e-0 x(3)= 34.152901e-0 y(1)= 33.979099E-0 y(2)= 33.845901E-0 y(3)= 33.732899E-0 r8y(1)= 33.979099e-0 r8y(2)= 33.845901e-0 r8y(3)= 33.732899e-0 r8yd(1)= 33.979099d-0 r8yd(2)= 33.845901d-0 r8yd(3)= 33.732899d-0 write(6,*)'x a real*8 variable loaded from a number E' write(6,*)'xd a real*8 variable loaded from a number D' write(6,*)'y a real*4 variable loaded from a number E' write(6,*)'r8y a real*8 variable loaded from a number E' write(6,*)'r8yd a real*8 variable loaded from a number D' write(6,*)' ' write(6,*)'Shows effect of setting a real*4 number in real*8' do i=1,3 diff1=dlog(xd(i)) - dlog(dble(y(i))) diff2=dlog(x(i)) - dlog(dble(y(i))) diff3=dlog(x(i)) - dlog(r8y(i)) diff4=dlog(x(i)) - dlog(r8yd(i)) diff5=dlog(xd(i)) - dlog(r8yd(i)) write(6,*)' ' write(6,*)'Example ',i write(6,*)'Test 1: xd - y real 8-real*4 diff1',diff1 write(6,*)'Test 2: x - y real 8-real*4 diff2',diff2 write(6,*)'Test 3: x - r8y real*8-real*8 diff3',diff3 write(6,*)'Test 4: x - r8yd real*8-real*8 diff4',diff4 write(6,*)'Test 5: xd - r8yd real*8-real*8 diff5',diff5 enddo c if(itestchar.ne.0)then write(6,*)' ' write(6,*)'------------------------------------------------------' read(unit=cwork1,fmt=*)xd read(unit=cwork2,fmt=*)x read(unit=cwork3,fmt=*)r8yd read(unit=cwork4,fmt=*)y read(unit=cwork4,fmt=*)r8y write(6,*)'x a real*8 variable loaded from a number E' write(6,*)'xd a real*8 variable loaded from a number D' write(6,*)'y a real*4 variable loaded from a number E' write(6,*)'r8y a real*8 variable loaded from a number E' write(6,*)'r8yd a real*8 variable loaded from a number D' write(6,*)' ' write(6,*)'* read does not differentiate between E and D' do i=1,3 diff1=dlog(xd(i)) - dlog(dble(y(i))) diff2=dlog(x(i)) - dlog(dble(y(i))) diff3=dlog(x(i)) - dlog(r8y(i)) diff4=dlog(x(i)) - dlog(r8yd(i)) diff5=dlog(xd(i)) - dlog(r8yd(i)) write(6,*)' ' write(6,*)'Example ',i write(6,*)'Test 1: xd - y real 8-real*4 diff1',diff1 write(6,*)'Test 2: x - y real 8-real*4 diff2',diff2 write(6,*)'Test 3: x - r8y real*8-real*8 diff3',diff3 write(6,*)'Test 4: x - r8yd real*8-real*8 diff4',diff4 write(6,*)'Test 5: xd - r8yd real*8-real*8 diff5',diff5 enddo endif stop end b34sreturn; call open(70,'_test.f'); call rewind(70); call copyf(4,70); call close(70); * compile fortran and save data; /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f '); * call dounix('g77 _test.f -o_test'); * call dounix('lf95 _test.f -o_test'); call dounix('fortcl _test.f -o_test'); b34srun; b34sexec options dodos('_test > myout'); b34srun; b34sexec options copyfout('myout'); b34srun; b34sexec options dodos('erase myout'); b34srun; == ==FORTRAN_4 Illustrates using Fortran real*4 read errors /; /; Shows problems of reading in real*4. Data from Mel Hinich /; b34sexec matrix ; datacards; ! ****************************************************************** ! TEST.F ! Copyright(c) Econometric Software and Consulting 2000 ! ! Created: 3/3/2008 2:48:16 PM ! Author : HOUSTON STOKES ! Last change: HS 3/3/2008 3:25:56 PM ! ****************************************************************** program testread c Program to test reading of data c Will illustrate costs of real*4 c real*8 x(10) real*4 xx(10) n=10 open(1,file='_test.data') write(6,*)'Data read and printed as real*8' do t=1,n read(1,*,err=2,iostat=io1) x(t) write(6,*)t,x(t) enddo c------- write(6,*)'-------------------------' write(6,*)'Data read and written as real*4' rewind(unit=1) do t=1,n read(1,*,err=2,iostat=io1) xx(t) write(6,*)t,xx(t) enddo write(6,*)'Convert real*8 to real*4 and see what comes out' write(6,*)'We get what was as read as real*4 ' do t=1,n xx(t)=x(t) write(6,*)t,xx(t) enddo go to 999 2 write(6,'(2x,''Read error for t '',i6)')t 999 stop end b34sreturn; call open(70,'_test.f'); call rewind(70); call copyf(4,70); call close(70); b34srun; /; /; Load data into a file using matrix /; b34sexec matrix; datacards; 518231327.0 518231529.0 518232269.0 518232308.0 518232610.0 518233114.0 518233486.0 518234614.0 518235817.0 518235866.0 b34sreturn; call open(70,'_test.data'); call rewind(70); call copyf(4,70); call close(70); * compile fortran and save data; /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f '); * call dounix('g77 _test.f -o_test'); * call dounix('lf95 _test.f -o_test'); call dounix('fortcl _test.f -o_test'); b34srun; b34sexec options dodos('_test > myout'); b34srun; b34sexec options copyfout('myout'); b34srun; b34sexec options dodos('erase myout'); b34srun; == ==FPRINT Formatted Print Command b34sexec matrix; r =dsqrt(110.); ii=202; name='Diana'; call fprint(:clear :col 10 :string 'At 10' :col 20 :display r '(g16.8)' :col 40 :string 'At col 40' :print :col 60 :string 'Added string at 60' :print :clear :string 'String at 1' :print :col 40 :string 'Added at 40' :col 60 :display ii '(i3)' :col 70 :string name :print :cr 2); b34srun; == ==FPRINT_2 Real*8, Real*16, Complex*16 & Complex*32 Examples /; /; Illustrates various display capability /; b34sexec matrix; r =rn(array(8:))+100.; r16=r8tor16(r); r =dsqrt(r); r16=dsqrt(r16); c16=complex(r,dsqrt(r)); c32=qcomplex(r16,dsqrt(r16)); call echooff; do i=1,norows(r); call fprint(:clear :col 1 :string 'This is Real*8' :col 20 /; :display r(i) '(g40.32)' :display r(i) :col 60 :string 'This is Real*16' :col 80 /; :display r16(i) '(g40.32)' :display r16(i) :print :clear :col 1 :string 'This is Complex*16' :col 20 :display c16(i) :print :col 1 :string 'This is Complex*32' :col 20 :display c32(i) :print); enddo; b34srun; == ==FPROB F Distribution b34sexec matrix; * IMSL page 925 ; f=648.0; dfn=1.0; dfd=1.0; p=1.0-fprob(f,dfn,dfd); call print('Probability that F(1,1) variable is GE ',f,' is ',p, 'Answer should be .0250'); b34srun; == ==FRACDIF Fractional Differencing /; /; 1. Fractional difference gasout and test /; 2. Generate two series and test /; 3. Test how many obs needed for GPH test for positive and /; negative d to be detected. /; /; Note: If d set < 0 then the resulting series is differenced /; with d > 0 since original series was white noise!! /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(gph :staging); call echooff; d=1./3.; fdgas=fracdif(gasout,d,20); call gph(fdgas,.5,d_est,se,se2,1); acf1=acf(gasout,12); acf2=acf(fdgas ,12); call tabulate(acf1,acf2); call graph(acf1,acf2 :Heading 'ACF of GASOUT and FD GASOUT'); * Testing with random numbers; n=10000; d=1./3.; x=rn(array(n:)); fx1=fracdif(x,d,100); call print('d set as ',d); call gph(fx1,.5,d_est,se,se2,1); acffx1=acf(fx1,50); d=(-1.0)*d; fx2=fracdif(x,d,100); call print('d set as ',d); call gph(fx2,.5,d_est,se,se2,1); acffx2=acf(fx2,50); call print('Table 2.3 in Cambell-Lo-MacKinlay', 'acffx1 has d=1/3. acffx2 has d=-1/3'); call tabulate(acffx1,acffx2); subroutine test_gph(n); x=rn(array(n:)); nn=20; d_in =array(nn:); d_out=array(nn:); d_t =array(nn:); d_t2 =array(nn:); adj=2./dfloat(nn); d=-.99; do i=1,nn; fx1=fracdif(x,d,100); call gph(fx1,.5,d_est,se,se2,0); d_in(i) =d; d_out(i)=d_est; d_t(i) =d_est/se; d_t2(i) =d_est/se2; d=d+adj; enddo; call print(' ':); call print('Note: d_in < 0. => positive d in the generated series':); call print(' d_in > 0. => negative d in the generated series':); call print(' Test does not pick up negative fractional diff ':); call print(' unless n is large (> 400) ':); call print(' Sample Size ',n:); call print(' Correlation ',ccf(d_in,d_out):); call tabulate(d_in,d_out,d_t,d_t2); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); return; end; call test_gph(200); call test_gph(300); call test_gph(400); call test_gph(500); call test_gph(1000); call test_gph(2000); call test_gph(5000); call test_gph(10000); b34srun; == ==FRACDIF_2 Tests Tsay Chung Paper JE (2000) b34sexec matrix; * Tests Tsay Chung paper that indicates if d1+d2 > .5 => spurious regression Note that as we generate series have to use -d1, -d2 The Spurious Regression of Fractionally Integreated Processes Journal of Econometrics 96 (2000) pp 155-182 ; * If n is increased the effect goes away assuming nterms remains at 100. The implications of this are not certain. Problems seen for n=10000 and nterms=150. nterms cannot get too large without dlgamma getting outside its range! ; n=1000; a=rn(array(n:)); b=rn(array(n:)); subroutine tfrac(a,b,d1,d2); nterms=100; x=fracdif(a,d1,nterms); y=fracdif(b,d2,nterms); s=dabs(d1)+dabs(d2); call print(' ' :); call print('Sum dabs(d1) + dabs(d2) ',s:); call olsq(y x :print); /; Testing the residuals n=10; adf=array(n+1:); adft=array(n+1:); lag=array(n+1:); padf=array(n+1:); padft=array(n+1:); do i=0,n; j=i+1; call df(%res,a1:adf i); adf(j)=a1; padf(j)=%dfprob; call df(%res,a2:adft i); adft(j)=a2; padft(j)=%dfprob; lag(j)=dfloat(i); enddo; call print('Dickey-Fuller tests':); call tabulate(lag,adf,padf,adft,padft); call graph(x,y); call print( '------------------------------------------------------------------':); return; end; call print(tfrac); call echooff; d1=-.1; d2=-.1; call tfrac(a,b,d1,d2); d1=-.15; d2=-.15; call tfrac(a,b,d1,d2); d1=-.2; d2=-.2; call tfrac(a,b,d1,d2); d1=-.25; d2=-.25; call tfrac(a,b,d1,d2); d1=-.3; d2=-.3; call tfrac(a,b,d1,d2); d1=-.35; d2=-.35; call tfrac(a,b,d1,d2); d1=-.4; d2=-.4; call tfrac(a,b,d1,d2); d1=-.45; d2=-.45; call tfrac(a,b,d1,d2); b34srun; == ==FRACDIF_3 Various Expermients with Fractional Differencing b34sexec matrix; call echooff; /$ Illustrates various Fractional Differencing Calculations /$ /$ binomial illustrates getting AR and MR coefficients /$ fdifacf illustrates the theoretical ACF /$ arfilter filters a series subroutine binomial(d,k,v,fd); /$ /$ solves v =(d(d-1.)(d-2.)..(d-dfloat(k)+1))/dfloat(k)! /$ fd=((-1.)**k)*v /$ /$ (1-L)**d = (1-dL+((d(d-1)L**2)/2! - d(d-1)(d-2)/3! /$ /$ v=array(k+1:); order=integers(0,k); fd=v; v(1)=1.0; fd(1)=v(1); do i=2,k+1; v(i)=(v(i-1)*(d-dfloat(i)+2.0))/dfloat(i-1); fd(i)=((-1.)**dfloat(i-1))*v(i); enddo; return; end; subroutine fdifacf(d,n,tacf); /$ /$ d = fractional difference /$ n = # of ACF /$ tacf = ACF in theory /$ /$ Baillie (1996) argues /$ p(1) = d/(1.-d) /$ p(2) = p(1)*(1.+d)/(2-d) /$ ........................ /$ p(k) = p(k-1.)*(k-1.+d)/(k-d) /$ if(kind(d).ne.8.or.kind(n).ne.-4)then; call epprint('ERROR: Inputs 1 or 2 not correct':); go to finish; endif; if(dabs(d).ge.1.)then; call epprint('ERROR: dabs(d) GE 1.0':); go to finish; endif; tacf=array(n:); tacf(1)=d/(1.-d); do i=2,n; tacf(i)=tacf(i-1)*((dfloat(i-1)+d)/(dfloat(i)-d)); enddo; finish continue; return; end; subroutine arfilter(coef,series,nseries); /$ /$ Using AR coefficients in coef, filter series /$ /$ coef = coefficient array starting with zero order term /$ series = series to be filtered /$ nseries = filtered series /$ n=norows(series); n2=norows(coef); nseries=array(norows(series):); nseries=nseries+missing(); jj=integers(n2,1); do i=n2,n; nseries(i)=vfam(coef)*vfam(series(jj)); jj=jj+1; enddo; return; end; n=1000; d=1./3.; call binomial(d,20,v,fd); call print('FD from Binomial Subroutine'); call tabulate(fd); testdata=rn(array(n:)); call arfilter(fd,testdata,new); call print('ACF of data filtered with Binomial coef':); call tabulate(acf(goodrow(new),20)); /$ Use built in routine n=20; call fdifacf(d,n,tacf); call print('Using fdifacf subroutine':); call print('TACF is Theoretical ACF for d= ',d:); d=(-1.0)*d; call print('TACF2 is Theoretical ACF for d = ',d:); call fdifacf(d,n,tacf2); call tabulate(tacf,tacf2); n=3000; testdata=rn(array(n:)); d=(-1.0)*d; test=fracdif(testdata,d,170); call print(' '); call print('Random series filtered with fracdif':); call print('Number of data points is ',n:); call print('ACF1 is actual ACF for d= ',d:); acf1=acf(test,20); d=(-1.0)*d; test=fracdif(testdata,d,170); acf2=acf(test,20); call print('ACF2 is actual ACF for d = ',d:); call tabulate(acf1,acf2); tt=fracdif(testdata,d,10); call print('From fracdif':); call tabulate(%fdacoef, %fdmcoef); call print('From Binomial':); call binomial(d ,10,v,fd); call tabulate(v,fd); call print('From Binomial d=.7':); call binomial(.7,10,v,fd); call tabulate(v,fd); call print('From Binomial d=1.':); call binomial(1.,10,v,fd); call tabulate(v,fd); b34srun; == ==FREE Call FREE => erase objects b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; call names; call free(n:); call names(info); call makeglobal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); call makelocal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); pdx(1,1)=.9999; call names; call print(pdx,'We now free at the local level'); call free(pdx); call names(info); call print('We now free at the global level'); call free(pdx:); call names(info:); b34srun; == ==FREQ Illustrates Frequency b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call print(timebase(ct),timestart(ct),freq(ct)); b34srun; == ==FUNCTEST Illustrates a Function Call b34sexec options ginclude('gas.b34'); b34srun; /$ Shows function call and data changed /$ Also shows a subroutine call from a function b34sexec matrix; call loaddata; call echooff; function meanf(x); xmean=mean(x); return(xmean); end; subroutine modit(yy); yy(1)=1500.; return; end; call print(meanf,modit); call print('Meanf back from function for gasout was', meanf(gasout) ); call print('Meanf back from function for gasin was', meanf(gasin) ); call print('Mean from root for mod of gasout was', mean(gasout) ); call print('Mean from root for mod of gasin was', mean(gasin) ); call names(all); b34srun; == ==FUNCTEST2 Illustrates Functions as arguments b34sexec matrix; function test(i); x=dfloat(i*i); return(x); end; function rtest(x); xx=x*x; return(xx); end; t=test(4); call print('t displayed (should be 16) ',t); call print('should show 16 here also ',rtest(test(2))); call print('test(4)/test(2) is 16/4 ',test(4)/test(2)); b34srun; == ==FUNCTEST3 Illustrates Function used as subroutine arguments b34sexec matrix; subroutine test(ii,jj); call print('ii was ',ii); call print('jj was ',jj); return; end; function dd(i); jj=i*i; return(jj); end; call test(dd(2),dd(3)); b34srun; == ==FYEAR Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GAMFIT Illustration of basic capability /; /; Linear = OLS /; /; Shows possible gains of going nonlinear /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(gamplot); call echooff; /; /; calling OLS and testing against GAMFIT /; call olsq( cpeptide age bdeficit :print); %olsyhat=%yhat; %olsres =%res; file='gam_3.fsv'; call gamfit(cpeptide age[predictor,3] bdeficit[predictor,3] :punch_sur :punch_res :filename file :print); call gamplot(%names,%lag,file,%olsyhat,%olsres,0); b34srun; /; /; Example Using Gas Data with Lags /; Illustrates call gamfit options /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(gamplot); call echooff; /; /; Estimates usual VAR model with 6 lags. See if GAM helps e'e /; maxlag=6; call olsq(gasout gasout{1 to maxlag} gasin{1 to maxlag} :print); %olsyhat=%yhat; %olsres =%res; file='gam_2.fsv'; call gamfit(gasout gasout[predictor,7]{1 to maxlag} gasin[predictor,8]{1 to maxlag} :print :punch_sur :punch_res :filename file ); /; /; 0); at end of next call shows graphs on screen. 1); turns this off. /; call gamplot(%names,%lag, file,%olsyhat,%olsres,0); b34srun; == ==GAMFIT_1 Various linear and nonlinear models /; Both b34sexec gamfit and call gamfit tested /; /; Linear = OLS /; /; Shows possible gains of going nonlinear /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; /; Linear Model b34sexec reg /; residualp ; model gasout=gasout{1 to 6} gasin{1 to 6}; b34srun; /; GAMFIT in "Full Linear Mode" replicates REG command b34sexec gamfit /; _list_res ; model gasout=gasout[predictor,1]{1 to 6} gasin[predictor,1]{1 to 6}; b34srun; /; Note gains if use degree = 3. Gasout{1} seems to benifit most! b34sexec gamfit /; tol(.1d-9,.1d-9) maxit(20000,20000) /; list_punch_res /; punch_sur /; filename='test1.fsv' ; model gasout=gasout[predictor,3]{1 to 6} gasin[predictor,3]{1 to 6}; b34srun; /; We try a linear model with just gasout{1} nonlinear b34sexec gamfit /; tol(.1d-9,.1d-9) maxit(20000,20000) /; list_punch_res /; punch_sur /; filename='test1.fsv' ; model gasout=gasout[predictor,1]{2 to 6} gasin[predictor,1]{1 to 6} gasout[predictor,3]{1}; b34srun; b34sexec gamfit; model gasout=gasin[predictor,1]; b34srun; b34sexec gamfit; model gasout=gasin[predictor,4]; b34srun; b34sexec gamfit; model gasout=gasout[predictor,3]{1} gasin[predictor,3]{4}; b34srun; b34sexec gamfit; model gasout=gasout[predictor,3]{1 to 4} gasin[predictor,4]{1 to 4}; b34srun; b34sexec matrix; call loaddata; call gamfit(gasout gasin[predictor,4] :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call gamfit(gasout gasout[predictor,3]{1} gasin[predictor,3]{4} :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest,%dof); call gamfit(gasout gasout[predictor,3]{1 to 4} gasin[predictor,4]{1 to 4} :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call gamfit(gasout gasout[predictor,3]{1 to 4} gasin[predictor,4]{1} gasin[predictor,4]{2} gasin[predictor,1]{3} gasin[predictor,4]{4} :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call gamfit(gasout gasout[predictor,3]{1} :print); call gamfit(gasout gasout[predictor,1]{1} :print); b34srun; == ==GAMFIT_2 Testing for Degree of GAM Model /; Using %sigma2 to test DF of gamfit b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; ntest=10; lag=6; holdrss =array(ntest:); holdsig2=array(ntest:); holddof =array(ntest:); holddof2=array(ntest:); mean_df=array(ntest:); do i=1,ntest; call gamfit(gasout gasout[predictor,i]{1 to lag} gasin[predictor,i]{1 to lag} /; :print ); /; call print(%rss,%sigma2,%dof,%df %ss_rest); holdrss(i) =%rss; holdsig2(i) =%sigma2; holddof(i) =dfloat(norows(%res))-sum(%df); holddof2(i) =sum(%df); mean_df(i) =sum(%df)/dfloat(%k); enddo; call tabulate(holdrss,holddof,holdsig2,mean_df); call graph(mean_df,holdsig2 :plottype xyplot :nocontact :pgborder :pgxscaletop 'I' :pgyscaleright 'IN' :heading 'Plot of (sumsq(res)/(N-sum(df)) vs mean(df)' :file 'gamfitmod.wmf'); b34srun; == ==GAMFIT_3 GAMFIT Options /; Illustrates call gamfit options b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call gamfit(gasout gasout[predictor,3]{1 to 4} gasin[predictor,4]{1 to 4} :print :punch_sur :punch_res :filename 'gamtest.fsv' ); call names(all); call print(%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call graph(%y,%yhat); gamres=%res; call olsq(gasout gasout{1 to 4} gasin{1 to 4} :print); call graph(%res,gamres :nolabel); call print(%yvar,%names,%lag,%vartype,%df,%dist,%link,%k,%nob); b34srun; == ==GAMFIT_4 Example Using Gas Data with Lags and plots /; Illustrates call gamfit options b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(gamplot); call echooff; maxlag=3; call olsq(gasout gasout{1 to maxlag} gasin{1 to maxlag} :print); %olsyhat=%yhat; %olsres =%res; file='gam_2.fsv'; call gamfit(gasout gasout[predictor,7]{1 to maxlag} gasin[predictor,8]{1 to maxlag} :print :punch_sur :punch_res :filename file ); /; itask=0 =; just displays /; itask=2 => saves and displays graphs itask=2; call gamplot(%names,%lag, file,%olsyhat,%olsres,itask); /; More plots /; call gamplot(%names,%lag, file,%olsyhat,%olsres,10); b34srun; == ==GAMFIT_5 Tests against SAS on gas data %b34slet runsas=1; b34sexec options header$ b34srun$ /; Both b34sexec gamfit and call gamfit tested /; /; Linear = OLS /; /; Shows possible gains of going nonlinear /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec reg /; residualp ; model gasout=gasout{1 to 6} gasin{1 to 6}; b34srun; b34sexec gamfit /; _list_res ; model gasout=gasout[predictor,1]{1 to 6} gasin[predictor,1]{1 to 6}; b34srun; b34sexec gamfit /; tol(.1d-9,.1d-9) maxit(20000,20000) /; list_punch_res /; punch_sur /; filename='test1.fsv' ; model gasout=gasout[predictor,3]{1 to 6} gasin[predictor,3]{1 to 6}; b34srun; b34sexec gamfit; model gasout=gasin[predictor,1]; b34srun; b34sexec gamfit; model gasout=gasin[predictor,4]; b34srun; b34sexec gamfit; model gasout=gasout[predictor,3]{1} gasin[predictor,3]{4}; b34srun; b34sexec gamfit; model gasout=gasout[predictor,3]{1 to 4} gasin[predictor,4]{1 to 4}; b34srun; b34sexec matrix; call loaddata; call gamfit(gasout gasin[predictor,4] :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call gamfit(gasout gasout[predictor,3]{1} gasin[predictor,3]{4} :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call gamfit(gasout gasout[predictor,3]{1 to 4} gasin[predictor,4]{1 to 4} :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call gamfit(gasout gasout[predictor,3]{1 to 4} gasin[predictor,4]{1} gasin[predictor,4]{2} gasin[predictor,1]{3} gasin[predictor,4]{4} :print); call print(%tss,%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call gamfit(gasout gasout[predictor,3]{1} :print); call gamfit(gasout gasout[predictor,1]{1} :print); call gamfit(gasout gasout[predictor,3]{ 6} gasin[predictor,3]{1 to 3} :maxit index(1500,1500) :tol array(:.1e-15,.1e-15) :print); call gamfit(gasout gasout[predictor,4]{1 to 6} gasin[predictor,4]{1 to 6} :maxit index(1500,1500) :tol array(:.1e-15,.1e-15) :print); b34srun; %b34sif(&runsas.eq.1)%then; b34sexec options open('testsas.sas') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=29 icntrl=29$ sas $ * sas commands next ; pgmcards$ data new; set b34sdata; l1gasout=lag1(gasout); l2gasout=lag2(gasout); l3gasout=lag3(gasout); l4gasout=lag4(gasout); l5gasout=lag5(gasout); l6gasout=lag6(gasout); l1gasin=lag1(gasin); l2gasin=lag2(gasin); l3gasin=lag3(gasin); l4gasin=lag4(gasin); l5gasin=lag5(gasin); l6gasin=lag6(gasin); run; proc reg; model gasout= l1gasout l1gasin l2gasout l2gasin l3gasout l3gasin l4gasout l4gasin l5gasout l5gasin l6gasout l6gasin; proc gam; model gasout= spline(l1gasout,df=4) spline(l1gasin,df=4) spline(l2gasout,df=4) spline(l2gasin,df=4) spline(l3gasout,df=4) spline(l3gasin,df=4) spline(l4gasout,df=4) spline(l4gasin,df=4) spline(l5gasout,df=4) spline(l5gasin,df=4) spline(l6gasout,df=4) spline(l6gasin,df=4) ; run; b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos('start /w /r sas testsas' ) dounix('sas testsas' ) $ b34srun$ b34sexec options npageout noheader writeout(' ','output from sas',' ',' ') writelog(' ','output from sas',' ',' ') copyfout('testsas.lst') copyflog('testsas.log') /;dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log') $ b34srun$ == ==GAMFIT_6 Further studies into GAMFIT options /; /; Illustraes internal GAMFIT Calculations /; %b34slet runsas=0; b34sexec options header$ b34srun$ /; /; Linear = OLS /; /; Shows possible gains of going nonlinear. /; Also shows gam and ols on gam vectors. /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; degree1=3; degree2=3; maxlag=1; nadj=norows(gasin)-maxlag; /; /; centering and variance adjustments /; fixdata=1; if(fixdata.eq.1)then; gasin =gasin -mean( gasin(integers(nadj))); gasout=gasout-mean(gasout(integers(nadj))); gasin = gasin /sqrt(variance( gasin(integers(nadj)))); gasout= gasout/sqrt(variance(gasout(integers(nadj)))); endif; /; Linear base model call olsq(gasout gasin{maxlag} gasout{maxlag} :print :savex); oldx1=%x(,1); oldx2=%x(,2); /; call print(%x); call gamfit(gasout gasin[predictor,degree1]{maxlag} gasout[predictor,degree2]{maxlag} :print :punch_sur :punch_res); rr1=%res; yhat1=%yhat; %yy1=%y; /; test residual save call getsca('gamfit.fsv' :member gam_res ); test_rr1=residual; call print('sum square of saved residual ',sumsq(test_rr1):); call print('sum square of memory residual ',sumsq(%res):); call getsca('gamfit.fsv' :member svar___1 ); /; call names(all); /; Illustrate how to get smooth_x1 using spline s_x1 =smooth_x; par_res1=part_res; mx=mean(x_var); /; call names(all); test_sx1=%coef(2)*(x_var-mx)+spline; call print(%coef); call print('mean part_res ',mean(part_res):); call print('sumsq part_res-smooth_x ',sumsq(part_res-smooth_x):); call tabulate(test_sx1,s_x1,to_array(%x(,1)),spline); /; /; The closer these graphs are the less nonlinear /; call graph(x_var s_x1 :plottype xyplot :heading 'gasin vs smooth gasin'); call graph(x_var spline:plottype xyplot :heading 'gasin vs spline '); call getsca('gamfit.fsv' :member svar___2 ); /; Illustrate how to get smooth_x2 s_x2=smooth_x; /; /; Tests to see if part_res can be used to detect nonlinearity /; par_res2=part_res; call graph(s_x1 par_res1 :nolabel :heading 'gasin that is nonlinear if lag 1'); call graph(s_x2 par_res2 :nolabel :heading 'gasout that is more linear if lag 1'); mx=mean(x_var); test_sx2=%coef(3)*(x_var-mx)+spline; call print('sumsq part_res ',sumsq(part_res):); call tabulate(test_sx2,s_x2,to_array(%x(,2)),spline); call graph(x_var s_x2 :plottype xyplot :heading 'gasout vs smooth gasout'); call graph(x_var spline :plottype xyplot :heading 'gasout vs spline '); call print('Note: Test Regressions scaled to have ~ 1.0 coef ':); call olsq(%yy1 s_x1 s_x2 :print :qr); rr2=%res; yhat2=%yhat; y_mean= %yy1-mean(%yy1); call print(' ':); call print('Effect of estimatiion with constant=0 on res sum of sq':); call olsq(y_mean s_x1 s_x2 :print :qr :noint); call olsq(y_mean s_x1 s_x2 :print :qr ); rr2=%res; yhat2=%yhat; call echooff; call tabulate(rr1,rr2,s_x1,s_x2,oldx1,oldx2,yhat1,yhat2); /; call print(' ':); call print('ccf(catcol(rr1,rr2,s_x1,s_x2,oldx1,oldx2,yhat1,yhat2))':); call print(ccf(catcol(rr1,rr2,s_x1,s_x2,oldx1,oldx2,yhat1,yhat2))); call print('rr1 mean ',mean(rr1) :); call print('rr2 mean ',mean(rr2) :); call print('s_x1 mean ',mean(s_x1) :); call print('s_x2 mean ',mean(s_x2) :); call print('oldx1 mean ',mean(oldx1) :); call print('oldx2 mean ',mean(oldx2) :); call print('rr1 var ',variance(rr1):); call print('rr2 var ',variance(rr2):); call print('s_x1 var ',variance(s_x1):); call print('s_x2 var ',variance(s_x2) :); call print('oldx1 var ',variance(oldx1):); call print('oldx2 var ',variance(oldx2):); call graph(s_x1,oldx1,s_x2,oldx2 :nolabel :heading 'Illustrates pattern of smooth and raw series') call olsq(s_x1 oldx1 :print); call olsq(s_x2 oldx2 :print); b34srun; %b34sif(&runsas.eq.1)%then; b34sexec options open('testsas.sas') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=29 icntrl=29$ sas $ * sas commands next ; pgmcards$ data new; set b34sdata; l1gasout=lag1(gasout); l1gasin =lag1(gasin); proc reg; model gasout=l1gasin l1gasout; run; proc gam; model gasout=spline(l1gasout,df=3) spline(l1gasin,df=3); run; b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos('start /w /r sas testsas' ) dounix('sas testsas' ) $ b34srun$ b34sexec options npageout noheader writeout(' ','output from sas',' ',' ') writelog(' ','output from sas',' ',' ') copyfout('testsas.lst') copyflog('testsas.log') /;dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log') $ b34srun$ b34sexec options header$ b34srun$ == ==GAMFIT_6 Complete break-down of GAM calculation /; /; Studies how the GAM model relates to a polynomial regression /; Also show how GAM is calculated. /; /; Problem studied by Hastie and Tibshirani page 2, 10 and in /; detail page 87 /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec list; b34srun; b34sexec matrix; call loaddata; call load(polyfit); call load(polyval); call load(gamfore); call load(gamplot); call echooff; call print(polyfit,polyval,gamfore); /; OLS Model call olsq(lpeptide age bdeficit :print); %olsyhat=%yhat; %olsres =%res; file='gamfit.fsv'; call gamfit(lpeptide age[predictor,3] bdeficit[predictor,3] :dist gauss :print :savex :punch_sur :punch_res :filename file); gam_se=afam(%coef)/afam(%z); call gamplot(%names,%lag, file,%olsyhat,%olsres,2); /; validate forecasting capability by an "in sample forecast" yhatold=%yhat; oldx=%x; newx=oldx; /; /; sets precision of polynomial regression fit of spline /; testdeg=9; if(testdeg.ne.0)then; deg =array(testdeg-3+1:); error=array(testdeg-3+1:); icount=0; do degmod=3,testdeg; icount=icount+1; oldmodel=%coef; call gamfore(%spline,oldx,newx,degmod,%coef,fore,%link,%vartype,%df,0); d=yhatold-fore; deg(icount)=degmod; error(icount)=sumsq(d); enddo; call print('Forecasts using Polynomial Model of various degrees ':); call tabulate(deg,error :noobslist); endif; if(testdeg.eq.0)then; degmod=3; call gamfore(%spline,oldx,newx,degmod,%coef,fore,%link,%vartype,%df,0); d=yhatold-fore; call print('Forecasts using Polynomial Model of degree ',degmod:); call print('Sum of squares of tracking error',sumsq(d):); /; call tabulate(yhatold,fore,d); endif; /; Reverse engineer smoothed x series from %spline matrix. /; Note that %coef has constant in location 1 ! call print(' ':); call print('Show how smoothed series relate to splines':); call print('new_x1=age-mean(age);':); call print('new_x2=bdeficit-mean(bdeficit); ':); call print('test1=afam(%coef(2))*afam(new_x1)+afam(%spline(,1));':); call print('test2=afam(%coef(3))*afam(new_x2)+afam(%spline(,2));':); call print(' ':); new_x1=age-mean(age); new_x2=bdeficit-mean(bdeficit); s_x1=afam(%smoothx(,1)); s_x2=afam(%smoothx(,2)); call print('Mean of smoothed x1 ',mean(s_x1):); call print('Mean of smoothed x2 ',mean(s_x2):); call print(' ':); sp_1=afam( %spline(,1)); sp_2=afam( %spline(,2)); call print('Mean of spline_1 ',mean(sp_1):); call print('Mean of spline_2 ',mean(sp_2):); call print(' ':); test1=afam(%coef(2))*afam(new_x1)+afam(sp_1); test2=afam(%coef(3))*afam(new_x2)+afam(sp_2); call print('s_x1 should = test1 and s_x2 should = test2':); call tabulate(s_x1,test1,s_x2,test2); call print(' ':); call print('Coefficients here are near their expected value of 1.0':); call olsq(lpeptide s_x1 s_x2 :print :qr ); call print(' ':); call print('transform y to unwind the GAM coefficients':); call print('trans_y = y - sum(%spline)':); sss=array(norows(%y):); do i=1,norows(%y); sss(i)=sum(%spline(i,)); enddo; y_sss=lpeptide-sss; call print('These are GAM coefficients ':); call olsq(y_sss age bdeficit :print :qr ); se_y_sss=afam(rolldown(%se)); gam_se=afam(gam_se); call print(' ':); call print('Constant SE to top - tt = gam_se/se_y_sss':); tt=gam_se/se_y_sss; call tabulate(gam_se se_y_sss,tt); call print(' ':); call print('Note: GAM uses N-sum(df). OLS uses T-k':); tt2=sqrt(dfloat(%nob-norows(%coef))/(dfloat(%nob)-sum(%df)-1.)); call print('sqrt((n-k)/(n-sum(%df)-1)) ',tt2:); call print(' ':); call print('Polynomial fit of x series maps to the spline.':); call print('1, 2 & 5 degree polynomial fit of new_x =f(spline)':); call print('call polyfit(new_x1,sp_1,1,coef,1);'); call polyfit(new_x1 ,sp_1, 1,coef,1); call print('call polyfit(new_x1,sp_1,2,coef,1);'); call polyfit(new_x1 ,sp_1, 2,coef,1); call print('call polyfit(new_x1,sp_1,3,coef,1);'); call polyfit(new_x1 ,sp_1, 3,coef,1); call print(' ':); call print('call polyfit(new_x2,sp_2,1,coef,1);'); call polyfit(new_x2,sp_2,1,coef,1); call print('call polyfit(new_x2,sp_2,2,coef,1);'); call polyfit(new_x2,sp_2,2,coef,1); call print('call polyfit(new_x2,sp_2,3,coef,1);'); call polyfit(new_x2,sp_2,3,coef,1); call print(' ':); call print('Running xx=s_x1-spline1 on newx1=x1-mean(x1))':); xx=s_x1-sp_1; call olsq(xx new_x1 :print :noint); call print(' ':); call print('Running xx=s_x2-spline2 on newx2=x2-mean(x2))':); xx=s_x2-sp_2; call olsq(xx new_x2 :print :noint); b34srun; == ==GAMFORE Forecast a GAM Model /; /; Problem studied by Hastie and Tibshirani page 2,10 and following /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(polyfit); call load(polyval); call load(gamfore); call echooff; iholdout=20; call olsq(lpeptide age bdeficit :print :holdout iholdout); %olscoef=%coef; %olsfore=%xfuture*%olscoef; call gamfit(lpeptide age[predictor,3] bdeficit[predictor,3] :dist gauss :print :savex :punch_sur :holdout iholdout); /; validate forecasting capability yhatold=%yhat; oldx=%x; newx=%xfuture; degmod=3; oldmodel=%coef; iprint=0; call gamfore(%spline,oldx,newx,degmod,%coef,%gamfore,%link,%vartype, %df,iprint); call names(all); actual=lpeptide(integers(%nob+1,norows(lpeptide))); errorols=vfam(%olsfore)-vfam(actual); errorgam=vfam(%gamfore)-vfam(actual); call tabulate(%xfobs,%gamfore,%olsfore,actual errorols,errorgam); call graph(errorols errorgam :heading 'Out of sample error' :nolabel :nocontact :pgborder); call print(' ':); call print('Sum squared out of sample Error OLS ',sumsq(errorols):); call print('Sum squared out of sample Error GAM ',sumsq(errorgam):); b34srun; == ==GAMFORE_1 Forecast a GAM Model checking in sample /; /; Studies how the GAM model relates to a polynomial regression /; Also show how GAM is calculated. /; /; Problem studied by Hastie and Tibshirani page 2,10 and following /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec list; b34srun; b34sexec reg; model lpeptide=age bdeficit; b34srun; b34sexec matrix; call loaddata; call load(polyfit); call load(polyval); call load(gamfore); call echooff; call print(polyfit,polyval,gamfore); call olsq(lpeptide age bdeficit :print); call gamfit(lpeptide age[predictor,3] bdeficit[predictor,3] :dist gauss :print :savex :punch_sur); /; validate forecasting capability call names(all); call print(%x %spline); yhatold=%yhat; oldx=%x; newx=oldx; /; /; degmod=3 => less good reverse engineering the spline /; degmod=9; oldmodel=%coef; iprint=0; call gamfore(%spline,oldx,newx,degmod,%coef,fore,%link,%vartype, %df,iprint); call print('Shows error of the forecast':); error=yhatold-fore; call tabulate(yhatold,fore,error); call graph(yhatold fore :heading 'Forecasting inside sample' :nolabel); call graph(Error :heading 'Forecasting generation error'); /; /; Illustrate how smooth_x in gamfit.fsv relates to splines /; Tested for the first variable /; call getsca('gamfit.fsv' :member age); call names(all); x_var2=x_var-mean(x_var); test_s_x = oldmodel(2)*x_var2 + spline; call tabulate( x_var x_var2 spline smooth_x test_s_x); b34srun; == ==GAMFORE_2 Gausian GAMMA, POISSON Models with different links b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec list; b34srun; b34sexec reg; model lpeptide=age bdeficit; b34srun; b34sexec matrix; call loaddata; call load(polyfit); call load(polyval); call load(gamfore); call echooff; /; call print(polyfit,polyval,gamfore); call olsq(lpeptide age bdeficit :print); program testfore; call gamfit(lpeptide age[predictor,3] bdeficit[predictor,3] :dist argument(distk) :link argument(linkk) :print :savex :punch_sur); /; validate forecasting capability yhatold=%yhat; oldx=%x; newx=oldx; oldmodel=%coef; call gamfore(%spline,oldx,newx,degmod,%coef,fore,%link,%vartype, %df,iprint); if(ilist.ne.0)then; call print('Test forecast by looking at in simple forecast & yhat':); error=yhatold-fore; call tabulate(yhatold,fore,error); endif; return; end; /; =8 => high forecasting accuracy degmod=8; iprint=0; ilist=1; distk='gauss'; linkk='ident'; call testfore; linkk='inver'; call testfore; linkk='logar'; call testfore; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ distk='poiss'; linkk='ident'; call testfore; linkk='inver'; call testfore; linkk='logar'; call testfore; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ distk='gamma'; linkk='ident'; call testfore; linkk='inver'; call testfore; linkk='logar'; call testfore; b34srun; == ==GAMFORE_3 GAM LOGIT analysis. Forecast Tests /; This job is setup to validate LOGIT GAM and LOGIT GAM Forecasting /; OLS and PROBIT contrasted to GAM LOGIT analysis %b34slet mars_exp=0; %b34slet runmars=0; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(polyfit); call load(polyval); call load(gamfore); call echooff; subroutine test_sub(title1,yhatold,fore,y); call print('Shows error of the forecast':); call print(title1); error=yhatold-fore; call tabulate(yhatold,fore,error); call print('Sumsq error =',sumsq(error)); call print('Sumsq eq error fit =',sumsq((y-fore))); call print('Sumsq eq error real=',sumsq((y-yhatold))); call graph(yhatold fore :heading title1 :nolabel); call graph(Error :heading title1); return; end; yvar=afam(d1); /; this sets model call character(cc,'t y lf nw'); call olsq(yvar argument(cc) :print); %yhatols=%yhat; call probit(yvar argument(cc) :print); %yhat_pb=%yhat; /; Master shutoff for MARS tests ++++++++++++++++++++++++++++++++ %b34sif(&mars_exp.ne.0)%then; %b34sif(&runmars.ne.0)%then; call mars(yvar argument(cc) :logit :nk 40 :mi 2 :print); %yhat1=%yhat; %b34sendif; call marspline(yvar argument(cc) :probit :nk 20 :mi 2 :savebx :df 2. :print); %yhat2=%yhat; call probit(yvar %probitx :noint :print); %yhat5=%yhat; /; This tests %probitx call olsq(yvar %probitx :noint :print); %b34sif(&runmars.ne.0)%then; call print( '%yhat1 - mars, %yhat2 - marspline, %yhat5 - Marspline/probit':); call tabulate(%y,%yhat1,%yhat2,%yhat5); %b34sendif; %b34sif(&runmars.eq.0)%then; call print( '%yhat2 - marspline, %yhat5 - Marspline/probit':); call tabulate(%y,%yhat2,%yhat5); %b34sendif; subroutine f_marslg(raw_s,adj1,adj2); /; /; Normalizes a prediction in the range 0-1 /; /; /; raw_s => the output from matspline /; adj1 => Values > 1.0 and < 0.0 set to 1.0 and 0.0 /; adj2 => Series rescaled /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ adj1 =dmin1(raw_s,1.0); adj1 =dmax1(adj1 ,0.0); mm1=min(raw_s); mm2=max(raw_s); range=mm2-mm1; if(mm1.lt.0.0)then; range=mm2+dabs(mm1); adj2 =raw_s+dabs(mm1); endif if(mm1.gt.0.0)adj2 =raw_s -mm1; adj2 =adj2 /range; return; end; call f_marslg(%yhat2,%yhat3,%yhat4); %b34sif(&runmars.ne.0)%then; call tabulate(%y,%yhatols,%yhat1,%yhat2,%yhat3,%yhat4,%yhat5); data=catcol( %y,%yhatols,%yhat_pb,%yhat1,%yhat2,%yhat3,%yhat4,%yhat5); call print('%yhat1 - old mars logit .. %yhat5 marspline/probit':); call print( 'Correlation %y,%yhatols,%yhat_pb,%yhat1,%yhat2,%yhat3,%yhat4,%yhat5', ccf(data)); call graph( %yhatols,%yhat_pb,%yhat1,%yhat2,%yhat3,%yhat4, %yhat5 :nolabel); %b34sendif; %b34sif(&runmars.eq.0)%then; call tabulate(%y,%yhatols,%yhat2,%yhat3,%yhat4,%yhat5); data=catcol( %y,%yhatols,%yhat_pb,%yhat2,%yhat3,%yhat4,%yhat5); call print( 'Correlation %y,%yhatols,%yhat_pb,%yhat2,%yhat3,%yhat4,%yhat5', ccf(data)); call graph( %yhatols,%yhat_pb,%yhat2,%yhat3,%yhat4,%yhat5 :nolabel); %b34sendif; %b34sendif; iprint=0; degmod=6; call gamfit(d1 t[predictor,3] y[predictor,3] lf[predictor,3] nw[predictor,3] :dist gauss :link ident :print :savex :punch_sur); gauss_yh=%yhat; gaussres=%res; oldx=%x; newx=oldx; oldmodel=%coef; call gamfore(%spline,oldx,newx,degmod,%coef,fore, %link,%vartype,%df,iprint); call test_sub('gauss model 1',gauss_yh,fore,%y); call gamfit(d1 t[predictor,3] y[predictor,3] lf[predictor,3] nw[predictor,3] :dist gauss :link logit :print :savex :punch_sur); logit_yh=%yhat; logitres=%res; oldx=%x; newx=oldx; oldmodel=%coef; /; needs bigger degmod degmod=9; /; call gamfore(%spline,oldx,newx,degmod,%coef,fore, %link,%vartype,%df,iprint); call test_sub('logit model 2',logit_yh,fore,%y); b34srun; == ==GAMPLOT Plot Results from GAMFIT Estimation /; /; Linear = OLS /; /; Shows possible gains of going nonlinear with a GAM or a MARSPLINE /; model. /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(gamplot); call echooff; /; calling OLS and testing against GAMFIT call olsq( cpeptide age bdeficit :print); %olsyhat=%yhat; %olsres =%res; file='gam_3.fsv'; call gamfit(cpeptide age[predictor,3] bdeficit[predictor,3] :punch_sur :punch_res :filename file :print); %gamyhat=%yhat; %gamres =%res; call gamplot(%names,%lag,file,%olsyhat,%olsres,0); call marspline(cpeptide age bdeficit :mi 2 :nk 20 :print); %marsyhat=%yhat; %marsres =%res; call graph( %olsres, %gamres, %marsres :nolabel :heading 'OLS vs MARS vs GAM Residuals'); call graph(%y %olsyhat, %gamyhat,%marsyhat :nolabel :heading 'OLS vs MARS vs GAM Yhat'); b34srun; == ==GAMPLOT2 Example Using Gas Data with Lags /; Illustrates call gamfit options b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(gamplot); call echooff; maxlag=6; call olsq(gasout gasout{1 to maxlag} gasin{1 to maxlag} :print); %olsyhat=%yhat; %olsres =%res; file='gam_2.fsv'; call gamfit(gasout gasout[predictor,7]{1 to maxlag} gasin[predictor,8]{1 to maxlag} :print :punch_sur :punch_res :filename file ); %gamyhat=%yhat; %gamres =%res; call gamplot(%names,%lag, file,%olsyhat,%olsres,0); call marspline(gasout gasout{1 to maxlag} gasin{1 to maxlag} :mi 2 :nk 40 :print); %marsyhat=%yhat; %marsres =%res; call graph( %olsres, %gamres, %marsres :nolabel); call graph(%y %olsyhat, %gamyhat,%marsyhat :nolabel); b34srun; == ==GAMPLOT3 Saving GAMFIT data for plots in another step /; Illustrates saving data and plotting on a PC in a later step b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(gamplot); call echooff; /; calling OLS and testing against GAMFIT call olsq( cpeptide age bdeficit :print); %olsyhat=%yhat; %olsres =%res; file='gam_3.fsv'; call gamfit(cpeptide age[predictor,3] bdeficit[predictor,3] :punch_sur :punch_res :filename file :print); %gamyhat=%yhat; %gamres =%res; call checkpoint(:var %names %lag file %olsyhat %olsres %gamyhat %gamres :file 'gamsave.por'); b34srun; /; From unix we move gamsave.por and gam_3.fsv b34sexec matrix; call load(gamplot); call restore(:file 'gamsave.por'); file='gam_3.fsv'; call gamplot(%names,%lag,file,%olsyhat,%olsres,0); b34srun; == ==GARCH2P_1 Test ARMA / GARCH Example b34sexec options ginclude('gas.b34'); b34srun; /$ User is controlling model b34sexec matrix; /$ /$ Subroutine is inside routine in comment form /$ /$ 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 ***************'); /$ call arma(data :nar nar :nma nma :print :refine refine); /$ 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); /$ res2=afam(%res); coef2=%coef; se2=%se; t2=%t; /$ return; /$ end; call loaddata; call load(garch2p); nar=6; nma=0; gnar=1; gnma=0; call garch2p(gasout,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; == ==GARCH2P_2 Shows Model that is revised later /$ /$ User attempts AR model with 10 terms /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(garch2p); * This setting is too big but tests software ; * For a more excessive example see ARMA_6 ; nar=10; nma=0; gnar=1; gnma=0; call garch2p(gasout,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; == ==GARCH2P_A Two Pass GARCH Estimation - Automatic /$ Template for basic Two pass GARCH Estimation /$ Menu facility will allow a more complex setup /$ The subroutine garch2pa in staging2 allows a simple setup. b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; b34sexec matrix; call loaddata; call echooff; call autobj(pi :autobuild :print :nac 24 :npac 24 /$ :seasonal 12 :rdif /$ :sdif /$ :smodeln 'moment1.mod' /$ :forecast 25 200 ); %res1 =%res; %ressq=%res*%res; call autobj(%ressq :autobuild :print :nac 24 :npac 24 /$ :smodeln 'moment2.mod' /$ :seasonal 12 /$ :forecast 25 200 ); %res2 =%res; acf1=acf(%res1,24); acf2=acf(%res2,24); call tabulate(acf1,acf2); b34srun; == ==GARCH2PF Shows Model that is revised later - Forecasts done /$ /$ User attempts AR model with 10 terms /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(garch2pf); * This setting is too big but tests software ; * For a more excessive example see ARMA_6 ; nar=10; nma=0; gnar=1; gnma=0; fbase1=norows(gasout); nf1=10; fbase2=fbase1; nf2=nf1; call garch2pf(gasout,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0,fbase1,nf1,fbase2,nf2,obs1,f1,conf1,obs2, f2,conf2); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); call tabulate(obs1,f1,conf1,obs2,f2,conf2); b34srun; == ==GARCH2P_3 Two Pass Model on Enders PI series /$ /$ User attempts MA model with 3 terms /$ b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; b34sexec matrix; call loaddata; call load(garch2p); call print(garch2p); * This setting is too big but tests software ; * For a more excessive example see ARMA_6 ; dpi=dif(pi); nar=0; nma=3; gnar=1; gnma=1; call garch2p(dpi,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; == ==GARCH2P_3A Automatic Two Pass on Enders Data /$ Template for basic Two pass GARCH Estimation /$ Menu facility will allow a more complex setup b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; b34sexec matrix; call loaddata; call echooff; call autobj(wpi :autobuild :print :nac 24 :npac 24 /$ :seasonal 12 /$ :rdif /$ :sdif /$ :smodeln 'moment1.mod' /$ :forecast 25 200 ); %res1 =%res; %ressq=%res*%res; call autobj(%ressq :autobuild :print :nac 24 :npac 24 /$ :smodeln 'moment2.mod' /$ :seasonal 12 /$ :forecast 25 200 ); %res2 =%res; /$ call manual; b34srun; == ==GARCHEST Joint GARCH(0,1) Estimation - Rats Tests Results /$ /$ Joint GARCH Estimation using GARCHEST Subroutine /$ RATS used to test results. /$ %b34slet dorats=0; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; call loaddata; call garchest(res,arch,gasout,func,3,n :nar 2 :ngma 1 :print ); call graph(goodrow(res)); call graph(goodrow(arch)); call tabulate(%resobs,res,arch); call names; b34srun; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(0,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 a0 a1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} frml garchvar = a0+a1*u11{1}**2 frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 3 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 3 * smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 print * * u11 v11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST10 TGARCH Test Case /$ Tests tgarch Problem Suggested by Tsay /$ Problem uses Tsay Starting Values /$ B34S "beats Rats" /$ MA term shou,d be in Model /; Very Difficult problem !! %b34slet dorats=1; %b34slet dob34s=1; b34sexec scaio readsca file('c:\b34slm\examples\findat01.mad') dataset(m_geln); b34srun; /$ /$ Joint GARCH Estimation using GARCHEST Subroutine /$ RATS used to test results. - Tsay Example /$ %b34sif(&dob34s.ne.0)%then; b34sexec matrix ; call loaddata; call load(gtest); y=m_geln; /; y=dif(y); res =array(norows(y):) -mean(y); arch=array(norows(y):) + variance(y); * Uses starting values suggested by Tsay ; * P0 0.0123 A0 4.0644e-04 A1 0.1172 A2 0.8114 B2 -7.5477e-10; call garchest(res,arch,y,func,2,n /; :nma 1 :ngar 1 /; :garparms array(:.5) :garparms array(:.8) /; :lower array(: .1E-16,.1e-16,.1e-16,.1e-16,-.1e+1) :ngma 1 :gmaparms array(:.07) /; :gmaparms array(:.1) :tgarch array(:.1) /; :tgarch array(:.001) :cparms array(2:.06 .03) /; :cparms array(2:.01 .0001) /; :simplex :print2 :steptol .0000001 :maxit 2000 :maxfun 2000 :maxg 2000 :print ); b34srun; %b34sendif; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * * all 0 888:1 * open data m-geln.dat * data(org=obs) /rt set rt = m_geln set h = 0.0 nonlin(parmset=base) p0 a0 a1 a2 b2 * nonlin(parmset=constraint) a1>=0.0 a2>=0.0 b2>=0.0 frml at = rt(t)-p0 frml g1 = a0+a1*at(t-1)**2 +a2*h(t-1) + $ %if(at(t-1)<0.0, b2*h(t-1),0.0) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 3 888 compute p0 = 0.06 compute a0 = 0.03, a1 = 0.07, a2 =0.5, b1 = 0.05, b2 = 0.1 * Unconstrained model * maximize(parmset=base+constraint,method=bhhh, $ maximize(parmset=base ,method=bhhh, $ recursive,iterations=150) logl set r1 = at(t) set r2 = g1(t) * print / r1 r2 set fv = g1(t) set resid = at(t)/sqrt(fv(t)) set residsq = resid(t)*resid(t) set shock = at(t) * Constrained setup set rt = m_geln set h = 0.0 nonlin(parmset=base) p0 a0 a1 a2 b2 nonlin(parmset=constraint) a1>=0.0 a2>=0.0 b2>=0.0 frml at = rt(t)-p0 frml g1 = a0+a1*at(t-1)**2 +a2*h(t-1) + $ %if(at(t-1)>0.0, b2*h(t-1),0.0) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 3 888 compute p0 = 0.06 compute a0 = 0.03, a1 = 0.07, a2 =0.5, b1 = 0.05, b2 = 0.1 * maximize(parmset=base ,method=bhhh, $ maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=150) logl b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST11 TGARCH B34S vs RATS Very Hard Problem b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; %b34slet dorats=1; %b34slet dob34s=1; %b34slet testopt=0; /$ /$ Joint GARCH Estimation using GARCHEST Subroutine /$ %b34sif(&dob34s.ne.0)%then; b34sexec matrix ; * here we allow negatives on coefficients ; call loaddata; call load(gtest); * arch=array(norows(sp500):)+dsqrt(variance(sp500)); call garchest(res,arch,sp500,func,3,n /$ :lower array(:.1e-6,.1e-6,-2., ,-1., -10.) :ngar 1 :garparms array(:.05) :ngma 1 :gmaparms array(:.05) :tgarch array(:.01) /$ :simplex :print2 :maxit2 2000 :steptol .1e-7 :maxit 9000 :maxfun 9000 :maxg 9000 :cparms array(2:mean(sp500),.05) :print ); b34srun; %b34sendif; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * compute gstart=3,gend=1996:12 set y = sp500 * * * TGARCH * set h = 0.0 * nonlin p0 ar1 a0 a1 a2 b2 a0>=0.0 a1>=0.0 a2>=0.0 nonlin p0 a0 a1 a2 b2 a0>=0.0 a1>=0.0 a2>=0.0 * frml at = y(t) - p0- ar1* y(t-1) frml at = y(t) - p0 * frml mask = (at(t-1)/abs(at(t-1))+1.0)/2.0 * frml g1 = a0+a1*at(t-1)**2 +a2*h(t-1) * frml gvar = g1+mask(t)*(b2*h(t-1)) frml g1 = a0+a1*at(t-1)**2 +a2*h(t-1) - $ %if(at(t-1),b2*h(t-1),0.0) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) linreg(noprint) y # constant * # constant y{1} * compute p0=%beta(1),ar1=%beta(2) compute p0=%beta(1),a0=.05,a1=.05,a2=.4,b2=.01 set h = %seesq maximize(method=simplex,iters=15,noprint) logl gstart gend maximize(method=bfgs,iters=100) logl gstart gend /$ maximize(method=bhhh,iters=100) logl gstart gend b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==GARCHEST12 Test Datasets suggested by Jin-Man Lee b34sexec options ginclude('b34sdata.mac') member(lee1); b34srun; %b34slet dorats=1; %b34slet doprob1=1; %b34slet doprob2=1; %b34slet doprob3=1; %b34slet doprob4=1; /; Note that Rats lets parameters go < 0.0 %b34sif(&doprob1.ne.0)%then; b34sexec matrix; * Very hard model; * tgarch(1,1); call loaddata; call load(gtest); y=doo1; call describe(y); mm=mean(y); v=variance(y); arch=array(norows(y):) + dsqrt(v); call garchest(res,arch,y,func,2,n :ngar 1 :garparms array(:.0005) :ngma 1 :gmaparms array(:.0005) :tgarch /$ :simplex :print2 /$ :lower array(:-.8,-.8,-.8,.001,.001) :maxit 2000 :maxfun 2000 /$ :steptol .1d-14 :cparms array(2:mean(y),dsqrt(v)) :print ); /; call gtest(res,arch,y,12); b34srun ; %b34sendif; /; Zakovian %b34sif(&doprob2.ne.0)%then; /; Zakovian b34sexec matrix; * tgarch(1,1); call loaddata; call load(gtest); y=doo1; call describe(y); mm=mean(y); v=variance(y); arch=array(norows(y):) + dsqrt(v); call garchest(res,arch,y,func,0,n :ngar 1 :garparms array(:.0005) :ngma 1 :gmaparms array(:.0005) :tgarch /; :tgarch2 array(:.0005) /$ :simplex :print2 /$ :lower array(:-.8,-.8,-.8,.001,.001) :maxit 2000 :maxfun 2000 /$ :steptol .1d-14 :cparms array(2:mean(y),dsqrt(v)) :print ); /; call gtest(res,arch,y,12); b34srun ; %b34sendif; %b34sif(&doprob3.ne.0)%then; b34sexec matrix; * TGARCH Symmetric ; call loaddata; call load(gtest); y=doo1; call describe(y); mm=mean(y); v=variance(y); arch=array(norows(y):) + dsqrt(v); call garchest(res,arch,y,func,2,n :ngar 1 :garparms array(:.0005) :ngma 1 :gmaparms array(:.0005) :tgarch3 /$ :simplex :print2 :lower array(:.1e-10,-.1,.001,.1) :maxit 2000 :maxfun 2000 /$ :steptol .1d-14 :cparms array(2:mm,dsqrt(v)) :print ); /; call gtest(res,arch,y,12); b34srun ; %b34sendif; %b34sif(&doprob4.ne.0)%then; b34sexec matrix; * GJR; call loaddata; call load(gtest); y=doo1; call describe(y); mm=mean(y); v=variance(y); arch=array(norows(y):) + v; call garchest(res,arch,y,func,2,n :ngar 1 :garparms array(:.05) :ngma 1 :gmaparms array(:.05) /$ :tgarch2 :gjr array(:.05) /$ :simplex :print2 :maxit 2000 :maxfun 2000 /$ :steptol .1d-14 :cparms array(2:mean(y),variance(y)) :print ); /; call gtest(res,arch,y,12); b34srun ; %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ compute gstart=2,gend=1000 set y = Doo1 * nonlin(parmset=meanparms) b0 frml resid = y - b0 declare series u ;* Residuals declare series h ;* Variances declare series s ;* SD * * tgarch display 'tgarch' * nonlin(parmset=garchparms) vc va vb vd frml sf = vc + va*s{1} + %if(u{1}>0.0,vb*u{1},0.0) - $ %if(u{1}<0.0,vd*u{1},0.0) frml logl = (s(t)=sf(t)),(u(t)=resid(t)),- $ .5*(log(s**2)+u**2/(s**2)) frml init = (s(t-1)=vc/(1-va-0.5*(vb+vd))) linreg(noprint) y / u # constant compute b0=%beta(1) compute vc=%seesq,va=.0005,vb=.0005,vd=.0005 set h = %seesq set s = sqrt(%seesq) maximize(parmset=meanparms+garchparms,method=simplex, $ start=init,iters=500,noprint) logl gstart gend maximize(parmset=meanparms+garchparms,method=bfgs, $ robusterrors,start=init,iters=100) logl gstart gend * * tgarch 2 display 'tgarch symmetric' * nonlin(parmset=garchparms) vc va vb frml sf = vc + va*s{1} + vb*u{1} frml logl = (s(t)=sf(t)),(u(t)=resid(t)),-.5*(log(s**2)+u**2/(s**2)) frml init = (s(t-1)=vc/(1-va-vb)) linreg(noprint) y / u # constant compute b0=%beta(1) compute vc=%seesq,va=.0005,vb=.0005 set h = %seesq set s = sqrt(%seesq) maximize(parmset=meanparms+garchparms,method=simplex, $ start=init,iters=500,noprint) logl gstart gend maximize(parmset=meanparms+garchparms,method=bfgs, $ robusterrors,start=init,iters=100) logl gstart gend * * gjr * display 'gjr garch' * nonlin(parmset=garchparms) vc va vb vd frml hf = vc + va*h{1} + vb*u{1}**2 + %if(u{1}<0.0,vd*u{1}**2,0.0) frml logl = (h(t)=hf(t)),(u(t)=resid(t)),-.5*(log(h)+u**2/h) frml init = (h(t-1)=vc/(1-va-vb)) linreg(noprint) y / u # constant compute b0=%beta(1) compute vc=%seesq,va=.05,vb=.05,vd=.05 set h = %seesq maximize(parmset=meanparms+garchparms,method=simplex, $ start=init,iters=500,noprint) logl gstart gend maximize(parmset=meanparms+garchparms,method=bfgs, $ robusterrors,start=init,iters=100) logl gstart gend b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST13 TGARCH Test Using Lee3 Data b34sexec options ginclude('b34sdata.mac') member(lee3); b34srun; /; Rats 6.02b fails on tgarch %b34slet dorats=1; %b34slet dob34s=1; %b34sif(&dob34s.ne.0)%then; b34sexec matrix ; call loaddata ; * The data has been generated by GAUSS by following settings $ * a1 = GMA = 0.09 $ * b1_n = GAR = 0.5 ( When Negative) $ * b1 = GAR = 0.1 $ call echooff ; maxlag=1 ; y=doo2 ; y=y-mean(y) ; v=variance(y) ; arch=array(norows(y):) + dsqrt(v); * GARCH on a TGARCH Model ; call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.0001) :ngma 1 :gmaparms array(:.0001) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :steptol .1d-14 :cparms array(2:.0001,.0001) :print ); * TGARCH on a TGARCH Model ; * arch=array(norows(y):) + dsqrt(v); arch=array(norows(y):) + v; call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.0001) :ngma 1 :gmaparms array(:.0001) :tgarch array(:.0001) /; :simplex :print2 /$ :lower array(:-.8,-.8,-.8,.001,.001) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :fctol .1d-15 /$ :steptol .1d-15 /$ :gradtol .1d-15 :cparms array(2:.0001,.0001) :print ); b34srun ; %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * The data has been generated by GAUSS by following settings * a1 = GMA = 0.09 * b1_n = GAR = 0.5 ( When Negative) * b1 = GAR = 0.01 compute gstart=2,gend=1000 declare series u ;* Residuals declare series h ;* Variances declare series s ;* SD * set rt = doo2 set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1 nonlin(parmset=constraint) a1>=0.0 b1>=0.0 * GARCH ************ Not correct model frml at = rt(t)-p0 frml g1 = a0 + a1*at(t-1)**2 + b1*h(t-1) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a1 = 0.0001, b1 =0.0001 maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl * Ruey's TGARCH set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1_p b1_n nonlin(parmset=constraint) a1>=0.0 b1_p>=0.0 b1_n>=0.0 frml at = rt(t)-p0 frml g1 = a0 + a1*at(t-1)**2 + %if(at(t-1)>0.0,b1_p*h(t-1),b1_n*h(t-1)) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a1 = 0.0001, b1_p =0.0001, b1_n = 0.0001 maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl * Ruey's TGARCH set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1 b1_n nonlin(parmset=constraint) a1>=0.0 b1>=0.0 b1_n>=0.0 frml at = rt(t)-p0 frml g1 = a0 + a1*at(t-1)**2 + b1*h(t-1)+ %if(at(t-1)<0.0,b1_n*h(t-1),0) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a1 = 0.0001, b1 =0.0001, b1_n = 0.0001 maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl b34sreturn; b34srun; b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST14 TGARCH Test Using Lee4 Data b34sexec options ginclude('b34sdata.mac') member(lee4); b34srun; %b34slet dorats=1; %b34slet dob34s=1; %b34sif(&dob34s.ne.0)%then; b34sexec matrix ; call loaddata ; * The data has been generated by GAUSS by following settings $ * a1 = GMA = 0.09 $ * b1_n = GAR = 0.5 ( When Negative) $ * b1 = GAR = 0.01 $ call echooff ; maxlag=0 ; y=doo1 ; y=y-mean(y) ; v=variance(y) ; arch=array(norows(y):) + dsqrt(v); * GARCH on a TGARCH Model ; call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.0001) :ngma 1 :gmaparms array(:.0001) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :steptol .1d-14 :cparms array(2:.0001,.0001) :print ); * TGARCH on a TGARCH Model ; arch=array(norows(y):) + dsqrt(v); call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.0001) :ngma 1 :gmaparms array(:.0001) :tgarch array(:.0001) /; :simplex :print2 /$ :lower array(:-.8,-.8,-.8,.001,.001) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :steptol .1d-14 :cparms array(2:.0001,.0001) :print ); b34srun ; %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * The data has been generated by GAUSS by following settings * a1 = GMA = 0.09 * b1_n = GAR = 0.5 ( When Negative) * b1 = GAR = 0.01 compute gstart=2,gend=1000 declare series u ;* Residuals declare series h ;* Variances declare series s ;* SD * set rt = doo1 set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1 nonlin(parmset=constraint) a1>=0.0 b1>=0.0 * GARCH ************ Not correct model frml at = rt(t)-p0 frml g1 = a0 + a1*at(t-1)**2 + b1*h(t-1) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a1 = 0.0001, b1 =0.0001 maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl * Ruey's TGARCH set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1_p b1_n nonlin(parmset=constraint) a1>=0.0 b1_p>=0.0 b1_n>=0.0 frml at = rt(t)-p0 frml g1 = a0 + a1*at(t-1)**2 + %if(at(t-1)>0.0,b1_p*h(t-1),b1_n*h(t-1)) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a1 = 0.0001, b1_p =0.0001, b1_n = 0.0001 maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl * Ruey's TGARCH set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1 b1_n nonlin(parmset=constraint) a1>=0.0 b1>=0.0 b1_n>=0.0 frml at = rt(t)-p0 frml g1 = a0 + a1*at(t-1)**2 + b1*h(t-1)+ %if(at(t-1)<0.0,b1_n*h(t-1),0) frml logl = -.5*log(h(t)=g1(t))-.5*at(t)**2/h(t) smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a1 = 0.0001, b1 =0.0001, b1_n = 0.0001 maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl b34sreturn; b34srun; b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST15 ETGARCH Model -- Very Hard /$ Dataset is not correct b34sexec options ginclude('b34sdata.mac') member(lee4); b34srun; %b34slet dorats=1; %b34slet dob34s=1; %b34sif(&dob34s.ne.0)%then; b34sexec matrix ; call loaddata ; * The data has been generated by GAUSS by following settings $ * a1 = GMA = 0.09 $ * b1_n = GAR = 0.5 ( When Negative) $ * b1 = GAR = 0.01 $ call echooff ; maxlag=2 ; y=doo1 ; * y=y-mean(y) ; v=variance(y) ; arch=array(norows(y):) + v; * GARCH on a TGARCH Model ; call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.1) :ngma 1 :gmaparms array(:.0001) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :steptol .1d-14 :cparms array(2:.0001,.0001) :print ); * ETGARCH on a TGARCH Model ; * arch=array(norows(y):) + dsqrt(v); call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.6) :ngma 1 :gmaparms array(:.1) :etgarch array(:.4,.1, .0001) :simplex :print2 :lower array(:.1e-7,.1e-8,.1e-8,-.01,.001,.001, -.1) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :steptol .1d-4 :cparms array(2: .01,.01) :print ); b34srun ; %b34sendif; %b34sif(&dorats.ne.0)%then; /$ Estimates ETGARCH Model %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * The data has been generated by GAUSS by following settings * a1 = GMA = 0.09 * b1_n = GAR = 0.5 ( When Negative) * b1 = GAR = 0.01 compute gstart=2,gend=1000 declare series u ;* Residuals declare series h ;* Variances declare series s ;* SD * set rt = doo1 set h = 0.0 nonlin(parmset=base) p0 a0 a1 b1 nonlin(parmset=constraint) a1>=0.0 b1>=0.0 * GARCH ************ Not correct model frml at = rt(t)-p0 frml g1 = a0 + a1*u(t-1)**2 + b1*h(t-1) frml logl = h(t)=g1(t), u(t) = at(t), -.5*log(h(t))-.5*u(t)**2/h(t) set u = 0.0 smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a1 = 0.0001, b1 =0.0001 maximize(parmset=base,method=simplex, $ recursive,iterations=20) logl maximize(trace,parmset=base+constraint,method=bhhh, $ recursive,iterations=10000) logl * Ruey's ETGARCH set h = 0.0 set u = 0.0 * nonlin(parmset=base) p0 a0 a0_n a1 a1_n b1 b1_n nonlin(parmset=base) p0 a0 a0_n a1 a1_n b1_n nonlin(parmset=constraint) a1>=0.0 a1_n>=0.0 b1_n>=0.0 frml at = rt(t)-p0 frml g1 = a0+a1*u(t-1)**2 $ + %if(u(t-1)>0,0.0,a0_n ) $ + %if(u(t-1)>0.0,0,b1_n*h(t-1) ) $ + %if(u(t-1)>0.0,0,a1_n*u(t-1)**2) frml logl = h(t)=g1(t), u(t) = at(t), -.5*log(h(t))-.5*u(t)**2/h(t) smpl 2 1000 compute p0 = 0.0001 compute a0 = 0.0001, a0_n = 0.0001 compute a1 = 0.0001, a1_n = 0.0001 compute b1 = 0.0001, b1_n = 0.0001 * Simplex causes problems maximize(parmset=base,method=simplex, $ recursive,iterations=20) logl maximize(parmset=base+constraint,method=bhhh, $ recursive,iterations=10000,trace) logl b34sreturn; b34srun; b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST_2 Joint GARCH(1,1) Estimation. Rats tests result. /$ /$ Joint GARCH Estimation using GARCHEST Subroutine /$ RATS used to test results. /$ /$ b34sexec options debugsubs(b34smat088a,b34smat088c); b34srun; %b34slet dorats=0; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; call loaddata; arch=array(norows(gasout):); call olsq(gasout gasout{1} gasout{2} :print); call print('RESVAR',%resvar :); call garchest(res,arch,gasout,func,2,n :cparms array(2:%coef(3), %resvar) :nar 2 :arparms array(2: %coef(1) %coef(2)) :ngar 1 :ngma 1 :gmaparms array(:.05) :print ); call tabulate(%resobs,res,arch); call graph(goodrow(res)); call graph(goodrow(arch)); b34srun; %b34sif(&dorats.ne.0)%then; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ /$ User must replace GASOUT with user series name /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 a0 a1 beta1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} frml garchvar = a0+a1*u11{1}**2 + $ beta1 * %if(v11{1}>1.e+100,%na,v11{1}) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 3 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 3 * smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 * New rats setup --- problems here if bfgs. Also convergence issues garch(p=1,q=1,regressors,subiterations=70, $ method=bhhh,iterations=90) / seriesn # constant seriesn{1 to 2} b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCHEST_3 Tests McCullough-Renfo b34sexec options ginclude('b34sdata.mac') macro(bg_test1); b34srun; /$ /$ See test job GARCH_6 for further results that illustrate /$ effect of starting values /$ /$ Test problem discussed in "Benchmarks and Software Standards: a /$ Case study of GARCH procedures" McCullouch & Renfro /$ Journal of Economic and Social Measurement 25 (1998) 59-71 /$ /$ Benchmark values (coef & t) reported in Greene (2003) Page 245 /$ /$ mu a(0) a(1) delta /$ -.006190 .01076 .1531 .8060 /$ -.709 3.445 5.605 26.731 /$ /$ Using defaults B34S Gets /$ /$ Constrained Maximum Likelihood Estimation using CMAXF2 Command /$ Final Functional Value 710.0988738779154 /$ # of parameters 4 /$ # of good digits in function 15 /$ # of iterations 33 /$ # of function evaluations 49 /$ # of gradiant evaluations 35 /$ Scaled Gradient Tolerance 6.055454452393343E-06 /$ Scaled Step Tolerance 3.666852862501036E-11 /$ Relative Function Tolerance 3.666852862501036E-11 /$ False Convergence Tolerance 2.220446049250313E-14 /$ Maximum allowable step size 2000.000000000000 /$ Size of Initial Trust region -1.000000000000000 /$ /$ # Name Coefficient Standard Error T Value /$ 1 MU -0.54028321E-02 0.78671320E-02 -0.68676007 /$ 2 A0 0.96955352E-02 0.19582736E-02 4.9510627 /$ 3 A1 0.14249617 0.20587446E-01 6.9215077 /$ 4 B1 0.82057943 0.23642897E-01 34.707228 /$ /$ If SETTERM1 = 1 B34S gets /$ /$ Final Functional Value 706.6732730011854 /$ # of parameters 4 /$ # of good digits in function 15 /$ # of iterations 28 /$ # of function evaluations 44 /$ # of gradiant evaluations 30 /$ Scaled Gradient Tolerance 6.055454452393343E-06 /$ Scaled Step Tolerance 3.666852862501036E-11 /$ Relative Function Tolerance 3.666852862501036E-11 /$ False Convergence Tolerance 2.220446049250313E-14 /$ Maximum allowable step size 2000.000000000000 /$ Size of Initial Trust region -1.000000000000000 /$ # of terms dropped in ML 1 /$ /$ # Name order Parm. Est. SE t-stat /$ 1 GAR 1 0.80585320 0.39662637E-01 20.317691 /$ 2 GMA 1 0.15343107 0.32072160E-01 4.7839331 /$ 3 CONS_1 0 -0.60866075E-02 0.84917751E-02 -0.71676504 /$ 4 CONS_2 0 0.10761839E-01 0.32544597E-02 3.3067975 /$ /$ Rats gets /$ /$ MAXIMIZE - Estimation by BHHH /$ Convergence in 23 Iterations. /$ Usable Observations 1973 /$ Function Value 710.20954834 /$ /$ Variable Coeff Std Error T-Stat Signif /$ ************************************************************** /$ 1. MU -0.005405453 0.008378648 -0.64515 0.51883241 /$ 2. A0 0.009737295 0.001209136 8.05310 0.00000000 /$ 3. A1 0.143009440 0.012892918 11.09209 0.00000000 /$ 4. B1 0.819965321 0.015312307 53.54943 0.00000000 /$ /$ Setterm1 one gets us very close to benchmark /$ See also bstart for bench mark starting values %b34slet dob34s =1; %b34slet bstart =0; %b34slet dosas =1; %b34slet dorats =1; %b34slet setterm1=1; %b34sif(&dob34s.eq.1)%then; b34sexec matrix ; call loaddata; res=array(norows(returns):); arch=res; smu=mean(returns); svar=variance(returns-smu); %b34sif(&setterm1.eq.1)%then; arch= arch+ (sumsq(returns-smu)/dfloat(norows(returns))); %b34sendif; /$ Benchmark starting values /$ These are benchmark starting values. /$ :ivalue array(:-.016427, .221130, .35,.50) call garchest(res,arch,returns,func,1,nbad %b34sif(&bstart.eq.0)%then; :ngar 1 :garparms array(:.5) :ngma 1 :gmaparms array(:.01) :cparms array(2:smu svar) :simplex :print2 :maxit2 1000 %b34sendif; %b34sif(&bstart.eq.1)%then; :ngar 1 :garparms array(:.35) :ngma 1 :gmaparms array(:.50) :cparms array(2:-.016427,.221130) %b34sendif; :lower array(:.1d-2, .1d-2, -10. .1d-2) :upper array(: 10. 10. 10. 10.) /$ /$ :maxsteps 6000. /$ :rftol .1e-25 /$ :fctol .1e-25 /$ these next 2 make hession get large ?? /$ :gradtol .1e-20 /$ :steptol .1e-16 :print); /$ call tabulate(%resobs,res,arch); call graph(goodrow(res)); call graph(goodrow(arch)); b34srun; %b34sendif; %b34sif(&dosas.eq.1)%then; B34SEXEC OPTIONS OPEN('testsas.sas') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29) $ B34Srun$ B34SEXEC PGMCALL IDATA=29 ICNTRL=29$ SAS $ PGMCARDS$ proc autoreg; model returns = / garch=(q=1,p=1); B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ /$ The next card has to be modified to point to SAS location /$ Be sure and wait until SAS gets done before letting B34S resume B34SEXEC OPTIONS dodos('start /w /r sas testsas') dounix('sas testsas')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT NOHEADER WRITEOUT(' ','Output from SAS',' ',' ') WRITELOG(' ','Output from SAS',' ',' ') COPYFOUT('testsas.lst') COPYFLOG('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log')$ B34SRUN$ B34SEXEC OPTIONS HEADER$ B34SRUN$ %b34sendif; /$ /$ BHHH & BFGS methods used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = returns compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin mu a0 a1 b1 * frml regresid = seriesn-mu frml garchvar = a0+a1*u11{1}**2+b1*v11{1} frml regresid = seriesn-mu frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) * bhhh method linreg seriesn # constant * Simplex can be used to start process compute mu=%beta(1), b1=.01, a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 2 * * bfgs Method linreg seriesn # constant * Simplex can be used to start process compute mu=%beta(1), b1=.01, a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bfgs,recursive,iterations=iter) garchlogl 2 * b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCHEST_4 GARCH(1,1) b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; b34sexec matrix ; call loaddata; dpi=dif(pi); call garchest(res,arch,dpi,func,1,n :nma 1 :ngar 1 :ngma 1 :noconst1 /$ :simplex :print2 :maxit2 1000 :maxfun 2000 :maxg 2000 :maxit 800 :print); b34srun; == ==GARCHEST_5 SP500 GARCH(1,1) b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; /$ Job illustrates problems in GARCH estimation. /$ SAS ~ B34S /$ Simplex used to get going. RATS allows GAR parameter to get /$ < 0.0. %b34slet dorats=0; %b34slet dosas =0; b34sexec matrix ; call loaddata; * GARCH setup where initial variance used; j=1; i=integers(j,norows(sp500)); y=sp500(i); vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); call garchest(res,arch,y,func,0,n /$ :lower array(4:-.17466563,.1d-6, -1.d-6, -1.d-6) /$ :upper array(4:10. .61490165 1.88727806 20.) :cparms array(2:mean(y),vstart) :ngar 1 :ngma 1 :maxfun 2000 :maxit 2000 :simplex :print2 :maxg 2000 :print ); call graph(goodrow(res)); call graph(goodrow(arch)); call tabulate(%resobs,res,arch); b34srun; /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * compute gstart=1989:1,gend=1996:12 set y = sp500 * nonlin(parmset=meanparms) b0 frml resid = y - b0 declare series u ;* Residuals declare series h ;* Variances * * GARCH(1,1) with initial variance from regression * NONLIN(parmset=garchparms) VC VA VB FRML HF = VC + VA*H{1} + VB*U{1}**2 FRML LOGL = (H(T)=HF(T)),(U(T)=RESID(T)),-.5*(log(h)+u**2/h) LINREG(NOPRINT) Y / U # CONSTANT COMPUTE B0=%BETA(1) COMPUTE VC=%SEESQ,VA=.05,VB=.05 SET H = %SEESQ * nlpar(criterion=value) MAXIMIZE(parmset=meanparms+garchparms, $ METHOD=SIMPLEX,ITERS=5,NOPRINT) LOGL GSTART GEND MAXIMIZE(parmset=meanparms+garchparms, $ METHOD=Bfgs,robusterrors,ITERS=100) LOGL GSTART GEND print * * u h b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') /$ dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; %b34sif(&dosas.ne.0)%then; /$ Loads B34S data in sas command file TESTSAS.SAS /$ User can optionally add SAS commands after PGMCARDS$ B34SEXEC OPTIONS OPEN('testsas.sas') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29) $ B34SEEND$ B34SEXEC PGMCALL IDATA=29 ICNTRL=29$ SAS $ PGMCARDS$ * Sas Statements after here ; prog autoreg; model sp500 = / garch = (q=1, p=1); run; B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ B34SEXEC OPTIONS dodos('start /w /r d:\sas\sas testsas') dounix('sas testsas')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT NOHEADER WRITEOUT(' ','Output from SAS',' ',' ') WRITELOG(' ','Output from SAS',' ',' ') COPYFOUT('testsas.lst') COPYFLOG('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log')$ B34SRUN$ B34SEXEC OPTIONS HEADER$ B34SRUN$ %b34sendif; == ==GARCHEST_6 Fattails GARCH(1,1) b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; /$ job illustrates problems in garch estimation. /$ attached rats job allows gar parameter to get < 0.0 /$ usuable observations < sample size /$ b34s setup does not allow this /$ we drop the first observation in the ml function /$ this makes a big difference %b34slet dorats=1; b34sexec matrix ; call loaddata; * garch setup where use fattail; j=1; i=integers(j,norows(sp500)); y=sp500(i); vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); /$ un comment to see effect /; arch=arch*0.0; call garchest(res,arch,y,func,1,n :lower array(5:.1d-6,.1d-6, 0.,0.0, 0.0) :cparms array(2:mean(y),vstart) :ngar 1 :ngma 1 :maxfun 200000 :maxit 200000 :maxg 200000 :fattail 50. :simplex :print2 :print ); vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); /$ un comment to see effect /; arch=arch*0.0; call garchest(res,arch,y,func,1,n :lower array(5:.1d-6,.1d-6, 0.,0.0, 0.0) :cparms array(2:mean(y),vstart) :ngar 1 :ngma 1 :maxfun 200000 :maxit 200000 :maxg 200000 :fattail 50. :simplex :print2 :print ); /; call graph(goodrow(res)); /; call graph(goodrow(arch)); /; call tabulate(%resobs,res,arch); b34srun; /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* data passed from b34s(r) system to rats', '* ') $ pgmcards$ * compute gstart=1989:1,gend=1996:12 set y = sp500 * nonlin(parmset=meanparms) b0 frml resid = y - b0 declare series u ;* residuals declare series h ;* variances * * garch(1,1) with initial variance from regression * nonlin(parmset=garchparms) vc va vb frml hf = vc + va*h{1} + vb*u{1}**2 frml logl = (h(t)=hf(t)),(u(t)=resid(t)),-.5*(log(h)+u**2/h) linreg(noprint) y / u # constant compute b0=%beta(1) compute vc=%seesq,va=.05,vb=.05 set h = %seesq * nlpar(criterion=value) maximize(parmset=meanparms+garchparms, $ method=simplex,iters=5,noprint) logl gstart gend maximize(parmset=meanparms+garchparms, $ method=bfgs,robusterrors,iters=100) logl gstart gend * print * * u h * * t-distribution * nonlin(parmset=garchparms) vc va vb vd * frml init = (h(t-1)=vc/(1-va-vb)) frml init = (h(1)=h(0)) frml hf = vc + va*h{1} + vb*u{1}**2 frml logl = (h(t)=hf(t)),(u(t)=resid(t)), $ log(%tdensity(u/sqrt(h),vd))-.5*log(h) linreg(noprint) y / u # constant compute b0=%beta(1) compute vc=%seesq,va=.05,vb=.05,vd=4.0 set h = %seesq maximize(parmset=meanparms+garchparms, $ method=simplex,start=init,iters=15,noprint) logl gstart gend maximize(parmset=meanparms+garchparms, $ method=bfgs,robusterrors,start=init,iters=100) logl gstart gend garch(p=1,q=1,method=bhhh) / y garch(p=1,q=1,dist=t,method=bhhh) / y b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') /$ dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST_7 IGARCH(1,1) /$ /$ Job NLPMIN1E solves same problem with NLPMIN1. /$ This setup shown below. /$ b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; /$ Job illustrates problems in GARCH estimation. /$ IGARCH(1,1) done two ways b34sexec matrix ; call loaddata; * IGARCH setup; j=1; i=integers(j,norows(sp500)); y=sp500(i); vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); /$ un comment to see effect /$ arch=arch*0.0; call garchest(res,arch,y,func,1,n :lower array(3:0.0, 0.0 , 0.0 ) :upper array(3:1. , 1.d+6 , 1.d+6) :cparms array(2:mean(y),vstart) :ngar 1 :maxfun 200000 :maxit 200000 :maxg 200000 :igarch :simplex :print2 :print ); call graph(goodrow(res)); call graph(goodrow(arch)); call tabulate(%resobs,res,arch); b34srun; /$ /$ IGARCH(1,1) using NLPMIN1 - shows general case. /$ More than IGARCH(1,1) can be done!!! /$ /$ Note that SE are not available /$ b34sexec matrix ; call loaddata; y=sp500; vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); call print('mean y ',mean(y):); call print('vstart ',vstart :); program test; call garch(res,arch,y,func,1,nbad :gar array(:gar) idint(array(:1)) :gma array(:gma) idint(array(:1)) :constant array(:a0 b0) ); if(%active(1)) g(1)=gar+gma-1.; func=(-1.)*func; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms gar gma a0 b0 :ivalue array(:.5,.5,mean(y),vstart) :nconst 1 0 :lower array(: 1.d-6, 1.d-6, 1.d-6, 1.d-6) :upper array(: 1.d+2, 1.d+2, 1.d+2, 1.d+2) :print :maxit 100 :iprint final); b34srun; == ==GARCHEST_8 EGARCH(1,1) b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; /$ Job illustrates problems in EGARCH estimation. b34sexec matrix ; call loaddata; * GARCH setup where use egarch ; * Note that for starting values for second moment we use dlog(vstart) ; * For difficult problems the upper limit array caps values such that exp( ) does not blow up ; j=1; i=integers(j,norows(sp500)); y=sp500(i); vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); /$ un comment to see effect /$ arch=arch*0.0; call garchest(res,arch,y,func,1,n :lower array(5:.1d-6,.1d-6,.1d-6,0.0,0.0) :upper array(5:10., 10., 20.,1.d+10, 1.d+10) :cparms array(2:mean(y),dlog(vstart)) :ngar 1 :ngma 1 :maxfun 200000 :maxit 200000 :maxg 200000 :egarch .1 :simplex :print2 :maxit2 600 :print ); call graph(goodrow(res)); call graph(goodrow(arch)); call tabulate(%resobs,res,arch); b34srun; == ==GARCHEST_9 GARCH(1,1) GJR b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; /$ GJR Model %b34slet dorats=1; %b34slet dob34s=1; /$ /$ Joint GARCH Estimation using GARCHEST Subroutine /$ /$ Illustrates effect of both B34S and Rats with constraints %b34sif(&dob34s.ne.0)%then; /$ Job illustrates problems in GARCH estimation. b34sexec matrix ; call loaddata; call load(gtest); * GARCH setup where use GJR Model ; j=1; i=integers(j,norows(sp500)); y=sp500(i); vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); /$ un comment to see effect /$ arch=arch*0.0; call garchest(res,arch,y,func,2,n :lower array(5:.1d-6,.1d-6,.1d-6,0.0, 0.0) :cparms array(2:mean(y),vstart) :ngar 1 :garparms array(:.1) :ngma 1 :gmaparms array(:.22) :maxfun 200000 :maxit 200000 :maxg 200000 :gjr array(:.9) /$ :simplex :print2 :maxit2 700 :print ); call gtest(res,arch,y,24); call tabulate(%resobs,res,arch); b34srun; %b34sendif; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * compute gstart=3,gend=1996:12 set y = sp500 nonlin(parmset=meanparms) b0 frml resid = y - b0 declare series u ;* Residuals declare series h ;* Variances * * gjr * nonlin(parmset=garchparms) vc va vb vd nonlin(parmset=constraint) b0>=0.0 vc>=0.0 va>=0.0 vb>=0.0 vd>=0.0 frml hf = vc + va*h{1} + vb*u{1}**2 + %if(u{1}<0.0,vd*u{1}**2,0.0) frml logl = (h(t)=hf(t)),(u(t)=resid(t)),-.5*(log(h)+u**2/h) * frml init = (h(1)=h0) linreg(noprint) y / u # constant compute b0=%beta(1) compute vc=%seesq,va=.05,vb=.05,vd=.05 set h = %seesq maximize(parmset=meanparms+garchparms+constraint, $ method=simplex, iters=5,noprint) logl $ gstart gend maximize(parmset=meanparms+garchparms+constraint, $ method=bfgs,robusterrors,iters=100) logl $ gstart gend b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST10 EGARCH(1,1) Experiments # 1 /$ /$ This program does RATS EGARCH Form of the model /$ Program lets parameters get in negative zone!! b34sexec scaio readsca /$ file('/usr/local/lib/b34slm/findat01.mad') file('c:\b34slm\examples\findat01.mad') dataset(m_ibmln); b34srun; %b34slet dob34s = 1; %b34slet dorats = 1; %b34sif(&dob34s.eq.1)%then; b34sexec matrix; call loaddata; * Shows B34S EGARCH which follows RATS EGARCH ; * Contrast with Tsay (2003) Page 104 & 121 ; * iijj is the lag ; * jjjj starts the data copy ; * Experiments with starting periods ; do iiii=1,1; do jjjj=1,2; i=integers(jjjj,864); y=ibmln(i); call olsq(y y{1} :print); ii=integers(2,norows(y)); res =array(norows(y):); arch=array(norows(y):)+%resvar; res(ii)=%res(ii-1); /$ un comment to see effect /$ arch=arch*0.0; call print('# dropped ++++++++++++++ ',iiii:); call print('Starting ++++++++++++++ ',jjjj:); call garchest(res,arch,y,func,iiii,n /$ p1 va vb vd p0 vc /$ ar gar gma vd cons(1) cons(2) :lower array(6: -.99999,.1d-9, .1d-9 .1d-9,-10.0, -10. ) :upper array(6: .99, .99 100. 100., 100.0, 100.) /$ :cparms array(2:mean(y),dlog(vstart)) /$ :cparms array(2:mean(y),.01 ) :cparms array(2:%coef(2),-.2 ) :ngar 1 :garparms array(:.1) :ngma 1 :gmaparms array(:.1) :nar 1 :arparms array(:%coef(1)) :maxfun 2000 :maxit 2000 :maxg 2000 :egarch .2 /$ :gradtol .1e-15 /$ :steptol .1e-4 /$ :rftol .1e-15 :simplex :print2 :maxit2 60 :print ); enddo; enddo; b34srun; %b34sendif; %b34sif(&dorats.eq.1)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ * * all 0 864:1 * open data m-ibmln.dat * data(org=obs) / rt set rt = ibmln set h = 0.0 * * This is what RATS calls EGARCH * * EGARCH(1,1) * compute vb = 0.0 smpl 1 864 declare series u declare series h * set rt = rt(t) - rt(t-1) nonlin(parmset=meanparms) p0 p1 * frml resid = rt(t)-p0-p1*rt{1} frml at = rt(t)-p0-p1*rt{1} * # 1 is egarch(1,1) * nonlin(parmset=garchparms) vc va vb vd vc>=0.0 va>=0.0 vd>=.0 vb>=0.0 * nonlin(parmset=garchparms) vc va vd vc>=0.0 va>=0.0 vd>=.0 nonlin(parmset=garchparms) vc va vb vd frml g = abs(u(t)/sqrt(h(t))) - sqrt(2.0/%pi) - vd*u(t)/sqrt(h(t)) frml hf = exp(vc + va*log(h{1}) + vb*g{1}) frml logl = (h(t)=hf(t)),(u(t)=at(t)),-.5*(log(h)+u(t)**2/h(t)) compute start=4 compute end=864 linreg(print) rt / u # constant rt{1} display '%seesq' %seesq compute p0=%beta(1) compute p1=%beta(2) compute vc=log(%seesq),va=.05,vb=.05,vd=.05 * compute vc=log(%seesq),va=.05,vb=.00,vd=.05 set h = %seesq maximize(parmset=meanparms+garchparms,method=simplex, $ recursive,iters=5,noprint) logl start end maximize(parmset=meanparms+garchparms,method=bfgs, $ recursive,robusterrors,iters=100) logl start end b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==GARCHEST11 EGARCH Experiments # 2 b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; /$ EGARCH %b34slet dorats=1; %b34slet dob34s=1; /$ /$ Joint EGARCH Estimation using GARCHEST Subroutine /$ /$ Illustrates effect of both B34S and Rats with constraints %b34sif(&dob34s.ne.0)%then; b34sexec matrix ; call loaddata; call load(gtest); * GARCH setup where use EGARCH Model ; * B34S appears to "beat" RATS ; j=1; i=integers(j,norows(sp500)); y=sp500(i); vstart=variance(y-mean(y)); call print(vstart); arch=array(norows(y):)+ vstart; res= y-mean(y); /$ un comment to see effect /$ arch=arch*0.0; call garchest(res,arch,y,func,1,n :lower array(5:.1d-6,.1d-6,.1d-6,0.0, 0.0) :cparms array(2:mean(y),vstart) :ngar 1 :garparms array(:.05) :ngma 1 :gmaparms array(:.05) :maxfun 200000 :maxit 200000 :maxg 200000 :egarch array(:.05) :simplex :print2 :maxit2 700 :print ); /$ call gtest(res,arch,y,24); /$ call tabulate(%resobs,res,arch); b34srun; %b34sendif; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * compute gstart=2,gend=1996:12 set y = sp500 nonlin(parmset=meanparms) b0 frml resid = y - b0 declare series u ;* Residuals declare series h ;* Variances * * egarch * nonlin(parmset=garchparms) vc va vb vd nonlin(parmset=constraint) b0>=0.0 vc>=0.0 va>=0.0 vb>=0.0 vd>=0.0 frml g = abs(u(t)/sqrt(h(t))) - sqrt(2.0/%pi) - vd*u(t)/sqrt(h(t)) frml hf = exp(vc + va*log(h{1}) + vb*g{1}) frml logl = (h(t)=hf(t)),(u(t)=resid(t)),-.5*(log(h)+u**2/h) * frml init = (h(1)=h0) linreg(noprint) y / u # constant compute b0=%beta(1) compute vc=%seesq,va=.05,vb=.05,vd=.05 set h = %seesq display '%seesq' %seesq maximize(parmset=meanparms+garchparms+constraint, $ method=simplex, iters=5,noprint) logl $ gstart gend maximize(parmset=meanparms+garchparms+constraint, $ method=bfgs,robusterrors,iters=100) logl $ gstart gend b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun %b34sendif; == ==GARCHEST12 SP500DR /$ tests tgarch SP500DR Complete Period /$ Rats and B34S Run very very closely!! %b34slet dob34s=1; %b34slet dorats=1; /;b34sexec scaio readsca file('SP500D.MAD') dataset(DATA); b34srun; b34sexec options ginclude('b34sdata.mac') member(sp500_2); b34srun; %b34sif(&dob34s.ne.0)then; b34sexec matrix; call loaddata; call echooff; call print('*******************************************************'); call print('** Analysis Performed on Variable: SP500DR'); call print('Options: EGARCH '); call print('*******************************************************'); /$ **************************************************************$/ /$ Set span for time series: SP500DR /$ **************************************************************$/ iorigins=integers(11406, 12837); /; SP500DR = SP500DR(iorigins); /$ **************************************************************$/ /$ Use mean/variance for CONSTANT starting values in model /$ **************************************************************$/ YMean=Mean(SP500DR); YSigma2=Variance(SP500DR-YMean); /$ **************************************************************$/ /$ Specify and estimate GARCH model /$ **************************************************************$/ call garchest(res1, res2, SP500DR,func,3,nbad :cparms array(:.113,.0112) :nar 1 :garorder idint(array(:1)) :garparms array(: .92) :lower array(:-100.,-100.,-100.,-100.,-100.,-100.) :gmaorder idint(array(:1)) :gmaparms array(: .08) :egarch .01 :maxfun 2000 :maxg 400 :maxit 2000 :ngood 15 :print); call print('Residual Sum of Squares is:',sumsq(goodrow(res1)):); b34srun; %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ set rt = sp500dr set h = 0.0 * * This is what RATS calls EGARCH * * EGARCH(1,1) * compute vb = 0.0 smpl 1 14012 declare series u declare series h * set rt = rt(t) - rt(t-1) nonlin(parmset=meanparms) p0 p1 * frml resid = rt(t)-p0-p1*rt{1} frml at = rt(t)-p0-p1*rt{1} * # 1 is egarch(1,1) * nonlin(parmset=garchparms) vc va vb vd vc>=0.0 va>=0.0 vd>=.0 vb>=0.0 * nonlin(parmset=garchparms) vc va vd vc>=0.0 va>=0.0 vd>=.0 nonlin(parmset=garchparms) vc va vb vd frml g = abs(u(t)/sqrt(h(t))) - sqrt(2.0/%pi) - vd*u(t)/sqrt(h(t)) frml hf = exp(vc + va*log(h{1}) + vb*g{1}) frml logl = (h(t)=hf(t)),(u(t)=at(t)),-.5*(log(h)+u(t)**2/h(t)) compute start=4 compute end=14012 linreg(print) rt / u # constant rt{1} display '%seesq' %seesq compute p0=%beta(1) compute p1=%beta(2) compute vc=log(%seesq),va=.05,vb=.05,vd=.05 * compute vc=log(%seesq),va=.05,vb=.00,vd=.05 set h = %seesq maximize(parmset=meanparms+garchparms,method=simplex, $ recursive,iters=5,noprint) logl start end maximize(parmset=meanparms+garchparms,method=bfgs, $ recursive,robusterrors,iters=100) logl start end b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==GARCHEST_A Transfer Function b34sexec options ginclude('gas.b34'); b34srun; /$ /$ Estimate a GARCH transfer function. /$ For a direct example using GARCH see GARCH_4 example /$ results tested with RATS in GARCH_4 and here /$ %b34slet dorats=0; b34sexec matrix ; call loaddata; call olsq(gasout gasout{1 to 2} gasin{1} gasin{3} :print); /$ res =array(norows(gasout):); /$ res=gasout-mean(gasout); /$ arch=array(norows(gasout):) +%resvar ; call garchest(res,arch,gasout,func,3,n :nar 2 :arparms array(:%coef(1) %coef(2)) :ngma 1 :ngar 1 :xvar gasin array(:%coef(3) %coef(4)) idint(array(:1 3)) idint(array(:2)) :cparms array(:%coef(5), %resvar) :lower array(:-.1d+30,-.1d+30,-.1d+30,-.1d+30, .1d-16, .1d-16,-.1d+30, .1d-16) :maxsteps 4. :gradtol .1e-4 /$ :simplex :print2 :maxit2 2000 :maxit 2000 :maxfun 2000 :maxg 2000 :print); /$ call print(sumsq(goodrow(res)):); call tabulate(res,arch); call graph(goodrow(res)); call graph(goodrow(arch)); b34srun; %b34sif(&dorats.ne.0)%then; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ /$ User must replace GASOUT with user series name /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 gin1 gin2 a0 a1 beta1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} $ -gin1*gasin{1}-gin2*gasin{3} frml garchvar = a0+a1*u11{1}**2 + $ beta1 * %if(v11{1}>1.e+100,%na,v11{1}) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} gasin{1} gasin{3} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 compute beta1=0.0 compute gin1=%beta(4) compute gin2=%beta(5) nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 4 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 4 * print * * u11 v11 smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCHEST_B Test of GARCHEST Transfer Function b34sexec options ginclude('gas.b34'); b34srun; /$ /$ Estimate a GARCHEST transfer function. /$ No second moment terms!! Model is tested against Direct OLS /$ => Without second moment equation we have OLS /$ b34sexec matrix ; call loaddata; call olsq(gasout gasout{1 to 2} gasin{3} gasin{4} :print); call print(%coef); call garchest(res,arch,gasout,func,5,n :nar 2 :arparms array(:%coef(1) %coef(2)) /$ :ngar 1 :xvar gasin array(:%coef(3) %coef(4)) idint(array(:3 4)) idint(array(:2)) :cparms array(:%coef(5), %resvar) /$ :simplex :print2 :maxit2 2000 :maxit 600 :maxfun 600 :maxg 600 :print); /$ call print(sumsq(goodrow(res)):); call tabulate(res,arch); call graph(goodrow(res)); if(variance(goodrow(arch)) .gt. .1d-6)call graph(goodrow(arch)); b34srun; == ==GARCHEST_C GARCH-M Transfer Function Model b34sexec options ginclude('gas.b34'); b34srun; /$ /$ Estimate a GARCH-M transfer function Model. /$ MU terms in for lags 1 and 2 /$ b34sexec matrix ; call loaddata; call olsq(gasout gasout{1 to 2} gasin{1} gasin{3} :print); /$ res =array(norows(gasout):); /$ res=gasout-mean(gasout); /$ arch=array(norows(gasout):) +%resvar ; call garchest(res,arch,gasout,func,3,n :nar 2 :arparms array(:%coef(1) %coef(2)) :ngma 1 :ngar 1 /$ :nmu 1 :muorder idint(array(:1 2)) :xvar gasin array(:%coef(3) %coef(4)) idint(array(:1 3)) idint(array(:2)) :cparms array(:%coef(5), %resvar) :lower array(:-.1d+30,-.1d+30,-.1d+30,-.1d+30, .1d-16, .1d-16,-1.d+30,-1.d+30,-.1d+30, .1d-16) :maxsteps 4. :gradtol .1e-4 /$ :simplex :print2 :maxit2 2000 :maxit 2000 :maxfun 2000 :maxg 2000 :print); /$ call print(sumsq(goodrow(res)):); call tabulate(res,arch); call graph(goodrow(res)); call graph(goodrow(arch)); b34srun; == ==GARCHM_1 ARCH-M Test Case using GARCH command /; This job uses GARCH to do what GARCHEST does. See GARCHM_2 job %b34slet dorats=0; b34sexec options ginclude('b34sdata.mac') member(archm); b34srun; b34sexec matrix display=col80medium; /$ /$ Model Discussed in Enders page 159 and on page 202. /$ In Enders (2004) see page 131 /$ Enders is running a model has h(t) not sqrt(h(t-1)) /$ in the first moment equation. /$ Note that B34S gets a better solution than RATS in terms of /$ function to be maximized. /$ Job substantially faster than a DO loop implementation /$ that will obtain same answer and, if need be, do custom /$ problems /$ call loaddata; j=norows(y); count=0.0; arch = array(j:); res = array(j:); archlog= array(j:); call echooff; program test; /$ Using built in garch subroutine to estimate a GARCH /$ Usual setup but uses subroutine garch func=0.0; call garch(res,arch,y,func,1,n :mu array(:a1) index(0) :nosqrt :gma array(:alpha1) index(1) :constant array(:a0 alpha0) ); return; end; /$ /$ Get starting values for first moment part of model /$ a0 = .5 ; a1 = .01 ; alpha0 = .4 ; alpha1 = 1. ; /$ /$ call cmaxf2(func :name test :parms a0 a1 alpha0 alpha1 :maxit 800 /$ :maxsteps 4. :ivalue array(:a0,a1,alpha0,alpha1) :gradtol .1e-4 :lower array(: -.1d+30, -.1d+30, .1d-8, .1d-8) :upper array(: .1d+30, .1d+30, .1d+30, .1d+30) :print); call print('Sum of squares of residual',sumsq(res):); call print('Variance of residual ',variance(goodrow(res)):); call print('Variance of Second Moment ',variance(goodrow(arch)):); /; call tabulate(res,arch); b34srun; %b34sif(&dorats .ne. 0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = y compute iter = 100,isiter=100 * * archm * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin a0 a1 alpha0 alpha1 frml garchvar = alpha0+alpha1*u11{1}**2 frml regresid = seriesn-a0-a1*sqrt(garchvar(t)) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) compute a0 = .5; compute a1 = .01 ; compute alpha0 = .4 ; compute alpha1 = 1. ; nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 2 * * print * * u11 v11 smpl(series=u11) statistics u11 statistics v11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('Output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCHM_2 ARCH-M Test Case using GARCHEST command /; This job uses GARCHEST to do what GARCH does. See GARCHM_1 job %b34slet dorats=0; b34sexec options ginclude('b34sdata.mac') member(archm); b34srun; b34sexec matrix display=col80medium; /$ /$ Model Discussed in Enders page 159 and on page 202. /$ Enders is running a model has h(t) not sqrt(h(t-1)) /$ in the first moment equation. /$ Note that B34S gets a better solution than RATS in terms of /$ function to me maximized. /$ Job substantially faster than a DO loop implementation /$ or call garch implementation /$ that will obtain same answer and, if need be, do custom /$ problems /$ call loaddata; j=norows(y); arch = array(j:); res = array(j:); call garchest(res,arch,y,func,1,n :muorder index(0) :muparms array(:.01) :nosqrt :ngma 1 :gmaparms array(:1.) :cparms array(:.5,.4) :print); call print('Sum of squares of residual',sumsq(res):); call print('Variance of residual ',variance(goodrow(res)):); call print('Variance of Second Moment ',variance(goodrow(arch)):); /; call tabulate(res,arch); b34srun; %b34sif(&dorats .ne. 0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = y compute iter = 100,isiter=100 * * archm * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin a0 a1 alpha0 alpha1 frml garchvar = alpha0+alpha1*u11{1}**2 frml regresid = seriesn-a0-a1*sqrt(garchvar(t)) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) compute a0 = .5; compute a1 = .01 ; compute alpha0 = .4 ; compute alpha1 = 1. ; nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 3 * print * * u11 v11 smpl(series=u11) statistics u11 statistics v11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('Output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCHM_3 Example from Tsay (2002) page 104 /$ /$ sqrt of m terms gives a better model? See Tsay (2002) page 101 /$ b34sexec scaio readsca /$ file('/usr/local/lib/b34slm/findat01.mad') file('c:\b34slm\examples\findat01.mad') dataset(sp500); b34srun; %b34slet dob34s = 1; %b34slet dorats = 1; %b34sif(&dob34s.eq.1)%then; b34sexec matrix; call loaddata; call echooff; /$ **************************************************************$/ /$ Set span for time series: SP500 /$ **************************************************************$/ iorigins=integers(1, 792); SP500 = SP500(iorigins); /$ **************************************************************$/ /$ Use mean/variance for CONSTANT starting values in model /$ **************************************************************$/ YMean=Mean(SP500); YSigma2=Variance(SP500-YMean); call garchest(res1, res2, SP500,func,1,nbad :cparms array(:YMean, YSigma2) /; :simplex /; :print2 /; :nosqrt :maxit 12000 :maxfun 12000 :maxg 12000 :steptol .1e-7 :garorder idint(array(:1)) :gmaorder idint(array(:1)) :muorder idint(array(:0)) :print); call garchest(res1, res2, SP500,func,1,nbad :cparms array(:YMean, YSigma2) /; :simplex /; :print2 :nosqrt :maxit 12000 :maxfun 12000 :maxg 12000 :steptol .1e-7 :garorder idint(array(:1)) :gmaorder idint(array(:1)) :muorder idint(array(:0)) :print); b34srun; %b34sendif; %b34sif(&dorats.eq.1)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ ************************ * This program performs a GARCH(1,1)-M model ************************ * all 0 792:1 * open data sp500.dat * data(org=obs) / rt set rt = sp500 set h = 0.0 nonlin a0 a1 b1 mu g0 * better model ? * This is the dsqrt( ) model !!!!! frml at = rt(t) - mu - g0*sqrt(h(t)) frml gvar = a0 + a1*at(t-1)**2 + b1*h(t-1) frml garchlog = -0.5*log(h(t)=gvar(t))-0.5*at(t)**2/h(t) smpl 2 792 compute mu = 0.01, a0 = 0.01, a1 =0.1, b1=0.6, g0 =0.01 maximize(method=bfgs,recursive,iterations=150) garchlog set rt = sp500 set h = 0.0 nonlin a0 a1 b1 mu g0 * better model ? frml at = rt(t) - mu - g0*h(t) frml gvar = a0 + a1*at(t-1)**2+b1*h(t-1) frml garchlog = -0.5*log(h(t)=gvar(t))-0.5*at(t)**2/h(t) smpl 2 792 compute mu = 0.01, a0 = 0.01, a1 =0.1, b1=0.6, g0 =0.01 maximize(method=bfgs,recursive,iterations=150) garchlog b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==GARCH_1 OLS - GARCH Example b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; /$ GARCH model using Stokes-Neuburger (RES79) model diffi = dropfirst(dif(fycp, 1,1),1); diffm2_2 = dif(fmscom,2,1); lag=24; call olsq(diffi,diffi{1 to lag},diffm2_2{0 to lag} :print); res1=%res; res2=afam(res1)*afam(res1); nar=6; nma=0; refine=2.; call arma(res2 :nar nar :nma nma :print :refine refine); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); /$ Now run Log Data lnfycp=dlog(fycp); lnfmscom=dlog(fmscom); ldiffi = dropfirst(dif(lnfycp, 1,1),1); ldifm2_2 = dif(lnfmscom,2,1); lag=24; call olsq(ldiffi,ldiffi{1 to lag},ldifm2_2{0 to lag} :print); res1=%res; res2=afam(res1)*afam(res1); nar=6; nma=0; refine=2.; call arma(res2 :nar nar :nma nma :print :refine refine); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; == ==GARCH_2 Joint GARCH(0,1) Estimation - Rats tests result /$ /$ Joint GARCH Estimation using GARCH subroutine /$ RATS used to test results. /$ b34sexec options ginclude('gas.b34'); b34srun; %b34slet dorats=0; b34sexec matrix ; call loaddata; count=0.0; j=norows(gasout); arch = array(j:)+1.; res = array(j:); archlog= array(j:); call echooff; program test; /$ Using built in garch subroutine func=0.0; count=count+1.0; call garch(res,arch,gasout,func,2,n :ar array(:b1,b2) idint(array(:1 2)) :gma array(:a1) idint(array(:1) ) :constant array(:b0 a0) ); call outstring(4,3,'F count a0 a1 b0 b1 b2'); call outdouble(34,3,func); call outdouble(54,3,count); call outdouble(4, 4, a0); call outdouble(24,4, a1); call outdouble(44,4, b0); call outdouble( 4,5, b1); call outdouble(24,5, b2); return; end; call print(test); /$ tests a1=.05; /$ /$ Get starting values /$ call olsq(gasout gasout{1 to 2} :print); call print(%coef); call cmaxf2(func :name test :parms b0 b1 b2 a0 a1 :ivalue array(:%coef(3),%coef(1),%coef(2),%resvar,a1) :maxit 300 :gradtol .1e-4 :lower array(:-.1d+30,-.1d+30,-.1d+30,0.0,0.0) :upper array(: .1d+30, .1d+30, .1d+30,.1d+30,.1d+30) :print); call print('Number out of function ',n); call print(sumsq(goodrow(res))); call tabulate(res,arch); b34srun; %b34sif(&dorats.ne.0)%then; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$PGMCARDS$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(0,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 a0 a1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} frml garchvar = a0+a1*u11{1}**2 frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 3 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 3 * smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 print * * u11 v11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCH_3 Joint GARCH(1,1) Estimation. Rats tests result. b34sexec options ginclude('gas.b34'); b34srun; %b34slet dorats=0; b34sexec matrix ; call loaddata; j=norows(gasout); count=0.0; arch = array(j:); res = array(j:); archlog= array(j:); call echooff; program test; /$ Using built in garch subroutine func=0.0; count=count+1.0; call garch(res,arch,gasout,func,2,n :ar array(:b1,b2) idint(array(:1 2)) :gma array(:a1) idint(array(:1) ) :gar array(:a2) idint(array(:1) ) :constant array(:b0 a0) ); call outstring(4,3,'Function'); call outdouble(24,3,func); call outdouble(64,3,count); call outdouble(4, 4, a0); call outdouble(24,4, a1); call outdouble(44,4, a2); call outdouble(64,4, b0); call outdouble( 4,5, b1); call outdouble(24,5, b2); return; end; call print(test); /$ tests a1=.05; a2=0.0; /$ /$ Get starting values /$ call olsq(gasout gasout{1 to 2} :print); call print(%coef); /$ call cmaxf2(func :name test :parms b0 b1 b2 a0 a1 a2 :maxit 200 :maxsteps 10. :ivalue array(:%coef(3),%coef(1),%coef(2),%resvar,a1,a2) :maxit 300 :gradtol .1e-4 :lower array(:-.1d+30,-.1d+30,-.1d+30,.1d-16,.1d-16, .1d-16) :upper array(: .1d+30, .1d+30, .1d+30,.1d+30,.1d+30, .1d+30) :print); b34srun; %b34sif(&dorats.ne.0)%then; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ /$ User must replace GASOUT with user series name /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 a0 a1 beta1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} frml garchvar = a0+a1*u11{1}**2 + $ beta1 * %if(v11{1}>1.e+100,%na,v11{1}) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 3 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 3 * smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCH_4 Transfer Function Model with GARCH. Rats tests Result b34sexec options ginclude('gas.b34'); b34srun; %b34slet dorats=0; /$ /$ Estimate a GARCH Transfer function. RATS used to validate /$ results. GARCHEST_A is an easier way to go!! /$ b34sexec matrix ; call loaddata; j=norows(gasout); count=0.0; arch = array(j:); res = array(j:); archlog= array(j:); call echooff; program test; /$ Using built in garch subroutine to estimate a GARCH /$ Transfer function func=0.0; count=count+1.0; call garch(res,arch,gasout,func,3,n :ar array(:b1,b2) idint(array(:1 2)) :gma array(:a1) idint(array(:1) ) :gar array(:a2) idint(array(:1) ) :xvar gasin array(:gin1 gin2) idint(array(:1 3)) idint(array(:2)) :constant array(:b0 a0) ); call outstring(4,3,'Function'); call outdouble(24,3,func); call outdouble(64,3,count); call outdouble(4, 4, a0); call outdouble(24,4, a1); call outdouble(44,4, a2); call outdouble(64,4, b0); call outdouble( 4,5, b1); call outdouble(24,5, b2); call outdouble( 4,6, gin1); call outdouble(24,6, gin2); return; end; call print(test); /$ tests a1=.01; a2=.01; /$ /$ Get starting values /$ call olsq(gasout gasout{1 to 2} gasin{1} gasin{3} :print); call print(%coef); /$ call cmaxf2(func :name test :parms b0 b1 b2 gin1 gin2 a0 a1 a2 :maxit 200 :maxsteps 4. :ivalue array(:%coef(5),%coef(1),%coef(2),%coef(3),%coef(4), %resvar,a1,a2) :gradtol .1e-4 :lower array(:-.1d+30,-.1d+30,-.1d+30,-.1d+30,-.1d+30, .1d-16,.1d-16, .1d-16) :upper array(: .1d+30, .1d+30, .1d+30, .1d+30, .1d+30, .1d+30,.1d+30, .1d+30) :print); call print(sumsq(goodrow(res))); call tabulate(res,arch); b34srun; %b34sif(&dorats.ne.0)%then; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ /$ User must replace GASOUT with user series name /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 gin1 gin2 a0 a1 beta1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} $ -gin1*gasin{1}-gin2*gasin{3} frml garchvar = a0+a1*u11{1}**2 + $ beta1 * %if(v11{1}>1.e+100,%na,v11{1}) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} gasin{1} gasin{3} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 compute beta1=0.0 compute gin1=%beta(4) compute gin2=%beta(5) nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 4 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 4 * print * * u11 v11 smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GARCH_5 Three GARCH Test Cases b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; /$ GRACH and GARCHEST estimate using GARCH and GARCHEST commands /$ Enders tests GARCHEST %b34slet garch =0; %b34slet garchest=0; %b34slet enders =1; %b34slet rats =1; %b34sif(&enders .ne. 0)%then; b34sexec matrix ; call loaddata; * See Enders page 155 ; j=norows(pi); jj=integers(1,j); pi=pi(jj); call olsq(pi pi{1} :print); j=norows(pi); arch = array(j:); res = array(j:); nback=8; call garchest(res,arch, pi,func,nback,n :maorder idint(array(:1,4)) :nar 1 :arparms array(:%coef(1)) :ngar 1 :ngma 1 :maxfun 2000 :maxg 2000 :maxit 10000 :cparms array(:%coef(2),%resvar) :print); call print(sumsq(goodrow(res))); * call tabulate(res,arch); b34srun; %b34sendif; %b34sif(&garchest .ne. 0)%then; b34sexec matrix ; call loaddata; dpi=dif(pi); call print(dpi); call garchest(res,arch,dpi,func,1,n :nma 1 :ngar 1 :ngma 1 :noconst1 :maxfun 2000 :maxg 2000 :maxit 800 :print); call print(sumsq(goodrow(res))); call tabulate(res,arch); b34srun; %b34sendif; %b34sif(&garch .ne. 0)%then; b34sexec matrix display=col80medium; /$ Model Discussed in Enders page 155 call loaddata; dpi=dif(pi); j=norows(dpi); arch = array(j:); res = array(j:); archlog= array(j:); call echooff; program test; /$ Using built in garch subroutine to estimate a GARCH func=0.0; call garch(res,arch,dpi,func,1,n :ma array(:b2) idint(array(:1) ) :gma array(:a1) idint(array(:1) ) :gar array(:a2) idint(array(:1) ) :constant array(:b0 a0) ); return; end; call print(test); /$ tests b2=.1; a1=.1; a2=.1; b0=0.0; a0=.1 ; /$ /$ note b0=0.0 and not estimated /$ call cmaxf2(func :name test :parms b2 a2 a1 a0 :maxit 2000 :maxfun 2000 :maxg 2000 :ivalue array(:b2,a2,a1,a0) :lower array(:-.1d+30,.1d-16,.1d-16, .1d-16) :upper array(: .1d+30,.1d+30,.1d+30, .1d+30) :print); call print(sumsq(goodrow(res))); call tabulate(res,arch); b34srun; %b34sendif; %b34sif(&rats .ne. 0)%then; /$ BHHH method used .. residuals set to 0 for beginning obs /$ /$ User must replace GASOUT with user series name /$ B34SEXEC OPTIONS OPEN('rats.dat') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = pi compute iter = 100,isiter=100 * * enders page 155 garch * * smpl(series=seriesn) linreg seriesn # constant seriesn{1} set u = 0.0 set v = 0.0 nonlin b0 b1 b2 b3 a0 a1 a2 frml regresid = seriesn-b0-b1*seriesn{1}-b2*u{1} -b3*u{4} frml garchvar = a0+a1*regresid{1}**2 +a2*v{1} frml garchlogl = (u = regresid),(v = garchvar), $ -.5*(log(garchvar)+regresid(t)**2/garchvar) * -.5*(log(v)+u**2/v) set v = %seesq compute b0=%beta(1), b1=%beta(2), b2=.01, b3=.01, a0=%seesq,a1=.3 ,a2=.5 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 9 * * maximize(method=bhhh,recursive,iterations=iter) garchlogl 9 * maximize(method=bfgs,recursive,iterations=iter) garchlogl 9 * smpl(series=u) statistics u set rssg21 = u(t)*u(t) statistics rssg21 smpl(series=rssg21) compute sumsqu21 = %sum(rssg21) display 'sum of squares of u for garch' sumsqu21 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT WRITEOUT('OUTPUT FROM RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==GARCH_6 Tests McCullough-Renfro b34sexec options ginclude('b34sdata.mac') macro(bg_test1); b34srun; /$ /$ This job illustrates the default b34s results /$ plus how a change in term one of the second moment /$ equation from 0.0, to an estimate of the variance /$ gets us very close to the Benchmark Values /$ %b34slet setterm1 =1; %b34slet dorats =0; %b34slet dosas =0; /$ Benchmark values (coef & t) reported in Greene (2003) Page 245 /$ /$ mu a(0) a(1) delta /$ -.006190 .01076 .1531 .8060 /$ -.709 3.445 5.605 26.731 /$ /$ if Setterm1 = 0 B34S Gets /$ /$ Constrained Maximum Likelihood Estimation using CMAXF2 Command /$ Final Functional Value 710.0988738779154 /$ # of parameters 4 /$ # of good digits in function 15 /$ # of iterations 33 /$ # of function evaluations 49 /$ # of gradiant evaluations 35 /$ Scaled Gradient Tolerance 6.055454452393343E-06 /$ Scaled Step Tolerance 3.666852862501036E-11 /$ Relative Function Tolerance 3.666852862501036E-11 /$ False Convergence Tolerance 2.220446049250313E-14 /$ Maximum allowable step size 2000.000000000000 /$ Size of Initial Trust region -1.000000000000000 /$ /$ # Name Coefficient Standard Error T Value /$ 1 MU -0.54028321E-02 0.78671320E-02 -0.68676007 /$ 2 A0 0.96955352E-02 0.19582736E-02 4.9510627 /$ 3 A1 0.14249617 0.20587446E-01 6.9215077 /$ 4 B1 0.82057943 0.23642897E-01 34.707228 /$ /$ if Setterm1 = 1 B34S Gets /$ /$ Constrained Maximum Likelihood Estimation using CMAXF2 Command /$ Final Functional Value 706.6732730011846 /$ # of parameters 4 /$ # of good digits in function 15 /$ # of iterations 30 /$ # of function evaluations 43 /$ # of gradiant evaluations 32 /$ Scaled Gradient Tolerance 6.055454452393343E-06 /$ Scaled Step Tolerance 3.666852862501036E-11 /$ Relative Function Tolerance 3.666852862501036E-11 /$ False Convergence Tolerance 2.220446049250313E-14 /$ Maximum allowable step size 2000.000000000000 /$ Size of Initial Trust region -1.000000000000000 /$ /$ # Name Coefficient Standard Error T Value /$ 1 MU -0.60866084E-02 0.84612032E-02 -0.71935495 /$ 2 A0 0.10761841E-01 0.21864483E-02 4.9220652 /$ 3 A1 0.15343109 0.21070041E-01 7.2819549 /$ 4 B1 0.80585317 0.24648237E-01 32.694150 /$ /$ Rats gets /$ /$ MAXIMIZE - Estimation by BHHH /$ Convergence in 23 Iterations. /$ Usable Observations 1973 /$ Function Value 710.20954834 /$ /$ Variable Coeff Std Error T-Stat Signif /$ ************************************************************** /$ 1. MU -0.005405453 0.008378648 -0.64515 0.51883241 /$ 2. A0 0.009737295 0.001209136 8.05310 0.00000000 /$ 3. A1 0.143009440 0.012892918 11.09209 0.00000000 /$ 4. B1 0.819965321 0.015312307 53.54943 0.00000000 /$ /$ /$ Set dorats=1 to run RATS on the test problem /$ /$ Test problem discussed in "Benchmarks and Software Standards: a /$ Case study of GARCH procedures" McCullouch & Renfro /$ Journal of Economic and Social Measurement 25 (1998) 59-71 /$ /$ /$ Has Do loop and GARCH implementation /$ Do loop runs very very slowly but can totally control /$ whst is being run /$ b34sexec matrix ; call loaddata; count=0.0; j=norows(returns); arch = array(j:); res = array(j:); archlog= array(j:); * one and pfive are inplace constants. Make code run faster; one=1; pfive=.5; smu=mean(returns); svar=variance(returns-smu); /$ Set starting value for h(1) if ne 0.0 /$ arch= arch+1.; %b34sif(&setterm1.eq.1)%then; arch= arch+ (sumsq(returns-smu)/dfloat(j)); %b34sendif; call echooff; program test; func=0.0; count=count+1.0; /$ Uncomment do loop and comment call garch to switch /$ mode of running /$ res=returns-mu; /$ do i=2,j; /$ arch(i)=a0+a1*(res(i-one)*res(i-one))+b1*arch(i-one); /$ func=func-(pfive*mlsum(arch(i)))-(pfive*((res(i)*res(i))/arch(i))); /$ enddo; /$ /$ adjusting h(1) /$ /$ if(count.gt.1.)then; /$ arch(1)=(sumsq(res)-(res(1)*res(1)))/dfloat(j-1); /$ endif; /$ /$ Using built in garch subroutine results in faster code res=returns-mu; call garch(res,arch,returns,func,1,n :gar array(:b1) idint(array(:1)) :gma array(:a1) idint(array(:1)) :constant array(:mu a0) ); call outstring(4,3,'F count mu a0 a1 b1'); call outdouble(34,3,func); call outdouble(54,3,count); call outdouble(4, 4, mu); call outdouble(24,4, a0); call outdouble(44,4, a1); call outdouble( 4,5, b1); * call print(func mu a0 a1 b1); return; end; call print(test); /$ /$ tests starting values /$ call cmaxf2(func :name test :parms mu a0 a1 b1 /$ These are benchmark starting values. /$ :ivalue array(:-.016427, .221130, .35,.50) :ivalue array(:smu, svar .01 .5) :maxit 9000 /$ :gradtol .1d-07 /$ :steptol .1d-12 :lower array(:-10., .1d-2, .1d-2, .1d-2) :upper array(: 10. 10. 10. 10. ) :print); call print(sumsq(goodrow(res))); * call tabulate(res,arch); * Two pass method ; fixedet=(returns-mean(returns))*(returns-mean(returns)); call arma(fixedet :maxit 2000 :relerr 0.0 :nar 1 :nma 1 :print); b34srun; /$ /$ BHHH & BFGS methods used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = returns compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin mu a0 a1 b1 * frml regresid = seriesn-mu frml garchvar = a0+a1*u11{1}**2+b1*v11{1} frml regresid = seriesn-mu frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) * bhhh method linreg seriesn # constant * Simplex can be used to start process compute mu=%beta(1), b1=.01, a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 2 * * bfgs Method linreg seriesn # constant * Simplex can be used to start process compute mu=%beta(1), b1=.01, a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bfgs,recursive,iterations=iter) garchlogl 2 * b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dodos('start /w /r rats386 rats.in rats.out') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; %b34sif(&dosas.eq.1)%then; B34SEXEC OPTIONS OPEN('testsas.sas') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29) $ B34Srun$ B34SEXEC PGMCALL IDATA=29 ICNTRL=29$ SAS $ PGMCARDS$ proc autoreg; model returns = / garch=(q=1,p=1); B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ /$ The next card has to be modified to point to SAS location /$ Be sure and wait until SAS gets done before letting B34S resume B34SEXEC OPTIONS dodos('start /w /r sas testsas') dounix('sas testsas')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT NOHEADER WRITEOUT(' ','Output from SAS',' ',' ') WRITELOG(' ','Output from SAS',' ',' ') COPYFOUT('testsas.lst') COPYFLOG('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log')$ B34SRUN$ B34SEXEC OPTIONS HEADER$ B34SRUN$ %b34sendif; == ==GARCH_7 IGARCH(1,1) using NLPMIN1 /$ IGARCH(1,1) using NLPMIN1 - shows general case /$ /$ Note that SE are not available b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; b34sexec matrix ; call loaddata; y=sp500; vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); call print('mean y ',mean(y):); call print('vstart ',vstart :); program test; call garch(res,arch,y,func,1,nbad :gar array(:gar) idint(array(:1)) :gma array(:gma) idint(array(:1)) :constant array(:a0 b0) ); if(%active(1)) g(1)=gar+gma-1.; func=(-1.)*func; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms gar gma a0 b0 :ivalue array(:.5,.5,mean(y),vstart) :nconst 1 0 :lower array(: 1.d-6, 1.d-6, 1.d-6, 1.d-6) :upper array(: 1.d+2, 1.d+2, 1.d+2, 1.d+2) :print :maxit 100 :iprint final); b34srun; == ==GARCH_DO1 GARCH using Do loops %b34slet dorats = 0; b34sexec options ginclude('gas.b34'); b34srun; /$ This problem runs slow but is most general case. /$ Using DO loops can express any model. Can use CMAXF2 if /$ limit problems. b34sexec matrix ; call loaddata; /$ subset if j reduced j=norows(gasout); call print('# cases used was ',j); count=0.0; arch = array(j:); res = array(j:); archlog= array(j:); call echooff; program test; /$ Using do loop func=0.0; do ii=i,j; res(ii) =gasout(ii) - (b0 +(b1*gasout(ii-1))+(b2*gasout(ii-2))); arch(ii) =a0 + (a1*(res(ii-1)*res(ii-1))) + a2*dmin1(dabs(arch(ii-1)),.1e+70) ; func=func+((-.5)*(dlog(dmax1(dabs(arch(ii)),.1e-10))+ ( (res(ii)*res(ii)) /arch(ii)))) ; * call outdouble(3,1,dfloat(ii)); * call outdouble(43,1,func); enddo; count=count+1.0; call outstring(4,3,'Function'); call outdouble(24,3,func); call outdouble(64,3,count); call outdouble(4, 4, a0); call outdouble(24,4, a1); call outdouble(44,4, a2); call outdouble(64,4, b0); call outdouble( 4,5, b1); call outdouble(24,5, b2); return; end; call print(test); i=3; /$ initial values that were set b0=2.; b1=1.7; b2=-.7; a0=.04; a1=.2; a2=.5; /$ /$ call test; /$ call stop; call maxf2(func :name test :parms b0 b1 b2 a0 a1 a2 :maxit 200 :ivalue array(:b0, b1, b2, a0, a1, a2) :print); /$ Alternative setup * call cmaxf2(func :name test :parms b0 b1 b2 a0 a1 a2 :maxit 2000 :maxfun 2000 :maxg 2000 :ivalue array(:b0, b1, b2, a0, a1, a2) :lower array(:-.1d+30,-.1d+30,-.1d+30, .1d-16, .1d-16, .1d-1) :upper array(: .1d+30, .1d+30, .1d+30, .1d+30, .1d+30, .1d+3) :print); b34srun; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ /$ User must replace GASOUT with user series name /$ %b34sif(&dorats .ne. 0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(1,1) with ma(1) error * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 a0 a1 beta1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} frml garchvar = a0+a1*u11{1}**2 + $ beta1 * %if(v11{1}>1.e+100,%na,v11{1}) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 3 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 3 * smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GENARMA ACF and Spectrum of AR(.9) & AR(-.09) b34sexec matrix; ar=array(:.9); n=1000; start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ar=array(:-.9); testar1b=genarma(ar,ma,1.0,start,.1,n); acf1a=acf(testar1a,20,se,pacf1a); acf1b=acf(testar1b,20,se,pacf1b); call spectral(testar1a,sinx,cosx,px,sx1a,freq:1 2 3 2 1); call spectral(testar1b,sinx,cosx,px,sx1b,freq:1 2 3 2 1); call graph(freq,sx1a:heading 'Spectrum of ar(.9)' :plottype xyplot); call graph(freq,sx1b:heading 'Spectrum of ar(-.9)' :plottype xyplot); call tabulate(acf1a,acf1b,pacf1a,pacf1b); b34srun; == ==GENARMA_1 Simple test of arma(3,2) model b34sexec matrix; * imsl test case; ar=array(:.7,-.5,.2 ); ma=array(:-.5,-.25); n=10; start=array(:.1,.05,.0375); test=genarma(ar,ma,1.0,start,.1,n); call print(test); n=1000; test=genarma(ar,ma,1.0,start,.1,n); acf1=acf(test,dmax1(norows(test)/50,2),se,pacf1); call graph(acf1,pacf1 :heading 'ACF & PACF of ARMA(3,2)'); call spectral(test,sinx,cosx,px,sx1,freq:1 2 3 2 1); call graph(freq,sx1:heading 'Spectrum of ARMA(3,2)' :plottype xyplot); b34srun; == ==GENARMA_2 Illustrates various AR Models b34sexec matrix; * Enders test cases on page 14; * Use to study ar values of .9, .5, -.5, 1. 1.01 -1.01 ; * By adjusting var can show effect of noise ; n=200; ndrop=0; ar=-1.01; var=.1; con=0.0; start=array(1:1.); case_1=genarma(ar,ma,con,start,var,n,ndrop); call graph(case_1 :heading 'Plot Case_1' ); b34srun; == ==GENARMA_2A More Extensive Graphics b34sexec matrix; call load(acf_plot); * Enders test cases on page 14; * Use to study ar values of .9, .5, -.5, 1. 1.01 -1.01 ; * By adjusting var can show effect of noise ; n=2000; ndrop=0; ar=-.9; var=.1; con=0.0; start=array(1:1.); test=genarma(ar,ma,con,start,var,n,ndrop); call graph(test :heading 'Plot AR(1)' ); /; Use acf_plot to make a nice graph /; /; 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 /; /; ********************************************** call acf_plot(test,dmax1(norows(test)/10,2),'ACF & PACF of AR(1)'); call spectral(test,sinx,cosx,px,sx1,freq:1 2 3 2 1); call graph(freq,sx1 :heading 'Spectrum of AR(1)' :plottype xyplot); b34srun; == ==GENARMA_3 Generates AR(2) Test Case b34sexec matrix; * Theory suggests acf is .77273, .55682 ; ar=array(:.85,-.1); n=100000; start=array(:.1,.1); testar2=genarma(ar,ma,1.0,start,.1,n,3000); acfar2=acf(testar2,20,se,pacfar2); call spectral(testar2,sinx,cosx,px,sxar2,freq:1 2 3 2 1); call graph(freq,sxar2:heading 'Spectrum of ar2(.85, -.1)' :plottype xyplot); call tabulate(acfar2,pacfar2); b34srun; == ==GENARMA_4 Generates ARMA models (AR(1) MA(1) ARMA) b34sexec matrix; n=4000; /$ Model fit was ar1(t)= .9 * ar1(t-1) + e(t) ar=.9; call free(ma); const=1.0; start=.1; wnv=1.0; nout=200; ar1=genarma(ar,ma,const,start,wnv,n,nout); acf1=acf(ar1,dmax1(norows(ar1)/50,2),se1,pacf1); call graph(acf1,pacf1 :heading 'ACF & PACF of ar1'); call spectral(ar1,sinx,cosx,px,sx1,freq:1 2 3 2 1); call graph(freq,sx1:heading 'Spectrum of ar1' :plottype xyplot); /$ Model fit was ma1(t)= e(t)-.1 * e(t-1) ma=.1; call free(ar); cons=1.0; start=.1; wnv=1.0; nout=200; ma1=genarma(ar,ma,const,start,wnv,n,nout); acf2=acf(ma1,dmax1(norows(ma1)/50,2),se2,pacf2); call graph(acf2,pacf2 :heading 'ACF & PACF of ma1'); call spectral(ma1,sinx,cosx,px,sx2,freq:1 2 3 2 1); call graph(freq,sx2:heading 'Spectrum of ma1' :plottype xyplot); /$ Model fix was (1-.9*B)*arma = (1-.1*B)*e(t) ar=.9; ma=.1; cons=1.0; start=.1; wnv=1.0; nout=200; arma=genarma(ar,ma,const,start,wnv,n,nout); acf3=acf(arma,dmax1(norows(arma)/50,2),se3,pacf3); call graph(acf3,pacf3 :heading 'ACF & PACF of arma(1,1)'); call spectral(arma,sinx,cosx,px,sx3,freq:1 2 3 2 1); call graph(freq,sx3:heading 'Spectrum of arma' :plottype xyplot); call makedata(arma,ar1,ma1); b34srun; == ==GENARMA_T Generates Actual and Theoretical ACF b34sexec matrix; * study the theoretical ACF of the ARMA(1,1) model; * |psi| must be > 0.0; call echooff; theta=-.9; psi=.9; n=200; nacf=30; sigmausq=1.0; i=integers(n); cc=psi-theta; cpsi=psi**(dfloat(i-1)) *cc; * call tabulate(i,cpsi); gamma0=sigmausq*(sumsq(cpsi)+1.); gamma=array((n-nacf):); jj=integers(n-nacf); do ii=1,nacf; gamma(ii)=sigmausq* (sum(cpsi(jj)*cpsi(jj+ii))+ cpsi(ii)); enddo; tacf1=gamma/gamma0; tacf=tacf1(integers(nacf)); * Now generate some data and see what happens ; nobs=100000; ndrop=1000; start=array(:1.); testarma=genarma(psi,theta,1.0,start,sigmausq,nobs,ndrop); acf1a=acf(testarma,nacf,se,pacf1a); call spectral(testarma,sinx,cosx,px,sx1a,freq:1 2 3 2 1); call graph(freq,sx1a:heading 'Spectrum of arma(1,1)' :plottype xyplot); call graph(acf1a:heading 'ACF of ARMA(1,1)'); materms=cpsi(integers(norows(tacf))); tgamma=gamma(integers(norows(tacf))); call print('Psi ',psi :); call print('Theta ',theta :); call print('GAMMA(0) ',gamma0:); call tabulate(tacf acf1a,pacf1a,tgamma,materms); call graph(tacf,acf1a :Heading 'Theoretical ACF and Model ACF'); b34srun; == ==GET Get One or More Series b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call get(gasout,gasin); call names; call graph(gasout); b34srun; == ==GET_2 Shows removing Missing Data b34sexec options ginclude('b34sdata.mac') member(karras4); b34srun; b34sexec matrix; call get(can_ex,jap_m, julian_ :dropmiss); date=chardate(julian_); call tabulate(date,can_ex,jap_m,julian_); call cleardat; call print('*********** Full Dataset **************':); call get(can_ex,jap_m, julian_ ); date=chardate(julian_); call tabulate(date,can_ex,jap_m,julian_); b34srun; == ==GETDAY Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GETDMF Loads a DMF File into Matrix workspace b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call echooff; call loaddata; call names(all); call olsq(lnq lnk lnl lnrm1 :print); people=namelist(houston,diana,will,melissa,bobby); call makedmf(lnq,lnl,lnk,lnrm1,lnrm2 %res %y %yhat people :file 'testdmf.dmf' :header 'RES (1972) data' :member test_dat :print); nrow=10; ncol=8; x=rn(matrix(nrow,ncol:)); call print(x); means=array(ncol:); do i=1,ncol; means(i)=mean(x(,i)); enddo; call print(means); call makedmf(x :print :file 'testdmf.dmf' :add :header 'Random Matrix Data'); call getdmf(:browse :browsename :file 'testdmf.dmf'); call cleardat; call getdmf(:file 'testdmf.dmf'); call names(all); call getdmf(:file 'testdmf.dmf' :member data1 :print); call names(all); test=catcol(m1col__1,m1col__3); call print(' ':); call print('mean(test(,1)),mean(test(,2))':); call print( mean(test(,1)),mean(test(,2))); test=catcol(lnq,lnl,lnk); call print(' ':); call print('mean(lnq),mean(lnl),mean(lnk)':); call print( mean(lnq),mean(lnl),mean(lnk)); b34srun; b34sexec options open('testdmf.dmf') unit=62; b34srun; b34sexec dmf infmt=formatted inunit=62$ browse listnames$ b34srun$ b34sexec data file('testdmf.dmf') dmfmember(test_dat) filef= dmf; b34srun; b34sexec list iend=10; b34srun; b34sexec data file('testdmf.dmf') dmfmember(data1 ) filef= dmf; b34srun; b34sexec list; b34srun; == ==GETHOUR Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GETKEY Gets a key press b34sexec matrix; call echooff; i=0; start continue; call getkey(i); if(i.ne.0)then; call outstring(1,3,'Hit escape to terminate'); call outstring(1,4,'key'); call outinteger(22,4,i); if(i.eq.27)go to stop; endif; go to start; stop continue; b34srun; == ==GETMATLAB Gets Matlab Data saved with MAKEB34S command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ When using the MATLAB GETB34S file use full path /$ xx=getb34s('c:\junk\junk.ttt'); call loaddata; call names; xx=rn(matrix(5,5:)); call makematlab(gasout,gasin:file 'junk.ttt'); call makematlab(xx :file 'junk2.ttt'); call getmatlab(x, :file 'junk.ttt'); call getmatlab(xx2 :file 'junk2.ttt'); call print(x,xx,xx2); call names; cx=complex(xx,xx*2.); call makematlab(cx :file 'junk3.ttt'); call getmatlab(cx2, :file 'junk3.ttt'); call print(cx,cx2); cc=c8array(3:'test1 ', 'test2', 'test3'); call makematlab(cc :file 'junk4.ttt'); call getmatlab(cc2, :file 'junk4.ttt'); call print(cc,cc2); call names(:); nlist=%names%; call makematlab(nlist :file 'junk5.ttt'); call getmatlab(nlist2 :file 'junk5.ttt'); call print(nlist,nlist2); b34srun; == ==GETMINUTE Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GETMONTH Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GETNDIMV Gets value from N Dimensional Object b34sexec matrix; x=rn(array(index(4,4,4:):)); call print(x,getndimv(index(4,4,4),index(1,2,1),x)); do k=1,4; do i=1,4; do j=1,4; test=getndimv(index(4,4,4),index(i,j,k),x); call print(i,j,k,test); enddo; enddo; enddo; b34srun; == ==GETQT Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GETRATS Get Rats Portable File /$ /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makerats(gasin,newgasi,gasout,newgaso :file 'full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call cleardat; call getrats('full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call names; call tabulate(obsnum,gasin,newgasi,gasout,newgaso); b34srun; == ==GETSCA Illustrate GETSCA Command reading fsv /$$ Tests GETSCA in Matrix command. b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; B34SEXEC OPTIONS OPEN('MY.FSV') DISP=UNKNOWN UNIT(44)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(44)$ B34SRUN$ B34SEXEC SCAINPUT$ MAKESCA DATASET=MYFILE /$ VAR=( ) SCAUNIT=44$ B34SRUN$ B34SEXEC OPTIONS CLOSE(44)$ B34SRUN$ b34sexec matrix; call getsca('MY.fsv'); call names; call graph(gasout); b34srun; == ==GETSCA_2 Illustrate GETSCA Command reading mad /$$ Tests GETSCA in Matrix command. /$$ Test file first built b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call makemad(gasin,gasout :file 'full.mad' :member test); b34srun; b34sexec matrix; call getsca('full.mad' :mad); call names; call graph(gasout); b34srun; == ==GETSCA_3 Character*8 support b34sexec matrix; g(1)='bill'; g(2)='liu'; call makemad(g :file 'full.mad' :member test); b34srun; b34sexec matrix; call getsca('full.mad' :mad); call names; call print(g); b34srun; b34sexec scaio readsca file('full.mad') dataset(test); b34srun; b34sexec list; b34srun; == ==GETSCA_4 Matrix Support /; /; Testing fsave and mad for matrix /; b34sexec matrix; testmad=1; n=25000; k=40; x=rn(matrix(n,k:)); if(testmad.ne.0)call makemad(x :file 'bug.mad'); /; if(testmad.ne.0)call makemad(x(,1),x(,2) :file 'bug.mad'); if(testmad.eq.0)call makesca(x :file 'bug.fsv'); call print(mean(x(,1)),mean(x(,k))); x=missing(); if(testmad.eq.0)call getsca('bug.fsv' ); if(testmad.ne.0)call getsca('bug.mad' :mad); call names(all); call print(mean(m1col__1)mean(m1col__2)); b34srun; /; /; if testmad=1 /; b34sexec scaio readsca file('bug.mad'); b34srun; == ==GETSECOND Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GETSECOND Get second and other time commands b34sexec matrix; call echooff; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.11; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); b34srun; == ==GETYEAR Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==GET_FILE Get File Command b34sexec matrix; call get_file(cc); call print('File found was ',cc); b34srun; == ==GET_NAME Get an Object Name b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; back continue; call loaddata; call load(get_name); call load(dataview); call load(data_acf); call get_name(cc,ii); if(ii.eq.0)go to done; call character(nn,cc); call dataview(eval(cc),nn); go to back; endif; done continue; b34srun; == ==GLM Generalized Linear Model on RES data /; /; RES 72 Data /; %b34slet runr =0; %b34slet runglm =1; %b34slet rmatlab=0; %b34slet file1="'_b34sdat.dat'"$ %b34slet file2="'b34sdata.m'"$ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; %b34sif(&runglm.ne.0)%then; b34sexec matrix; call loaddata; call echooff; /; call marspline(lnq lnl lnk time:print); marsyhat=%yhat; marsres=%res ; call olsq(lnq lnl lnk time :print); olsyhat=%yhat; olsres=%res; /; call olsq(lnq time :print); call glm(lnq lnl lnk time :print :nlam 55 :lamdamin .002971 /; :na :savex ); /; call print(%x %y %yhat %res); /; call names(all); call print(%coef %ia); call tabulate(%rsq,%rss,%alm,%a0); /; /; Getting yhat from %coef, %lmu and %ao variables testyhat=mfam(%x)*vfam(%coef(,%lmu))+vfam(%a0(%lmu)); testres=vfam(%y)-vfam(testyhat); glmyhat=%yhat(,%lmu); glmres=afam(%y)-afam(glmyhat); call print(%yhat,%res); call tabulate(%y glmyhat glmres testyhat testres olsyhat olsres marsyhat marsres); call graph(lnq glmyhat,olsyhat,marsyhat :nolabel :file 'alt_yhat.wmf' :pgborder :nocontact); call graph(glmres olsres,marsres :nolabel :file 'alt_res.wmf' :pgborder :nocontact); c_lnl = dropfirst(%coef(1,),1); c_lnk = dropfirst(%coef(2,),1); c_time = dropfirst(%coef(3,),1); %alm=dropfirst(%alm,1); call graph(%alm c_lnl c_lnk c_time :plottype xyplot :nolabel :heading 'Effect of Lamda on Coefficients' :file 'coef.wmf' :pgborder :nocontact); b34srun; %b34sendif; /; Unit 28 is the data %b34sif(&runr.ne.0)%then; b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') library(glmnet) ## will list what is loaded library() lm(lnq~lnl+lnk) lm(lnq~lnl+lnk+lnrm2) x=matrix(rnorm(100*20),100,20) y=rnorm(100) g2=sample(1:2,100,replace=TRUE) g4=sample(1:4,100,replace=TRUE) fit1=glmnet(x,y) print(fit1) fit2=glmnet(x,g2,family="binomial") print(fit2) fit3=glmnet(x,g4,family="multinomial") print(fit3) plot(fit3,type="s",pch=19) ## predict(fit1,newx=x[1:5,],s=c(0.01,0.005)) ## predict(fit1,type="coef") ## ## plot(fit1,xvar="lamda") ## ## fit2=glmnet(x,g2,family="binomial") v=c(lnl,lnk,lnrm2) ## v xx=matrix(v,nrow=39) xx fit6=glmnet(xx,lnq) lm(lnq~lnl+lnk+lnrm2) predict(fit6,type="coef") fit6 q() b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ b34sexec options dodos(' r rjob' ) unix( ' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dos('erase rjob.r','erase rjob.R.Rout') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; %b34sif(&rmatlab.ne.0)%then; /$ /$ Builds a MATLAB input file for MATLAB version 6. /$ Changes made 2 February 2002 /$ /$ Since MATLAB is case sensitive, use lower case for all variable /$ references that are from b34s. MATLAB users upper case for a matrix /$ variable /$ /$ This job assumes user has already loaded data in B34S /$ The file name for file1 is hard coded in the matlab m file (file2) /$ /$ User changes this to default matlab file directory /$ /$ /$ Job runs on linux matlab and windows matlab /$ /$ When job ends, output will be seen in b34s.out file /$ /$ User loads data here if it has not occured already /$ b34sexec options open(%b34seval(&file1)) unit(28) disp=unknown$ b34seend$ b34sexec options clean(28)$ b34seend$ b34sexec options open(%b34seval(&file2)) unit(29) disp=unknown$ b34seend$ b34sexec options clean(29)$ b34seend$ b34sexec pgmcall$ matlab lowercase outfile(%b34seval(&file1))$ pgmcards$ % User MATLAB commands here such as plot(varname) x=[lnl,lnk,time] fit1=glmnet(x,lnq); glmnetPrint(fit1); glmnetPlot(fit1); % quit is needed since have to get out of matlab automatically % Comment to stay in matlab and see plot quit b34sreturn$ b34seend$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('matlab /r b34sdata /logfile matlab.out') dounix('matlab < b34sdata.m > matlab.out'); b34srun; b34sexec options dos('pause'); b34srun; b34sexec options writeout(' ', 'Output from Matlab ', ' '); b34srun; b34sexec options copyfout('matlab.out'); b34srun; b34sexec options dodos('erase matlab.out') dounix('rm matlab.out'); b34srun; %b34sendif; == ==GLM2 b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; m=5 ; nlam=20; call olsq(gasout gasout{1 to m} gasin{1 to m} :print); olsres =%res; olsyhat=%yhat; call glm(gasout gasout{1 to m} gasin{1 to m} :print :nlam nlam :thr 1.d-8 :na :lamdamin .3d-5 ); call print(%coef); call print(%nin,%ia); call tabulate(%a0 %rsq %rss %alm); glmyhat=%yhat(,%lmu); glmres = %res(,%lmu); call tabulate(%y,olsyhat,olsres,glmyhat,glmres); call print('rss = ',sumsq(glmres)); call graph(olsres glmres :nolabel :pgborder :nocontact); call graph(%y olsyhat glmyhat :nolabel :pgborder :nocontact); call olsq(gasout gasout{1} gasin{3 to 4} :print); b34srun; == ==GLM3 GLM on the Murder Data /; /; Probit Model vs GLM Tests /; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; call probit(d1 t y lf nw :print ); %p_yhat=%yhat; call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 1'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep, nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); d1p1=d1+1.; call ranforest(d1p1 t y lf nw :print :class 2 :vote_yhat); call glm(d1p1 t y lf nw :print :class 1 :nlam 4); call print( %a0 %coef %alm %ia %nin %yhat); glmyhat=%yhat(,%lmu); call tabulate(%y %p_yhat glmyhat); test=catcol(%y %p_yhat %yhat); call print('Actual - Probit prediction - GLM Prediction':); cross_c=ccf(test); call print(cross_c); call print(' ':); do ii=2,%lmu; call print('+++++++++++++++++++++++++++++++++++++++++++++++ ':); call print('Confusion Matrix for glm model ',ii:); call tlogit((%y-1.) ,%yhat(,ii),upper,lower,cc,ntruer,ntruep, nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call print(' ':); enddo; b34srun; == ==GLM4 GLM Tests on out-of-sample RSS /; Illustrates effect of reduction in model on the out of sample /; performance /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(glm_info :staging); call echooff; /; logic works for holdout > 0 /; set max VAR lag and holdout # of obs /; /; k=max lag, parm(0.0)=> ridge (1.0) lasso, nlam = # models tried k=6; holdout=100; maxlag=k; nlam=100; lam_min=.0001; thr =.1e-6; parm = .5; ne = 9; /; At issue is how are yhat values calculated within the sample treated? /; For purposes of this analysis they are removed call olsq(gasout gasout{1 to k} gasin{1 to k} :print :savex :holdout holdout); %yfuture= gasout(integers(norows(%x)+maxlag,norows(gasout))); olsf=mfam(%xfuture)*vfam(%coef); olsfss=sumsq(afam(%yfuture)-afam(olsf)); call print(' ':); call print('ols forecast error sum sq ',olsfss:); call print(' ':); call glm(gasout gasout{1 to k} gasin{1 to k} :print :savex :lamdamin lam_min :nlam nlam :holdout holdout :thr thr :parm parm :ne ne); call print(' ':); %yfuture= gasout(integers(norows(%x)+maxlag,norows(gasout))); call glm_info(%yfuture,%xfuture,%coef,%a0,%alm,glmf, fss,mod,1); call print(' ':); call print('glm forecast sum of squares ',fss:); call print(' ':); res_ols=vfam(%yfuture)-olsf; res_glm=vfam(%yfuture)-glmf; call graph(%yfuture,olsf,glmf :nolabel :nocontact :pgborder :file 'ols_glm_yhat_oos.wmf' :heading 'OLS vs GLM yhat out-of-sample'); call graph( res_ols res_glm :nolabel :nocontact :pgborder :file 'ols_glm_res_oos.wmf' :heading 'OLS vs GLM residual out-of-sample'); call tabulate(%yfuture,olsf,glmf res_ols res_glm); /; tests of reduction loss as a function of restriction tparm=grid(.1,.9,.1); fsstest=array(norows(tparm):); nein=ne; do jj=1,norows(tparm); call glm(gasout gasout{1 to k} gasin{1 to k} :savex :lamdamin lam_min :nlam nlam :holdout holdout :thr thr :parm tparm(jj) :ne ne); call glm_info(%yfuture,%xfuture,%coef,%a0,%alm,glmf, fss,mod,1); fsstest(jj)=fss; enddo; call tabulate(tparm fsstest ); call graph( tparm fsstest :plottype xyplot :grid :nolabel :nocontact :pgborder :file 'PARM_vs_OSS.wmf' :heading 'Parm vs GLM residual SS out of sample'); rss_glm=array(2*k:); ne_used=array(2*k:); icount=1; %yfuture= gasout(integers(norows(%x)+maxlag,norows(gasout))); do ne=1,2*k; ii=ne; call glm(gasout gasout{1 to k} gasin{1 to k} :savex :lamdamin lam_min :nlam nlam :holdout holdout :thr thr :parm parm :ne ii /; :print ); /; call print('+++++++++++++++++++++++++':); call glm_info(%yfuture,%xfuture,%coef,%a0,%alm,glmf,fss, mod,0); rss_glm(icount)=sfam(fss); ne_used(icount)=sfam(dfloat(ii)); icount=icount+1; enddo; rss_glm =dropfirst(rss_glm,1); ne_used =dropfirst(ne_used,1); call tabulate(rss_glm,ne_used); call graph(ne_used rss_glm :grid :heading 'RSS out-of-sample as a function of model reduction' :plottype xyplot :nocontact :nolabel :pgborder :file 'rss_loss.wmf'); b34srun; == ==GLM5 Matlab Test Cases b34sexec matrix; call echooff; idotest2=1; idotest3=1; idotest4=1; ido_olsq=1; ido_reg =0; ido_rf =1; call restore(:file 'c:\b34slm\lib\glmdata.psv' :list); call restore(:file 'c:\b34slm\lib\glmdata.psv'); call printall; if(idotest2.ne.0)then; if(ido_olsq.ne.0)call olsq(y2 x2 :print); call glm(y2 x2 :lamdamin .0005 :print); endif; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(idotest3.ne.0)then; if(ido_olsq.ne.0)call olsq(y3 x3 :print); if(ido_reg.ne.0)then; call glm(y3 x3 :print :lamdamin .03 :savex); %alm=dropfirst(%alm,1); %rss=dropfirst(%rss,1); %rsq=dropfirst(%rsq,1); call tabulate(%rsq,%rss,%alm); call graph(%alm %rss :plottype xyplot :heading 'sumsq(%res) vs lamda' :pgborder :nocontact); call graph(%alm %rsq :plottype xyplot :heading '%rsq vs lamda' :pgborder :nocontact); endif; if(ido_rf.ne.0)call ranforest(y3 x3:class 42 :print :vote_yhat); call glm(y3 x3 :class 4 :print :nlam 50); call print(%coef,%alm %y %yhat); call names(all); endif; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(idotest4.ne.0)then; if(ido_olsq.ne.0)call olsq(y4 x4 :print); if(ido_rf.ne.0)call ranforest(y4 x4 :class 2 :print :vote_yhat); if(ido_reg.ne.0)call glm(y4 x4 :print :lamdamin .0003); call glm(y4 x4 :class 1 :print :lamdamin .0003); do i=1,norows(%yhat); do j=1,nocols(%yhat); if(%yhat(i,j) .ge. .5)%yhat(i,j)=2.; if(%yhat(i,j) .lt. .5)%yhat(i,j)=1.; enddo; enddo; call tabulate(%y %yhat(,1),%yhat(,2),%yhat(,3),%yhat(,4),%yhat(,5), %yhat(,6),%yhat(,7)); test=catcol(%y %yhat); call print(ccf(test),%a0,%alm); endif; b34srun; == ==GMFAC LU Factorization b34sexec matrix; * Problem from MATLAB; x=matrix(3,3:8. 1. 6. 3. 5. 7. 4. 9. 2.); call gmfac(x,l,u,info); call print(x,l,u,info,l*u); cx=complex(x,dsqrt(dabs(x))); call gmfac(cx,cl,cu,info); call print(cx,cl,cu,info,cl*cu); b34srun; == ==GMINV Inverse using LAPACK b34sexec matrix; call echooff; n=5; x=rn(matrix(n,n:)); call gminv(x,xinv1,info); xinv2=inv(x); dtest=matrix(n,n:)+1.0; test1=x*xinv1; test2=x*xinv2; if(n.le.5)call print(x ,xinv1 ,xinv2 ,test1,test2); call print('Real Matrix is of order ',n:); call print('Max Error for LAPACK ', dmax(dabs(dtest-test1)):); call print('Max Error for LINPACK ', dmax(dabs(dtest-test2)):); call print('Sum Error for LAPACK ', sum(dabs(dtest-test1)):); call print('Sum Error for LINPACK ', sum(dabs(dtest-test2)):); call print('Sumsq Error for LAPACK ',sumsq(dtest-test1):); call print('Sumsq Error for LINPACK ',sumsq(dtest-test2):); cx=complex(x,dsqrt(dabs(x))); call gminv(cx,cxinv1,info); cxinv2=inv(cx); dc=complex(dtest,0.0); test1=cx*cxinv1; test2=cx*cxinv2; if(n.le.5)call print(cx,cxinv1,cxinv2,test1,test2); call print('Complex Matrix is of order ',n:); call print('Max Error for LAPACK real ', dmax(dabs(real(dc-test1))):); call print('Max Error for LINPACK real ', dmax(dabs(real(dc-test2))):); call print('Max Error for LAPACK imag ', dmax(dabs(imag(dc-test1))):); call print('Max Error for LINPACK imag ', dmax(dabs(imag(dc-test2))):); call print('Sum Error for LAPACK real ',sum(dabs(real(dc-test1))):); call print('Sum Error for LINPACK real ',sum(dabs(real(dc-test2))):); call print('Sum Error for LAPACK imag ',sum(dabs(imag(dc-test1))):); call print('Sum Error for LINPACK imag ',sum(dabs(imag(dc-test2))):); call print('Sumsq Error for LAPACK real ',sumsq(real(dc-test1)):); call print('Sumsq Error for LINPACK real ',sumsq(real(dc-test2)):); call print('Sumsq Error for LAPACK imag ',sumsq(imag(dc-test1)):); call print('Sumsq Error for LINPACK imag ',sumsq(imag(dc-test2)):); b34srun; == ==GMINV_2 Speed tests of LAPACK vs LINPACK b34sexec matrix; * Tests speed of Linpack vs LAPACK; call echooff; icount=0; n=0; upper=600; mesh=50; top continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done; x=rn(matrix(n,n:)); ii=matrix(n,n:)+1.; call timer(base1); call gminv(x,xinv1,info); call timer(base2); error1(icount)=sum(dabs(ii-(xinv1*x))); call timer(base3); xinv1=inv(x); call timer(base4); error2(icount)=sum(dabs(ii-(xinv1*x))); size(icount) =dfloat(n); lapack(icount) =(base2-base1); linpack(icount)=(base4-base3); call free(x,xinv1,ii) call compress; go to top; done continue; call tabulate(size,lapack,linpack,error1,error2); call graph(size lapack,linpack :plottype xyplot); b34srun; == ==GMINV_3 Speed tests for LAPACK vs LINPACK b34sexec matrix; * At 150 LINPACK is faster ; * At 300 and 600 LAPACK wins ; * For this reason the inv( ) command uses LINPACK; n=150; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call print('GM time',t2-t1); call compress; call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); call compress; n=300; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call print('GM time',t2-t1); call compress; call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); call compress; n=600; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call compress; call print('GM time',t2-t1); call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); b34srun; == ==GMINV_4 Tests of invert done different ways b34sexec matrix; call echooff; n=100; * test1 and test3 use LAPACK ; x=rn(matrix(n,n:)); * to show effect of balancing uncomment next statement; * x(1,)=x(1,)*100000.; call gminv(x,xinv1,info); xinv2=inv(x); xinv3=inv(x:gmat); j=inv(x,rcond:gmat); j=inv(x,rcond2); xinv4=inv(x,rcond3 :refine); xinv5=inv(x,rcond4 :refinee); dtest=matrix(n,n:)+1.0; test1=x*xinv1; test2=x*xinv2; test3=x*xinv3; test4=x*xinv4; test5=x*xinv5; if(n.le.5)call print(x ,xinv1 ,xinv2,xinv3 ,test1,test2,test3); call print('Matrix is of order ',n:); call print('LAPACK 3 => refine':); call print('LAPACK 4 => refinee':); call print('Max Error for LAPACK 1', dmax(dabs(dtest-test1)):); call print('Max Error for LAPACK 2', dmax(dabs(dtest-test3)):); call print('Max Error for LAPACK 3', dmax(dabs(dtest-test4)):); call print('Max Error for LAPACK 4', dmax(dabs(dtest-test5)):); call print('Max Error for LINPACK ', dmax(dabs(dtest-test2)):); call print('Sum Error for LAPACK 1', sum(dabs(dtest-test1)):); call print('Sum Error for LAPACK 2', sum(dabs(dtest-test3)):); call print('Sum Error for LAPACK 3', sum(dabs(dtest-test4)):); call print('Sum Error for LAPACK 4', sum(dabs(dtest-test5)):); call print('Sum Error for LINPACK ', sum(dabs(dtest-test2)):); call print('Sumsq Error for LAPACK 1',sumsq(dtest-test1):); call print('Sumsq Error for LAPACK 2',sumsq(dtest-test3):); call print('Sumsq Error for LAPACK 3',sumsq(dtest-test4):); call print('Sumsq Error for LAPACK 4',sumsq(dtest-test5):); call print('Sumsq Error for LINPACK ',sumsq(dtest-test2):); call print('rcond rcond2 rcond3,rcond4',rcond,rcond2,rcond3,rcond4); cx=complex(x,dsqrt(dabs(x))); call gminv(cx,cxinv1,info); cxinv2=inv(cx); cxinv3=inv(cx:gmat); cxinv4=inv(cx,rcond3 :refine); cxinv5=inv(cx,rcond4 :refinee); dc=complex(dtest,0.0); test1=cx*cxinv1; test2=cx*cxinv2; test3=cx*cxinv3; test4=cx*cxinv4; test5=cx*cxinv5; j=inv(x,rcond:gmat); j=inv(x,rcond2); if(n.le.5)call print(cx,cxinv1,cxinv2,cxinv3,test1,test2,test3); call print('Matrix is of order ',n:); call print('Max Error for LAPACK 1 real', dmax(dabs(real(dc-test1))):); call print('Max Error for LAPACK 2 real', dmax(dabs(real(dc-test3))):); call print('Max Error for LAPACK 3 real', dmax(dabs(real(dc-test4))):); call print('Max Error for LAPACK 4 real', dmax(dabs(real(dc-test5))):); call print('Max Error for LINPACK real', dmax(dabs(real(dc-test2))):); call print('Max Error for LAPACK 1 imag', dmax(dabs(imag(dc-test1))):); call print('Max Error for LAPACK 2 imag', dmax(dabs(imag(dc-test3))):); call print('Max Error for LAPACK 3 imag', dmax(dabs(imag(dc-test4))):); call print('Max Error for LAPACK 4 imag', dmax(dabs(imag(dc-test5))):); call print('Max Error for LINPACK imag', dmax(dabs(imag(dc-test2))):); call print('Sum Error for LAPACK 1 real',sum(dabs(real(dc-test1))):); call print('Sum Error for LAPACK 2 real',sum(dabs(real(dc-test3))):); call print('Sum Error for LAPACK 3 real',sum(dabs(real(dc-test4))):); call print('Sum Error for LAPACK 4 real',sum(dabs(real(dc-test5))):); call print('Sum Error for LINPACK real',sum(dabs(real(dc-test2))):); call print('Sum Error for LAPACK 1 imag',sum(dabs(imag(dc-test1))):); call print('Sum Error for LAPACK 2 imag',sum(dabs(imag(dc-test3))):); call print('Sum Error for LAPACK 3 imag',sum(dabs(imag(dc-test4))):); call print('Sum Error for LAPACK 4 imag',sum(dabs(imag(dc-test5))):); call print('Sum Error for LINPACK imag',sum(dabs(imag(dc-test2))):); call print('Sumsq Error for LAPACK 1 real',sumsq(real(dc-test1)):); call print('Sumsq Error for LAPACK 2 real',sumsq(real(dc-test3)):); call print('Sumsq Error for LAPACK 3 real',sumsq(real(dc-test4)):); call print('Sumsq Error for LAPACK 4 real',sumsq(real(dc-test5)):); call print('Sumsq Error for LINPACK real',sumsq(real(dc-test2)):); call print('Sumsq Error for LAPACK 1 imag',sumsq(imag(dc-test1)):); call print('Sumsq Error for LAPACK 2 imag',sumsq(imag(dc-test3)):); call print('Sumsq Error for LAPACK 3 imag',sumsq(imag(dc-test4)):); call print('Sumsq Error for LAPACK 4 imag',sumsq(imag(dc-test5)):); call print('Sumsq Error for LINPACK imag',sumsq(imag(dc-test2)):); call print('rcond rcond2 rcond3,rcond4',rcond,rcond2,rcond3,rcond4); b34srun; == ==GMSOLV Solution of equations system b34sexec matrix; n=6; x=rec(matrix(n,n:)); b=rec(x); call gmsolv(x,b,aa,info); call print(x,b,aa,inv(x)*b); call gmsolv(x,b,aa,info:refine); call print(x,b,aa,inv(x)*b); call print(%rcond,%ferror,%berror); call gmsolv(x,b,aa,info:refinee); call print(x,b,aa,inv(x)*b); call print(%rcond,%ferror,%berror); b34srun; == ==GMSOLV_2 Tests Various GMSOLV Options b34sexec matrix; /$ /$ Not clear that Refinement makes much difference /$ subroutine test(n); x=rn(matrix(n,n:)); x(1,)=100000.*x(1,); b=rn(x); call print('Matrix Order ',n:) call print('a => refine. ':); call print('b => refinee ':); call print(' ':); call gmsolv(x,b,test1,info); call gmsolv(x,b,test1a,info:refine); call print('refine case', %rcond,%ferror,%berror); call gmsolv(x,b,test1b,info:refinee); call print('refinee case',%rcond,%ferror,%berror); test2=inv(x)*b; diff =dabs(test1-test2); diffa=dabs(test1-test1a); diffb=dabs(test1-test1b); if(n.le.5)call print(x ,b ,test1,test2,diff,test1a,test1b,diffa,diffb); call print('Real Matrix Case ':); call print('max diff ',dmax(diff) :); call print('max diffa ',dmax(diffa):); call print('max diffb ',dmax(diffa):); call print('sumsq diff ',sumsq(diff) :); call print('sumsq diffa ',sumsq(diffa):); call print('sumsq diffb ',sumsq(diffa):); cx=complex(x,dsqrt(dabs(x))); cb=complex(b,dsqrt(dabs(b))); call gmsolv(cx,cb,test1,info); call gmsolv(cx,cb,test1a,info:refine); call print('refine case ',%rcond,%ferror,%berror); call gmsolv(cx,cb,test1b,info:refinee); call print('refinee case',%rcond,%ferror,%berror); test2=inv(cx)*cb; diff =dabs(test1-test2); diffa=dabs(test1-test1a); diffb=dabs(test1-test1b); if(n.le.5)call print(cx,test1,test2,diff,test1a,test1b,diffa,diffb); call print('Complex Case':); call print('max diff on real ', dmax(real(diff)) :); call print('max diff on imag ', dmax(imag(diff)) :); call print('max diffa on real ', dmax(real(diffa)):); call print('max diffa on imag ', dmax(imag(diffa)):); call print('max diffb on real ', dmax(real(diffb)):); call print('max diffb on imag ', dmax(imag(diffb)):); call print('sumsq diff on real ',sumsq(real(diff)): ); call print('sumsq diff on imag ',sumsq(imag(diff)): ); call print('sumsq diffa on real ',sumsq(real(diffa)):); call print('sumsq diffa on imag ',sumsq(imag(diffa)):); call print('sumsq diffb on real ',sumsq(real(diffb)):); call print('sumsq diffb on imag ',sumsq(imag(diffb)):); return; end; * above 5 only tests max difference and sumsq ; n=5; call test(n); call echooff; do i=50,250,50; call test(i); enddo; b34srun; == ==GOODCOL Test goodcol command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); b34srun; == ==GOODROW Test goodrow command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); b34srun; == ==GOTO Tests GOTO statement b34sexec matrix; /$ See also DOTEST4 for a bigger example do i=1,10; if(i.gt.7)go to n10; call print('I should be less than 7',i); n10 continue; enddo; b34srun; == ==GRANGER Calculate a Granger Test Statistic b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec reg; model gasout=gasout{1 to 10} gasin{1 to 10}; test gasout{1 to 10}; test gasin{1 to 10}; b34srun; b34sexec matrix; call echooff; call loaddata; call load(granger); n=9; call olsq(gasout gasout{1 to n} gasin{1 to n} :print); uss=%rss; k1=%k; call olsq(gasout gasin{1 to n} :print); rss=%rss; k2=%k; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasout causes gasout':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); call olsq(gasout gasout{1 to n} :print); rss=%rss; k2=%k; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasin causes gasout':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); /; MARS tests call marspline(gasout gasout{1 to n} gasin{1 to n} :nk 30 :print); uss=%rss; k1=%k; kk1=norows(%n_nzero); call marspline(gasout gasin{1 to n} :nk 30 :print); rss=%rss; k2=%k; kk2=norows(%n_nzero); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasout causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasin causes gasout':); call granger(uss,rss,%nob,kk1,kk2,teststat,probf,1); call marspline(gasout gasout{1 to n} :nk 30 :print); rss=%rss; k2=%k; kk2=norows(%n_nzero); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasin causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Tests using # of columns in knot matrix %xx':); call granger(uss,rss,%nob,kk1,kk2,teststat,probf,1); /; GAM tests call gamfit(gasout gasout[predictor,3]{1 to n} gasin[predictor,3]{1 to n} :print); uss=%rss; k1=%k; kk1=%k*3; call gamfit(gasout gasin[predictor,3]{1 to n} :print); rss=%rss; k2=%k; kk2=%k*3; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasout causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Tests using # DF correction':); call granger(uss,rss,%nob,kk1,kk2,teststat,probf,1); call gamfit(gasout gasout[predictor,3]{1 to n} :print); rss=%rss; k2=%k; kk2=norows(%n_nzero); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasin causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Tests using # of columns in knot matrix %xx':); call granger(uss,rss,%nob,kk1,kk2,teststat,probf,1); /; PPREG tests call ppreg(gasout gasout{1 to n} gasin{1 to n} :reg :m 30 :alpha .5 :print); uss=%rss; k1=%k; call ppreg(gasout gasin{1 to n} :m 30 :reg :alpha .5 :print); rss=%rss; k2=%k; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasout causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); call ppreg(gasout gasout{1 to n} :m 30 :reg :alpha .5 :print); rss=%rss; k2=%k; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasin causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); /; Random Forest Tests call ranforest(gasout gasout{1 to n} gasin{1 to n} :maxtree 30 :reg :print); uss=%rss; k1=%k; call ranforest(gasout gasin{1 to n} :maxtree 30 :reg :print); rss=%rss; k2=%k; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasout causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); call ranforest(gasout gasout{1 to n} :maxtree 30 :reg :print); rss=%rss; k2=%k; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Test if lag gasin causes gasout':); call print('Tests using # of potential Variables':); call granger(uss,rss,%nob,k1,k2,teststat,probf,1); b34srun; == ==GRANGER2 Illustrates rgranger command /; /; Illustrates quick way to perform Granger Tests /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call load(granger); call load(acf_plot); _lag=12; nacf=36; iprint=1; iplot=1; call print(' ':); call print('Analysis of gasout=f(gasout{1 to m} gasin{1 to m}':); call print(' ':); /; set time call settime(gasout,1,1,12.); call settime(gasin, 1,1,12.); call rgranger(gasout,gasin,y,x,uss,rss,_lag, teststat,k1,k2,probf,jj, acft,nacf,se,pacf,mq,mq2,max_data,min_data,iprint,iplot); call print(' ':); call print('Analysis of gasin=f(gasout{1 to m} gasin{1 to m}':); call print(' ':); /; set time call settime(gasout,1,1,12.); call settime(gasin, 1,1,12.); call rgranger(gasin,gasout,y,x,uss,rss,_lag, teststat,k1,k2,probf,jj, acft,nacf,pe,pacf,mq,mq2,max_data,min_data,iprint,iplot); b34srun; == ==GRAPH Call Graph => High Resolution Graphics b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin); call graph(gasout,gasin:nokey :heading 'Nokey option'); call graph(gasout gasin :colors bblue bred bgreen); call graph(gasin); call graph(gasout:plottype hist2d :heading 'Hist2d Plot' :ylabelpos .5 :ylabelleft 'This is a special label - 1 2 3 4 5 6' 'C9'); call graph(gasout :plottype hist3d :heading 'Hist3d Plot'); call graph(gasout :plottype hist3dc:heading 'Hist3dc Plot'); call graph(gasout :plottype bar2d :heading 'Bar2d Plot'); call graph(gasout :plottype bar2dc :heading 'Bar2dc Plot'); call graph(gasout :plottype Bar3d :heading 'Bar3d Plot'); call graph(gasout :plottype Bar3dc :heading 'Bar3dc Plot'); call print(ccf1); call graph(ccf1 :plottype hist2d); call graph(ccf1 :heading 'CCF1 '); call names; ccf1=ccf(gasin,gasout,24,lags); ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24,se); call graph(acf1,se:heading 'ACF and SE'); call tabulate(ccf1,ccf2,acf1,lags); * special pie chart graph ; n=namelist(houston diana Will bobby); weight=vector(4:198,130,165,200); call tabulate(n weight); call names; call graph(weight,n :plottype pie :heading 'Family Weight'); b34srun$ /$ shows time plot b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call names(all); year=getyear(bjulian_); call graph(year fms :plottype xyplot); b34srun; /$ Shows xyplot and xyscatter and scatter b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; x=array(4:1 20 3 4); y=array(4:4 3 2 1); z=2.*x; call graph(x y z :plottype xyplot :heading 'x y z using xyplot'); call graph(gasin,gasout :plottype xyscatter :markpoint 1 1 3 33 :nokey :heading 'gasin gasout xyscatter'); * move axis ; call graph(gasin,gasout :plottype xyscatter :markpoint 1 1 3 33 :nokey :pgborder :pgaxesxy array(2:min(gasin),min(gasout)) :heading 'gasin gasout xyscatter'); call graph(gasin,gasout :plottype scatter :markpoint 1 1 3 33 :nokey :heading 'gasin gasout scatter'); b34srun; == ==GRAPH1 Illustrates More Complex Settings b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasin :heading 'No Spline setting'); call graph(gasin :heading 'Spline setting' :fitspline); g1=gasout - 5.; g2=g1 - 5.; g3=g2 - 5.; g4=g3 - 5.; g5=g4 - 5.; g6=g5 - 5.; call graph(gasout g1 g2 g3 g4 g5 g6 :pspaceon :heading 'Shows all types of linetype & Proportional' :linetype solid dotted dashed dotdash dotdotdash longshort short :nokey); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 3 14' :markpoint 1 1 3 14); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 111' :markpoint 1 1 4 111); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 116' :markpoint 1 1 4 116); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 120' :markpoint 1 1 4 120); b34srun$ == ==GRAPH2 3-D Graphics Examples b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :grid :d3axis :d3border :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :grid :d3axis :d3border :angle 22.0 :rotation 25.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :grid :d3axis :d3border :angle 10.0 :rotation 90. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :grid :d3axis :d3border :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3d' :plottype stepped3d :grid :d3axis :d3border :angle 10.0 :rotation 70. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc - Default box' :plottype stepped3dc :grid :d3axis :d3border :angle 22.0 :rotation 130.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc grid=100' :box 100 :plottype stepped3dc :grid :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnk :Heading 'RES72 Data - plottype xyplot' :plottype xyplot :grid :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnl lnk :Heading 'RES72 Data - plottype xyzplot' :plottype xyzplot :grid :d3axis :d3border :angle 22.0 :rotation 180.); b34srun$ == ==GRAPH3 Makes a file of a graph /$ File illustrates saving a graph b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasout gasin :htitle 1.5 1.5 :heading 'Illustrates making a Graph in a file' :file 'junk.wmf'); b34srun$ == ==GRAPH4A View Matrix(100,100) in 3D b34sexec matrix; n=100; k=100; x=rn(matrix(n,k:)); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'This is the data'); call graph(x :plottype meshc :d3axis :d3border :heading 'The data as a surface'); x=transpose(x)*x; call graph(x :plottype mesh :d3axis :d3border :heading 'This is what transpose(x)*x is'); call graph(x :plottype meshc :d3axis :d3border :heading 'Transpose(x)*x in color!!'); call graph(x :plottype meshc :grid :d3axis :d3border :heading 'Transpose(x)*x in color with Grid'); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype meshc :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype mesh :rotation 90. :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshc :rotation 90. :grid :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshstep :rotation 70. :angle 10. :grid :heading 'Transpose(x)*x rotation 70. meshstep'); call graph(x :plottype meshstepc :rotation 70. :angle 30. :grid :d3axis :heading 'Trans(x)*x rotation 70. meshstepc angle 30.'); call graph(x :plottype meshstepc :rotation 70. :angle 0. :grid :heading 'Trans(x)*x rotation 70. meshstepc angle 0.'); b34srun; == ==GRAPH4B View Alternative size Materices b34sexec matrix; do i=2,6,2; n=50; x=rn(matrix(n,i:)); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'This is the data'); call graph(x :plottype meshc :d3axis :d3border :heading 'The data as a surface'); x=transpose(x)*x; call graph(x :plottype mesh :d3axis :d3border :heading 'This is what transpose(x)*x is'); call graph(x :plottype meshc :d3axis :d3border :heading 'Transpose(x)*x in color!!'); call graph(x :plottype meshc :grid :d3axis :d3border :heading 'Transpose(x)*x in color with Grid'); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype meshc :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype mesh :rotation 90. :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshc :rotation 90. :grid :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshstep :rotation 70. :angle 10. :grid :heading 'Transpose(x)*x rotation 70. meshstep'); call graph(x :plottype meshstepc :rotation 70. :angle 30. :grid :d3axis :heading 'Trans(x)*x rotation 70. meshstepc angle 30.'); call graph(x :plottype meshstepc :rotation 70. :angle 0. :grid :heading 'Trans(x)*x rotation 70. meshstepc angle 0.'); enddo; b34srun; == ==GRAPH5A View 3-D Matrix in a Volume Plot b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :Heading 'Data looked at as a 1-D array'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 10. :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 30. :scale :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.' ); vel=vel+100.; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); b34srun; == ==GRAPH5B View Slices of 3-D Volume Plot b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); velhold=vel; nn=35*41; dd=missing(); do i=15,4,-1; iii=index(35,41,15:1,1,i); jj=integers(1,nn)+iii-1; vel(jj)=dd; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 20. :heading 'Vol3dc plot of Wind Vel Cut Away'); enddo; vel=velhold; * here we make box smaller ; do i=15,12,-1; vel2=velhold(integers(1,(35*41*i))); call graph(vel2 :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,i) :angle 20. :rotation 0.0 :heading 'Vol3dc plot of Wind Vel.'); enddo; b34srun; == ==GRAPH6 ACF / Overlay Plots b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; acf1=acf(gasout,24,se1,pacf1); call graph(acf1,pacf1 :nokey :heading 'ACF & PACF of Gasout'); call graph(acf(dif(gasout),24) :Heading 'ACF of Gasout(1-B)'); call graph(acf(dif(gasout,2,1),24) :heading 'ACF of Gasout(1-B)**2'); acf2=acf(gasin,24,se2,pacf2); call graph(acf2,pacf2 :nokey :heading 'ACF & PACF of Gasin'); call graph(acf1,SE1 :nokey :heading 'ACF and SE of ACF of Gasout'); i=integers(24); call tabulate(i,acf1,acf2,se1,se2,pacf1,pacf2); call print('ACF, SE, PACF, Modified Q Prob Q for gasin':); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call tabulate(acf2,se2,pacf2,mq2,pmq2); call graph(acf2,pmq2); call graph(acf2 se2 :overlay acfplot /$ /$ Un comment next line to get a hard copy /$ :file 'testacf.wmf' :heading 'Overlay plot of ACF of gasin'); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :heading 'ACF of Random series'); call graph(acf2,se2 :overlay acfplot :heading 'ACF of rn(1-B)'); call graph(acf3,se3 :overlay acfplot :heading 'ACF of rn(1-B)**2'); b34srun$ == ==GRAPH7 Illustrates fonts/Character Sets b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasout :heading 'This is the current default'); call graph(gasout :heading 'This is a standard.chr' :grcharset 'standard.chr'); call grcharset('H'); call graph(gasout :heading 'This is a test 1' :pspaceon :grcharfont 1 :file 't1.wmf'); call graph(gasout :heading 'This is a test 2' :grcharfont 2 :file 't2.wmf'); call graph(gasout :heading 'This is a test 3' :grcharfont 3 :file 't3.wmf'); call graph(gasout :heading 'This is a test 4' :grcharfont 4 :file 't4.wmf'); call graph(gasout :heading 'This is a test 5' :grcharfont 5 :file 't5.wmf'); call graph(gasout :heading 'This is a test 6' :grcharfont 6 :file 't6.wmf'); call graph(gasout :heading 'This is a test 7' :grcharfont 7 :file 't7.wmf'); call graph(gasout :heading 'This is a test 8' :grcharfont 8 :file 't8.wmf'); call graph(gasout :heading 'This is a test roman.chr' :grcharset 'roman.chr'); call graph(gasout :heading 'This is a test romanbld.chr' :grcharset 'romanbld.chr'); call graph(gasout :heading 'This is a test swiss.chr' :grcharset 'swiss.chr'); call graph(gasout :heading 'This is a test swissbld.chr' :grcharset 'swissbld.chr'); call graph(gasout :heading 'This is a test fixed.chr' :grcharset 'fixed.chr'); call graph(gasout :heading 'This is a test fixedbld.chr' :grcharset 'fixedbld.chr'); call graph(gasout :heading 'This is a test simplexr.chr' :grcharset 'simplexr.chr'); call graph(gasout :heading 'This is a test duplexr.chr' :grcharset 'duplexr.chr'); call graph(gasout :heading 'This is a test triplexr.chr' :grcharset 'triplexr.chr'); call graph(gasout :heading 'This is a test complexr.chr' :grcharset 'complexr.chr'); call graph(gasout :heading 'This is a test H' :grcharset 'H'); call graph(gasout :heading 'This is a test complexi.chr' :grcharset 'complexi.chr'); call graph(gasout :heading 'This is a test triplexi.chr' :grcharset 'triplexi.chr'); call graph(gasout :heading 'This is a test simplexs.chr' :grcharset 'simplexs.chr'); call graph(gasout :heading 'This is a test complexs.chr' :grcharset 'complexs.chr'); call graph(gasout :heading 'This is a test simplexg.chr' :grcharset 'simplexg.chr'); call graph(gasout :heading 'This is a test complexg.chr' :grcharset 'complexg.chr'); call graph(gasout :heading 'This is a test complexc.chr' :grcharset 'complexc.chr'); call graph(gasout :heading 'This is a test gothicen.chr' :grcharset 'gothicen.chr'); call graph(gasout :heading 'This is a test gothicit.chr' :grcharset 'gothicit.chr'); call grcharset(' '); b34srun; == ==GRAPH8 Histograms and Bar Graphs b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); n=6; mn=-1*n; ccf1=dabs(ccf(gasin gasout,n)); tt=dfloat(integers(mn,n)); call print(tt); call graph(ccf1 :plottype hist2d :histscale 0*integers(1,13) :xscale tt :heading 'Hist2d Plot nothing on axis'); call graph(ccf1 :plottype hist2d :histscale integers(1,13) :xscale tt :heading 'Hist2d Plot with every axis'); call graph(ccf1 :plottype hist2d :xscale tt :heading 'Hist2d Plot with default axis'); call graph(ccf1 tt :plottype hist2dv :heading 'Hist2dv Plot' :nokey); call graph(ccf1 :plottype bar2d :heading 'Bar2d Plot using default'); call graph(ccf1 :plottype bar2d :barscale 0*integers(1,13) :heading 'Bar2d Plot nothing on axis'); call graph(ccf1 :plottype bar2d :barscale integers(1,13) :heading 'Bar2d Plot every axis'); call graph(ccf1 tt :plottype bar2dv :heading 'Bar2dv Plot' :nokey); b34srun; == ==GRAPH10 Custom plot settings /; /; Advanced Graphics settings /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call graph(gasout :heading 'Change in G4 Test ' :xlabelpos .74 :xlabeltop 'Change top Test ' 'C' :xlabel 'Obs Dropped' :pgborder :nocontact :ylabelpos .5 :ylabelleft 'll ' 'c9' :ylabelright 'rr ' 'c9' :file 'g4dif.wmf' ); b34srun; == ==GRAPH11 obsplot-timeplot-obsplotb-timeplotb b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnrm2 :plottype obsplot :heading 'Obs Plot'); call graph(lnrm2 :plottype timeplot :heading 'Timeplot'); i=integers(50,norows(lnrm2)); lnrm2(i)=missing(); lnrm2=goodrow(lnrm2); s=variance(lnrm2); top=lnrm2+ 2.*sqrt(s); bot=lnrm2- 2.*sqrt(s); call graph(lnrm2 bot top :plottype obsplotb :heading 'obsplotb'); call graph(lnrm2 bot top :plottype timeplotb :heading 'timeplotb'); b34srun; == ==GRAPHP Graph Program Command b34sexec matrix; call grcharset('H'); y=rn(array(20:)); yhat=rn(array(4:)); error=dfloat(integers(4))/2.; se =error+yhat; se2 =yhat - error; call character(title,'Test Forecast Plot'); call load(forplot); call print(forplot); /$ Graph using graph call graph(y :pgborder :heading 'graph command' :htitle 2. 2. :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :colors black bred ); /$ Foreplot using graphp call forplot(y,yhat,se,se2,title,' '); b34srun; /$ /$ Here we add to the graph with the toolbox /$ b34sexec matrix; call graphp(:start); call graphp(:cont :grarea array(:0. 0. 1. 1.) :grunits array(:0. 0. 100. 100.) :pgarea array(:.1 .1 .9 .9) :pgunits array(:0. 0. 100. 100.) :color red :pgborder :charjustify l /$ :charrotate 60. /$ :chardirection v /$ xpos ypos in range 0. - 100. :charout array(:1. 60.) 'This is at 1. 60.' :grcharset 'fixedbld.chr' :charoutrel 'Line 2! at fixedbld.chr' :grcharset ' ' :charout array(:1. 30.) 'This is at 1. 30.' :color bblue :pginfo :graphpvocab :grfillpattern index( 1 1 1) :grrectangle array(: 50. 50. 60. 80.) :grtriangle array(:30. 30. 60. 80. 90. 10.) :grcircle array(:50. 50. 10.) :toolbox ); call graphp(:final); b34srun; == ==GRAPHP2 Tests Drawing /$ Can modify this code to pass data to graphp b34sexec matrix; call graphp(:start); call graphp(:cont :grarea array(:0. 0. 1. 1.) :grunits array(:0. 0. 1. 1.) :color red :toolbox ); call graphp(:final); b34srun; == ==GRAPHP3 Illustrates graphp b34sexec matrix; call echooff; /; call getsca('Findat01.mad' :mad :member D_AA); call getsca('c:\b34slm\examples\findat01.mad' :mad :member D_AA); YMean=Mean(D_AA); YSigma2=Variance(D_AA-YMean); call garchest(res1, res2, D_AA,func,1,nbad :cparms array(:YMean, YSigma2) :garorder idint(array(:1)) :gmaorder idint(array(:1)) :print ); _sqrmat=array(dmax1(norows(res1),norows(res2)),2:); _sqrmat(,1)=res1; _sqrmat(,2)=res2; _sqrmat =goodrow(_sqrmat); res1=_sqrmat(,1); res2=_sqrmat(,2); Residual=goodrow(res1); Sigma=goodrow(dsqrt(goodrow(res2))); et=Residual/Sigma; x=et; /; data in variable x ibars=13 ; /; Automatic calculation not used. /; call datafreq(x _table :equal ibars midpts); /; This forces the midpoints to be -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 upper= 5.5; lower=-5.5; call datafreq(x _table :equaluser ibars midpts lower upper); call tabulate(_table midpts); call character(cc,'Default plot '); call graph(_table :plottype hist2d :heading cc :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :colors black bblue bred ); /; we set range of x axis and y axis. /; By defining xmax2 etc it allows a fudge as has been done with ymax2 /; Note that datafreq gives us the exact midpoints of each rectangle xmax=dmax(x); xmin=dmin(x); /; xmax2=xmax; /; xmin2=xmin; xmax2= 6.5; xmin2=-6.5; ymin2=0.0; ymax2=dmax(_table)+(dmax(_table)/20.); uscale=midpts; /; Make sure no rectangles are 0.0 height. We add a "fudge" /; testing xmin=lower; do ii=1,norows(_table); if(_table(ii).le.0.0)_table(ii)=.1e-4; enddo; call graphp(:start :file '_table.wmf'); call graphp(:cont :grarea array(:0.0 0.0 1. 1.) :grunits array(: 1. xmin2 xmax2 dfloat(norows(_table)) ) :pgarea array(: .1 .1 .9 .9) :pgunits array(: xmin2 ymin2 xmax2 ymax2) :pgborder :pspaceon :xscale uscale :pgxscale 'TN' :pgyscaleleft 'n' :xlabel 'Distribution of Standardized Residual' :ylabelleft '# of Cases' /; :ylabelleft '# of Cases' 'Cr' /; :ylabelleft '# of Cases' 'C9' :heading 'This is a test histogram' :pgnewgraph index(1,norows(_table)) array(:' ' ' ' 'H') :pgstyle index(1,4,0,0,icolor(green),icolor(black)) :pghistogram _table ); call graphp(:final); /; Quick see what we have!! call grreplay('_table.wmf'); b34srun; == ==GRAPHTEST Full Test of Graph Options /$ Master Graph Test b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin); call graph(gasout,gasin:nokey :heading 'Nokey & grid option' :grid); call graph(gasout gasin :colors bblue bred bgreen); call graph(gasin); call graph(gasout:plottype hist2d :heading 'Hist2d Plot' :ylabelpos .5 :ylabelleft 'This is a special label - 1 2 3 4 5 6' 'C9'); call graph(gasout:plottype hist3d :heading 'Hist3d Plot' ); call graph(gasout:plottype hist3dc:heading 'Hist3dc Plot'); call graph(gasout:plottype bar2d :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dv :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dc :heading 'Bar2dc Plot'); call graph(gasout:plottype Bar3d :heading 'Bar3d Plot'); call graph(gasout:plottype Bar3dc :heading 'Bar3dc Plot'); call print(ccf1); call graph(ccf1 :plottype hist2d); call graph(ccf1 :heading 'CCF1 '); call names; ccf1=ccf(gasin,gasout,24,lags); ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24,se); call graph(acf1,se:heading 'ACF and SE'); call tabulate(ccf1,ccf2,acf1,lags); * special pie chart graph ; n=namelist(houston diana Will bobby); weight=vector(4:198,130,165,200); call tabulate(n weight); call names; call graph(weight,n :plottype pie :heading 'Family Weight'); b34srun$ /$ shows time plot b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call names(all); year=getyear(bjulian_); call graph(year fms :plottype xyplot); b34srun; b34sexec matrix; /$ Problems in Economics 322 developed by Houston Stokes /$ TR-TC q=grid(0.,40.,.1); tr = 250.*q - 3.*q**2.; tc = 1500. + 50.*q + 2.*q**2.; profit=tr-tc; call graph(q,profit :plottype xyplot); call graph(q,tr,tc :plottype xyplot); call print(q,tr,tc); b34srun; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasin :heading 'No Spline setting'); call graph(gasin :heading 'Spline setting' :fitspline); g1=gasout - 5.; g2=g1 - 5.; g3=g2 - 5.; g4=g3 - 5.; g5=g4 - 5.; g6=g5 - 5.; call graph(gasout g1 g2 g3 g4 g5 g6 :pspaceon :heading 'Shows all types of linetype & Proportional' :linetype solid dotted dashed dotdash dotdotdash longshort short :nokey); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 3 14' :markpoint 1 1 3 14); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 111' :markpoint 1 1 4 111); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 116' :markpoint 1 1 4 116); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 120' :markpoint 1 1 4 120); b34srun$ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :angle 22.0 :rotation 25.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :angle 10.0 :rotation 90. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :d3axis :d3border :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3d' :plottype stepped3d :d3axis :d3border :angle 10.0 :rotation 70. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc - Default box' :plottype stepped3dc :d3axis :d3border :angle 22.0 :rotation 130.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc grid=100' :box 100 :plottype stepped3dc :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnk :Heading 'RES72 Data - plottype xyplot' :plottype xyplot :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnl lnk :Heading 'RES72 Data - plottype xyzplot' :plottype xyzplot :d3axis :d3border :angle 22.0 :rotation 180.); b34srun$ b34sexec matrix; n=100; k=20; x=rn(matrix(n,k:)); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'This is the data'); call graph(x :plottype meshc :heading 'The data as a surface'); x=transpose(x)*x; call graph(x :plottype mesh :heading 'This is what transpose(x)*x is'); call graph(x :plottype meshc :heading 'Transpose(x)*x in color!!'); call graph(x :plottype meshc :grid :heading 'Transpose(x)*x in color with Grid'); call graph(x :plottype mesh :angle 10. :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype meshc :angle 10. :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype mesh :rotation 90. :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshc :rotation 90. :grid :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshstep :rotation 70. :angle 10. :grid :heading 'Transpose(x)*x rotation 70. meshstep'); call graph(x :plottype meshstepc :rotation 70. :angle 30. :grid :d3axis :heading 'Trans(x)*x rotation 70. meshstepc angle 30.'); call graph(x :plottype meshstepc :rotation 70. :angle 0. :grid :heading 'Trans(x)*x rotation 70. meshstepc angle 0.'); b34srun; b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :Heading 'Data looked at as a 1-D array'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 10. :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 30. :scale :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.' ); vel=vel+100.; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); b34srun; b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); velhold=vel; nn=35*41; dd=missing(); do i=15,4,-1; iii=index(35,41,15:1,1,i); jj=integers(1,nn)+iii-1; vel(jj)=dd; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 20. :heading 'Vol3dc plot of Wind Vel Cut Away'); enddo; vel=velhold; * here we make box smaller ; do i=15,12,-1; vel2=velhold(integers(1,(35*41*i))); call graph(vel2 :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,i) :angle 20. :rotation 0.0 :heading 'Vol3dc plot of Wind Vel.'); enddo; b34srun; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; acf1=acf(gasout,24,se1,pacf1); call graph(acf1,pacf1 :nokey :heading 'ACF & PACF of Gasout'); call graph(acf(dif(gasout),24) :Heading 'ACF of Gasout(1-B)'); call graph(acf(dif(gasout,2,1),24) :heading 'ACF of Gasout(1-B)**2'); acf2=acf(gasin,24,se2,pacf2); call graph(acf2,pacf2 :nokey :heading 'ACF & PACF of Gasin'); call graph(acf1,SE1 :nokey :heading 'ACF and SE of ACF of Gasout'); i=integers(24); call tabulate(i,acf1,acf2,se1,se2,pacf1,pacf2); call print('ACF, SE, PACF, Modified Q Prob Q for gasin':); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call tabulate(acf2,se2,pacf2,mq2,pmq2); call graph(acf2,pmq2); call graph(acf2 se2 :overlay acfplot /$ /$ Un comment next line to get a hard copy /$ :file 'testacf.wmf' :heading 'Overlay plot of ACF of gasin'); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :heading 'ACF of Random series'); call graph(acf2,se2 :overlay acfplot :heading 'ACF of rn(1-B)'); call graph(acf3,se3 :overlay acfplot :heading 'ACF of rn(1-B)**2'); b34srun$ == ==GRAPHTEST2 Advanced Graph Scale Tests /$ Master Graph Test for advanced features - Graphtest2 b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin :heading 'Base case'); call graph(gasout,gasin :heading 'Base case pgaxesxy 0. 20.' :pgaxesxy array(:0. 20.)); call graph(gasout,gasin :heading 'Base case with :pgborder' :pgborder); call graph(gasout,gasin :heading 'Base case with :pgborder xscaletop yscaleright' :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder); call graph(gasout,gasin :heading 'Base case with :pgborder' :pgborder); call graph(gasout,gasin :LINEWIDTH INDEX(2,2) :heading 'linewidth index(2,2)'); call graph(gasout,gasin :xscale array(:0.,20. 50.) :heading 'using xscale array(:0.,20. 50.)'); call graph(gasout,gasin :yscale array(:0.,25. 50.) :heading 'using yscale array(:0.,25. 50.)'); call graph(gasout,gasin :setxscale array(:0.,10.) :nxticks 5 :heading 'using setxscale 0. 10 nxticks 5'); call graph(gasout,gasin :setyscale array(:0.,10.) :nyticks 4 :heading 'using setyscale 0. 10 nyticks 4'); call graph(gasout,gasin :setxrange array(:0.,100.) :heading 'using setxrange 0. 100.'); call graph(gasout,gasin :setyrange array(:0.,100.) :heading 'using setyrange 0. 100.'); call graph(ccf1 :plottype hist2d :heading 'base case'); call graph(ccf1 :plottype hist2d :histscale index(4 8 12) :heading 'histscale index(4 8 12)'); call graph(ccf1 :plottype bar2d :heading 'base case'); call graph(ccf1 :plottype bar2d :barscale index(4 8 12) :heading 'barscale index(4 8 12)'); acf1=acf(gasout,24,se1,pacf1); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call graph(acf2 se2 :overlay acfplot :heading 'base case'); call graph(acf2 se2 :overlay acfplot :heading 'Tests histscale index(4 8 12 16)' :histscale index(4 8 12 16) ); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(acf2 :overlay acfplot :pgborder :heading 'Just plot of ACF of gasin with pgborder'); call graph(acf2 se2 :overlay acfplot :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :heading 'ACF + se2 with pgborder and ticks') call graph(pacf2 se2 :overlay acfplot3d :histscale index(4 8 12 16) :heading '3D Overlay histscale index(4 8 12 16)'); call graph(acf2 :overlay acfplot :histscale index(4 8 12 16) :heading 'Just plot of ACF histscale index(4 8 12 16)'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :pgborder :pgxscaletop 'i' :pgyscaleright 'in' :heading 'ACF of Random series numbers on right'); call graph(acf2,se2 :overlay acfplot :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :heading 'ACF of rn(1-B) ticks and border' ); call graph(acf3,se3 :overlay acfplot :pgxscaletop 'i' :pgyscaleright 'i' :heading 'ACF of rn(1-B)**2 no border but ticks'); b34srun$ b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin); call graph(gasout,gasin:nokey :heading 'Nokey option'); call graph(gasout gasin :colors bblue bred bgreen); call graph(gasin); call graph(gasout:plottype hist2d :heading 'Hist2d Plot' :ylabelpos .5 :ylabelleft 'This is a special label - 1 2 3 4 5 6' 'C9'); call graph(gasout:plottype hist3d :heading 'Hist3d Plot' ); call graph(gasout:plottype hist3dc:heading 'Hist3dc Plot'); call graph(gasout:plottype bar2d :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dv :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dc :heading 'Bar2dc Plot'); call graph(gasout:plottype Bar3d :heading 'Bar3d Plot'); call graph(gasout:plottype Bar3dc :heading 'Bar3dc Plot'); call print(ccf1); call graph(ccf1 :plottype hist2d); call graph(ccf1 :heading 'CCF1 '); call names; ccf1=ccf(gasin,gasout,24,lags); ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24,se); call graph(acf1,se:heading 'ACF and SE'); call tabulate(ccf1,ccf2,acf1,lags); * special pie chart graph ; n=namelist(houston diana Will bobby); weight=vector(4:198,130,165,200); call tabulate(n weight); call names; call graph(weight,n :plottype pie :heading 'Family Weight'); b34srun$ /$ shows time plot b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call names(all); year=getyear(bjulian_); call graph(year fms :plottype xyplot); b34srun; /$ Shows xyplot and xyscatter and scatter b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; x=array(4:1 20 3 4); y=array(4:4 3 2 1); z=2.*x; call graph(x y z :plottype xyplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'x y z using xyplot'); call graph(gasin,gasout :plottype xyscatter :markpoint 1 1 3 33 :nokey :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'gasin gasout xyscatter'); call graph(gasin,gasout :plottype scatter :markpoint 1 1 3 33 :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :nokey :heading 'gasin gasout scatter'); call graph(x y z :plottype xyplot :nocontact :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'x y z using xyplot nocontact'); call graph(gasin,gasout :plottype xyscatter :nocontact :markpoint 1 1 3 33 :nokey :pgxscaletop 'I' :pgyscaleleft 'NI' :pgyscaleright 'NI' :nolabel :pgborder :heading 'gasin gasout xyscatter nocontact'); call graph(gasin,gasout :plottype scatter :nocontact :markpoint 1 1 3 33 :nokey :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'gasin gasout scatter nocontact'); b34srun; == ==GRAPHTEST3 Illustrate various Graph Settings b34sexec options ginclude('gas.b34'); b34srun; /$ /$ Illustrating various GRAPH settings /$ This will not run on Linux / Unixc with out name changes /$ b34sexec matrix; call loaddata; call getsca('c:\b34slm\examples\fcst.fsv'); call names; * call tabulate(appl_tv fcst se); year=dfloat(integers(norows(fcst))); call names(all); y1=dmin(fcst)-600.; y2=dmax(fcst)+600.; call graph(year fcst :plottype xyplot :heading 'No setrange - xyplot' :pgborder :pgxscaletop 'I' :pgyscaleright 'I' ); call graph(year fcst :heading 'Manual mode setting of x & y range' :plottype xyplot :pgborder :markpoint 1 1 4 218 :pgxscaletop 'I' :pgyscaleright 'I' :setyrange array(:y1 y2) :setxrange array(:0.0 25.)); call graph( fcst :nocontact :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :heading 'nocontact setting - default plot'); /$ This is the way to plot a time series with graph year=year+1900.; call graph(year fcst :plottype xyplot :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :heading 'xyplot 1901..'); call graph(year fcst :nocontact :plottype xyplot :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :heading 'xyplot default :nocontact setting 1901...'); call graph(year fcst :plottype xyplot :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :heading 'xyplot 1901..'); nn=dfloat(integers(norows(gasout))); call graph( gasout gasin :heading 'Nocontact setting' :nocontact /$ :plottype xyplot :markpoint 1 1 4 162 :pgborder :pgxscaletop 'I' :pgyscaleright 'I' /$ :setyrange array(:y1 y2) /$ :setxrange array(:0. dfloat(norows(gasin)+1 )) ); call graph( gasout gasin :heading 'Nocontact setting' :nocontact :pgborder :pgxscaletop 'I' :pgyscaleright 'I' ); b34srun; == ==GRAPHTEST4 + and - Graphs b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; yl=gasout-5.; yu=gasout+5.; call graph(gasout yl yu :heading 'Y +- 5.' ); call graph(gasout yl yu :plottype obsplotb :heading 'Y +- 5.' ); b34srun; == ==GRCHARSET Reset Charset b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call grcharset('H'); call graph(gasout :heading 'This is a test 1'); call grcharset('triplexr.chr'); call graph(gasout :heading 'This is a test 2'); call grcharset(' '); b34srun; == ==GRID Tests GRID command b34sexec matrix; g=grid(-2.0,2.0,.1); call print(g); ii=.1; x=grid(0.0, pi(),ii); call print(x,pi()); * 2 argument version ; x=grid(0.0, pi()); call print(x,pi()); b34srun$ == ==GRREPLAY Replay Graph files b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call graph(gasout :file 'p1.hp1' :hardcopyfmt HP_GL2); call graph(gasin :file 'p2.hp1' :hardcopyfmt HP_GL2); call grreplay('p1.hp1','p2.hp1'); call grreplay('p1.hp1','p2.hp1' :file 'new.wmf' :hardcopyfmt wmf); call grreplay('new.wmf'); call grreplay('p1.hp1','p2.hp1' :file ' ' :hardcopyfmt wmf); b34srun; == ==GRREPLAY_2 Replay Graph files using advanced commands b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnk :file 'p1.hp1' :heading 'lnk hp_GL2' :nocontact :pgborder :pgxscaletop 'T' :pgyscaleright 'T' :noshow :hardcopyfmt HP_GL2 ); call graph(lnl :file 'p2.hp1' :heading 'lnl HP_GL2' :nocontact :pgborder :pgxscaletop 'T' :pgyscaleright 'T' :noshow :hardcopyfmt HP_GL2 ); call graph(lnrm1 :file 'p3.hp1' :heading 'Real M1 HP_GL2' :nocontact :pgborder :pgxscaletop 'T' :pgyscaleright 'T' :noshow :hardcopyfmt HP_GL2 ); call grreplay('p1.hp1' 'p2.hp1' 'p3.hp1' ); call grreplay(:start :file 'mythree.wmf' :hardcopy wmf); call grreplay(:cont 'p1.hp1' :gformat threegraphv 1); call grreplay(:cont 'p2.hp1' :gformat threegraphv 2); call grreplay(:cont 'p3.hp1' :gformat threegraphv 3); 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); call grreplay(:start); call grreplay(:cont 'p1.hp1' :gformat threegraphv 1); call grreplay(:cont 'p2.hp1' :gformat threegraphv 2); call grreplay(:cont 'p3.hp1' :gformat threegraphv 3); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'p1.hp1' :gformat threegraphh 1); call grreplay(:cont 'p2.hp1' :gformat threegraphh 2); call grreplay(:cont 'p3.hp1' :gformat threegraphh 3); call grreplay(:final); call graph(lnq :heading 'Ln Q' :file 'plot1.wmf' :noshow); call graph(lnl :heading 'Ln L' :file 'plot2.wmf' :noshow); call graph(lnk :heading 'Ln k' :file 'plot3.wmf' :noshow); call graph(lnrm1 :heading 'Ln rm1' :file 'plot4.wmf' :noshow); call graph(lnrm2 :heading 'Ln rm2' :file 'plot5.wmf' :noshow); call graph(P :heading 'P ' :file 'plot6.wmf' :noshow); call graph(m1 :heading 'M1 ' :file 'plot7.wmf' :noshow); call graph(m2 :heading 'M2 ' :file 'plot8.wmf' :noshow); call graph(L :heading 'L ' :file 'plot9.wmf' :noshow); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat onegraph 1); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat twograph 1); call grreplay(:cont 'plot2.wmf' :gformat twograph 2); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat fourgraph 1); call grreplay(:cont 'plot2.wmf' :gformat fourgraph 2); call grreplay(:cont 'plot3.wmf' :gformat fourgraph 3); call grreplay(:cont 'plot4.wmf' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat ninegraph 1); call grreplay(:cont 'plot2.wmf' :gformat ninegraph 2); call grreplay(:cont 'plot3.wmf' :gformat ninegraph 3); call grreplay(:cont 'plot4.wmf' :gformat twograph 2); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat ninegraph 1); call grreplay(:cont 'plot2.wmf' :gformat ninegraph 2); call grreplay(:cont 'plot3.wmf' :gformat ninegraph 3); call grreplay(:cont 'plot4.wmf' :gformat ninegraph 4); call grreplay(:cont 'plot5.wmf' :gformat ninegraph 5); call grreplay(:cont 'plot6.wmf' :gformat ninegraph 6); call grreplay(:cont 'plot7.wmf' :gformat ninegraph 7); call grreplay(:cont 'plot8.wmf' :gformat ninegraph 8); call grreplay(:cont 'plot9.wmf' :gformat ninegraph 9); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat ninegraph 1); call grreplay(:cont 'plot2.wmf' :gformat ninegraph 2); call grreplay(:cont 'plot3.wmf' :gformat ninegraph 3); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat ninegraph 1); call grreplay(:cont 'plot2.wmf' :gformat ninegraph 4); call grreplay(:cont 'plot3.wmf' :gformat ninegraph 7); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat ninegraph 2); call grreplay(:cont 'plot2.wmf' :gformat ninegraph 5); call grreplay(:cont 'plot3.wmf' :gformat ninegraph 8); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat onegraph 1 :zoom array(:.33333 .33333 .66666 .66666)); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :area array(:.33333 .33333 .66666 .66666) :zoom array(:.33333 .33333 .66666 .66666)); call grreplay(:final); b34srun; == ==GRREPLAY_3 Quick way to put 2-3 plots together and save /; /; Quick way to put 2-3 plots together and save /; Plot also viewed. /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnk :file 'p1.hp1' :heading 'lnk hp_GL2' :nocontact :pgborder :pgxscaletop 'T' :pgyscaleright 'T' :noshow :plottype timeplot :hardcopyfmt HP_GL2 ); call graph(lnl :file 'p2.hp1' :heading 'lnl HP_GL2' :nocontact :pgborder :pgxscaletop 'T' :pgyscaleright 'T' :noshow :plottype timeplot :hardcopyfmt HP_GL2 ); call graph(lnrm1 :file 'p3.hp1' :heading 'Real M1 HP_GL2' :nocontact :pgborder :pgxscaletop 'T' :pgyscaleright 'T' :noshow :plottype timeplot :hardcopyfmt HP_GL2 ); call grreplay('p1.hp1' 'p2.hp1' 'p3.hp1' :file 'my3.wmf' :hardcopyfmt wmf ); call grreplay('my3.wmf'); b34srun; == ==GR_TFLASH Tests for flash with hardcopy output b34sexec options ginclude('gas.b34'); b34srun; /$ Try to remove flash!!!! b34sexec matrix; call loaddata; do i=1,10; call graph(gasout :file 'p1.hp1' :noshow :hardcopyfmt HP_GL2); call graph(gasin :file 'p2.hp1' :noshow :hardcopyfmt HP_GL2); enddo; b34srun; == ==GTEST Tests outfrom a ARCH / GARCH Model /$ /$ Joint GARCH Estimation using GARCHEST Subroutine /$ RATS used to test results. /$ %b34slet dorats=0; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; call loaddata; call load(gtest); arch=array(norows(gasout):); call olsq(gasout gasout{1} gasout{2} :print); call print('RESVAR',%resvar :); call garchest(res,arch,gasout,func,2,n :cparms array(2:%coef(3), %resvar) :nar 2 :arparms array(2: %coef(1) %coef(2)) :ngar 1 :ngma 1 :gmaparms array(:.05) :print ); call tabulate(%resobs,res,arch); call gtest(res,arch,gasout,48); b34srun; %b34sif(&dorats.ne.0)%then; /$ /$ BHHH method used .. residuals set to 0 for beginning obs /$ /$ User must replace GASOUT with user series name /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin b0 b1 b2 a0 a1 beta1 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} frml garchvar = a0+a1*u11{1}**2 + $ beta1 * %if(v11{1}>1.e+100,%na,v11{1}) frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) linreg seriesn # constant seriesn{1} seriesn{2} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 3 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 3 * smpl(series=u11) statistics u11 set rssg11 = u11(t)*u11(t) statistics rssg11 smpl(series=rssg11) compute sumsqu11 = %sum(rssg11) display 'sum of squares of u11 for garch' sumsqu11 b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==GWRITE Saves Series in a GAUSS Format b34sexec matrix; call load(gwrite); call open(70,'testdata'); y=array(2,2:1 2 3 4); xx=rn(matrix(5,5:)); nn=namelist(y); call gwrite(y,nn,70); nn=namelist(xx); call gwrite(xx,nn,70); i=integers(1,23); ii=namelist(i); call gwrite(i,ii,70); call close(70); b34srun; == ==GWRITE2 Passing large dataset to GAUSS in two files b34sexec matrix; /$ /$ User gives command gaussb testdata > jj.out /$ This sample job turns off the GAUSS run /$ call load(gwrite2); call open(70,'testdata'); x1=rn(array(10000:)); nn=namelist(x1); call gwrite2(x1,nn,70); yy=10. + x1 + 10.*rn(x1); nn=namelist(yy); call gwrite2(yy,nn,70); /$ Do an OLS Model in GAUSS call character(cc,'ols("",yy,x1);'); call write(cc,70); call close(70); /$ Run GAUSS and place output back in B34S /$ call system('gaussb testdata > jj.out'); b34srun; /$ b34sexec options npageout /$ writeout('Output from GAUSS',' ',' ') /$ copyfout('jj.out'); /$ b34srun; == ==GWRITE_2 OLS In GAUSS from under B34S Matrix b34sexec matrix; /$ /$ User gives command gaussb testdata > jj.out /$ This sample job turns off the GAUSS run /$ call load(gwrite); call open(70,'testdata'); x1=rn(array(100:)); nn=namelist(x1); call gwrite(x1,nn,70); yy=10. + x1 + rn(x1); nn=namelist(yy); call gwrite(yy,nn,70); call character(cc,'ols("",yy,x1);'); call write(cc,70); call close(70); /$ call system('gaussb testdata > jj.out'); b34srun; /$ b34sexec options npageout /$ writeout('Output from GAUSS',' ',' ') /$ copyfout('jj.out'); /$ b34srun; == ==HANSEN92 Hansen (1992) Coefficient Stability Test %b34slet runrats1=0; %b34slet runrats2=0; %b34slet runrats3=0; %b34slet runrats4=0; b34sexec options ginclude('b34sdata.mac') member(romer89); b34srun; b34sexec data set dropmiss; gen if(obs.le.18)obs=missing(); b34srun; b34sexec matrix; call loaddata; call echooff; call load(hansen92); call olsq(difgnp difgnp{1} :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); b34srun; %b34sif(&runrats1.ne.0)%then; /; /; Rats UG Manual page 350 /; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec options copyf(4,29); b34sexec pgmcall$ RATS PASSASTS pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * Rats run under B34S(r) system * display @1 %dateandtime() @33 'Rats Version ' %ratsversion() * @baiperron(tests,maxbreaks=1) difgnp * * # constant difgnp{1} @stabtest difgnp * * # constant difgnp{1} b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run ') /; dodos('start /w /r rats32s rats.in ') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call load(hansen92); m=6; call olsq(gasout gasout{1 to m} gasin{1 to m} :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); b34srun; %b34sif(&runrats2.ne.0)%then; /; /; Rats UG Manual page 350 /; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec options copyf(4,29); b34sexec pgmcall$ RATS PASSASTS pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * Rats run under B34S(r) system * display @1 %dateandtime() @33 'Rats Version ' %ratsversion() * @baiperron(tests,maxbreaks=1) gasout * * # constant gasout{1 to 6} gasin{1 to 6} @stabtest gasout * * # constant gasout{1 to 6} gasin{1 to 6} b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run ') /; dodos('start /w /r rats32s rats.in ') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call echooff; call load(hansen92); call olsq(lnq lnl lnk time lnrm1 :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); b34srun; %b34sif(&runrats3.ne.0)%then; /; /; Rats UG Manual page 350 /; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec options copyf(4,29); b34sexec pgmcall$ RATS PASSASTS pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * Rats run under B34S(r) system * display @1 %dateandtime() @33 'Rats Version ' %ratsversion() * @baiperron(tests,maxbreaks=1) lnq * * # constant lnl lnk time lnrm1 @stabtest lnq * * # constant lnl lnk time lnrm1 b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run ') /; dodos('start /w /r rats32s rats.in ') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; b34sexec matrix; call echooff; call load(hansen92); n=1000; k=40; x=rn(matrix(n,k:)); x(,k)=1.0; b=vector(k:)+1.0; y=x*b+10.*rn(vector(n:)); call olsq(y x :noint :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); b34srun; b34sexec data noob=1000$ build y1 y2 x z e1 e2$ gen e1=rn()$ gen e2=rn()$ gen x =10*rn()$ gen z =10*rn()$ gen y1 = 10 + 5*x + 5*z + 50*e1 $ gen if(x .gt. 0) y2= 10 + 5*x + 5*z + 50*e2$ gen if(x .le. 0) y2= 10 - 10*x + 5*z + 50*e2$ b34srun; b34sexec matrix; call echooff; call loaddata; call load(hansen92); /; OK Model call olsq(y1 x z :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); /; TAR Model call olsq(y2 x z :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); call fls(y1 x z :print); call fls(y2 x z :print); call print(' ':); call print('Hanson (1992) test NOT invariant to sort order':); call print('----------------------------------------------':); call print(' ':); i=ranker(x); x=x(i); y1=y1(i); y2=y2(i); z=z(i); call olsq(y1 x z :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); /; TAR Model call olsq(y2 x z :savex :print); iprint=1; call hansen92(%y,%x,%names,%coef,%res,%lag,lc,siglc, jointlc,sjointlc,iprint); call fls(y1 x z :print); call fls(y2 x z :print); b34srun; %b34sif(&runrats4.ne.0)%then; /; /; Rats UG Manual page 350 /; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec options copyf(4,29); b34sexec pgmcall$ RATS PASSASTS pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * Rats run under B34S(r) system * display @1 %dateandtime() @33 'Rats Version ' %ratsversion() * @baiperron(tests,maxbreaks=1) y1 * * # constant x z @baiperron(tests,maxbreaks=1) y2 * * # constant x z @stabtest y1 * * # constant x z @stabtest y2 * * # constant x z b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run ') /; dodos('start /w /r rats32s rats.in ') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==HAUSMAN OLS vs LS2 Test b34sexec options noheader; b34srun; b34sexec options ginclude('micro.mac') member(griliches76); b34srun; b34sexec matrix; call loaddata; call load(ls2); call echooff; call character(lhs,'lw'); call character(endvar, 'iq'); call character(endvar2,'iq s'); call character(rhs,'iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant'); call character(ivar,'s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant med kww age mrt'); call character(ivar2,'expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant med kww age mrt'); call olsq(argument(lhs) argument(rhs) :noint :print :savex); call print(' ':); Call print('Baum (2006) page 193':); call print(' ':); call print(lhs,rhs,ivar,endvar); call ls2(%y,%x,catcol(argument(ivar)),%names,%yvar,1); * Hausman test ; call hausman('2SLS Model large sample covar - Testing coef 1', %olscoef(1),submatrix(%varcov1,1,1,1,1), %ls2coef(1),submatrix(%covar_l,1,1,1,1),h,sig_h,1); call hausman('2SLS Model small sample covar - Testing coef 1', %olscoef(1),submatrix(%varcov1,1,1,1,1), %ls2coef(1),submatrix(%covar_s,1,1,1,1),h,sig_h,1); call print('Baum (2006) page 198':); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); * Do C test to see it S is a good instrument; * s is removed from ivar to ivar2 ; call olsq(argument(lhs) argument(rhs) :noint :print :savex); call print(' ':); call print('Now there are 2 endogenous on the right':); call print(lhs,rhs,ivar2,endvar2); call ls2(%y,%x,catcol(argument(ivar2)),%names,%yvar,1); jj=integers(1,2); call hausman('2SLS Model large sample covar - Testing coef 1-2', %olscoef(jj),submatrix(%varcov1,1,2,1,2), %ls2coef(jj),submatrix(%covar_l,1,2,1,2),h,sig_h,2); jj=integers(1,2); call hausman('2SLS Model small sample covar - Testing coef 1-2', %olscoef(jj),submatrix(%varcov1,1,2,1,2), %ls2coef(jj),submatrix(%covar_s,1,2,1,2),h,sig_h,2); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); b34srun; == ==HC_SIGMA Het Correction for sigma b34sexec options ginclude('gas.b34'); b34srun; /; Illustrate mcov function and HC_sigma function /; /; mcov is more general. HC_SIGMA works for real*8 and real*16 /; b34sexec matrix; call loaddata; call echooff; call olsq(gasout gasin :savex); call print('Usual case no lag',mcov(%x,%res,0,0.0,0)); call print('hc_sigma ',hc_sigma(1.0,%x,%res)); b34srun; == ==HEXTOCH Illustrates Programming with HEXTOCH b34sexec matrix; /$ Illustrates Character Handeling and Hex Conversion; /$ Looking at Printable Characters ; i=integers(33,127); call igetchari(i,cc); call names(all); call tabulate(i,cc); call igetichar(cc,iitest); call chtohex(cc,hexcc); /$ Repack this character*2 array saved as character*1; /$ Next two statments work the same /$ hexcc2= array(norows(hexcc)/2,2:hexcc); hexcc2=c1array(norows(hexcc)/2,2:hexcc); hex1=hexcc2(,1); hex2=hexcc2(,2); call hextoch(hexcc,cctest); xx=transpose(hexcc2); call print(xx,hexcc2); call hextoch(xx,cctest2); call names(all); /$ get hexcc2 in a printable variable; blank=c1array(norows(hex1):); call names(all); c8var=catcol(hex1, hex2,blank,blank, blank, blank,blank,blank); call names(all); /$ call print(c8var); c8var=c8array(norows(c8var):transpose(c8var)); call tabulate(i,cc,iitest,hex1,hex2,cctest,cctest2,c8var); b34srun; == ==HINICH82 Call Hinich82 => Hinich(82) Nonlinearity Test b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call hinich82(gasout,m,g,l:meanonly); call print('Mean Data for Hinich(82) Test on Gasout',g,l); m=17; call hinich82(gasout,m,g,l:setm); call print('Mean Data for Hinich(82) Test on Gasout M Set',m,g,l); call hinich82(gasout,m,g,l); call print('Hinich(82) Test on Gasout not Smoothed'); call tabulate(m,g,l); call hinich82(gasout,m,g,l:meanonly :smoothspec); call print('Mean Data for Hinich(82) Test on Gasout',g,l); m=16; call hinich82(gasout,m,g,l:setm :smoothspec); call print('Mean Data for Hinich(82) Test on Gasout Mean Set',g,l); call hinich82(gasout,m,g,l :smoothspec); call print('Hinich(82) Test on Gasout Smoothed'); call tabulate(m,g,l); b34srun; /$ This sections validates matrix Command B34SEXEC BJIDEN$ var =gasout $ seriesn var = gasout $ rauto gasout$ bispec iauto iturno vhtest $ B34SEEND$ B34SEXEC BJIDEN$ var =gasout $ seriesn var = gasout $ rauto gasout$ bispec iauto iturno vhtest ismoo$ B34SEEND$ /; This sections shows how a nonlinear residual looks and a random /; series looks. The residual Hinich #'s match Chapter 7 of /; Stokes (1997) using matrix command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasout{1 to 6} gasin{1 to 6} :print); x=rn(array(1000:)); call hinich82(%res,m,g,l); call print('Hinich(82) Test on Gasout_res',g,l); call hinich82(x,m,g,l); call print('Hinich(82) Test on x',g,l); b34srun; == ==HINICH82_1 Estimate Critical values for Hinich(1982) /$ /$ Break key allows termination between models. /$ Hit break key only once /$ /$ Job establishes critical values for Hinich (1982) /$ /$ Job illustrates how matrix command can be used to get /$ critical values of a test. If Setup with NCASE1=3000 => /$ over 24 hours on a 400 MH machine. 27,000,000 data points /$ are estimated and tested. 21,000 datasets are /$ generated. For each of the 21,000 21 Hinich bases are /$ investigated. Each daaset contains 2000 observations. /$ Progress in the analysis is monitored using outstring /$ and outinteger. The user can use the break key to /$ kill a model. /$ /$ Unless ncase1 is set to 10, the command call echooff /$ should not be removed. /$ /$ B34S workspace should be large when running this job. /$ b34sexec matrix ; call echooff; * ncase=3000; ncase = 10; n=2000; coef=array(7:-.9,-.6,-.3,0.0,.3,.6,.9); do j=1,7; l1 = array(ncase:); l7 = array(ncase:); l21= array(ncase:); l22= array(ncase:); call outstring(1,2,'Model '); call outinteger(12,2,j); do i=1,ncase; call outstring(1,4,'Ncase'); call outinteger(12,4,i); ar=coef(j); call free(ma); const=1.0; start=.1; wnv=1.0; nout=200; ar1=genarma(ar,ma,const,start,wnv,n,nout); call hinich82(ar1,m,g,l:smoothspec); * call print(l); l1(i) =l(1); l7(i) =l(7); l21(i)=l(21); l22(i)=l(22); enddo; * call print(l1,l7,l21,l22); q=array(4:.90,.95,.975,.99); call quantile(l1, q,value1); call quantile(l7, q,value7); call quantile(l21, q,value21); call quantile(l22, q,value22); Call Print('AR(1) Model at .90 .95 .975 .99 for ar =',coef(j)); call tabulate(q,value1,value7,value21,value22); call break('We are at the end of one model'); enddo; b34srun; == ==HINICH96 Call Hinich96 => Hinich (96) Nonlinearity Test b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call hinich96(gasout,0.0,V,H); call print('Mean Data for Hinich(96) Test on Gasout',V,H); c=grid(.2 .45,.02); v=array(norows(c):); h=array(norows(c):); do i=1,norows(c); call hinich96(gasout,c(i),vv,hh); v(i)=vv; h(i)=hh; enddo; call print('Hinich(96) Test on Gasout for various c values'); call tabulate(c,v,h); b34srun; == ==HPFILTER Hodrick-Prescott Decomposition /; /; Illustrates testing against rats /; If obs are dropped off near end the ends of the series /; transformed series are changed. This suggests that /; models updated by more data points will have older /; observations changed. /; -------------------------------------------------------- %b34slet runrats=0; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; s=1600.; call hpfilter(gasout,gast,gasdev,s); call graph(gasout,gast,gasdev :nolabel); * This gives the same answer as no filtering; call hpfilter(gasout,gast2,gasdev2,0.0); call tabulate(gasout,gast,gasdev,gast2,gasdev2); call print(' ':); call print('Dropping obs changes filter!!!':); call print('------------------------------':); newgas1= droplast(gasout,100); newgas2= droplast(gasout,10); call hpfilter(gasout, ngast, ngasdev,s); call hpfilter(newgas1,ngast1, ngasdev,s); call hpfilter(newgas2,ngast2, ngasdev,s); call tabulate(ngast1,ngast2, ngast); b34srun; %b34sif(&runrats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * filter(type=hp,tuning=1600) gasout / gasoutt set detrend = gasout-gasoutt print * * gasout gasoutt detrend b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==HP_2 Tests HP_2 Routine b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(hp_2); call print(hp_2); julian=array(norows(gasin):); nwindow=50; ncc=10; lamda=100.; series1=gasin; series2=gasout; call echooff; call hp_2(series1,series2,nwindow,ncc, lamda,cortrhp,cordevhp,var1trh,var2trh,var1devh,var2devh, corrmat1,corrmat2,corrmat3,corrmat4); call names; call graph(var1trh,var1devh); b34srun; == ==HP_BP_1 HP_BP_1 Subroutine b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(hp_bp_1); call print(hp_bp_1); julian=array(norows(gasin):); series1=gasin; series1=gasout; call character(name,'Gasout Series'); call echooff; /$ HELP FILE ********************************************** /$ call 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 /$ /$ ***************************************************** highf=6.; lowf=32.; nterms=10; lamda=1600.; printit=1; graphit=1; call hp_bp_1(julian,series1,name,highf,lowf,nterms, lamda,printit,graphit,rjulian,rseries, hptrend,hpdev,bptrend,bpdev); call names; b34srun; == ==HP_BP_2 Moving HP and BK Filtering Routine b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(hp_bp_2); call print(hp_bp_2); julian=array(norows(gasin):); nwindow=50; ncc=10; lamda=1600.; highfreq=6.; lowfreq=32.; nterms=20; series1=gasin; series2=gasout; call echooff; /$ call 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 1600. /$ 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 /$ call 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); call names; call graph(var1trh,var1devh :Heading 'Variance of trend and Dev HP Series 1'); call graph(var1trb,var1devb :Heading 'Variance of trend and Dev BK Series 1'); call graph(var2trh,var2devh :Heading 'Variance of trend and Dev HP Series 2'); call graph(var2trb,var2devb :Heading 'Variance of trend and Dev BK Series 2'); b34srun; == ==HUGE Largest number of type b34sexec matrix; i=1; i8=i4toi8(i); x=1.; x16=r8tor16(x); y=sngl(x); call print('Largest integer*4 ',huge(i):); call print('Largest integer*8 ',huge(i8):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Largest real*16 ',huge(x16):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Smallest real*16 ',tiny(x16):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); call print('Epsilon real*16 ',epsilon(x16):); call print('Precision real*4 ',precision(y):); call print('Precision real*8 ',precision(x):); call print('Precision real*16 ',precision(x16):); x=.1d+00; x16=r8tor16(x); y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; x16=x16*r8tor16(dfloat(i)); spx(j) =spacing(x); spy(j) =spacing(y); spx16(j) =spacing(x16); nearpr8(j) =nearest(x, 1.); nearmr8(j) =nearest(x,-1.); nearpr16(j)=nearest(x16, r8tor16(1.)); nearmr16(j)=nearest(x16,r8tor16(-1.)); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8, Real*16 and Real*4'); call tabulate(testnum,spx,spy,spx16,nearpr8, nearmr8,nearpr4,nearmr4 nearpr16,nearmr16); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; == ==HYPDF Evaluate Hypergeometric Distribution Function b34sexec matrix; k=7; n=100; m=70; l=1000; pr=hypdf(k,n,m,l); call print('Evaluate Hypergeometric Distribution Function ':); call print('Probability that X is LE 7 = ',pr:); Call print('Note: Answer should be .5995':); b34srun; == ==HYPPR Evaluate Hypergeometric Probability Function b34sexec matrix; k=7; n=100; m=70; l=1000; pr=hyppr(k,n,m,l); call print('Evaluate Hypergeometric Probability Function':); call print('Probability that X is 7 = ',pr:); Call print('Note: Answer should be .1628':); b34srun; == ==INT_TEST /; /; Test case for experimental B34S /; b34sexec matrix; call int_test(1.); call int_test(2.); call int_test(5.); call int_test(6.); call int_test(7.); b34srun; == ==IAMAX Index of abs(max) in a 1D or 2D object b34sexec matrix; x=rn(array(10:))*100.; sx=sngl(x); qx=r8tor16(x); ix=idint(x); call tabulate(x,sx,qx,ix); call print('iamax x ',iamax(x):); call print('iamax sx ',iamax(sx):); call print('iamax qx ',iamax(qx):); call print('iamax ix ',iamax(ix):); call print('iamin x ',iamin(x):); call print('iamin sx ',iamin(sx):); call print('iamin qx ',iamin(qx):); call print('iamin ix ',iamin(ix):); call print('imax x ',imax(x):); call print('imax sx ',imax(sx):); call print('imax qx ',imax(qx):); call print('imax ix ',imax(ix):); call print('imin x ',imin(x):); call print('imin sx ',imin(sx):); call print('imin qx ',imin(qx):); call print('imin ix ',imin(ix):); b34srun; == ==IAMIN Index of abs(min) in a 1D or 2D object b34sexec matrix; x=rn(array(10:))*100.; sx=sngl(x); qx=r8tor16(x); ix=idint(x); call tabulate(x,sx,qx,ix); call print('iamax x ',iamax(x):); call print('iamax sx ',iamax(sx):); call print('iamax qx ',iamax(qx):); call print('iamax ix ',iamax(ix):); call print('iamin x ',iamin(x):); call print('iamin sx ',iamin(sx):); call print('iamin qx ',iamin(qx):); call print('iamin ix ',iamin(ix):); call print('imax x ',imax(x):); call print('imax sx ',imax(sx):); call print('imax qx ',imax(qx):); call print('imax ix ',imax(ix):); call print('imin x ',imin(x):); call print('imin sx ',imin(sx):); call print('imin qx ',imin(qx):); call print('imin ix ',imin(ix):); b34srun; == ==IMAX Index of max in a 1D or 1D object b34sexec matrix; x=rn(array(10:))*100.; sx=sngl(x); qx=r8tor16(x); ix=idint(x); call tabulate(x,sx,qx,ix); call print('iamax x ',iamax(x):); call print('iamax sx ',iamax(sx):); call print('iamax qx ',iamax(qx):); call print('iamax ix ',iamax(ix):); call print('iamin x ',iamin(x):); call print('iamin sx ',iamin(sx):); call print('iamin qx ',iamin(qx):); call print('iamin ix ',iamin(ix):); call print('imax x ',imax(x):); call print('imax sx ',imax(sx):); call print('imax qx ',imax(qx):); call print('imax ix ',imax(ix):); call print('imin x ',imin(x):); call print('imin sx ',imin(sx):); call print('imin qx ',imin(qx):); call print('imin ix ',imin(ix):); b34srun; == ==IMIN Index of min in a 1D or 1D object b34sexec matrix; x=rn(array(10:))*100.; sx=sngl(x); qx=r8tor16(x); ix=idint(x); call tabulate(x,sx,qx,ix); call print('iamax x ',iamax(x):); call print('iamax sx ',iamax(sx):); call print('iamax qx ',iamax(qx):); call print('iamax ix ',iamax(ix):); call print('iamin x ',iamin(x):); call print('iamin sx ',iamin(sx):); call print('iamin qx ',iamin(qx):); call print('iamin ix ',iamin(ix):); call print('imax x ',imax(x):); call print('imax sx ',imax(sx):); call print('imax qx ',imax(qx):); call print('imax ix ',imax(ix):); call print('imin x ',imin(x):); call print('imin sx ',imin(sx):); call print('imin qx ',imin(qx):); call print('imin ix ',imin(ix):); b34srun; == ==I4TOI8 Move an integer*4 object to integer*8 /; /; Tests integer*8 capability /; b34sexec matrix; i4=123; call print(i4*i4,123.*123.,i4toi8(i4)*i4toi8(i4)); i8=integer8('1234567678900987654'); ii8=i8; call print(i8,ii8,i8/kindas(i8,10)); iv4=integers(1,6); iv8=i4toi8(iv4); call names(all); new=i8toi4(iv8); i4mat=idint(10.*rn(matrix(4,4:))); i8mat=i4toi8(i4mat); new8 =i8toi4(i8mat); call print(i8,iv4,iv8,new,i4mat,i8mat,new8); call print(kindas(new,i8)); call print(kindas(i8, iv4)); i8=integer8('123'); i4=i8toi4(i8); call names(all); call print(i8,i4,i4*i4,i8*i8,i4*i4); i4array=afam(i4mat)+10; i8array=i4toi8(i4array); call print(i4array,i8array); call stop; call print(i4mat+i4mat,i8mat+i8mat); call print(i4mat-i4mat,i8mat-i8mat); call print(i4array+i4array,i8array+i8array); call print(i4array-i4array,i8array-i8array); call print(i4array*i4array,i8array*i8array); call print((2*i4array)/i4array,(kindas(i8,2)*i8array)/i8array); b34srun; == ==I8TOI4 Move an integer*8 object to integer*4 /; /; Tests integer*8 capability /; b34sexec matrix; i4=123; call print(i4*i4,123.*123.,i4toi8(i4)*i4toi8(i4)); i8=integer8('1234567678900987654'); ii8=i8; call print(i8,ii8,i8/kindas(i8,10)); iv4=integers(1,6); iv8=i4toi8(iv4); call names(all); new=i8toi4(iv8); i4mat=idint(10.*rn(matrix(4,4:))); i8mat=i4toi8(i4mat); new8 =i8toi4(i8mat); call print(i8,iv4,iv8,new,i4mat,i8mat,new8); call print(kindas(new,i8)); call print(kindas(i8, iv4)); i8=integer8('123'); i4=i8toi4(i8); call names(all); call print(i8,i4,i4*i4,i8*i8,i4*i4); i4array=afam(i4mat)+10; i8array=i4toi8(i4array); call print(i4array,i8array); call stop; call print(i4mat+i4mat,i8mat+i8mat); call print(i4mat-i4mat,i8mat-i8mat); call print(i4array+i4array,i8array+i8array); call print(i4array-i4array,i8array-i8array); call print(i4array*i4array,i8array*i8array); call print((2*i4array)/i4array,(kindas(i8,2)*i8array)/i8array); b34srun; == ==IMAG Tests IMAG command b34sexec matrix; xr=matrix(2,2:1 2 3 4); xi=dsqrt(xr); cc=complex(xr,xi); call print(cc,real(cc),imag(cc)); cc32=c16toc32(cc); call print(cc32,real(cc32),imag(cc32)); vpacc=vpa(cc); call print(vpacc,real(vpacc),imag(vpacc)); b34srun; == ==INTEGER8 Load an Integer*8 object /; /; Tests integer*8 capability /; b34sexec matrix; i4=123; call print(i4*i4,123.*123.,i4toi8(i4)*i4toi8(i4)); i8=integer8('1234567678900987654'); ii8=i8; call print(i8,ii8,i8/kindas(i8,10)); iv4=integers(1,6); iv8=i4toi8(iv4); call names(all); new=i8toi4(iv8); i4mat=idint(10.*rn(matrix(4,4:))); i8mat=i4toi8(i4mat); new8 =i8toi4(i8mat); call print(i8,iv4,iv8,new,i4mat,i8mat,new8); call print(kindas(new,i8)); call print(kindas(i8, iv4)); i8=integer8('123'); i4=i8toi4(i8); call names(all); call print(i8,i4,i4*i4,i8*i8,i4*i4); i4array=afam(i4mat)+10; i8array=i4toi8(i4array); call print(i4array,i8array); call stop; call print(i4mat+i4mat,i8mat+i8mat); call print(i4mat-i4mat,i8mat-i8mat); call print(i4array+i4array,i8array+i8array); call print(i4array-i4array,i8array-i8array); call print(i4array*i4array,i8array*i8array); call print((2*i4array)/i4array,(kindas(i8,2)*i8array)/i8array); b34srun; == ==IALEN Actual length of a string b34sexec matrix; call character(cc,'This ends at 15 '); call ialen(cc,ipos); call print('Should be 15',ipos); b34srun; == ==IB34S11 Tokenize a string b34sexec matrix; call character(cc,'10. 11 test y(10) jj=44 print'); ibase=1; call echooff; do j=1,100; imax=0; call ib34s11(cc,ibase,ifbase,isize,itokty,inewp,imax); if(isize.eq.0)go to finish; call print('ifbase found ',ifbase :line); call print('Size of token found ',isize :line); call print('Type of token found ',itokty :line); call print('inewp of token found ',inewp :line); i=integers(ifbase,ifbase+isize-1); find=cc(i); call character(tt,'Token found was: '); call expand(tt,find,20,(20+isize)); call print(tt :line); call print(' ' :line); ibase=inewp; if(inewp.eq.-99)go to finish; enddo; finish continue; call print('All done tokenizing'); b34srun; == ==IBFCLOSE Close a file open for binary I/O b34sexec matrix; call ibfopen('test.ff',writeonly,ihandle); r=rn(array(10:)); call ibfwriter(ihandle,r,norows(r)*8,iwrite); call ifilesize(' ','test.ff',isize); call print('isize was ',isize); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; == ==IBFOPEN Open a file for binary I/O b34sexec matrix; call ibfopen('test.ff',writeonly,ihandle); r=rn(array(10:)); call ibfwriter(ihandle,r,norows(r)*8,iwrite); call ifilesize(' ','test.ff',isize); call print('isize was ',isize); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; == ==IBFREADC Read Character Data from Binary File b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array((isize/8)+1:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array((isize/8)+1:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; == ==IBFREADR Read Real Data from Binary File b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array((isize/8)+1:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array((isize/8)+1:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; == ==IBFSEEK Position to read b34sexec matrix; call ibfopen('test.ff',READWRITE,ihandle); x=rn(array(10:)); call ibfwriter(ihandle,x,norows(x)*8,iwrite); call ifilesize(' ','test.ff',isize); xnew=array(isize/8:); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; == ==IBFWRITEC Write Character Data to a Binary File b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array(isize/8:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array(isize:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; == ==IBFWRITER Write Real Data to a Binary File b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array(isize/8:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array(isize:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; == ==ICOLOR Gets Color integer value b34sexec matrix; call print(icolor(red)); call print(icolor(green)); call print(icolor(blue)); b34srun; == ==IDINT idint function => Convert real*8 to integer b34sexec matrix; x=grid(1.,10.,1.); call print('A real* array',x); ix=idint(x); call print('An integer array',ix); x=rn(matrix(5,5:)) + 20.; ix=idint(x); call print(x,ix); x=x*(-.1d+32); ix=idint(x); call print(x,ix); b34seend; b34sexec matrix; x=grid(1.,10.,.1); ix=idint(x); ix2=idnint(x); call print('x = real*8, ix idint, ix2=idnint'); call tabulate(x,ix,ix2); b34seend; == ==IDNINT idnint function => Convert Rounded real*8 to integer b34sexec matrix; x=grid(1.,10.,.1); ix=idint(x); ix2=idnint(x); call print('x = real*8, ix idint, ix2=idnint'); call tabulate(x,ix,ix2); b34seend; == ==IFILESIZE Gets File Size b34sexec matrix; call ifilesize('c:\b34slm\lib','matrix.mac',isize); call print(isize); b34srun; == ==IFILLSTR Fill a string b34sexec matrix; call character(cc,'This is a string'); newcc=cc; call ifillstr(newcc,'a'); call print(cc,newcc); b34srun; == ==IF_TEST IF Test Cases b34sexec matrix; * Simple do loop; do i=1,10; call print('This is in the simple loop',i); if(i.ge.2.and.i.lt.6)then; call print('I is ge 2 and lt 6'); endif; if(i.ne.9)call print('I was not = 9 in this pass'); if(i.eq.9)call print('I was 9 in this pass'); enddo; call print('All Done'); b34srun; /$ More complex Cases b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; if(sfam(lnq(1)) .ne. sfam(lnq(2)))jj=10; if(sfam(lnq(1)) .eq. sfam(lnq(1)))then; call print('test case 1',lnq(1)); endif; s=sfam(lnq(1)); if(s.ne.1.0)call print('simple test'); if(sfam(lnq(1)) .eq. sfam(lnq(1))) call print('test case 2',lnq(1)); if(lnq(1).ne.0.0)lnq(1)=-9999.; call print(lnq); x=integers(1,10); xx=x; /$ Note that Where sets one element to 99 rest to 0.0; where(x.eq.5)x=99; /$ This may not be what is desired. /$ This is the right way to do calculation using masks xx=idint((xx.eq.5))*99+idint((xx.ne.5))*xx; call print(x,xx); b34srun; b34sexec matrix; subroutine divide(i,x,y); call print(i,x,y,x/y); return; end; x=array(3: 2.0 8.0 3.0); y=array(3: 2.0 0.0 1.0); ans1=array(3:)+missing(); ans2=array(3:)+missing(); do i=1,3; jj=888.; if(y(i).ne.0.0)ans1(i)=x(i)/y(i); if(y(i).ne.0.0)jj =x(i)/y(i); if(y(i).ne.0.0)call divide(i,x(i),y(i)); ans2(i)=jj; enddo; call tabulate(x,y,ans1,ans2); b34srun; == ==IGETCHARI From Integer get char value b34sexec matrix; call character(astring,'ABCDEFG'); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(astring,ichar,ichar2,newstr); b34srun; == ==IGETICHAR Get ICHAR value from string b34sexec matrix; call character(astring,'ABCDEFG'); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(astring,ichar,ichar2,newstr); b34srun; == ==IJUSTSTR Left/Center/Right a String b34sexec matrix; call character(c,'This is a statement '); leftc=c; centerc=c; rightc=c; call ijuststr(leftc, left); call ijuststr(centerc,center); call ijuststr(rightc, right); call print(c,leftc,centerc,rightc); b34srun; == ==ILCOPY Byte Copy Command b34sexec matrix; call character(cc,'This is a test'); call displayb(cc); call character(cc2,'This is a test with numbers 1 2 3 # $ % 7 && 8 &'); call displayb(cc2); * Put in reals we know what they are; x=array(20:integers(20)); call print(x); call displayb(x); x(1)=0.0; x(2)=1.0; * Hide an integer in a real; call displayb(x); i1=1; i2=2; call ilcopy(4,i1,1,1,x,1,1); call ilcopy(4,i2,1,1,x,1,5); call displayb(x); b34srun; == ==ILOCATESTR Locate a string within an array b34sexec matrix; call character(cc,' in5to11 '); call ilocatestr(cc,in,iout); call print(cc,in,iout); b34srun; == ==ILOWER Lower case a string b34sexec matrix; call character(cc,'THIS IS UPPER'); lower=cc; call ilower(lower); upper=lower; call iupper(upper); call print(cc,lower,upper); b34srun; == ==IMATRIX Shell called by IntMatrix button for Display Manager /; /; This shell can be modified to load data set if desired. The /; disadvantage is that all users of B34S will ooad this data /; Warning: If this script is not corrrect, interactive matrix /; will not work /; b34sexec matrix; call manual; b34srun; == ==INDEX Define Integer vector b34sexec matrix; xx=index(1,2,3,4,5,4,3); call names(all); call print(xx); call print('Integer*4 Array ',index(1 2 3 4 5 4 3)); call print('# elements in 1 2 3 4 is 24',index(2 3 4:)); call print('Position of 1 2 in a 4 by 4 is 5',index(4 4:1 2):); call print('Integer*4 Array ',index(1,2,3,4,5 4 3)); call print('# elements in 1 2 3 5 is 30',index(2,3,5:)); call print('Position of 1 3 in a 4 by 4 is 9',index(4,4:1,3):); * bigger example showing large matrix; maxsize=index(4,5,6:); xbig =array(maxsize:integers(maxsize)); call print(xbig); ii2 =index(4,5,6:1 1 2); subx=xbig(integers(ii2,ii2+20-1)); call print(subx); b34srun; == ==INEXTI4 Get next Int b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; == ==INEXTR4 Get next real*4 b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; == ==INEXTR8 Get next real*8 b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; == ==INEXTSTR Get next string b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; == ==INFOGRAPH Graphics info b34sexec matrix; r=array(14:); ii=integers(14); do i=1,14; r(i)=infograph(i); enddo; call tabulate(ii,r); b34srun; == ==INLINE Inline creatioon of a Program /$ Shows two ways to create a program /$ Note that the program copy places program at level 100 /$ /$ Default name %INLINE_ if no : found /$ /$ second job uses inline model specification for maxf2 b34sexec matrix; call testarg('x=10;','y=10.+15.9*sin(yy);':test); /$ Note we have to use the same name !!!!!!! funny2=inline('x=10;','y=10.+15.9*sin(yy);':funny2); program funny; x=10.; call print(x); return; end; funny3=inline('x=10;','y=10.+15.9*sin(yy);'); call print('FUNNY3 hides %INLINE_'); call print(funny,funny2,funny3); call names(all); b34srun; /$ MAXF2 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 b34sexec matrix; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; call echooff; call maxf2(func :name inline('func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.);') :parms x1 x2 :ivalue array(2:-1.2,1.0) :print); b34srun; == ==INT Converts real*4 to integer b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; == ==INTEGERS INTEGERS function => Generate a vector of integers b34sexec matrix; i1=integers(24); i2=integers(2,26); i3=integers(0,30); call tabulate(i1,i2,i3); b34srun$ == ==INTEGERS Illustrates INTEGER command b34sexec matrix; call print(integers(10)); call print(integers(0,30,3)); b34srun; == ==INTTOSTR Integer to String b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; == ==INV Inv function => calculate inverse /$ This job does not print very much n can be increased /$ at "change this n" to test accuracy of LINPACK vs LAPACK!! b34sexec matrix; * Small sample ; n=4; x=rec(matrix(n,n:)); t1=(1.0/x); t2=inv(x); test1=x*t1; test2=x*t2; if(n.le.5)then; call print(x,t1,t2,x*t1); call print(x*inv(x),x*inv(x:refine),x*inv(x:refinee)); endif; if(n.le.5)then; cx=complex(x,2.*x); ct1=(complex(1.0,0.0)/cx); ct2=inv(cx); ctest1=cx*ct1; ctest2=cx*ct2; call print(ct1,ct2,ctest1,ctest2); call print(cx*inv(cx),cx*inv(cx:refine),cx*inv(cx:refinee)); endif; * change this n ; call echooff; n=100; x=rec(matrix(n,n:)); x(1,)=x(1,)*10000.; t1=(1.0/x); t2=inv(x); test1=x*t1; test2=x*t2; if(n.le.5)then; call print(x,t1,t2,x*t1); endif; call echooff; call print('Order of system ',n:); call print('LINPACK for T1':); call print('LINPACK for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t1) )', dmax( (matrix(n,n:)+1.) - (x*t1) ):); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t1) )' sumsq((matrix(n,n:)+1.) - (x*t1) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); t2=inv(x:gmat); test2=x*t2; call print('LAPACK for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); t2=inv(x:refine); test2=x*t2; call print('LAPACK refine for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); t2=inv(x:refinee); test2=x*t2; call print('LAPACK refinee for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); b34srun; == ==INV2 Simple Inversion test with Printing /$ Job illustrates inverse of PDMATRIX 6 ways /$ gminv uses LAPACK /$ pdmac uses LINPACK /$ pdmac2 uses LAPACK /$ b34sexec matrix; n=4; x=rn(matrix(n,n:)); x=transpose(x)*x; t1=(1.0/x); t2=inv(x); test1=x*t1; test2=x*t2; call gminv(x,t3); cx=mfam(complex(afam(x),dsqrt(dabs(afam(x))))); scx=transpose(cx)*cx; cx=dconj(transpose(cx))*cx; ct1=(complex(1.0,0.0)/cx); ct2=inv(cx); call gminv(cx,ct3); ctest1=cx*ct1; ctest2=cx*ct2; ctest3=cx*ct3; call print(x,t1,t2,t3,cx,ct1,ct2,ct3,ctest1,ctest2,ctest3); t2a=inv(x:smat); t2b=inv(x:pdmat); t2c=inv(x:pdmat2); call print(t1,t2,t3,t2a,t2b, t2c); ct2a=inv(scx:smat); tct2a=complex(1.0,0.0)/scx; ct2b=inv(cx:pdmat); ct2c=inv(cx:pdmat2); call print(cx,ct1,ct2,ct3,ct2b,ct2c); call print('Note that Complex Symmetric matrix NE PD Complex'); call print(scx,ct2a,tct2a); b34srun; == ==INV3 LAPACK vs LINPACK b34sexec matrix; call echooff; * above 5 only tests max difference; n=5; x=rn(matrix(n,n:)); * Play with this parameter; x(,1)=x(,1)*100000000.; test1=inv(x); test2=inv(x:refine); test3=inv(x:refinee); dd=matrix(n,n:)+1.; call print('Rank of matrix was ',n:); if(n.le.5)call print(x,test1,test2,test3); call print('Error of LINPACK ',sumsq((test1*x)-dd):); call print('Error of LAPACK REFINE ',sumsq((test2*x)-dd):); call print('Error of LAPACK REFINEE ',sumsq((test3*x)-dd):); call free(dd,test1,test2,test3); cx =complex(x,2.*x); cdd=complex(matrix(n,n:),matrix(n,n:)) + complex(1.,0.0); ctest1=inv(cx); ctest2=inv(cx:refine); ctest3=inv(cx:refinee); if(n.le.5)call print(cx,ctest1,ctest2,ctest3); call print('Real Error LINPACK ',sumsq(real((ctest1*cx)-cdd)):); call print('Real Error LAPACK REFINE ',sumsq(real((ctest2*cx)-cdd)):); call print('Real Error LAPACK REFINEE',sumsq(real((ctest3*cx)-cdd)):); call print('Imag Error LINPACK ',sumsq(imag((ctest1*cx)-cdd)):); call print('Imag Error LAPACK REFINE ',sumsq(imag((ctest2*cx)-cdd)):); call print('Imag Error LAPACK REFINEE',sumsq(imag((ctest3*cx)-cdd)):); b34srun; == ==INVBETA Inverse of Beta distribution b34sexec matrix; * Sample problem from IMSL page 915 ; pin= 12.0; qin= 12.0; p = .9 ; test=invbeta(p,pin,qin); call print('X is less than ',p,' with probability ',test, 'Answer should be .6299'); b34srun; == ==INVCHISQ Inverse of Chisq distribution b34sexec matrix; * Sample problem from IMSL page 921 ; df1 = 2.0; p = .99 ; test1=invchisq(p,df1); df2 = 64.; test2=invchisq(p,df2); call print('The ',p,' percentage point of Chi-square with df ',df1,test1 'Answer should be 9.210' 'The ',p,' percentage point of Chi-square with df ',df2,test2 'Answer should be 93.217'); b34srun; == ==INVFDIS Inverse F Distribution b34sexec matrix; * IMSL page 927 ; p=.99; dfn=1.; dfd=7.0; f=invfdis(p,dfn,dfd); call print('F(1,7) critical value at .01 is GE ',f, 'Answer should be 12.246'); n1=100; n2=10; ftab=array(n1,n2:); call echooff; do i=1,norows(ftab); do j=1,nocols(ftab); ftab(i,j)=invfdis(.95,dfloat(i),dfloat(j)); enddo; enddo; call print('F table at 95% probability',ftab); b34srun; == ==INVSPEED Shows Speed Differences for different inverse command b34sexec matrix; * By setting n to different values we test and compare inverse speed; call echooff; do n=200,600,100; x=rec(matrix(n,n:));pdx=transpose(x)*x; dd= matrix(n,n:)+1.; cdd=complex(dd,0.0); nn=namelist(math,inv,gmat,smat,pdmat,pdmat2,refine,refinee,); cpdx=complex(x,mfam(dsqrt(x))); scpdx=transpose(cpdx)*cpdx; cpdx=dconj(transpose(cpdx))*cpdx; if(n.le.5)call print(pdx,cpdx,scpdx,eig(pdx),eig(cpdx),eig(scpdx)); call compress; /; call print('Using LINPACK DGECO/DGRDI - ZGECO/ZGEDI':); call timer(base1); xinv=(1.0/pdx); call timer(base2); /; call print('Inverse using (1.0/pdx) took',(base2-base1):); realm(1)=base2-base1; error1(1)=sumsq((pdx*xinv)-dd); call compress; call timer(base1); cinv=(complex(1.0,0.)/cpdx); call timer(base2); /; call print('Inverse using (1.0/cpdx) took',(base2-base1):); complexm(1)=base2-base1; error2a(1)=sumsq(real((cpdx*cinv)-cdd)); error2b(1)=sumsq(imag((cpdx*cinv)-cdd)); call compress; call timer(base1); xinv=inv(pdx); call timer(base2); /; call print('Inverse using inv(pdx) took',(base2-base1):); realm(2)=base2-base1; error1(2)=sumsq((pdx*xinv)-dd); call compress; call timer(base1); cinv=inv(cpdx); call timer(base2); /; call print('Inverse using inv(cpdx) took',(base2-base1):); complexm(2)=base2-base1; error2a(2)=sumsq(real((cpdx*cinv)-cdd)); error2b(2)=sumsq(imag((cpdx*cinv)-cdd)); call compress; /; call print('Using LAPACK ':); call timer(base1); xinv=inv(pdx:GMAT); call timer(base2); /; call print('Inverse using inv(pdx:GMAT) took',(base2-base1):); realm(3)=base2-base1; error1(3)=sumsq((pdx*xinv)-dd); call compress; call timer(base1); cinv=inv(cpdx:GMAT); call timer(base2); /; call print('Inverse using inv(cpdx:GMAT) took',(base2-base1):); complexm(3)=base2-base1; error2a(3)=sumsq(real((cpdx*cinv)-cdd)); error2b(3)=sumsq(imag((cpdx*cinv)-cdd)); call compress; /; call print('Using LINPACK':); call timer(base1); xinv=inv(pdx:SMAT); call timer(base2); /; call print('Inverse using inv(pdx:SMAT) took',(base2-base1):); realm(4)=base2-base1; error1(4)=sumsq((pdx*xinv)-dd); call compress; call timer(base1); cinv=inv(scpdx:SMAT); call timer(base2); /; call print('Inverse using inv(scpdx:SMAT) took',(base2-base1):); complexm(4)=base2-base1; error2a(4)=sumsq(real((scpdx*cinv)-cdd)); error2b(4)=sumsq(imag((scpdx*cinv)-cdd)); call compress; /; call print('Using LINPACK':); call timer(base1); xinv=inv(pdx:PDMAT); call timer(base2); /; call print('Inverse using inv(pdx:PDMAT) took',(base2-base1):); realm(5)=base2-base1; error1(5)=sumsq((pdx*xinv)-dd); call compress; call timer(base1); cinv=inv(cpdx:PDMAT); call timer(base2); /; call print('Inverse using inv(cpdx:PDMAT) took',(base2-base1):); complexm(5)=base2-base1; error2a(5)=sumsq(real((cpdx*cinv)-cdd)); error2b(5)=sumsq(imag((cpdx*cinv)-cdd)); /; call compress; /; call print('Using LAPACK':); call timer(base1); xinv=inv(pdx:PDMAT2); call timer(base2); /; call print('Inverse using inv(pdx:PDMAT2) took',(base2-base1):); realm(6)=base2-base1; error1(6)=sumsq((pdx*xinv)-dd); /; call compress; call timer(base1); cinv=inv(cpdx:PDMAT2); call timer(base2); /; call print('Inverse using inv(cpdx:PDMAT2) took',(base2-base1):); complexm(6)=base2-base1; error2a(6)=sumsq(real((cpdx*cinv)-cdd)); error2b(6)=sumsq(imag((cpdx*cinv)-cdd)); /; call print('Using LAPACK':); call timer(base1); xinv=inv(pdx:REFINE); call timer(base2); /; call print('Inverse using inv(pdx:REFINE) took',(base2-base1):); realm(7)=base2-base1; error1(7)=sumsq((pdx*xinv)-dd); call compress; call timer(base1); cinv=inv(cpdx:REFINE); call timer(base2); /; call print('Inverse using inv(cpdx:REFINE) took',(base2-base1):); complexm(7)=base2-base1; error2a(7)=sumsq(real((cpdx*cinv)-cdd)); error2b(7)=sumsq(imag((cpdx*cinv)-cdd)); call compress; /; call print('Using LAPACK':); call timer(base1); xinv=inv(pdx:REFINEE); call timer(base2); /; call print('Inverse using inv(pdx:REFINEE) took',(base2-base1):); realm(8)=base2-base1; error1(8)=sumsq((pdx*xinv)-dd); call compress; call timer(base1); cinv=inv(cpdx:REFINEE); call timer(base2); /; call print('Inverse using inv(cpdx:REFINEE) took',(base2-base1):); complexm(8)=base2-base1; error2a(8)=sumsq(real((cpdx*cinv)-cdd)); error2b(8)=sumsq(imag((cpdx*cinv)-cdd)); /; call print('Error2a and error2b = real and imag Complex*16 error':); call print(' ':); call print('Matrix Order',n:); call tabulate(nn,realm,error1,complexm,error2a,error2b); call compress; enddo; b34srun; == ==INVSPEED2 PDFAC-LAPACK-LINPACK-GINV b34sexec matrix; * Tests speed of Linpack vs LAPACK vs svd (pinv); * Uses PD matrix; call echooff; icount=0; n=0; upper=500; mesh=50; top continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done; x=rn(matrix(n,n:)); x=transpose(x)*x; ii=matrix(n,n:)+1.; call compress; call timer(base11); xinv1=inv(x :pdmat); call timer(base22); error(icount)=sumsq(ii-(xinv1*x)); call compress; call timer(base111); xinv1=inv(x :pdmat2); call timer(base222); error0(icount)=sumsq(ii-(xinv1*x)); call compress; call timer(base1); xinv1=inv(x:gmat); call timer(base2); error1(icount)=sumsq(ii-(xinv1*x)); call compress; call timer(base3); xinv1=inv(x); call timer(base4); error2(icount)=sumsq(ii-(xinv1*x)); call compress; call timer(base5); xinv1=pinv(x); call timer(base6); error3(icount)=sum(ii-(xinv1*x)); size(icount) = dfloat(n); pdmat(icount) =(base22-base11); pdmat2(icount) =(base222-base111); lapack(icount) =(base2-base1); linpack(icount)=(base4-base3); svdt(icount) =(base6-base5); call free(x,xinv1,ii); go to top; done continue; call print('LINPACK Cholesky vs LAPACK Cholesky':); call tabulate(size,pdmat,pdmat2,error,error0); call print('LAPACK vs LINPACK GMAT vs PINV':); call tabulate(size,lapack,linpack,svdt,error1,error2,error3); call graph(size pdmat,pdmat2,lapack,linpack svdt :plottype xyplot); b34srun; == ==INVSPEED3 Further LAPACK vs LINPACK Tests b34sexec matrix; * At 150 LINPACK is faster ; * At 300 and 600 LAPACK wins ; * For this reason the inv( ) command uses LINPACK; n=150; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call print('GM time',t2-t1); call compress; call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); call compress; n=300; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call print('GM time',t2-t1); call compress; call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); call compress; n=600; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call compress; call print('GM time',t2-t1); call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); b34srun; == ==INVTDIS Inverse t distribution b34sexec matrix; p=.950; df=6.; t=invtdis(p,df); call print('The two sided t(',df,') value is ',t, 'Correct value should be 2.447'); n=100; pval=array(4:.975 .95,.90,.85); tval=array(n,norows(pval):); call echooff; do j=1,norows(pval); do i=1,n; df=dfloat(i); tval(i,j)=invtdis(pval(j),df); enddo; enddo; at975=tval(,1); at95=tval(,2); at90=tval(,3); at85=tval(,4); df=integers(n); call tabulate(df,at975,at95,at90,at85); b34srun; == ==IOCOMMANDS READ/WRITE/OPEN/REWIND/CLOSE b34sexec matrix; * Tests I/O package ; n=10000; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); call names(all); call free(test); call rewind(70); call close(70); call open(71,'testdata'); test2=array(n:); call read(test2,71); tmean2=mean(test2); call print(tmean2); call names(all); call close(71); b34srun; == ==IQINT iqint function => Convert real*16 to integer b34sexec matrix; x=r8tor16(grid(1.,10.,1.)); call print('A real*16 array',x); ix=iqint(x); call print('An integer array',ix); x=r8tor16(rn(matrix(5,5:)) + 20.); ix=iqint(x); call print(x,ix); b34seend; == ==IQNINT iqnint function => Convert Rounded real*16 to integer b34sexec matrix; x=r8tor16(grid(1.,10.,.1)); ix=iqint(x); ix2=iqnint(x); call print('x = real*16, ix iqint, ix2=iqnint'); call tabulate(x,ix,ix2); b34seend; == ==IRF Impulse Response Functions for VAR Model b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /; /; These tests validate IRF Calculations /; %b34slet runtests=0; %b34sif(&runtests.ne.0)%then; b34sexec bjest; model gasout; modeln p=(1,2,3,4,5,6); forecast nf=12 nt=296; b34srun; b34sexec btiden; title('Var Estimation to replicate Tiao-Box 1981 '); seriesn var=gasin Name('Box-Jenkins Gasin series'); seriesn var=gasout Name('Box-Jenkins Gasout series'); estvar p=6 output=normal ilarf numirf=12 granger; b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(irf); call echooff; /; Help for IRF /; /; call 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)) /; /; --------------------------------------------------------------------- /; 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 /; 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); /; /; /; Need to load VAREST and BUILDLAG /; /; ****************************************************** 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); /$ One variable test x=matrix(norows(gasout),1:gasout); call print(' ':); call print('One Variable Test':); call irf(x,ibegin,iend,beta,t1,res,sigma,psi,ipsi,tirf,iprint, nterms,nlag,var,varxhat,rsq); call tabulate(psi,tirf); /$ One variable test on random data n=2000; x=matrix(n,1:); x=rn(x); ibegin = 1; iend = n/2; nlag=12; nterms=20; iprint=0; call print(' ':); call print('Test using Random Data':); call irf(x,ibegin,iend,beta,t1,res,sigma,psi,ipsi,tirf,iprint, nterms,nlag,var,varxhat,rsq); call tabulate(psi,tirf); b34srun; == ==IRF2 - Inpulse Response Function for 1 Lag Models b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /; /; One lag testing /; %b34slet runtests=1; %b34sif(&runtests.ne.0)%then; b34sexec bjest; model gasout; modeln p=(1); forecast nf=12 nt=296; b34srun; b34sexec btiden; title('Var Estimation to replicate Tiao-Box 1981 '); seriesn var=gasin Name('Box-Jenkins Gasin series'); seriesn var=gasout Name('Box-Jenkins Gasout series'); estvar p=1 output=normal ilarf numirf=12 granger; b34srun; %b34sendif; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(irf); call echooff; ibegin=1; iend=296; nlag=1; 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 print(psi tirf); alttirf=matrix(18,4:tirf); call print(alttirf); 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); b34srun; == ==IR8TOSTR Real*8 to String b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; == ==ISEXTRACT Move data into and out of a datatype b34sexec matrix; /; /; Define a structure with names of variables /; people=namelist(pname,ssn,age,race,income); /; /; load the elements of the structure /; pname =namelist(sue,joan,bob); ssn =array(:99,9821,22); age =idint(array(:35,45,58)); race =namelist(hisp,white,black); income=array(:40000,35000,50000); /; /; Test what has been loaded /; call tabulate(pname,ssn,age,race,income); /; /; Pull out data for age for all in people /; call print(sextract(people(3))); /; /; Get ss# and age fcor person 2 /; call print('Second person',sextract(people(1),2), sextract(people(3),2)); /; /; Update age array and place back in structure /; nage=age+1; call isextract(people(3),nage); call print(age); /; /; Make person # 1 77 /; call isextract(people(3),77,1); call print(age); b34srun; == ==ISMISSING Testing for Missing values b34sexec matrix; x=0.0; xmiss=missing(); call print(x,xmiss); y=grid(1.,20.,1.); oldy=y; do i=1,norows(y); if(dmod(y(i),2.).eq.0.0)y(i)=missing(); enddo; test=ismissing(y); call tabulate(oldy,y,test); b34srun; == ==ISTRTOINT String to Integer b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; == ==ISTRTOR8 String to Real*8 b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; == ==IUPPER Upper case a string b34sexec matrix; call character(cc,'THIS IS UPPER'); lower=cc; call ilower(lower); upper=lower; call iupper(upper); call print(cc,lower,upper); b34srun; == ==IWEEK Variable form of Week Day /$ Tests Y2K capability of B34S /$ /$ day month year read in and converted to julian /$ /$ julian = # of days since 1 Jan 1960 /$ /$ b34s data step looks at day ahead and behind /$ /$ dates in 1400's, 1800's 1900's 2000's and 2100's tested /$ /$ ******************************************************* /$ b34sexec options sasdateon; b34srun; b34sexec data heading('Y2K test') idvar=cdate1; input day month year ; build dayinyr dbehind1 dbehind2 dahead1 cweekd iweekd dahead2 qt cdate1 cdate2 julian julianp1 julianm1; character cdate1 cdate2 dbehind1 dbehind2 dahead1 dahead2 cweekd; gen julian = juldaydmy(day,month,year); gen dayinyr = julian - juldaydmy(1,1,getyear(julian))+1.; gen cdate1 = chardate(julian); gen cdate2 = chardatemy(julian); gen julianp1=julian+1.; gen julianm1=julian-1.; gen dbehind1= chardate(julianm1); gen dbehind2= chardatemy(julianm1); gen dahead1 = chardate(julianp1); gen dahead2 = chardatemy(julianp1); gen qt = getqt(julian); gen iweekd = iweek(julian); gen cweekd = cweek(julian); datacards; 9 9 1999 31 12 1999 1 1 2000 2 1 2000 3 1 2000 28 2 2000 29 2 2000 1 3 2000 31 12 2000 1 1 1850 31 12 1899 1 1 2001 5 1 2100 1 5 1492 1 1 1999 2 1 1999 1 2 1999 1 1 1960 b34sreturn; b34seend; b34sexec list ; b34srun; b34sexec list; var julian julianp1 julianm1; b34srun; /$ /$ Data passed to Matrix to see it it prints OK /$ b34sexec matrix; call loaddata; call names; call tabulate(day month year julian dayinyr dbehind1 dbehind2 dahead1 dahead2 qt); call tabulate(day month year julian julianm1 julianp1 cdate1 cdate2); tj =chardate(julian); tjm1 =chardate(julianm1); tjp1 =chardate(julianp1); iiweekd =iweek(julian); ccweekd =cweek(julian); julian =idint(julian); julianm1=idint(julianm1); julianp1=idint(julianp1); call print('This tests calculations within MATRIX of julian data'); call tabulate(day month year julian julianm1 julianp1 tj tjm1 tjp1); call tabulate(day,month,year,julian,iiweekd,ccweekd,iweekd,cweekd); b34srun; == ==I_DRNBET Random numbers from beta distribuition b34sexec matrix; * Test problem from IMSL; p=3.; q=2.; n=5; beta=array(n:); call i_rnset(123457); call i_drnbet(beta,p,q); call print('Beta(3. 2.) Distribution', 'Answers should be .2814 .9483 .3984 .3103 .8296', beta); n=500; beta=array(n:); call i_drnbet(beta,p,q); call graph(beta :heading 'Beta Distribution'); b34srun; == ==I_DRNCHI Random numbers from Chi-squared distribution b34sexec matrix; * Test problem from IMSL; df=5.; n=5; chisq=array(n:); call i_rnset(123457); call i_drnchi(chisq,df); call print('Chisq Distribution', 'Answers should be 12.0900 .4808 1.7976 14.8712 1.7477', chisq); n=500; chisq=array(n:); call i_drnchi(chisq,df); call graph(chisq :heading 'Chi-squared Distribution'); b34srun; == ==I_DRNCHY Random numbers from Cauchy distribution b34sexec matrix; * Test problem from IMSL; n=5; cauchy=array(n:); call i_rnset(123457); call i_drnchy(cauchy); call print('Cauchy Distribution', 'Answers should be 3.5765 .9353 15.5797 2.0815 -.1333', cauchy); n=5; cauchy=array(n:); call i_drnchy(cauchy); call graph(cauchy :heading 'Cauchy Distribution'); b34srun; == ==I_DRNEXP Random numbers from standard exponential b34sexec matrix; * Test problem from IMSL; n=5; expdis=array(n:); call i_rnset(123457); call i_drnexp(expdis); call print('Exponential Distribution', 'Answers should be .0344 1.3443 .2662 .5633 .1686', expdis); n=500; expdis=array(n:); call i_drnexp(expdis); call graph(expdis :heading 'Standard Exponential Distribution'); b34srun; == ==I_DRNEXT Random numbers from mixture of two exponential distri b34sexec matrix; * Test problem from IMSL; n=5; theta1=2.0; theta2=1.0; p=.5; mexp=array(n:); call i_rnset(123457); call i_drnext(mexp,theta1,theta2,p); call print('Mixture of two Exponentials', 'Answers should be .0700 1.3024 .6301 1.9756 .3716', mexp); n=500; mexp=array(n:); call i_drnext(mexp,theta1,theta2,p); call graph(mexp :heading 'Mixture of two Exponentials'); b34srun; == ==I_DRNGAM Random numbers from standard gamma distribution b34sexec matrix; * Test problem from IMSL; n=5; a=3.0; gamma=array(n:); call i_rnset(123457); call i_drngam(gamma,a); call print('Gamma Distribution', 'Answers should be 6.8428 3.4452 1.8535 3.9992 .7794', gamma); n=500; gamma=array(n:); call i_rnset(123457); call i_drngam(gamma,a); call graph(gamma :heading 'Standard Gamma Distribution'); b34srun; == ==I_DRNGCT Random numbers from general continuous distribution b34sexec matrix; * Problem from IMSL. Tests Berta(3.,2.) distribution; x =grid(0.0,1.,.01); pp =array(norows(x):)+3.; qq =array(norows(x):)+2.; cdf=betaprob(x,pp,qq); call tabulate(x,cdf); call i_rnset(123457); n=5; xr=array(n:); call i_drngct(xr,x,cdf); call print('Test values should be', '.9208 .4641 .7668 .6536 .8171',xr); n=500; xr=array(n:); call i_drngct(xr,x,cdf); call graph(xr :heading 'Random Numbers from Beta using i_drngct'); b34srun; == ==I_DRNGDA Random integers from discrete distribution alias appr b34sexec matrix; * Sample problem from IMSL; imin=1; n=5; ir=idint(array(n:)); pf=array(:.05 .45 .31 .04 .15); call i_rnset(123457); call i_drngda(ir,imin,pf); ir2=ir; call i_drngda(ir2,imin,pf); call print('Random integers from Discrete Distribution - Alias Approach' 'Test values should be 3 2 2 3 5',ir,'and 1 3 4 5 3',ir2); b34srun; == ==I_DRNGDT Random integers from discrete using table lookup b34sexec matrix; * Sample problem from IMSL; imin=1; n=5; ir=idint(array(n:)); pf=array(:.05 .45 .31 .04 .15); call i_rnset(123457); call i_drngdt(ir,imin,pf); call print('Random integers from Discrete Distribution - Table Lookup', 'Test values should be 5 2 3 3 4',ir); b34srun; == ==I_DRNGES Get the table used in the shuffled generators. b34sexec matrix; table=rec(array(128:)); call i_drnses(table); call i_drnges(table2); call tabulate(table,table2); b34srun; == ==I_DRNLNL Random numbers from lognormal distribution b34sexec matrix; * Test problem from IMSL; n=5; xmean=0.0; xsd=1.0; lognorm=array(n:); call i_rnset(123457); call i_drnlnl(lognorm,xmean,xsd); call print('Log Normal Distribution', 'Answers should be 7.7801 2.9543 1.0861 3.5885 .2935', lognorm); n=500; lognorm=array(n:); call i_rnset(123457); call i_drnlnl(lognorm,xmean,xsd); call graph(lognorm :heading 'Log Normal Distribution'); b34srun; == ==I_DRNMVN Random numbers from multivariate normal b34sexec matrix; * Problem from IMSL; nr=5; k=2; r=array(nr,k:); cov=matrix(k,k:.5 .375 .375 .5); rsig=pdfac(cov); call print(rsig); call i_rnset(123457); call i_drnmvn(r,rsig); call print('Multivariate Normal Deviates' 'Col 1 1.4507 .7660 .0584 .9035 -.8669' 'Col 2 1.2463 -.0429 -.6692 .4628 -.9334', r); b34srun; == ==I_DRNNOA Random normal numbers using acceptance/rejection b34sexec matrix; * problem from IMSL ; x=array(5:); call i_rnset(123457); call i_drnnoa(x); call print('answers should be ', ' 2.0516 1.0833 .0826 1.2777 -1.2260',x); x=array(500:); call i_drnnoa(x); call graph(x :Heading 'Random Normal Values'); b34srun; == ==I_DRNNOR Random normal numbers using CDF method b34sexec matrix; * problem from IMSL ; x=array(5:); call i_rnset(123457); call i_drnnor(x); call print('answers should be ', ' 1.8279 -.6412 .7266 .1747 1.0145',x); x=array(500:); call i_drnnor(x); call graph(x :Heading 'Random Normal Values - CDF Method'); b34srun; == ==I_DRNSES Initializes the table used in the shuffled generators b34sexec matrix; table=rec(array(128:)); call i_drnses(table); call i_drnges(table2); call tabulate(table,table2); b34srun; == ==I_DRNSPH Random numbers on the unit circle b34sexec matrix; * problem from IMSL; n=2; k=3; r=array(n,k:); call i_rnset(123457); call i_drnsph(r); call print('Random points on unit circle' 'Row 1 .8893 .2316 .3944' 'Row 2 .1901 .0396 -.9810',r); b34srun; == ==I_DRNSTA Random numbers from stable distribution b34sexec matrix; * Test problem from IMSL; n=5; sta=array(n:); call i_rnset(123457); alpha=1.5; bprime=0.0; call i_drnsta(sta,alpha,bprime); call print('Stable Distribution', 'Answers should be 4.4091 1.0564 2.5463 5.6724 2.1656' sta); n=500; sta=array(n:); call i_drnsta(sta,alpha,bprime); call graph(sta :heading 'Stable Distribution'); b34srun; == ==I_DRNTRI Random numbers from triangular dsitribution b34sexec matrix; * Test problem from IMSL; n=5; tri=array(n:); call i_rnset(123457); call i_drntri(tri); call print('Triangular Distribution', 'Answers should be .8700 .3610 .6581 .5360 .7215' tri); n=500; tri=array(n:); call i_drntri(tri); call graph(tri :heading 'Triangular Distribution'); b34srun; == ==I_DRNUN Uniform (0,1) Generator b34sexec matrix; * IMSL test case; call i_rnset(123457); x=array(5:); call i_drnun(x); call print('answers should be' ' .9662 .2607 .7663 .5693 .8448'); call print(x); n=300; x=array(n:); call i_drnun(x); call graph(x :heading 'random numbers'); b34srun; == ==I_DRNVMS Random numbers from Von Mises distribution b34sexec matrix; * Test problem from IMSL; n=5; vm=array(n:); c=1.0; call i_rnset(123457); call i_drnvms(vm,c); call print('Von Mises Distribution', 'Answers should be .2472 -2.4326 -1.0216 -2.1722 -.5029' vm); n=500; vm=array(n:); call i_drnvms(vm,c); call graph(vm :heading 'Von Mises Distribution'); b34srun; == ==I_DRNWIB Random numbers from Weibull distribution b34sexec matrix; * Test problem from IMSL; n=5; wb=array(n:); a=2.0; scale=6.; call i_rnset(123457); call i_drnwib(wb,a); wb=wb*scale; call print('Weibull Distribution', 'Answers should be 1.1122 6.9567 3.0959 4.5031 2.4638' wb); n=500; wb=array(n:); call i_drnvms(wb,a); wb=wb*scale; call graph(wb :heading 'Weibull Distribution'); b34srun; == ==I_RNBIN Random integers from binomial distribution b34sexec matrix; * Problem from IMSL ; ir=idint(array(5:)); ntrials = 20; probs = .5; call i_rnset(123457); call i_rnbin(ir,ntrials,probs); call print('answers should be 14 9 12 10 12',ir, 'Number of trials ',ntrials, 'Probability of Success ',probs); b34srun; == ==I_RNGEO Random integers from Geometric distribution b34sexec matrix; * Problem from IMSL ; ir=idint(array(5:)); p=.3; call i_rnset(123457); call i_rngeo(ir,p); call print('Geometric Distribution', 'Answers should be 1 4 1 2 1', ir,'Probability of Success',p); b34srun; == ==I_RNGET Gets seed used in IMSL Random Number generators. b34sexec matrix; call i_rnget; call i_rnget(ii); call print('Seed was ',ii); call i_rnset(3452); call i_rnget; b34srun; == ==I_RNHYP Random integers from hypergeometric distribution b34sexec matrix; * Sample problem from IMSL ; ii=idint(array(5:)); call i_rnset(123457); n=4; m=12; l=20; call i_rnhyp(ii,n,m,l); call print('Should be 4 2 3 3 3 ',ii, 'Items in sample ',n, 'Special items in population ',m, 'Number of items in lot ',l); b34srun; == ==I_RNMTN Random numbers from multinomial distribution b34sexec matrix; * Test problem from IMSL; nr=5; k=3; ir=idint(array(nr,k:)); n=20; p=array(k:.1 .3 .6); call i_rnset(123457); call i_rnmtn(ir,n,p); call print('Multinomial distribution', 'Answers should be:', 'col 1 5 3 3 5 4' 'col 2 4 6 3 5 5' 'col 3 11 11 14 10 11' ir); b34srun; == ==I_RNNBN Negative binomial distribution b34sexec matrix; * Test problem from IMSL; * Since R is an integer we have a Pascal distribution; r=4.; p=.3; n=5; ii=idint(array(n:)); call i_rnset(123457); call i_rnnbn(ii,r,p); call print('Pascal Distribution', 'Answers should be 5 1 3 2 3', ii); b34srun; == ==I_RNOPG Gets the type of generator currently in use. b34sexec matrix; call i_rnopg; call echooff; do i=1,7; call i_rnopt(i); call i_rnopg; call i_rnopg(j); if(i.ne.j)then; call epprint('ERROR: i_rnopt and i_rnopg not correct'); call epprint('sett was ',i,' return was ',j); endif; enddo; call i_rnopg(ii,recver,rnver); call print('imsl code ',ii,recver,rnver); b34srun; == ==I_RNOPT Selects the type of uniform (0,1) generator. b34sexec matrix; call i_rnopg; call echooff; do i=1,7; call i_rnopt(i); call i_rnopg; call i_rnopg(j); if(i.ne.j)then; call epprint('ERROR: i_rnopt and i_rnopg not correct'); call epprint('sett was ',i,' return was ',j); endif; enddo; b34srun; == ==I_RNPER Random pertibation of integers b34sexec matrix; * Test problem from IMSL; n=10; ii=idint(array(n:)); call i_rnset(123457); call i_rnper(ii); call print('Random Pertibation of Integers', 'Answers should be 5 9 2 8 1 6 4 7 3 10', ii); b34srun; == ==I_RNSET Sets seed used in IMSL Random Number generators. b34sexec matrix; call i_rnget; call i_rnget(ii); call print('Seed was ',ii); call i_rnset(3452); call i_rnget; b34srun; == ==I_RNSRI Index of random sample without replacement b34sexec matrix; * Test problem from IMSL; nsamp=5; npop =100; ii=idint(array(nsamp:)); call i_rnset(123457); call i_rnsri(ii,npop); call print('Random Sample of Indices without replacement' 'Answer should be 2 22 53 61 79' ii); b34srun; == ==JULDAYDMY Gets Julday from Day, Month, year b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==JULDAYQY Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==JULDAYY Illustrates Date processing b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; == ==JULIAN_TO_TB Julian to Time Base b34sexec matrix; freq1=12.; ioff=6; series1=rn(array(6:)); call julian_to_tb(juldaydmy(1,5,1972),freq1,tbase1,tstart1); call print(tbase1,tstart1); call up_date_tb(tbase1,tstart1,freq1,tbase2,tstart2,ioff); call settime(series1,tbase2,tstart2,freq1); call describe(series1); /; /; Here he have a time series but want to trap and updtae the /; tbase and tstart info: /; tbase1 =timebase(series1); tstart1=timestart(series1); freq1=freq(series1); ioff=6; call up_date_tb(tbase1,tstart1,freq1,tbase1,tstart2,ioff); call print(tbase1,tbase2,tstart1,tstart2); b34srun; == ==KEENAN Illustrates Keenan Test b34sexec options ginclude('gas.b34'); b34srun; /; /; See Keenan D. 'A Tukey Nonadditive Type Test for Time Series /; Nonlinearity' Biometrika 72, 39-44 1985 /; b34sexec matrix; call echooff; call loaddata; do i=2,18; call keenan(gasout,tt,i,pp); j=i-1; test(j) =tt; prob(j) =pp; order(j) =i; enddo; call print('Keenan (1985) Test of Gasout Series'); call tabulate(order,test,prob); b34srun; b34sexec options ginclude('b34sdata.mac') member(blake); b34srun; b34sexec matrix; call loaddata; call echooff; call print('Results should be:' ' 2 3 4 5 ' ' -.086613 -1.6219 -1.8737 -1.2281'); call bds(blake,.5,5,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); do i=2,18; call keenan(blake,tt,i,pp); j=i-1; test(j) =tt; prob(j) =pp; order(j) =i; enddo; call print('Keenan (1985) Test of Blake Series'); call tabulate(order,test,prob); b34srun; == ==KEEPFIRST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; == ==KEEPLAST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; == ==KIND Kind of an object b34sexec matrix; x=rn(matrix(3,3:)); ii=idint(2.0); cc=complex(1.2,3.3); call print(kind(x), kind(ii),kind(cc), klass(x),klass(ii),klass(cc)); b34srun; == ==KINDAS Change kind of an object b34sexec matrix; x=10.; one1=kindas(x,1.0); one2=kindas(r8tor16(x),1.0); vpa_data=vpa('1234.7713'); testr8 =kindas(x,vpa_data); testr16=kindas(r8tor16(x),vpa_data); new_vpa1=kindas(vpa_data,testr8); new_vpa2=kindas(vpa_data,testr16); call names(all); call print(vpa_data,testr8,testr16,new_vpa1,new_vpa2); b34srun; /$ Illustrates use of kindas for a general subroutine b34sexec matrix ; subroutine test(x); call print('now in test'); call print('x found to be ',x); call names(all); x=x*kindas(x,2.); return; end; x=array(2:11 22); r16x=r8tor16(x); call print(x); call test(x); call print(x); call print(r16x); call test(r16x); call print(r16x); b34srun; == ==KINDAS_2 Shows how errors can creek in if constants b34sexec matrix; x8=7.234; x16=real16('7.234'); x16alt=kindas(x16,7.234); x16alt2=kindas(x16,real16('7.234')); x8alt= kindas(x8, real16('7.234')); call print(x16,x16alt,x16alt2); call print( 'Shows error since wrong conversion',(x16-x16alt):); call print( 'Shows right way to proceed ',(x16-x16alt2):); call print( 'Looking at real*8 ',x8,x8alt); call print( 'Error using real*8 ',(x8-x8alt):); b34srun; == ==KLASS Klass of an object b34sexec matrix; x=rn(matrix(3,3:)); ii=idint(2.0); cc=complex(1.2,3.3); call print(kind(x), kind(ii),kind(cc), klass(x),klass(ii),klass(cc)); b34srun; == ==KPROD Kronecker Product b34sexec matrix; * Example from Greene (2000) page 35; a=matrix(2,2:3 0 5 2); b=matrix(2,2:1 4 4 7); x=kprod(a,b); call print('Answer matrix(2,2: 3* b , 0 * b , 5 * b , 2 * b)':); call print(a,b,x); * Complex case; aa=complex(a,-1.*dsqrt(a)); bb=complex(b,-1.*dsqrt(b)); cx=kprod(aa,bb); call print(aa,bb,cx); * Matlab 11-1 case; x=matrix(2,2:1. 2. 3. 4.); y=matrix(2,2:)+1.; call print(x,y,kprod(x,y),kprod(y,x)); b34srun; == ==KPSS KPSS Stationarity Test %b34slet dorats=1; /; setup. to look at Hamilton data; %b34slet pass2=0; b34sexec options ginclude('greene.mac') member(nf5_1); b34srun; b34sexec matrix; call loaddata; call echooff; call load(cov :staging); y=dlog(realgdp); infl=goodrow(infl); call print('Elliot-Rotherberg-Stock Tests on log(realgdp)':); call load(df_gls); call load(kpss); dosim=1; /; call print(df_gls); /$ /$ 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 /$ /$ ********************************************************** /$ /$ 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; do i=1,4; call print('Elliot-Rothenberg-Stock test Lag ',i:); call DF_GLS(y,i,notrend,trend,notrendx,trendx,iprint); call print(' ':); enddo; /; 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 /; iprint - 1 => print /; 2 => print stat and give OLS equations also /; /; For added detail see Greene (2008) page 755 /; /; lagg=integers(0,10); notrendt=array(11:); trendt =array(11:); do i=0,10; j=i+1; call kpss(y,test1,test2,i,1); notrendt(j)=test1; trendt(j) =test2; enddo; call tabulate(lagg,notrendt,trendt); /; Simulation Study if(dosim.ne.0)then; n=1000; lagg1=20; call print(' ':); call print('--------------------------------------------------------':); call print('Tests with stationary (sseries) & unit root data (uroot)':); call print('# of observations in series was ',n:); call print('# of lags used was 1 to ',lagg:); call print(' ':); sseries=rn(array(n:)); uroot=cusum(sseries); call print('--------------------------------------------------------':); call print('Stationary Series Being Tested':); call print(' ':); call print('--------------------------------------------------------':); lagg=integers(0,lagg1); notrendt=array(lagg1+1:); trendt =array(lagg1+1:); do i=0,lagg1; j=i+1; call kpss(sseries,test1,test2,i,0); notrendt(j)=test1; trendt(j) =test2; enddo; call tabulate(lagg,notrendt,trendt); call print('--------------------------------------------------------':); call print('Unit Root Series Being Tested',:); call print(' ':); call print('--------------------------------------------------------':); lagg=integers(0,lagg1); notrendt=array(lagg1+1:); trendt =array(lagg1+1:); do i=0,lagg1; j=i+1; call kpss(uroot,test1,test2,i,0); notrendt(j)=test1; trendt(j) =test2; enddo; call tabulate(lagg,notrendt,trendt); b34srun; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * source d:\r\dfunit.src source d:\r\ppunit.src source d:\r\kpss.src source d:\r\stockwat.src set y = log(realgdp) @dfunit(lags=0) y @ppunit(lags=4) y * This 100% agrees with Greene (2008) page 755 @kpss(lags=0) y @kpss(lags=0,det=trend) y @kpss(lags=1) y @kpss(lags=1,det=trend) y do i=0,10 @kpss(lags=i) y @kpss(lags=i,det=trend) y end do i do i=1,4 @stockwat(arcorr=i) y end do i b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; %b34sif(&pass2.ne.0)then; b34sexec options ginclude('b34sdata.mac') member (hamilton1); b34srun; b34sexec matrix; call loaddata; call echooff; call print('Elliot-Rothenberg-Stock Tests on tbill '); call load(df_gls); call load(kpss); /; call print(df_gls); iprint=1; do i=1,4; call print('Elliot-Rothenberg-Stock test Lag ',i:); call DF_GLS(tbill,i,notrend,trend,notrendx,trendx,iprint); call print(' ':); enddo; call print('Tests on Hamilton':); lagg1=20; lagg=integers(0,lagg1); notrendt=array(lagg1+1:); trendt =array(lagg1+1:); do i=0,lagg1; j=i+1; call kpss(tbill,test1,test2,i,0); notrendt(j)=test1; trendt(j) =test2; enddo; call tabulate(lagg,notrendt,trendt); b34srun; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * source d:\r\dfunit.src source d:\r\ppunit.src source d:\r\kpss.src source d:\r\stockwat.src @dfunit(lags=0) tbill @ppunit(lags=4) tbill @kpss(lags=4) tbill @kpss(lags=4,det=trend) tbill do i=1,10 @kpss(lags=i) tbill @kpss(lags=i,det=trend) tbill end do i do i=2,10 @stockwat(arcorr=i) tbill end do i b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; %b34sendif; == ==KSWTEST K Period Stock Watson Test b34sexec options ginclude('gas.b34'); b34srun$ b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); call load(kswtest); /$ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /$ ======================================================== /$ SUBROUTINE for Multi Breaking Periods /$ /$ /$ subroutine kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2); /$ /$ Generate k by k Stock Watson Test Statistics /$ /$ 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 /$ 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 /$ /$ **************************************************************** /$ /$ ========================================================== nlag = 8; nterms = 20; iprint = 0; iprint2= -1; call get(gasin,gasout :dropmiss); call echooff; * Single series model ; vbegin1 = index( 1 100); vend1 = index( 99 189) ; x=gasout; call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); if(iprint2.eq.0)call print(%var___1, %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1); vbegin1 = index( 1 100 190); vend1 = index( 99 189 296) ; x=gasout; call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); if(iprint2.eq.0)call print(%var___1, %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1); * multi series model; vbegin1 = index( 1 100); vend1 = index( 99 189) ; x = mfam(catcol(gasin,gasout)); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); if(iprint2.eq.0)call print(%var___1 %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1 %var___2 %varh__2 %rsq___2 %fac___2 %dfac__2 %dstr__2 %dvar__2 ); vbegin1 = index( 1 100 190); vend1 = index( 99 189 296) ; x = mfam(catcol(gasin,gasout)); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); if(iprint2.eq.0)call print(%var___1, %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1 %var___2 %varh__2 %rsq___2 %fac___2 %dfac__2 %dstr__2 %dvar__2 ); b34srun ; == ==KSWBOOTS Critical values for output from KSWTEST %b34slet kswboot =1; %b34slet kswboot2=1; %b34slet swboot =1; /$ Observation of Three Period /$ US Others Year /$ 1st Begin : 1 1 1890 1886 /$ 1st End : 25 29 1914 /$ 2nd Begin : 31 35 1920 /$ 2nd End : 50 54 1939 /$ 3rd Begin : 61 65 1950 /$ 3rd End : 112 116 2001 b34sexec options ginclude('b34sdata.mac') member(JML_GDP); b34srun; b34sexec matrix; call loaddata ; call load(buildlag); call load(varest); call load(swartest); call load(kswtest) ; call load(kswboots) ; call load(swboots) ; call echooff; nlag = 1 ; nterms = 10 ; iprint = 0 ; iprint2= -1 ; p=nlag ; printout=0 ; /; Note: Activate to 100 or more for actual runs!!! niter = 10 ; /; niter = 100; * method = 1 ; k = 30 ; call print('====================================') ; call print(' 3 Period Log differeced US GDP AR1 ') ; call print('====================================') ; call print(' x = us_gdp ') ; Call print('Without Interwar periods') ; call print('====================================') ; vbegin1 = index( 1 31 61) ; vend1 = index(25 50 112) ; x = us_gdp ; %b34sif(&kswboot.ne.0)%then; call print('Testing KSWTEST - KSWBOOTS one variable model':); call print('__________________________':); call print(' ':); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; call kswboots(x,p,k,printout,niter,1,vbegin1,vend1,nterms); /; call kswboots(x,p,k,printout,niter,2,vbegin1,vend1,nterms); /; call kswboots(x,p,k,printout,niter,3,vbegin1,vend1,nterms); %b34sendif; %b34sif(&kswboot2.ne.0)%then; call print('Testing KSWTEST - KSWBOOTS two variable model':); call print('__________________________':); call print(' ':); x=catcol(us_gdp uk_gdp); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; call kswboots(x,p,k,printout,niter,1,vbegin1,vend1,nterms); /; call kswboots(x,p,k,printout,niter,2,vbegin1,vend1,nterms); /; call kswboots(x,p,k,printout,niter,3,vbegin1,vend1,nterms); %b34sendif; %b34sif(&swboot.ne.0)%then; call print('Testing SWARTEST-SWBOOTS':); call print('________________________':); call print(' ':); bb=vbegin1; ar_p=p; ibegin1=1; iend1 =25; ibegin2=31; iend2 =50; iprint=1; printout=0; k=0; 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 print('Bootstrap Errors using Original Errors':); call swboots(X,ar_p,k,printout,niter,1,ibegin1,iend1,ibegin2,iend2, nterms); call print('Monte Carlo Critical value':) ; call swboots(X,ar_p,k,printout,niter,3,ibegin1,iend1,ibegin2,iend2, nterms); %b34sendif; b34srun ; == ==KSWTESTM Moving Period Stock Watson Test b34sexec options ginclude('gas.b34'); b34srun$ b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); call load(kswtestm); nlag = 8; nterms = 20; iprint = 0; iprint2= 0; call get(gasin,gasout :dropmiss); /$ **************************************************************** call echooff; * Single series model ; vbegin1 = index( 1 100); vend1 = index( 99 199); vbegin2 = index(100 200); vend2 = index(199 296); x=gasout; call echooff; call kswtestm(x,vbegin1,vend1, vbegin2,vend2,nlag,nterms, iprint,iprint2) ; call names(all); if(iprint2.eq.0) call print(%t11___1 %t12___1 %t22___1 %t21___1 %VAR1__1 %VAR2__1 %RSQ1__1 %VARH1_1 %VARH2_1 %RSQ2__1 %DFAC__1 %DVAR1_1 %DVAR2_1 %DSTR1_1 %DSTR2_1); /$ Multi Series Model call print('Multi Series Model':); call print('******************':); x = mfam(catcol(gasin,gasout)); call kswtestm(x,vbegin1,vend1,vbegin2,vend2, nlag,nterms,iprint,iprint2) ; /$ call names(all); if(iprint2.eq.0) call print(%t11___1 %t12___1 %t22___1 %t21___1 %VAR1__1 %VAR2__1 %RSQ1__1 %VARH1_1 %VARH2_1 %RSQ2__1 %DFAC__1 %DVAR1_1 %DVAR2_1 %DSTR1_1 %DSTR2_1 %t11___2 %t12___2 %t22___2 %t21___2 %VAR1__2 %VAR2__2 %RSQ1__2 %VARH1_2 %VARH2_2 %RSQ2__2 %DFAC__2 %DVAR1_2 %DVAR2_2 %DSTR1_2 %DSTR2_2 ); b34srun ; == ==LABEL Illustrate LABEL b34sexec matrix; short=10.; long= 20; call names; call setlabel(short,'test'); call setlabel(long, 'This is a long label'); call names; call print('Label for long' ,label(long), 'Label for short',label(short)); b34srun; /; /; Advanced example using label to generate a matrix /; b34sexec options ginclude('h_t_f_data.mac') member(cancer); b34srun; b34sexec matrix; call loaddata; /; /; Make %names% /; call names(:); i=norows(%names%); nn=%names%(integers(2,i-2)); /; /; Simple access to one label /; /; Note that the label is saved by col!! /; call print(label(argument(nn(1)))); /; /; Labels saved in 40 by 64 Character*1 array /; tt=label(argument(nn)); call print(transpose(tt)); call names(all); b34srun; == ==LAG Lag function b34sexec matrix; n=10; x=array(n:integers(n)); lagx =lag(x,1); lagx2=lag(x,2); lagxm =lag(x,-1); lagxm2=lag(x,-2); misslagx=ismissing(lagx); call tabulate(x,lagx,lagx2,lagxm,lagxm2,misslagx); b34srun; b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; == ==LAGMATRIX Builds a matrix with lagged variables b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call lagmatrix(gasin{1 to 6} gasout{4 to 8} :matrix mm); call tabulate(gasin,gasout); call names(all); call tabulate(%lmatvar,%lmatlag); call print(mm); call tabulate(%lmatvar,%lmatlag); call print(%k,%noblags,%xfobs %xfuture); /; /; negative lags /; call print('+_ and - lags done two ways to get same answer':); call olsq(gasout gasout{ 1 to 6} gasin{-5 to 5} :print); call lagmatrix( gasout{ 1 to 6} gasin{-5 to 5} :matrix mm :noint); yy=%y; call olsq(yy mm :print); gasin16=r8tor16(gasin); gasout16=r8tor16(gasout); call print('Real*16 results':); call print('+++++++++++++++++++++++++++++++++++++++':); call names(all); call lagmatrix(gasin16{1 to 6} gasout16{4 to 8} :matrix mm16); call tabulate(gasin16,gasout16); call print(mm16); call tabulate(%lmatvar,%lmatlag); call print(%k,%noblags,%xfobs %xfuture); call names(all); /; /; negative lags /; call print('+_ and - lags done two ways to get same answer':); call olsq(gasout16 gasout16{ 1 to 6} gasin16{-5 to 5} :print); call names(all); call lagmatrix( gasout16{ 1 to 6} gasin16{-5 to 5} :matrix mm :noint); yy=%y; call olsq(yy mm :print); b34srun; == ==LAGMATRIX2 Illustrates use of lagmatrix to generate hfuture /$ Illustrates use of lagmatrix to generate hfuture /$ prior to the call to mars b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; * build the matrix for forecasts; * Variables must be what is supplied ; * Note that mars does not have to supply a constant; call print(gasin,gasout); maxlag=6; maxhave=100; * This logic tests sample generation based on value; sample=(gasin.ge. 0.0); call tabulate(sample,gasin,gasout); * This logic tests killing data due to obs number; sample=array(norows(gasin):); i=integers(1,maxhave); sample(i)=1.0; call tabulate(sample,gasin,gasout); * adjust sample to kill obs; i=integers(1,maxlag); sample(i)=missing(); sample=goodrow(sample); call lagmatrix(gasin{1 to maxlag} gasout{1 to maxlag} :noint :sample sample); hfuture=%xfuture; call names; call print('Truncated sample'); call print(%matrix); call print(%xfuture); call tabulate(%lmatvar,%lmatlag); call olsq(gasout gasin{1 to maxlag} gasout{1 to maxlag} :print :sample sample ); call print(%xfuture*%coef); call mars(gasout gasin{1 to maxlag} gasout{1 to maxlag} :print :forecast hfuture :sample sample ); call print(hfuture,%xfuture); b34srun; == ==LAGTEST Illustrate LAGTEST Subroutine b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(lagtest); call echooff; /$ 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 /$ ylag = 24; xlag = 24; nsubsets = 12; call lagtest(gasout,gasin,ylag,xlag,nsubsets,rss); call checkpoint; b34srun; == ==LAGTEST2 Tests Alternative lags of MARS Model b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(lagtest2); call echooff; ylag = 12; xlag = 12; nsubsets = 5; nk=20; mi=2; call lagtest2(gasout,gasin,ylag, xlag,nsubsets,mi,nk,rss); call checkpoint; b34srun; == ==LAGTEST_2 Mink-Muskrat Lags b34sexec options ginclude('b34sdata.mac') member(mink); b34srun; b34sexec matrix; call loaddata; call load(lagtest); call echooff; /$ 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 /$ ylag = 6 ; xlag = 6 ; nsubsets = 5 ; call lagtest(mink,muskrat,ylag,xlag,nsubsets,rss); call checkpoint; b34srun; == ==LAGTEST_3 AAA=f(PD_M1) b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call load(lagtest); call echooff; /$ subroutine lagtest(y,x,ylag,xlag,nsubsets,rss); /$ /$ Purpose: Use 3-D Graph to display RSS for /$ alternative lags of OLS Model /$ /$ y y-variable /$ x x-variable /$ ylag # lags on y /$ xlag # lags on x /$ nsubsets # subsets /$ ylag = 24; xlag = 24; nsubsets = 12; call lagtest(fyaac,pcrm1,ylag,xlag,nsubsets,rss); call checkpoint; b34srun; == ==LAPACK Sets LAPACK b34sexec matrix; x=rec(matrix(4,4:)); call lapack; xi=inv(x:gmat); call print(x,xi); call lapack(1,1); call lapack; xi=inv(x:gmat); call print(x,xi); call lapack(:reset); call lapack; b34srun; == ==LAPACK_2 Shows Speed gains due to Blocksize /$ Blocksize tests b34sexec matrix; call echooff; isize=12; Mat_ord =array(isize:); linpack =array(isize:); lapack1 =array(isize:); lapack4 =array(isize:); lapack7 =array(isize:); lapack10 =array(isize:); lapack13 =array(isize:); lapack16 =array(isize:); lapack19 =array(isize:); lapackd =array(isize:); j=0; do i=1,19,3; n=64; top continue; j=j+1; if(n.gt.768)go to endit; /; call print('Order of Matrix ',n:); mat_ord(j)=n; x=rec(matrix(n,n:)); /; set blocksize for lapack /; LINPACK need only to be run one time call lapack(1,i); if(i.eq.1)then; call timer(t1); xx=inv(x); call timer(t2); /; call print('LINPACK time ',t2-t1:); linpack(j)=t2-t1; call compress; endif; call timer(t1); xx=inv(x:gmat); call timer(t2); /; call print('LAPACK time ',t2-t1:); if(i.eq.1)lapack1(j)=t2-t1; if(i.eq.4)lapack4(j)=t2-t1; if(i.eq.7)lapack7(j)=t2-t1; if(i.eq.10)lapack10(j)=t2-t1; if(i.eq.13)lapack13(j)=t2-t1; if(i.eq.16)lapack16(j)=t2-t1; if(i.eq.19)lapack19(j)=t2-t1; call compress; if(i.eq.1)then; call lapack(:reset); call timer(t1); xx=inv(x:gmat); call timer(t2); /; call print('LAPACK Defaults ',t2-t1:); lapackd(j)=t2-t1; call compress; endif; n=n+64; go to top; endit continue; j=0; enddo; call print(' ':); call print('Effects on Relative Speed of LAPACK blocksize':); call tabulate(mat_ord,linpack,lapack1,lapack4,lapack7, lapack10,lapack13,lapack16,lapack19, lapackd); b34srun; == ==LEVEL Level function => Determine level b34sexec matrix; subroutine test(y); call names(all); call print('In test level and y were ',level(),y); call test2(y); return; end; subroutine test2(x); call names(all); call print('In test2 level and x were ',level(),x); return; end; call print('Level in root',level()); i=1.; call test(i); call print('Back in root. Level was',level()); call names(all); b34srun; == ==LEVEL2 Advanced Level Examples /; /; Global variable moved to a subroutine where it is made local. /; Calculations then made and the result put back at the global level. /; b34sexec matrix; y=array(:10. 20.); call makeglobal(y); call print(level(v)); call print(level(y)); subroutine useit(x); call names(all); call print(x); x=x+100.; return; end; call useit(y); call names(all); call print(y); b34srun; == ==LM Engle LM ARCH test Test b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; n=30; lmvalue=array(n:); lag=idint(array(n:)); prob=array(n:); do i=1,n; lag(i)=i; call lm(gasout,value,i,pp); lmvalue(i)=value; prob(i)=pp; enddo; call print('Engle LM Test for ARCH in Gasout Series'); call tabulate(lag,lmvalue,prob); b34srun; == ==LMTEST Test LMTEST Subroutine b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call load(lmtest); call print('Test on gasout directly':); call lmtest(gasout,30,lag,tt,prob,1); call print( 'Test residuals of gasout=f(gasout(t-1,...,6) gasin(t-1,...,6)':); call print('This Model was studied by Tiao-Box (1981)' :); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); u=%res; call lmtest(u ,30,lag,tt,prob,1); good=rn(array(10000:)); call print('Test on good=rn(array(10000:))':); call lmtest(good ,30,lag,tt,prob,1); call print('Test on residuals of AR(6) on gasout ':); call print('Model discussed in Chapter 12 of Stokes (200x)':); call olsq(gasout gasout{1 to 6} : print); u=%res; call lmtest(u,4,lag,tt,prob,1); b34srun; == ==LOAD Call LOAD => Load a subroutine, function or program b34sexec matrix; * The Load command cannot be used in the Manual mode; call load(testpgm); call print(testpgm); call testpgm; call load(testsub); call print(testsub); call testsub(2.); call load(testfun); call print(testfun); call print('function call in sub call. f ',testfun(4.0)); f=testfun(4.0); call print(f); call load(pvalue_1); call print(pvalue_1); call pvalue_1(1,.06,a); call print(a); call names(all); b34srun; == ==LOADDATA Call LOADDATA => Load B34S data into Matrix command b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix saveasvector$ call print('This Loads the gas data.', 'Simple graphs are next done.'); call loaddata; call print('This is GASIN',gasin); call graph(gasout:heading 'This is GASOUT'); call names; b34srun$ == ==LOWERT Lower Triangle b34sexec matrix; x=rn(matrix(4,4:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); cx=complex(x,x*2.); x=r8tor16(x); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); cx=c16toc32(cx); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); b34srun; == ==LOESS Tests LOESS_SA LOESS_SPS LOESS_MV /; Loess Smoothing /; Turns on loess_MV on same example b34sexec options ginclude('b34sdata.mac') member(dow); b34srun; b34sexec matrix; call loaddata; call print('Default test case':); y=djones; call names(all); x=fyear(bjulian_); call loess_sps(x,y,sort_x,smoothy :print); /; The smaller the f => the more the smooth series follows the /; original series call print(' ':); call print('Test case # 1 ':); call loess_sps(x,y,sort_x,smoothy2 :print :f .15 :nsteps 0 :delta 0.); call print(' ':); call print('Test case # 2 ':); call loess_sps(x,y,sort_x,smoothy3 :print :f .40 :nsteps 0 :delta 0.); /; call tabulate(x,y,sort_x,smoothy, smoothy2 smoothy3,%res_xy); call graph(x y smoothy smoothy2 smoothy3 :plottype xyplot :nolabel :pgborder :nocontact :file 'loess_sps.wmf' :heading 'Data Smoothed by Default setup, f=.15 & f = .40'); call print('Using OLS as a base cvase':); call olsq(y x :print ); ols_ss1=%rss; olsres = %res; olsyhat= %yhat; /; call print(%y %x); call free(%x,%y); f=.75 ; call loess_mv(y x :noint :poly_deg 1 :savex :print :f f); yhatdg1=%yhat; resdg1=%res; /; Testing to see if robust estimation matters call loess_mv(y x :noint :poly_deg 2 :savex :print :f f); rr1=%res; yhat1=%yhat; call loess_mv(y x :noint :poly_deg 2 :robust :savex :print :f f); /; call tabulate(%y,olsyhat yhatdg1,yhat1,%yhat); call graph(%y,%yhat,yhat1 yhatdg1 olsyhat :nolabel :file 'loess_mv1.wmf' :pgborder :nocontact :heading 'Robust Estimation (%yhat) vs. no robust (yhat1)'); call graph(%res,rr1 resdg1 olsres :nolabel :file 'loess_mv2.wmf' :pgborder :nocontact :heading 'Robust Estimation (%res) vs. no robust (rr1)'); b34srun; b34sexec options ginclude('b34sdata.mac') member(loess_sa); b34srun; b34sexec matrix; call loaddata; call loess_sa(co2,sa_co2,trendco2 :print); /; call tabulate(co2,sa_co2,trendco2); call graph(co2,sa_co2,trendco2 :heading 'Loess Seasonal Adjustment' :nolabel); /; uses stl call loess_sa(co2,sa_co3,trendco3 :ildeg 0 :print); /; call tabulate(co2,sa_co2,trendco2,sa_co3,trendco3); call graph(co2,sa_co2,trendco2 :heading 'Loess Seasonal Adjustment' :nolabel); /; set up stl to mimic stlez 100% call loess_sa(co2,sa_co2,trendco2 :print); call loess_sa(co2,sa_co4,trendco4 :ildeg 0 :print :ns 7 :isdeg 0 :itdeg 0 :no 6 :nt 23 :nl 13 :ildeg 0 :nsjump 1 :ntjump 3 :nljump 2 :ni 1 :print); /; call tabulate(co2,sa_co2,trendco2,sa_co4,trendco4); b34srun; == ==LOESS_MV Multivariate Loess Modeling b34sexec options printvascmat; b34srun; %b34slet do_r =0; %b34slet do_b34s=1; b34sexec options ginclude('b34sdata.mac') member(breiman); b34srun; b34sexec list; b34srun; %b34sif(&do_b34s.eq.1)%then; b34sexec matrix; call loaddata; call echooff; call print('Using OLS as a base cvase':); call olsq(y e_ratio c_ratio :print ); ols_ss1=%rss; olsres = %res; olsyhat= %yhat; /; call print(%y %x); call free(%x,%y); f=.75 ; call print('Degree = 0 => sumsq(residual) ~= Total sum of squares':); call print(' ':); vv=array(88:)+1.; * call loess_mv(y e_ratio c_ratio :poly_deg 1 :nsing :weights vv :savex :print :f f ); call loess_mv(y e_ratio c_ratio :noint :poly_deg 1 :savex :print :f f); /; Testing to see if robust estimation matters and is slowcalc matters call loess_mv(y e_ratio c_ratio :noint :poly_deg 2 :savedhat :slowcalc :savex :print :f f); rr1=%res; yhat1=%yhat; call loess_mv(y e_ratio c_ratio :noint :poly_deg 2 :savedhat :robust :savex :print :f f); call tabulate(%y,%yhat,%res); call graph(%y,%yhat,yhat1 :nolabel :pgborder :nocontact :heading 'Does Robust Estimation (%yhat) result in gains?'); call graph(%res,rr1 :nolabel :pgborder :nocontact :heading 'Does Robust Estimation (%res) result in gains?'); /; Robust tests end ++++++++++++++++++++++++++++++++++++++++++++++++++ /; lsres=%res; call graph(olsres,lsres :heading 'OLS RES vs LS Degree 2 RES' :nolabel); call names(all); /; call tabulate(olsyhat,%yhat,olsres,%res,%y); /; call print(%delta,%trl,%diaghat); /; call graph(%diaghat :heading 'Diagonal of Hat Matrix'); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('++++++++++++++++++++++ Forecasting +++++++++++++++++++++':); /; get holdout data saved and trim values outside range of sample call olsq(y e_ratio c_ratio :noint :holdout 10 :savex); %x_out=%xfuture; /; uses same as R default if f = .75 f=.65; /; Loop over .70 to .90 do i=1,5; f=f+.05; j=integers(norows(y)-10+1,norows(y)); actual=y(j); call loess_mv(y e_ratio c_ratio :noint :poly_deg 1 :holdout 10 :robust /; :savehat :forecast %x_out :savex :print :f f); %forer=%fore; errorr=actual-%forer; call loess_mv(y e_ratio c_ratio :noint :poly_deg 1 :holdout 10 /; :savehat :forecast %x_out :savex :print :f f); error=actual-%fore; /; call print(%L); call print('test case for r => f=.75 degree = 1 +++++++++++++++++++':); call print('________________________________________________________':); call print(' ':); /; call tabulate(olsyhat,%yhat,olsres,%res,%y); /; call tabulate(%foreobs %fore,%forer,actual,error,errorr); call print(' ':); call print('SUMSQ error for out of sample forecasting without robust', sumsq(error):); call print('SUMSQ error for out of sample forecasting with robust', sumsq(errorr):); call print(' ':); obsn=dfloat(%foreobs); hh ='Lowess Forecasts degree 1 for F = '; add=' '; call ir8tostr(f,add,'(f4.2)'); hh=catrow(hh,add); call graph(obsn %fore,%forer,actual :plottype xyplot :nocontact :nolabel :heading hh); call loess_mv(y e_ratio c_ratio :noint :poly_deg 2 :holdout 10 :robust :forecast %x_out :savex :print :f f); %forer=%fore; errorr=actual-%forer; call loess_mv(y e_ratio c_ratio :noint :poly_deg 2 :holdout 10 :forecast %x_out :savex :print :f f); error=actual-%fore; call print('test case for r => f=.75 degree = 2 +++++++++++++++++++':); call print('________________________________________________________':); call print(' ':); /; call tabulate(olsyhat,%yhat,olsres,%res,%y); /; call tabulate(%foreobs %fore,%forer,actual,error,errorr); call print(' ':); call print('SUMSQ error for out of sample forecasting without robust', sumsq(error):); call print('SUMSQ error for out of sample forecasting with robust', sumsq(errorr):); call print(' ':); obsn=dfloat(%foreobs); hh ='Lowess Forecasts degree 2 for F = '; add=' '; call ir8tostr(f,add,'(f4.2)'); hh=catrow(hh,add); call graph(obsn %fore,%forer,actual :plottype xyplot :nocontact :nolabel :heading hh); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++++++':); enddo; program t_loess; /; /; Needs model for OLS and loess_mv to be inside a c8 variable = vars /; call olsq(argument(vars) :print); ols_ss1=%rss; g=grid(.1,.9,.1); ig=norows(g); rss1=array(ig:); rss2=array(ig:); ols_ss=array(ig:)+ols_ss1; do i=1,ig; call loess_mv(argument(vars) :noint :poly_deg 1 :f g(i) :print); rss1(i)=%rss; call loess_mv(argument(vars) :noint :poly_deg 2 :f g(i) :print); rss2(i)=%rss; enddo; call graph(g,ols_ss,rss1,rss2 ols_ss :plottype xyplot :nolabel :heading 'Effect of F and degree'); call graph(g, ,rss1, ols_ss :plottype xyplot :nolabel :heading 'Effect of F and degree'); call graph(g, ,rss2, ols_ss :plottype xyplot :nolabel :heading 'Effect of F and degree'); call tabulate(g,ols_ss,rss1,rss2); return; end; vars='y e_ratio c_ratio'; call t_loess; call print('Full yhat matrix ++++++++++++++++++++++++++++++++++++':); f=.75; call loess_mv(y e_ratio c_ratio :noint :poly_deg 2 :savehat :savex :print :f f); /; call print(%l,%delta); /; call print(diag(%l)); b34srun; %b34sendif; %b34sif(&do_r.eq.1)%then; b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') ## plot(y ~ e_ratio) lmod = lm(y ~ e_ratio + c_ratio) coef(lmod) predict(lmod) olserror=y - predict(lmod) rssols=olserror %*% olserror print(olserror) print(rssols) f.lo <- loess(y ~ e_ratio + c_ratio) loessyhat = predict(f.lo, se = TRUE) print(loessyhat) error = y - loessyhat$fit print(error) rss=error %*% error print(rss) quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos(' r rjob' ) unix( ' r rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') unix('rm rjob.r','rm rjob.out','rm rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ b34sexec options printvascmat; b34srun; == ==LOESS_MV2 Loess On Gas Data /; Tests against R b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; %b34slet do_r =0; %b34slet do_b34s=1; %b34sif(&do_b34s.eq.1)%then; b34sexec matrix; call loaddata; call echooff; /; This job requires a great deal of space such as /; /; b34s2 testmv2 15000000 /; program t_loess; /; /; Needs arguments to OLS and loess_mv to be inside vars a c8 variable /; call olsq(argument(vars) :print); ols_ss1=%rss; g=grid(.3,.9,.05); ig=norows(g); rss1=array(ig:); rss1r=array(ig:); rss2=array(ig:); rss2r=array(ig:); ols_ss=array(ig:)+ols_ss1; do i=1,ig; call loess_mv(argument(vars) :noint :poly_deg 1 :f g(i) :worksize worksize :nvmax nvmax /; :print ); rss1(i)=%rss; call compress; call loess_mv(argument(vars) :noint :poly_deg 1 :f g(i) :robust :worksize worksize :nvmax nvmax /; :print ); rss1r(i)=%rss; call compress; call loess_mv(argument(vars) :noint :poly_deg 2 :f g(i) :worksize worksize :nvmax nvmax /; :print ); rss2(i)=%rss; call compress; call loess_mv(argument(vars) :noint :poly_deg 2 :f g(i) :robust :worksize worksize :nvmax nvmax /; :print ); rss2r(i)=%rss; call compress; enddo; call print('OLSQ SS = ',ols_ss1:); f=g; call tabulate(f,rss1,rss1r,rss2,rss2r :title 'Deg. 1 & 2 Lowess RSS with/without robust for Various F'); call graph(f rss1 rss1r :plottype xyplot :pgborder :nocontact :hardcopyfmt HP_GL :noshow :nolabel :heading 'Degree 1 Non robust and robust for various F' :file 'p1.hp'); call graph(f rss2 rss2r :plottype xyplot :pgborder :nocontact :hardcopyfmt HP_GL :noshow :nolabel :heading 'Degree 2 Non robust and robust for various F' :file 'p2.hp'); /$ view the two files call grreplay('p1.hp','p2.hp' /; :file 'test_f.wmf' ); return; end; /; vars='gasout gasin{3 to 3} gasout{1} gasout{3}'; vars='gasout gasin{3 to 3} gasout{1 to 3}'; worksize=30; nvmax = 5000; call t_loess; b34srun; %b34sendif; %b34sif(&do_r.eq.1)%then; b34sexec data set maxlag=3; build l1gasout l2gasout l3gasout l1gasin l2gasin l3gasin; gen l1gasout=lag1(gasout); gen l2gasout=lag2(gasout); gen l3gasout=lag3(gasout); gen l1gasin =lag1(gasin); gen l2gasin =lag2(gasin); gen l3gasin =lag3(gasin); b34srun; b34sexec reg; model gasout = l3gasin l1gasout l2gasout l3gasout; b34srun; b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') ## plot(gasout ~ gasin) lmod = lm(gasout ~ l3gasin + l1gasout + l2gasout + l3gasout) coef(lmod) ## predict(lmod) olserror = gasout - predict(lmod) rssols = olserror %*% olserror ## print(olserror) print(rssols) f.lo <- loess(gasout ~ l3gasin+l1gasout+l2gasout+l3gasout, degree = 1) loessyhat = predict(f.lo, se = TRUE) ## print(loessyhat) error = gasout - loessyhat$fit ## print(error) rss = error %*% error print(rss) f.lo <- loess(gasout ~ l3gasin+l1gasout+l2gasout+l3gasout, degree = 2) loessyhat = predict(f.lo, se = TRUE) ## print(loessyhat) error = gasout - loessyhat$fit ## print(error) rss = error %*% error print(rss) quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos(' r rjob' ) unix( ' r rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') unix('rm rjob.r','rm rjob.out','rm rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==LOESS_MV3 Cleveland Ozone Data b34sexec options printvascmat; b34srun; %b34slet do_r =1; %b34slet do_b34s=1; b34sexec options ginclude('b34sdata.mac') member(c_ozone); b34srun; b34sexec list; b34srun; %b34sif(&do_b34s.eq.1)%then; b34sexec matrix; call loaddata; call echooff; call print('Using OLS as a base cvase':); vars='ozone s_rad temp wind'; call olsq(argument(vars) :print ); ols_ss1=%rss; olsres = %res; olsyhat= %yhat; /; call print(%y %x); call free(%x,%y); f=.75 ; call print('Degree = 0 => sumsq(residual) ~= Total sum of squares':); call print(' ':); call loess_mv(argument(vars) :noint :poly_deg 1 :savex :print :f f); /; Testing to see if robust estimation matters and is slowcalc matters call loess_mv(argument(vars) :noint :poly_deg 2 :savedhat :slowcalc :savex :print :f f); rr1=%res; yhat1=%yhat; call loess_mv(argument(vars) :noint :poly_deg 2 :savedhat :robust :savex :print :f f); call tabulate(%y,%yhat,%res); call graph(%y,%yhat,yhat1 :nolabel :heading 'Does Robust Estimation (%yhat) result in gains?'); call graph(%res,rr1 :nolabel :heading 'Does Robust Estimation (%res) result in gains?'); /; Robust tests end ++++++++++++++++++++++++++++++++++++++++++++++++++ /; lsres=%res; /; call graph(olsres,lsres :heading 'OLS RES vs LS Degree 2 RES' :nolabel); call names(all); call tabulate(olsyhat,%yhat,olsres,%res,%y); call print(%delta,%trl,%diaghat); call graph(%diaghat :heading 'Diagonal of Hat Matrix'); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('++++++++++++++++++++++ Forecasting +++++++++++++++++++++':); /; get holdout data saved and trim values outside range of sample call olsq(argument(vars) :noint :holdout 10 :savex); %x_out=%xfuture; /; uses same as R default if f = .75 f=.65; /; Loop over .70 to .90 do i=1,5; f=f+.05; j=integers(norows(ozone)-10+1,norows(ozone)); actual=ozone(j); call loess_mv(argument(vars) :noint :poly_deg 1 :holdout 10 :robust /; :savehat :forecast %x_out :savex :print :f f); %forer=%fore; errorr=actual-%forer; call loess_mv(argument(vars) :noint :poly_deg 1 :holdout 10 /; :savehat :forecast %x_out :savex :print :f f); error=actual-%fore; /; call print(%L); call print('test case for r => f=.75 degree = 1 +++++++++++++++++++':); call print('________________________________________________________':); call print(' ':); call tabulate(olsyhat,%yhat,olsres,%res,%y); call tabulate(%foreobs %fore,%forer,actual,error,errorr); call print(' ':); call print('SUMSQ error for out of sample forecasting without robust', sumsq(error):); call print('SUMSQ error for out of sample forecasting with robust', sumsq(errorr):); call print(' ':); obsn=dfloat(%foreobs); hh ='Lowess Forecasts degree 1 for F = '; add=' '; call ir8tostr(f,add,'(f4.2)'); hh=catrow(hh,add); call graph(obsn %fore,%forer,actual :plottype xyplot :nocontact :nolabel :heading hh); call loess_mv(argument(vars) :noint :poly_deg 2 :holdout 10 :robust :forecast %x_out :savex :print :f f); %forer=%fore; errorr=actual-%forer; call loess_mv(argument(vars) :noint :poly_deg 2 :holdout 10 :forecast %x_out :savex :print :f f); error=actual-%fore; call print('test case for r => f=.75 degree = 2 +++++++++++++++++++':); call print('________________________________________________________':); call print(' ':); call tabulate(olsyhat,%yhat,olsres,%res,%y); call tabulate(%foreobs %fore,%forer,actual,error,errorr); call print(' ':); call print('SUMSQ error for out of sample forecasting without robust', sumsq(error):); call print('SUMSQ error for out of sample forecasting with robust', sumsq(errorr):); call print(' ':); obsn=dfloat(%foreobs); hh ='Lowess Forecasts degree 2 for F = '; add=' '; call ir8tostr(f,add,'(f4.2)'); hh=catrow(hh,add); call graph(obsn %fore,%forer,actual :plottype xyplot :nocontact :nolabel :heading hh); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++++++':); enddo; program t_loess; /; /; Needs model for OLS and loess_mv to be inside a c8 variable = vars /; call olsq(argument(vars) :print); ols_ss1=%rss; g=grid(.1,.9,.1); ig=norows(g); rss0=array(ig:); rss1=array(ig:); rss2=array(ig:); ols_ss=array(ig:)+ols_ss1; do i=1,ig; *call loess_mv(argument(vars) :noint :poly_deg 0 :f g(i) :print); *rss0(i)=%rss; call loess_mv(argument(vars) :noint :poly_deg 1 :f g(i) :print); rss1(i)=%rss; call loess_mv(argument(vars) :noint :poly_deg 2 :f g(i) :print); rss2(i)=%rss; enddo; call graph(g,rss1,rss2 ols_ss :plottype xyplot :nolabel :heading 'Effect of F and degree'); call graph(g, ,rss1, ols_ss :plottype xyplot :nolabel :heading 'Effect of F and degree'); call graph(g, ,rss2, ols_ss :plottype xyplot :nolabel :heading 'Effect of F and degree'); return; end; call t_loess; call print('Full yhat matrix ++++++++++++++++++++++++++++++++++++':); f=.75; * call loess_mv(argument(vars) :noint :poly_deg 2 :savehat :savex :print :f f); * call print(%l,%delta); * call print(diag(%l)); b34srun; %b34sendif; %b34sif(&do_r.eq.1)%then; b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') lmod = lm(ozone ~ s_rad+temp+wind) coef(lmod) predict(lmod) olserror=ozone - predict(lmod) rssols=olserror %*% olserror print(olserror) print(rssols) f.lo <- loess(ozone ~ s_rad+temp+wind) loessyhat = predict(f.lo, se = TRUE) print(loessyhat) error = ozone - loessyhat$fit print(error) rss=error %*% error print(rss) quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos(' r rjob' ) unix( ' r rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ b34sexec options printvascmat; b34srun; == ==LOESS_SPS1 LOESS smoothing of DJONES /; Loess Smoothing /; Turns on loess_MV on same example %b34slet do_mv = 1; b34sexec options ginclude('b34sdata.mac') member(dow); b34srun; b34sexec matrix; call loaddata; call print('Default test case':); y=djones; call names(all); x=fyear(bjulian_); call loess_sps(x,y,sort_x,smoothy :print); /; The smaller the f => the more the smooth series follows the /; original series call print(' ':); call print('Test case # 1 ':); call loess_sps(x,y,sort_x,smoothy2 :print :f .15 :nsteps 0 :delta 0.); call print(' ':); call print('Test case # 2 ':); call loess_sps(x,y,sort_x,smoothy3 :print :f .40 :nsteps 0 :delta 0.); call tabulate(x,y,sort_x,smoothy, smoothy2 smoothy3,%res_xy); call graph(x y smoothy smoothy2 smoothy3 :plottype xyplot :nolabel :pgborder :nocontact :file 'loess_sps.wmf' :heading 'Data Smoothed by Default setup, f=.15 & f = .40'); %b34sif(&do_mv.ne.0)%then; call print('Using OLS as a base cvase':); call olsq(y x :print ); ols_ss1=%rss; olsres = %res; olsyhat= %yhat; /; call print(%y %x); call free(%x,%y); f=.75 ; call loess_mv(y x :noint :poly_deg 1 :savex :print :f f); yhatdg1=%yhat; resdg1=%res; /; Testing to see if robust estimation matters call loess_mv(y x :noint :poly_deg 2 :savex :print :f f); rr1=%res; yhat1=%yhat; call loess_mv(y x :noint :poly_deg 2 :robust :savex :print :f f); call tabulate(%y,olsyhat yhatdg1,yhat1,%yhat); call graph(%y,%yhat,yhat1 yhatdg1 olsyhat :nolabel :file 'loess_mv1.wmf' :pgborder :nocontact :heading 'Robust Estimation (%yhat) vs. no robust (yhat1)'); call graph(%res,rr1 resdg1 olsres :nolabel :file 'loess_mv2.wmf' :pgborder :nocontact :heading 'Robust Estimation (%res) vs. no robust (rr1)'); %b34sendif; b34srun; == ==LOESS_SPS2 Scatter Plot Smoother using LOESS Method b34sexec options ginclude('b34sdata.mac') member(loess_sps); b34srun; b34sexec matrix; /; Test case suggested by Cleveland /; /; X values: /; 1 2 3 4 5 6 6 6 6 6 6 6 6 6 6 8 10 12 14 50 /; /; Y values: /; 18 2 15 6 10 4 16 11 7 3 14 17 20 12 9 13 1 8 5 19 /; /; /; YS values with F = .25, NSTEPS = 0, DELTA = 0.0 /; 13.659 11.145 8.701 9.722 10.000 (10)11.300 13.000 6.440 5.596 /; 5.456 18.998 /; /; YS values with F = .25, NSTEPS = 0 , DELTA = 3.0 /; 13.659 12.347 11.034 9.722 10.511 (10)11.300 13.000 6.440 5.596 /; 5.456 18.998 /; /; YS values with F = .25, NSTEPS = 2, DELTA = 0.0 /; 14.811 12.115 8.984 9.676 10.000 (10)11.346 13.000 6.734 5.744 /; 5.415 18.998 call loaddata; call print('Default test case':); call loess_sps(x,y,sort_x,smooth_y :print); call tabulate(x,y,sort_x,smooth_y,%sort_y,%res_xy); call graph(x,y :plottype xyplot :heading 'Smoothed Scatter Plot'); call print(' ':); call print('Test case # 1 ':); call loess_sps(x,y,sort_x,smooth_y :print :f .25 :nsteps 0 :delta 0.); call tabulate(x,y,sort_x,smooth_y,%sort_y,%res_xy); call print(' ':); call print('Test case # 2 ':); call loess_sps(x,y,sort_x,smooth_y :print :f .25 :nsteps 0 :delta 3.); call tabulate(x,y,sort_x,smooth_y,%sort_y,%res_xy); call print(' ':); call print('Test case # 3 ':); call loess_sps(x,y,sort_x,smooth_y :print :f .25 :nsteps 2 :delta 0.); call tabulate(x,y,sort_x,smooth_y,%sort_y,%res_xy); b34srun; == ==LOESS_SA Seasonal Adjustmentbusing LOESS Method b34sexec options ginclude('b34sdata.mac') member(loess_sa); b34srun; b34sexec matrix; call loaddata; call loess_sa(co2,sa_co2,trendco2 :print); call tabulate(co2,sa_co2,trendco2); call graph(co2,sa_co2,trendco2 :heading 'Loess Seasonal Adjustment' :nolabel); /; uses stl call loess_sa(co2,sa_co3,trendco3 :ildeg 0 :print); call tabulate(co2,sa_co2,trendco2,sa_co3,trendco3); call graph(co2,sa_co2,trendco2 :heading 'Loess Seasonal Adjustment' :nolabel); /; set up stl to mimic stlez 100% call loess_sa(co2,sa_co2,trendco2 :print); call loess_sa(co2,sa_co4,trendco4 :ildeg 0 :print :ns 7 :isdeg 0 :itdeg 0 :no 6 :nt 23 :nl 13 :ildeg 0 :nsjump 1 :ntjump 3 :nljump 2 :ni 1 :print); call tabulate(co2,sa_co2,trendco2,sa_co4,trendco4); b34srun; == ==LOGOFF Turn off log b34sexec matrix; call echooff; call epprint('This will show in log'); call logoff; call epprint('This will show in the output only'); call outputoff; call epprint('This will never be seen.'); call logon; call outputon; call epprint('This will be seen in both log and output'); b34srun; == ==LOGON Turn on log b34sexec matrix; call echooff; call epprint('This will show in log'); call logoff; call epprint('This will show in the output only'); call outputoff; call epprint('This will never be seen.'); call logon; call outputon; call epprint('This will be seen in both log and output'); b34srun; == ==LPMAX Linear Programing MAXIMUM b34sexec matrix; neq=0; a=matrix(4,2: 1., 0., 0., 1., 1., 1., -1.,-1.); b=vector( :1., 1.,1.5, -.5); c=vector( :1., 3.); call lpmax(c,a,b,neq :print); /; Problem from Lindo /; Answers Objective function 2628. /; x1 = 150., x2 = 650. /; Shadow prices 3.22 0. 0. 0. .08 .0 neq=0; aa=matrix(6,2: 1., 1., 10., 6., 9., 6.5, 1., 0., 0., 1., 0., -1.); bb=vector( 6:800.,6000.,5850.,450.,650.,-300.); cc=vector( 2:3.22 3.3); call lpmax(cc,aa,bb,neq :print); /; Problem from Lindo /; Answers Objective function 2640. /; x1 = 260., x2 = 540. /; Shadow prices 3.30 0. 0. 0. 0. .0 /; Note price change for x1 neq=0; aa=matrix(6,2: 1., 1., 10., 6., 9., 6.5, 1., 0., 0., 1., 0., -1.); bb=vector( 6:800.,6000.,5850.,450.,650.,-300.); cc=vector( 2:3.3 3.3); call lpmax(cc,aa,bb,neq :print); b34srun; b34sexec lpmax n=2 m1=4 m2=0; * Sample problem from IMSL ; amatrix(1.0,0., 0., 1., 1., 1., -1.,-1.); bvector(1.,1.,1.5,-.5); cvector(1,3.); b34srun; b34sexec matrix; * problem from Hadley(1962) page 3; * max should be 127370588235294 ; * primal = 294.118 1500 0.0 58.8235 ; * Dual = 1.95353 .242353 1.37824 ; neq=0; a=matrix(3,4: 1.5 1.0 2.4 1. 1. 5. 1. 3.5 1.5 3. 3.5 1.); b=vector(: 2000. 8000. 5000.); c=vector(: 5.24 7.30 8.34 4.18); call lpmax(c,a,b,neq :print); call names; b34srun; b34sexec lpmax n=4 m1=3 m2=0; * problem from Hadley(1962) page 3; * max should be 127370588235294 ; * primal = 294.118 1500 0.0 58.8235 ; * Dual = 1.95353 .242353 1.37824 ; amatrix(1.5 1.0 2.4 1. 1. 5. 1. 3.5 1.5 3. 3.5 1.); bvector(2000 8000 5000); cvector(5.24 7.30 8.34 4.18); b34srun; b34sexec matrix; * problem from Hadley(1962) page 135; * max should be 12.37. x1=1.053 x2=2.368; neq=0; a=matrix(2,2:3. 5. 5. 2.); b=vector(: 15. 10.); c=vector(: 5. 3.); call lpmax(c,a,b,neq :print); call names; b34srun; b34sexec lpmax n=2 m1=2 m2=0; * problem from Hadley(1962) page 135; * max should be 12.37. x1=1.053 x2=2.368; amatrix( 3. 5. 5. 2. ); bvector(15. 10. ); cvector( 5. 3. ); b34srun; b34sexec matrix ; * problem from Hadley (1962) page 138; * answer should be 40 x1=7.273 x3 = 6.36364; neq=0; a=matrix(3,4: 1., 3., 2., 5., -2.,-16., -1., -1., 3., -1., -5., 10. ); b=vector( :20., -4., -10. ); c=vector( :2. , 1., 4. 5. ); call lpmax(c,a,b,neq :print); call names; b34srun; b34sexec lpmax n=4 m1=3 m2=0; * problem from Hadley (1962) page 138; * answer should be 40 x1=7.273 x3 = 6.36364; amatrix(1. 3., 2., 5., -2., -16., -1., -1., 3., -1., -5., 10.); bvector(20. -4. -10.); cvector(2. 1. 4. 5.); b34srun; == ==LPMAX_2 Extended Dief Problem solved as a Max b34sexec matrix; * Dorfman- Samuelson-Solow page 45; * Extended Diet Problem ; * max z = 700*u1 + 400*u2 ; * u1 le 2 ; * u2 le 20 ; * u1 le 3 ; * u1+u2 le 11 ; * 2u1+u2 le 12 ; * Page 57-58 z = 4700 ; * u1=1, u2=10, x4=100, x5=300 ; neq=0; a=matrix(5,2: 1., 0., 0., 1., 1., 0., 1., 1. 2., 1.); b=vector( :2.,20.,3.,11.,12.); c=vector( :700.,400.); call lpmax(c,a,b,neq :print); b34srun; == ==LPMIN Linear Programing Mininum b34sexec matrix; * Test Problem from IMSL ; * Problem solved as a MAX problem ; * Objective = 3.5 ; * Primal = .5 1. ; * Dual =1. .0; ncon=2; nvar=2; a=matrix(ncon,nvar:1.0 1.0 1.0 1.0); b=vector(ncon:1.5 .1); c=vector(nvar:1.0 3.0); call lpmin(c,a,b:lowerx vector(:0.0 0.0) :upperx vector(:1.0 1.0) :constr namelist(LE GE) :print :max); call names; b34srun; == ==LPMIN_2 Extended Diet Problem Solved Two ways b34sexec matrix; * Test Problem from Dorfman-Samuelson-Solow page 45 ; * Unless we constrain lowerx to 0.0 we get unbounded ; ncon=2; nvar=5; a=matrix(ncon,nvar: 1.0, 0.0, 1.0, 1.0, 2.0, 0.0, 1.0, 0.0, 1.0, 1.0); b=vector(ncon:700.,400.); c=vector(nvar: 2.0, 20., 3., 11., 12.); call lpmin(c,a,b :lowerx array(:0.,0.,0.,0.,0.) :constr namelist(GE GE) :print); * Solve as a max; * Dorfman-Samuelson-Solow page 45; * Extended Diet Problem ; * max z = 700*u1 + 400*u2 ; * u1 le 2 ; * u2 le 20 ; * u1 le 3 ; * u1+u2 le 11 ; * 2u1+u2 le 12 ; * Page 57-58 z = 4700 ; * u1=1, u2=10, x4=100, x5=300 ; nvar=2; ncon=5; a=matrix(ncon,nvar: 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 1.0, 1.0, 2.0, 1.0); b=vector(ncon:2., 20.,3.,11.,12.); c=vector(nvar: 700., 400.); call lpmin(c,a,b :max :constr namelist(LE LE LE LE LE) :print); b34srun; == ==LRE Log Relative Error b34sexec options ginclude('b34sdata.mac') member(wampler); b34srun; b34sexec matrix; call loaddata; n=16; call print(' ':); call print('With QR':); call olsq(y5 x1 x2 x3 x4 x5 :print ); c=array(norows(%coef):)+1.0; call lre(c,n,%coef,lrevalue,bits); d=afam(c)-afam(%coef); call tabulate(c,%coef,lrevalue,bits,d); call print('Results using Cholesky':); call lre(c,n,%coef,lrevalue,bits :print); call olsq(y5 x1 x2 x3 x4 x5 :print :qr); call print('Results using QR':); call lre(c,n,%coef,lrevalue,bits :print); nn=5; x=rn(matrix(nn,nn:)); invx=inv(x); tt=x*invx; get=diag(tt); value=array(norows(x):)+1.0d+00; call print('Inversion test':); call lre(value,16,get,lrevalue,bits :print); dd=det(x); altdd=real(prod(eig(x))); call print('Determinant two Ways - Easy Problem':); call lre(dd,16,altdd,test,bits :print); xtest=mfam(catcol(x1 x2 x3 x4 x5)); xnew=transpose(xtest)*xtest; dd=det(xnew); altdd=real(prod(eig(xnew))); call print('Determinant two Ways - Harder Problem':); call lre(dd,16,altdd,test,bits :print); call print('Real*16 results *******************':); n=32; call print(' ':); call print('With QR':); y5=r8tor16(y5); x1=r8tor16(x1); x2=r8tor16(x2); x3=r8tor16(x3); x4=r8tor16(x4); x5=r8tor16(x5); call olsq(y5 x1 x2 x3 x4 x5 :print ); c=r8tor16(array(norows(%coef):)+1.0); call lre(c,n,%coef,lrevalue,bits); d=afam(c)-afam(%coef); call tabulate(c,%coef,lrevalue,bits,d); call print('Results using Cholesky':); call lre(c,n,%coef,lrevalue,bits :print); call olsq(y5 x1 x2 x3 x4 x5 :print :qr); call print('Results using QR':); call lre(c,n,%coef,lrevalue,bits :print); x=r8tor16(x); invx=inv(x); tt=x*invx; get=diag(tt); value=r8tor16(array(norows(x):)+1.0d+00); call print('Inversion test Real*16':); call lre(value,n,get,lrevalue,bits :print); dd=det(x); altdd=qreal(prod(eig(x))); call print('Determinant two Ways - Easy Problem':); call lre(dd,n,altdd,test,bits :print); xtest=mfam(catcol(x1 x2 x3 x4 x5)); xnew=transpose(xtest)*xtest; dd=det(xnew); altdd=qreal(prod(eig(xnew))); call print('Determinant two Ways - Harder Problem':); call lre(dd,n,altdd,test,bits :print); b34srun; == ==LRE_2 Tests Matrix Power /$ /$ Matrix Power does with Eigen Analysis. /$ This is tested against multiple matrix mult. /$ b34sexec matrix; call echooff; r=18.0; n=10; x=rn(matrix(n,n:)); x=transpose(x)*x; x(,1)=x(,1)*1.d+15; test1=x**r; test2=x; do i=2,idint(r); test2=test2*x; enddo; call print('Are test1 and test2 the same?':); call print(test1,test2); zero=matrix(n,n:); zero1=test1-test2; call lre(zero,16,zero1,lretest,bits:print); call print('In Complex Domain with fractional Powers':); r=.5; n=4; x=rn(matrix(n,n:)); test1=complex(x)**complex(r); test2= test1**complex(1.0/r); call print(x,test1,test2); e1=eig(complex(x) :lapack); e2=eig(test2 :lapack); call print(e1,e2,prod(e1),prod(e2)); call lre(x,16,real(test2),lrtest,bits:print); * Full Complex implementation; r=.5; n=4; x=complex(rn(matrix(n,n:)),rn(matrix(n,n:))); test1=x**complex(r); test2=test1**complex(1.0/r); call print(x,test1,test2); e1=eig(x ); e2=eig(test2); call print(e1,e2,prod(e1),prod(e2)); call print('Tests Real Part':); call lre(real(x),16,real(test2),lrtest,bits:print); call print('Tests Imag Part':); call lre(imag(x),16,imag(test2),lrtest,bits:print); b34srun; == ==MAKEDATA Makes a datastep from matrix data b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makedata(gasin,newgasi,gasout,newgaso:file 'full.b34'); xx=rn(array(norows(gasout)/2:)); call makedata(gasin,newgasi,gasout,newgaso,xx:file 'full2.b34'); b34srun; b34sexec options include('full.b34'); b34srun; b34sexec options include('full2.b34'); b34srun; b34sexec list; b34srun; /$ shows MAKEDATA with a matrix b34sexec matrix; x=rn(matrix(100,20:)); call makedata(x :file 'full3.b34'); b34srun; b34sexec options include('full3.b34'); b34srun; == ==LS2 Two Stage Least Squares and GMM Estimation /; A number of tests are run with SAS, STATA, B34s/SIMEQ and RATS /; /; For 3slq B34S Agrees with Kmenta (1971) for demand and supply /; For Kementa (1986) the Supply equation differs slightly. /; SAS gets the Kmenta (1986) Demand and Supply. /; Rats gets the Kmenta Demand but its Supply is quite different /; RATS is getting what B34S calls I3SLS! /; B34S uses matrix command to validate its SIMEQ command /; %b34slet dosas =0; %b34slet dorats =1; %b34slet ratsliml=0; %b34slet dosimeq =0; %b34slet domatrix=1; %b34slet verbose =0; %b34slet dostata =1; b34sexec options ginclude('b34sdata.mac') member(kmenta); b34srun; /; B34SEXEC LIST $ VAR Q P D F A $ B34SEEND $ /$ /; Note: ipr set = 6 for # of significant digits. If 10 is set /; will get a convergence error with ils3 %b34sif(&dosimeq.ne.0)%then; b34sexec simeq printsys reduced ols liml ls2 ls3 ils3 icov ipr=6 itmax=2000 kcov=diag $ heading=('test case from kmenta 1971 page 565 - 582 ' ) $ exogenous constant d f a $ endogenous p q $ model lvar=q rvar=(constant p d) name=('demand eq.') $ model lvar=q rvar=(constant p f a) name=('supply eq.') $ b34seend $ /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; /$ /$ Estimates Kmenta Problem with Matrix command. /$ Purpose is to illustrate OLS/2SLS/3SLS/FIML both with /$ SIMEQ and with Matrix Commands. /$ /$ FIML SE same as 3SLS asymptotically (See Greene 5e page 408) /$ /$ Problem Discussed in "Specifying and Diagnostically Testing /$ Econometric Models" Chapter 4 Third Edition /$ %b34sendif; %b34sif(&domatrix.ne.0)%then; b34sexec matrix; call loaddata; call echooff; call load(ls2); call print('OLS for Equation # 1':); call olsq(q p d :savex :print); call ls2(%y,%x,catcol(d,f,a,constant),%names,%yvar,1); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); call graph(%y %yhatols %yhatls2,%yhatgmm :nocontact :pgborder :nolabel :heading 'Demand side'); 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); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); call graph(%y %yhatols %yhatls2,%yhatgmm :nocontact :pgborder :nolabel :heading 'Supply Side'); b34srun; %b34sendif; %b34sif(&dosas.eq.1)%then; B34SEXEC OPTIONS OPEN('testsas.sas') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29) $ B34SEEND$ B34SEXEC PGMCALL IDATA=29 ICNTRL=29$ SAS $ PGMCARDS$ proc means; run; proc syslin 3sls reduced; instruments d f a constant; endogenous p q; demand: model q = p d; supply: model q = p f a; run; proc syslin it3sls reduced; instruments d f a constant; endogenous p q; demand: model q = p d; supply: model q = p f a; run; B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ /$ The next card has to be modified to point to SAS location /$ Be sure and wait until SAS gets done before letting B34S resume B34SEXEC OPTIONS dodos('start /w /r sas testsas') dounix('sas testsas')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT NOHEADER WRITEOUT(' ','Output from SAS',' ',' ') WRITELOG(' ','Output from SAS',' ',' ') COPYFOUT('testsas.lst') COPYFLOG('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log')$ B34SRUN$ B34SEXEC OPTIONS HEADER$ B34SRUN$ %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * heading=('test case from kmenta 1971 page 565 - 582 ' ) $ * exogenous constant d f a $ * endogenous p q $ * model lvar=q rvar=(constant p d) name=('demand eq.') $ * model lvar=q rvar=(constant p f a) name=('supply eq.') $ linreg q # constant p d linreg q # constant p f a instruments constant d f a linreg(inst) q # constant p d linreg(inst) q # constant p f a * GMM linreg(inst,optimalweights) q # constant p d linreg(inst,optimalweights) q # constant p f a %b34sif(&ratsliml.ne.0)%then; source d:\r\liml.src @liml q # constant p d @liml q # constant p f a %b34sendif; equation demand q # constant p d equation supply q # constant p f a * Supply does not match known answers!! sur(inst,iterations=200) 2 # demand resid1 # supply resid2 nonlin(parmset=structural) c0 c1 c2 d0 d1 d2 d3 compute c0 = .1 compute c1 = .1 compute c2 = .1 compute d0 = .1 compute d1 = .1 compute d2 = .1 compute d3 = .1 frml d_eq q = c0 + c1*p + c2*d frml s_eq q = d0 + d1*p + d2*f + d3*a nlsystem(inst,parmset=structural,outsigma=v) * * d_eq s_eq b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; %b34sif(&dostata.ne.0)%then; b34sexec options open('statdata.do') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options open('stata.do') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall idata=28 icntrl=29$ stata$ pgmcards$ // uncomment if do not use /e // log using stata.log, text sum describe * command for stata 11.0 global eq1 d global eq2 f a bootstrap _b _se, reps(400): ivregress 2sls q (p = d f a) $eq1 bootstrap _b _se, reps(400): ivregress 2sls q (p = d f a) $eq2 ivregress 2sls q (p = d f a) $eq1 ivregress 2sls q (p = d f a) $eq2 * estimates store new_iv bootstrap _b _se, reps(400): ivreg2 q (p = d f a) $eq1, gmm2s robust bootstrap _b _se, reps(400): ivreg2 q (p = d f a) $eq2, gmm2s robust ivreg2 q (p = d f a) $eq1, gmm2s robust ivreg2 q (p = d f a) $eq2, gmm2s robust b34sreturn$ b34seend$ b34sexec options close(28); b34srun; b34sexec options close(29); b34srun; b34sexec options dodos('stata /e do stata.do') dounix('stata -b do stata.do '); b34srun; b34sexec options npageout writeout('output from stata',' ',' ') copyfout('stata.log') dodos('erase stata.do','erase stata.log','erase statdata.do') dounix('rm stata.do','rm stata.log','rm statdata.do') $ b34srun$ %b34sendif; == ==LS2_2 Hausman Tests with LS2 & GMM using B34S, SAS & Stata %b34slet dob34s =1; %b34slet dosas =1; %b34slet dostata=1; b34sexec options noheader; b34srun; b34sexec options ginclude('micro.mac') member(griliches76); b34srun; %b34sif(&dob34s.ne.0)%then; b34sexec matrix; call loaddata; call load(ls2); call echooff; call character(lhs,'lw'); call character(endvar, 'iq'); call character(endvar2,'iq s'); call character(rhs,'iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant'); call character(ivar,'s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant med kww age mrt'); call character(ivar2,'expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant med kww age mrt'); call olsq(argument(lhs) argument(rhs) :noint :print :savex); call print(' ':); Call print('Baum (2006) page 193':); call print(' ':); call print(lhs,rhs,ivar,endvar); call ls2(%y,%x,catcol(argument(ivar)),%names,%yvar,1); * Hausman test ; call hausman('2SLS Model large sample covar - Testing coef 1', %olscoef(1),submatrix(%varcov1,1,1,1,1), %ls2coef(1),submatrix(%covar_l,1,1,1,1),h,sig_h,1); call hausman('2SLS Model small sample covar - Testing coef 1', %olscoef(1),submatrix(%varcov1,1,1,1,1), %ls2coef(1),submatrix(%covar_s,1,1,1,1),h,sig_h,1); call print('Baum (2006) page 198':); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); * Do C test to see it S is a good instrument; * s is removed from ivar to ivar2 ; call olsq(argument(lhs) argument(rhs) :noint :print :savex); call print(' ':); call print('Now there are 2 endogenous on the right':); call print(lhs,rhs,ivar2,endvar2); call ls2(%y,%x,catcol(argument(ivar2)),%names,%yvar,1); jj=integers(1,2); call hausman('2SLS Model large sample covar - Testing coef 1-2', %olscoef(jj),submatrix(%varcov1,1,2,1,2), %ls2coef(jj),submatrix(%covar_l,1,2,1,2),h,sig_h,2); jj=integers(1,2); call hausman('2SLS Model small sample covar - Testing coef 1-2', %olscoef(jj),submatrix(%varcov1,1,2,1,2), %ls2coef(jj),submatrix(%covar_s,1,2,1,2),h,sig_h,2); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); b34srun; %b34sendif; %b34sif(&dostata.ne.0)%then; b34sexec options open('statdata.do') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options open('stata.do') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall idata=28 icntrl=29$ stata$ * for detail on stata commands see Baum page 205 ; pgmcards$ * uncomment if do not use /e * log using stata.log, text global xlist s expr tenure rns smsa iyear_67 /// iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 global xlist2 expr tenure rns smsa iyear_67 /// iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 ivregress 2sls lw $xlist (iq=med kww age mrt) estat endogenous estat overid ivreg2 lw $xlist (iq=med kww age mrt), gmm2 robust * s is now endogenous ivregress 2sls lw $xlist2 (s iq=med kww age mrt) estat endogenous estat overid ivreg2 lw $xlist2 (s iq=med kww age mrt), gmm2 robust b34sreturn$ b34seend$ b34sexec options close(28); b34srun; b34sexec options close(29); b34srun; b34sexec options dounix('stata -b do stata.do ') dodos('stata /e do stata.do'); b34srun; b34sexec options npageout writeout('output from stata',' ',' ') copyfout('stata.log') dodos('erase stata.do', 'erase stata.log', 'erase statdata.do') $ b34srun$ %b34sendif; %b34sif(&dosas.ne.0)%then; B34SEXEC OPTIONS OPEN('testsas.sas') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29) $ B34SEEND$ B34SEXEC PGMCALL IDATA=29 ICNTRL=29$ SAS $ PGMCARDS$ proc means; run; proc model ; endogenous iq; lw= ciq*iq + cs*s + cexpr*expr+ ctenture*tenure+ crns*rns + csmsa*smsa+ ciyear_67*iyear_67+ ciyear_68*iyear_68 + ciyear_69*iyear_69 + ciyear_70*iyear_70+ + ciyear_71*iyear_71 + ciyear_73*iyear_73 + interc; fit lw / ols 2sls hausman; instruments s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 med kww age mrt; run; proc model ; endogenous iq s; lw= ciq*iq + cs*s + cexpr*expr+ ctenture*tenure+ crns*rns + csmsa*smsa+ ciyear_67*iyear_67+ ciyear_68*iyear_68 + ciyear_69*iyear_69 + ciyear_70*iyear_70+ + ciyear_71*iyear_71 + ciyear_73*iyear_73 + interc; fit lw / ols 2sls hausman; instruments expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 med kww age mrt; run; B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ /$ The next card has to be modified to point to SAS location /$ Be sure and wait until SAS gets done before letting B34S resume B34SEXEC OPTIONS dodos('start /w /r sas testsas') dounix('sas testsas')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT NOHEADER WRITEOUT(' ','Output from SAS',' ',' ') WRITELOG(' ','Output from SAS',' ',' ') COPYFOUT('testsas.lst') COPYFLOG('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log')$ B34SRUN$ %b34sendif; == ==LS2_3 LS2 Test Cases using Griliches76 Data %b34slet dob34s1=0; %b34slet dob34s2=1; %b34slet dostata=1; %b34slet dorats =1; b34sexec options ginclude('micro.mac') member(griliches76); b34srun %b34sif(&dob34s1.ne.0)%then; b34sexec matrix; call loaddata; call echooff; call olsq(iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 med kww age mrt :print); iqyhat=%yhat; call olsq(lw iqyhat s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print); call olsq(lw iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print); call gamfit(lw iq s expr tenure rns[factor,1] smsa[factor,1] iyear_67[factor,1] iyear_68[factor,1] iyear_69[factor,1] iyear_70[factor,1] iyear_71[factor,1] iyear_73[factor,1] :print); call marspline(lw iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print :nk 40 :mi 2); call gamfit(lw80 iq s expr tenure rns[factor,1] smsa[factor,1] iyear_67[factor,1] iyear_68[factor,1] iyear_69[factor,1] iyear_70[factor,1] iyear_71[factor,1] iyear_73[factor,1] :print); call marspline(lw80 iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 :print :nk 40 :mi 2); b34srun; %b34sendif; %b34sif(&dob34s2.ne.0)%then; b34sexec matrix; call loaddata; call load(ls2); call echooff; call character(lhs,'lw'); call character(endvar,'iq'); call character(rhs,'iq s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant'); call character(ivar,'s expr tenure rns smsa iyear_67 iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 constant med kww age mrt'); call olsq(argument(lhs) argument(rhs) :noint :print :savex); call ls2(%y,%x,catcol(argument(ivar)),%names,%yvar,1); call print(lhs,rhs,ivar,endvar); call gmmest(%y,%x,%z,%names,%yvar,j_stat,sigma,1); call graph(%y %yhatols %yhatls2,%yhatgmm :nocontact :pgborder :nolabel); b34srun; %b34sendif; %b34sif(&dostata.ne.0)%then; b34sexec options open('statdata.do') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options open('stata.do') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall idata=28 icntrl=29$ stata$ * for detail on stata commands see Baum page 205 ; pgmcards$ * uncomment if do not use /e * log using stata.log, text global xlist s expr tenure rns smsa iyear_67 /// iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 bootstrap _b _se, reps(50): /// ivregress 2sls lw $xlist (iq=med kww age mrt) * Durbin-Wu-Hausman exogenous test robust errors ivregress 2sls lw $xlist (iq=med kww age mrt), vce(robust) estat endogenous * manual D-W-H Test with robust regress iq med kww age mrt $xlist predict v1hat, resid regress lw $xlist v1hat iq, vce(robust) test v1hat * Durbin-Wu-Hausman exogenous test without robust errors ivregress 2sls lw $xlist (iq=med kww age mrt) estat endogenous * manual D-W-H Test without robust regress iq med kww age mrt $xlist predict vv1hat, resid regress lw $xlist vv1hat iq test vv1hat * --------------------------------------------------------- ivregress 2sls lw $xlist (iq=med kww age mrt) ivregress liml lw $xlist (iq=med kww age mrt) ivregress gmm lw $xlist (iq=med kww age mrt) ivreg lw $xlist (iq=med kww age mrt) bootstrap _b _se, reps(50):ivreg2 lw $xlist (iq=med kww age mrt) ivreg2 lw $xlist (iq=med kww age mrt) ivreg2 lw $xlist (iq=med kww age mrt), gmm2s robust overid, all * orthog(age mrt) gmm (lw-{xb:$xlist iq} +{b0}), /// instruments ($xlist med kww age mrt) onestep nolog exit,clear b34sreturn$ b34seend$ b34sexec options close(28); b34srun; b34sexec options close(29); b34srun; b34sexec options dounix('stata -b do stata.do ') dodos('stata /e stata.do'); b34srun; b34sexec options npageout writeout('output from stata',' ',' ') copyfout('stata.log') dodos('erase stata.do', /; 'erase stata.log', 'erase statdata.do') $ b34srun$ %b34sendif; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * instruments s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 $ med kww age mrt constant * OLS linreg lw # constant s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 iq * 2SLS linreg(inst) lw # constant s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 iq * GMM linreg(inst,optimalweights) lw # constant s expr tenure rns smsa iyear_67 $ iyear_68 iyear_69 iyear_70 iyear_71 iyear_73 iq b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==MAKEDMF Loads series in DMF file b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call names(all); call olsq(lnq lnk lnl lnrm1 :print); call makedmf(lnq,lnl,lnk,lnrm1,lnrm2); call getdmf(browse); call cleardat; call getdmf; call names(all); b34srun; == ==MAKEDMF2 Loads series in a DMF File - Bigger example b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call echooff; call loaddata; call names(all); call olsq(lnq lnk lnl lnrm1 :print); people=namelist(houston,diana,will,melissa,bobby); call makedmf(lnq,lnl,lnk,lnrm1,lnrm2 %res %y %yhat people :file 'testdmf.dmf' :header 'RES (1972) data' :member test_dat :print); nrow=10; ncol=8; x=rn(matrix(nrow,ncol:)); call print(x); means=array(ncol:); do i=1,ncol; means(i)=mean(x(,i)); enddo; call print(means); call makedmf(x :print :file 'testdmf.dmf' :add :header 'Random Matrix Data'); call getdmf(:browse :browsename :file 'testdmf.dmf'); call cleardat; call getdmf(:file 'testdmf.dmf'); call names(all); call getdmf(:file 'testdmf.dmf' :member data1 :print); call names(all); test=catcol(m1col__1,m1col__3); call print(' ':); call print('mean(test(,1)),mean(test(,2))':); call print( mean(test(,1)),mean(test(,2))); test=catcol(lnq,lnl,lnk); call print(' ':); call print('mean(lnq),mean(lnl),mean(lnk)':); call print( mean(lnq),mean(lnl),mean(lnk)); b34srun; b34sexec options open('testdmf.dmf') unit=62; b34srun; b34sexec dmf infmt=formatted inunit=62$ browse listnames$ b34srun$ b34sexec data file('testdmf.dmf') dmfmember(test_dat) filef= dmf; b34srun; b34sexec list iend=10; b34srun; b34sexec data file('testdmf.dmf') dmfmember(data1 ) filef= dmf; b34srun; b34sexec list; b34srun; == ==MAKEDMF3 Speed tests dfor various saves /; /; Big Test of Data base Alternatives /; /; Rats limit k=999 /; dmf and fsv are the fastest!! /; %b34slet n=1000; %b34slet k=800; %b34slet dodmf=1; %b34slet docheck=1; %b34slet dofsv =1; %b34slet dorats =1; b34sexec matrix; subroutine fixname(ccname1,ccname2,k); /; /; Builds name /; ccname1=c1array(8:'m1col__1'); ccname2=c1array(8:'m1col___'); if(k.ge.0.and.k.le.9)then; call inttostr(k,junk,'(i1)'); ccname2(i,8)=junk(1); endif; if(k.ge.10.and.k.le.99)then; call inttostr(k,junk,'(i2)'); ccname2(8)=junk(2); ccname2(7)=junk(1); endif; if(k.ge.100.and.k.le.999)then; call inttostr(k,junk,'(i3)'); ccname2(8)=junk(3); ccname2(7)=junk(2); ccname2(6)=junk(1); endif; if(k.ge.1000.and.k.le.9999)then; call inttostr(k,junk,'(i4)'); ccname2(8)=junk(4); ccname2(7)=junk(3); ccname2(6)=junk(2); ccname2(5)=junk(1); endif; ccname1=c8array(1:ccname1); ccname2=c8array(1:ccname2); return; end; call echooff; call print('Tests done where N was ',%b34seval(&n):); call print('Tests done where K was ',%b34seval(&k):); call print(' ':); %b34sif(&dodmf.ne.0)%then; n=%b34seval(&n); k=%b34seval(&k); x=rn(matrix(n,k:)); call print(' ':); call print('++++++++++++++++++++++++++++++++++++++++++++++++':); call print(' ':); call print('Mean x(,1) ',mean(x(,1)):); call print('Mean x(,k) ',mean(x(,k)):); call timer(base1); call makedmf(x); call timer(base2); et=base2-base1; call print('Makedmf time was ',et:); call cleardat; /; call getdmf(browse :print); call timer(base1); call getdmf; call timer(base2); et=base2-base1; call print('Getdmf time was ',et:); k=%b34seval(&k); call fixname(ccname1,ccname2,k); call print('Mean x(,1) ',mean(eval(ccname1)):); call print('Mean x(,k) ',mean(eval(ccname2)):); %b34sendif; /; /; Alternative approach that can save matrix /; %b34sif(&docheck.ne.0)%then; call cleardat; n=%b34seval(&n); k=%b34seval(&k); x=rn(matrix(n,k:)); call print(' ':); call print('++++++++++++++++++++++++++++++++++++++++++++++++':); call print(' ':); call print('Data before Restore':); call print('Mean x(,1) ',mean(x(,1)):); call print('Mean x(,k) ',mean(x(,k)):); call timer(base1); call checkpoint; call timer(base2); et=base2-base1; call print('checkpoint time was ',et:); call cleardat; n=%b34seval(&n); k=%b34seval(&k); call timer(base2); call restore; call timer(base2); et=base2-base1; call print('restore time was ',et:); call print('Data after Restore':); call print('Mean x(,1) ',mean(x(,1)):); call print('Mean x(,k) ',mean(x(,k)):); %b34sendif; /; /; fsv file approach /; %b34sif(&dofsv.ne.0)%then; call cleardat; n=%b34seval(&n); k=%b34seval(&k); x=rn(matrix(n,k:)); call print(' ':); call print('++++++++++++++++++++++++++++++++++++++++++++++++':); call print(' ':); call print('Before fSV save ++++++++++++++++++++++++':); call print('Mean x(,1) ',mean(x(,1)):); call print('Mean x(,k) ',mean(x(,k)):); call timer(base1); call makesca(x :file 'full.fsv' :member test); call timer(base2); et=base2-base1; call print('makesca time was ',et:); call cleardat; call timer(base1); call getsca('full.fsv' :member test); call timer(base2); et=base2-base1; call print('getsca time was ',et:); call print('From FSV File ':); n=%b34seval(&n); k=%b34seval(&k); call fixname(ccname1,ccname2,k); call print('Mean x(,1) ',mean(eval(ccname1)):); call print('Mean x(,k) ',mean(eval(ccname2)):); %b34sendif; /; Rats %b34sif(&dorats.ne.0.and.&k.le.999)%then; call cleardat; n=%b34seval(&n); k=%b34seval(&k); x=rn(matrix(n,k:)); call print(' ':); call print('++++++++++++++++++++++++++++++++++++++++++++++++':); call print(' ':); call print('Before Rats save ++++++++++++++++++++++++':); call print('Mean x(,1) ',mean(x(,1)):); call print('Mean x(,k) ',mean(x(,k)):); call timer(base1); call makerats(x :file 'full.por'); call timer(base2); et=base2-base1; call print('makerats time was ',et:); call cleardat; call timer(base1); call getrats('full.por'); call timer(base2); et=base2-base1; call print('getrats time was ',et:); call print('After Rats save ++++++++++++++++++++++++':); k=%b34seval(&k); call fixname(ccname1,ccname2,k); call print('Mean x(,1) ',mean(eval(ccname1)):); call print('Mean x(,k) ',mean(eval(ccname2)):); %b34sendif; b34srun; == ==MAKEFAIR Make a Fair-Parke Data loading file B34SEXEC DATA NOHEAD CORR noob=20 filef=@@$ INPUT Q P D F A $ LABEL Q = 'Food consumption per head'$ LABEL P = 'Ratio of Food Prices to consumer prices'$ LABEL D = 'Disposable Income in constant prices'$ LABEL F = 'Ratio of T-1 years price to general P'$ LABEL A = 'Time'$ COMMENT=('KMENTA(1971) PAGE 565 ANSWERS PAGE 582')$ DATACARDS$ 98.485 100.323 87.4 98.0 1 99.187 104.264 97.6 99.1 2 102.163 103.435 96.7 99.1 3 101.504 104.506 98.2 98.1 4 104.240 98.001 99.8 110.8 5 103.243 99.456 100.5 108.2 6 103.993 101.066 103.2 105.6 7 99.900 104.763 107.8 109.8 8 100.350 96.446 96.6 108.7 9 102.820 91.228 88.9 100.6 10 95.435 93.085 75.1 81.0 11 92.424 98.801 76.9 68.6 12 94.535 102.908 84.6 70.9 13 98.757 98.756 90.6 81.4 14 105.797 95.119 103.1 102.3 15 100.225 98.451 105.1 105.0 16 103.522 86.498 96.4 110.5 17 99.929 104.016 104.4 92.5 18 105.223 105.769 110.7 89.3 19 106.232 113.490 127.1 93.0 20 B34SRETURN$ B34SEEND$ b34sexec matrix; call loaddata; call makefair(:file 'kmenta.dat' :var q p d f a); b34srun; == ==MAKEFAIR2 Kmenta Test Problem /; /; Test fp program on Kmenta Data /; /; b34sexec options debugsubs(b34smat084,b34smat08); b34srun; %b34slet runb34s=0; B34SEXEC DATA NOHEAD CORR noob=20 filef=@@$ INPUT Q P D F A $ LABEL Q = 'Food consumption per head'$ LABEL P = 'Ratio of Food Prices to consumer prices'$ LABEL D = 'Disposable Income in constant prices'$ LABEL F = 'Ratio of T-1 years price to general P'$ LABEL A = 'Time'$ COMMENT=('KMENTA(1971) PAGE 565 ANSWERS PAGE 582')$ DATACARDS$ 98.485 100.323 87.4 98.0 1 99.187 104.264 97.6 99.1 2 102.163 103.435 96.7 99.1 3 101.504 104.506 98.2 98.1 4 104.240 98.001 99.8 110.8 5 103.243 99.456 100.5 108.2 6 103.993 101.066 103.2 105.6 7 99.900 104.763 107.8 109.8 8 100.350 96.446 96.6 108.7 9 102.820 91.228 88.9 100.6 10 95.435 93.085 75.1 81.0 11 92.424 98.801 76.9 68.6 12 94.535 102.908 84.6 70.9 13 98.757 98.756 90.6 81.4 14 105.797 95.119 103.1 102.3 15 100.225 98.451 105.1 105.0 16 103.522 86.498 96.4 110.5 17 99.929 104.016 104.4 92.5 18 105.223 105.769 110.7 89.3 19 106.232 113.490 127.1 93.0 20 B34SRETURN$ B34SEEND$ %b34sif(&runb34s.ne.0)%then; b34sexec simeq printsys reduced ols liml ls2 ls3 ils3 fiml kcov=diag ipr=6 ; heading=('test case from kmenta (1971) pages 565 - 582 ' ) $ exogenous constant d f a $ endogenous p q $ model lvar=q rvar=(constant p d) name=('demand equation')$ model lvar=q rvar=(constant p f a) name=('supply equation')$ b34seend$ %b34sendif; b34sexec matrix; datacards; KMENTA MODEL FOR FP PROGRAM MARCH 16, 2007 SPACE MAXVAR=200 MAXS=2 MAXCOEF=20 MAXFSR=30 FIRSTPER=1950 YEAR LASTPER= 1969 MAXCOV=9; @ @ For solution, do at least 2 iterations: @ SETUPSOLVE MINITERS=2 ; @ @ No missing values in IS MODEL: @ SETUPSOLVE NOMISS; @ @ For estimation divide by T rather than T-K: @ @ SETUPEST DIVIDET; @ @ Use (6.13) and (6.14), p. 212, in Fair (1984) to compute the @ 2SLS estimates: @ SETUPEST ALT2SLS; @ @ Set up some options for the DFP algorithm: @ SETUPDFP PRINTOBJ PRINTVALUES; @ @ Load the data: @ SMPL 1950 1969; LOADDATA FILE=kmenta.dat; @ @ Create the constant term: seems to need name cnst @ CREATE CNST=1; @ @ Generate the needed variables: @ @ GENR LOGC=LOG(C); @ GENR LOGI=LOG(I); @ GENR LOGY=LOG(Y); @ @ Create variables needed only for FSRs: @ @ CREATE LOGG=LOG(G); @ @ Create the time trend: @ @ CAPITAL I=CNST K=T BENCHPER=1952.1 BENCHVAL=1. DEPRATE=0.; @ @ Specify the equations and the LHS commands: @ EQ 1 q cnst p d ; @ undo left hand side not needed here @ LHS q=log(q) ; EQ 2 q cnst p f a ; @ undo left hand side not needed here @ LHS q=log(q) ; @ IDENT Y=C+I+G; @ @ Specify the FSRs (first stage regressions) for eq 1-2 @ EQ 1 FSR cnst d f a; EQ 2 FSR cnst d f a; @ @ Check the IDENT and LHS commands: @ @ SMPL 1 20; @ CHECK IDENT; @ CHECK LHS; @ @ Estimate the coefficients, S, and COV and save in files: @ @ SMPL 1 20; @ 2SLS S COV FILECOEF=ISCOEF2.BIN FILES=ISS2.BIN @ FILECOV=ISCOV2.BIN; @ ols s cov ; est 1 2; end; @ @ 2sls save3sls used for 3sls if model is linear 2sls s cov filecoef=kmentacoef2.bin files=kmenta_s2.bin filecov =kmentacov2.bin ; est 1 2; end; @ quit; @ +++++++++++++++++++++++++++++++++++ @ @ file fsr3 contains a list of first stage regressors @ format is one variable per line. Last line must be ; in col 1 @ lags are gmp -2 for a lag 2 of gnp @ @ 3SLS filefsr=fsr3.var COV filecoef=iscoef3.bin maxiters=30 ; prints; printcov diag; reads file=kmenta_s2.bin; @ +++++++++++++++++++++++++++++++++++ @ 2SLAD COV ; @ EST 1 2; @ END; @ +++++++++++++++++++++++++++++++++++ @ @ since linear all derivatives are -1 @ @ jacob based on eq ordering of variables @ EQ 1 q cnst p d ; @ EQ 2 q cnst p f a ; @ @ endogenous q p @ exogenous constant d f a @ @ Model written @ 0 = q -cnst -coef( )*p - coef( )*d @ 0 = q -cnst -coef( )*p - coef( )*f - coef( )*a @ @ deriv(i,j) => derivative of equation j with respect @ to endogenous variable i @ jacob deriv(1,1) = 1.; jacob deriv(2,1) = -coef(2,1)*p; jacob deriv(1,2) = 1.; jacob deriv(2,2) = -coef(2,2)*p; @ Two ways to go ..... Makes a difference @ FIML COV ; @ prints; @ printcov diag; FIML COV DFP; prints; printcov diag; FIML COV ; prints; printcov diag; @ must have next command quit; b34sreturn; /; This section copies the FP command to a named file /; and loads data in a file call rewind(4); call open(77,'KMENTA.INP'); call rewind(77); call copyf(4,77); call close(77); call loaddata; call makefair(:file 'KMENTA.DAT' :var q p d f a :start '1950.' :end '1969.' ); /; three stage first stage var list /; required is 3sls vars_fs=namelist(cnst d f a ); call open(77,'FSR3.VAR'); call rewind(77); do i=1,norows(vars_fs); call write(vars_fs(i),77); enddo; call igetchari(59,cc); call write(cc,77); call close(77); /; ++++++++++++++++++++++++++++++++++++++++++++ /; This section makes the in file that lists the fp command /; file name call open(77,'in'); call rewind(77); /; 1234567890123456789012345678901234567890 test='input file=KMENTA.INP '; c1test=c1array(40:test); /; /; put in ; /; call igetchari(59,cc); c1test(40)=cc; call print(c1test); call write(c1test,77); call close(77); b34srun; b34sexec options dodos('c:\b34slm\fp > outt < in') dounix('/usr/local/lib/b34slm/fp > outt < in'); b34srun; b34sexec options copyfout('outt'); b34srun; /; clean up mess b34sexec options unix('rm TEMP*.DAT' 'rm SCR*' 'rm outt' 'rm TEMP' 'rm TEMPOVER' 'rm *.BIN') dos('erase temp*.dat' 'erase scr*' 'erase outt' 'erase TEMP' 'erase TEMPOVER' 'erase *.bin') ; b34srun; == ==MAKEGLOBAL Call MAKEGLOBAL => Make a local object global b34sexec matrix; n=4 ;x=rn(matrix(n,n:));pdx=transpose(x)*x; call free(n:); call names(info); call makeglobal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); call makelocal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); pdx(1,1)=.9999; call print(pdx,'We now free at the local level'); call free(pdx); call names(info); b34srun; == ==MAKEJUL Makes a Julian Variable from a Series b34sexec matrix; x=rn(array(120:)); call settime(x,1960,1,12.); call print(timebase(x),timestart(x),freq(x)); jdate=makejul(x); year=fyear(jdate); call graph(year,x :plottype xyplot); b34srun; == ==MAKELOCAL Call MAKELOCAL => Make a global object local b34sexec matrix; n=4 ;x=rn(matrix(n,n:));pdx=transpose(x)*x; call free(n:); call names(info); call makeglobal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); call makelocal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); pdx(1,1)=.9999; call print(pdx,'We now free at the local level'); call free(pdx); call names(info); b34srun; == ==MAKELOCAL2 Call MAKELOCAL for key movement b34sexec matrix; subroutine test(oldlev); getit=rn(matrix(3,3:)); call print(getit); call print('In Test':); call names(info); call makelocal(getit :level level(), oldlev); return; end; call names(info); call test(level()); call names(info); call print(getit); b34srun; == ==MAKEMAD Makes a SCA MAD file from matrix data /$ /$ In SCA the commands: /$ call procedure is name. file is 'full.mad' /$ /$ /$ will read the data /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makemad(gasin,newgasi,gasout,newgaso :file 'full.mad' :member test); call print(mean(gasin)); xx=rn(matrix(300,60:)); call makemad(xx :file 'full.mad' :member mm :add); b34srun; b34sexec scaio readsca file('full.mad') dataset(test); b34srun; b34sexec scaio readsca file('full.mad') dataset(mm); b34srun; == ==MARKMAD2 Character*8 support b34sexec matrix; g(1)='bill'; g(2)='liu'; call makemad(g :file 'full.mad' :member test); b34srun; b34sexec matrix; call getsca('full.mad' :mad); call names; call print(g); b34srun; b34sexec scaio readsca file('full.mad') dataset(test); b34srun; b34sexec list; b34srun; == ==MAKEMATLAB Gets & Makes Matlab Data saved with MAKEB34S command b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ When using the MATLAB GETB34S file use full path /$ xx=getb34s('c:\junk\junk.ttt'); call loaddata; call names; xx=rn(matrix(5,5:)); call makematlab(gasout,gasin:file 'junk.ttt'); call makematlab(xx :file 'junk2.ttt'); call getmatlab(x, :file 'junk.ttt'); call getmatlab(xx2 :file 'junk2.ttt'); call print(x,xx,xx2); call names; cx=complex(xx,xx*2.); call makematlab(cx :file 'junk3.ttt'); call getmatlab(cx2, :file 'junk3.ttt'); call print(cx,cx2); cc=c8array(3:'test1 ', 'test2', 'test3'); call makematlab(cc :file 'junk4.ttt'); call getmatlab(cc2, :file 'junk4.ttt'); call print(cc,cc2); call names(:); nlist=%names%; call makematlab(nlist :file 'junk5.ttt'); call getmatlab(nlist2 :file 'junk5.ttt'); call print(nlist,nlist2); b34srun; == ==MAKE_R Makes a R data loading file b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call make_r(gasout gasin :file 'rjob2.r'); x=matrix(3,3:1 2 3 4 5 6 7 8 9); call make_r(x time :add); big=rn(array(10,5:)); f=10.; call make_r(f,big :add); b34srun; b34sexec options copyfout('rjob2.r'); b34srun; == ==MAKERATS Make Rats Portable File - Shows Obs and Dated File b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makerats(gasin,newgasi,gasout,newgaso :file 'full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call cleardat; call getrats('full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call names; call tabulate(obsnum,gasin,newgasi,gasout,newgaso); b34srun; /$ /$ Time series section /$ b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makerats(gasin,newgasi,gasout,newgaso :timeseries juldaydmy(1,02,1945) 12. :file 'tfull.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call cleardat; call getrats('tfull.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call names; cdate=chardate(julian_); call tabulate(julian_,cdate,gasin,newgasi,gasout,newgaso); b34srun; /$ /$ Missing data section /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; do i=1,20; gasout(i)=missing(); enddo; call tabulate(gasin,gasout); call makerats(gasin,gasout :file 'junk.por' :timeseries 366. 12.); b34srun; b34sexec matrix; call getrats('junk.por'); call tabulate(gasin,gasout); call names; call cleardat; call getrats('junk.por' :keepmiss); call tabulate(gasin,gasout); call names; call print('Means of gasin and gasout' mean(goodrow(gasin )),mean(goodrow(gasout))); b34srun; == ==MAKESCA Makes a SCA FSAVE file from matrix data /$ /$ In SCA the commands: /$ finput file is 'full.fsv'. @ /$ dataset is test. /$ /$ will read the data /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makesca(gasin,newgasi,gasout,newgaso :file 'full.fsv' :member test); call print(mean(gasin)); xx=rn(matrix(300,60:)); call makesca(xx :file 'full.fsv' :member mm :add); call cleardat; call getsca('full.fsv' :member test); call print(mean(gasin)); b34srun; == ==MANUAL Call Manual => Get into interactive mode b34sexec matrix ; * Illustrates Running in Manual Mode.; n=6; v=rn(vector(n:)); sin=dsin(grid(.1 40.,.1)); cos=dcos(grid(.1 40.,.1)); call graph(sin, cos:heading 'This graphs sin and cos'); i=idint(array(3:3,2,4)); call print(v,i); * We jump into manual mode here; call manual; * We are back in run mode here; x=rn(matrix(n,n:)); call print(x); b34srun; == ==MARS MARS Under Matrix b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); call graph(%res :heading 'Residual from OLS 1-6'); call graph(%y %yhat:heading 'Fit from OLS 1-6'); call lagmatrix(gasin{1 to 6} gasout{1 to 6} :noint); call mars(gasout gasin{1 to 6} gasout{1 to 6} :print :forecast %xfuture); call print(%varrimp); call dispmars; call names(all); call graph(%res :heading 'Residual from Mars 1-6'); call graph(%y %yhat:heading 'Fit from Mars 1-6'); call mars(gasout gasin{1 to 6} gasout{1 to 6} :nk 80 :mi 3 :print :forecast %xfuture); call dispmars; call names(all); call graph(%res :heading 'Residual from :nk 80 :mi 3 Mars 1-6'); call graph(%y %yhat:heading 'Fit from :nk 80 :mi 3 Mars 1-6'); call print(%xfobs,%xfuture); * here xfobs and xfuture not defined; call mars(gasout gasin :print); call dispmars; call names(all); call print(kind(%xfobs),kind(%xfuture)); b34srun; == ==MARS_2 Data from Friedman b34sexec options ginclude('b34sdata.mac') member(friedman); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; call olsq(y x1 x2 x3 x4 x5 :print); call graph(%res :heading 'Residual from ols '); call graph(%y %yhat:heading 'Fit from ols '); olsres=%res; call mars(y x1 x2 x3 x4 x5 :print); call dispmars; call graph(%res :heading 'Residual from Mars '); call graph(%y %yhat:heading 'Fit from Mars '); marsres=%res; call graph(olsres marsres :heading 'OLS vs MARS'); b34srun; == ==MARS_3 Advanced Forecasting /$ Job shows an estimate and a forecast b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); * We forecast the last 10 insample data points ; npred=10; call echooff; xin=matrix(npred,1:); nn=norows(gasout)-npred; do i=1,npred; xin(i,1)=gasin(nn+i); enddo; call print(xin ); call names(all); call mars(gasout gasin :print :forecast xin ); call dispmars; call tabulate(%y %yhat %res gasout gasin); call tabulate(%fore %foreobs); b34srun; /$ Job shows an estimate and a model save b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; call open(60,'junk.mod'); call mars(gasout gasin :print :savemodel :murewind); call dispmars; b34srun; /$ now see if can get model b34sexec matrix; call loaddata; * We forecast the last 10 insample data points ; npred=10; call echooff; xin=matrix(npred,1:); nn=norows(gasout)-npred; do i=1,npred; xin(i,1)=gasin(nn+i); enddo; call print(xin ); call names(all); call mars(gasout gasin :print :getmodel :forecast xin ); call tabulate(%fore %foreobs); b34srun; == ==MARS_3A Bad values set to missing /$ Job shows an estimate and a forecast /$ here outside forecasts set = missing /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); * We forecast the last 10 insample data points ; npred=10; call echooff; xin=matrix(npred,1:); nn=norows(gasout)-npred; do i=1,npred; xin(i,1)=gasin(nn+i); enddo; xin(2,1)=.5e+30; call print(xin ); call names(all); call mars(gasout gasin :print :nocorner :forecast xin ); call dispmars; call tabulate(%y %yhat %res gasout gasin); call tabulate(%fore %foreobs); call print('Here set to corner and give message':); call print(xin ); call names(all); call mars(gasout gasin :print :forecast xin ); call dispmars; call tabulate(%y %yhat %res gasout gasin); call tabulate(%fore %foreobs); b34srun; == ==MARS_4 Graphs of Curves and Surfaces b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ /$ Job MARS_4B shows the automatic plot program MARSPLOT /$ b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; call mars(gasout gasin{1 to 6} gasout{1 to 6} :ngc 100 :ngs 200 :graph :mi 2 :nk 15 :print); call dispmars; call print('%ns ',%ns); call print('%nc ',%nc); call tabulate(%y %yhat %res); call names(all); call echooff; /$ /$ This illustrates the logic of MARSPLOT /$ i=integers(1,%ngc*2*%nc); bigm=matrix(%ngc,2*%nc: %crv(i)); ii_=0; do ii=1,%nc,2; ii_=ii_+1; m1=submatrix(bigm,1,%ngc,ii,ii+1); call char1(cc,'Curve Plot '); call inttostr(ii_,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; b34srun; == ==MARS_4B Plots Curves and Surfaces using MARSPLOT b34sexec options ginclude('b34sdata.mac') member(friedman); b34srun; b34sexec matrix; call loaddata; call load(marsplot); call load(dispmars :staging); call echooff; call olsq(y x1 x2 x3 x4 x5 :print); call graph(%res :heading 'Residual from ols '); call graph(%y %yhat:heading 'Fit from ols '); olsres=%res; call mars(y x1 x2 x3 x4 x5 :graph :mi 2 :nk 15 :print); call dispmars; call graph(%res :heading 'Residual from Mars '); call graph(%y %yhat:heading 'Fit from Mars '); marsres=%res; call graph(olsres marsres :heading 'OLS vs MARS'); call marsplot; b34srun; == ==MARS_5 Effect of NK on Residual Variance /$ /$ Shows effect of NK of residual variance /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; call olsq(gasout gasout{1 to 6} gasin{1 to 6} :print); nn=25; nk=integers(nn); resvar=array(nn:); do i=1,nn; call mars(gasout gasout{1 to 6} gasin{1 to 6} :mi 3:nk i ); resvar(i)=%resvar; enddo; call tabulate(nk,resvar); call graph(resvar); b34srun; == ==MARS_6 3D Plots RESVAR=f(NK,lag,mi) /$ /$ Shows effect of NK of residual variance & lags /$ Try various MAXMI values /$ maxmi=1 and maxmi=2 are of interest /$ /$ As set up Job runs nn*lag MARS models or 250 /$ /$ Hooks are in place to run the OLS Version. /$ b34sexec options ginclude('gas.b34'); b34srun; %b34slet domars=1; %b34slet dools =0; %b34sif(&domars.ne.0)%then; b34sexec matrix; call loaddata; call echooff; call olsq(gasout gasout{1 to 6} gasin{1 to 6} :print); nn=25; lag=10; maxmi=1; rss =array(lag,nn:); do j=1,lag; do i=1,nn; call mars(gasout gasout{1 to j} gasin{1 to j} :mi maxmi :nk i ); rss(j,i)=%rss ; enddo; enddo; /$ 123456789012345678901234567890123456 call character(cc,'Lags - Knots - Degree '); call inttostr(1, n1,'(i1)'); call inttostr(norows(rss),n2,'(i2)'); call inttostr(1, n3,'(i2)'); call inttostr(nocols(rss),n4,'(i2)'); cc =place(n1, 7, 7,cc); cc =place(n2, 9,10,cc); cc =place(n3,19,20,cc); cc =place(n4,22,23,cc); call inttostr(0,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 0. :heading cc); call inttostr(90,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 90. :heading cc); call inttostr(180,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 180. :heading cc); call inttostr(270,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 270. :heading cc); call graph(submatrix(rss,2,norows(rss),3,25) :plottype meshc :grid :d3axis d3border :rotation 0. :heading 'submatrix(rss,2,norows(resvar),3,25)'); call print(rss); call checkpoint; b34srun; %b34sendif; %b34sif(&dools.ne.0)%then; b34sexec matrix; call loaddata; call echooff; nn=15; lag=15; rss=array(nn,lag:); do j=1,lag; do i=1,nn; call olsq(gasout gasout{1 to j} gasin{1 to i}); rss(i,j)=%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,10; /$ 123456789012345678901234567890123456 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; call print(rss); call checkpoint; b34srun; %b34sendif; == ==MARS_7 Getting data from a MARS run b34sexec options ginclude('b34sdata.mac') member(friedman); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call mars(y x1 x2 x3 x4 x5 :print :nk 15 :mi 2); call dispmars; call print(%coef); call tabulate(%names,%lag,%minvar,%maxvar); call tabulate(%typek,%varink,%knot,%parent); call print('++++++++++++++++++++++++++++++++++++++++++':); call mars(y x1 x2 x3 x4 x5 ); call print(%coef); call tabulate(%names,%lag,%minvar,%maxvar); call tabulate(%typek,%varink,%knot,%parent); call print('++++++++++++++++++++++++++++++++++++++++++':); call mars(y x1 x2 x3 x4 x5 :print :mi 3 :nk 4); call dispmars; call print(%coef); call tabulate(%names,%lag,%minvar,%maxvar); call tabulate(%typek,%varink,%knot,%parent); b34srun; == ==MARS_8 Out of sample MARS Model with lags /$ Out of sample MARS Modeling when lags /$ Illustrates use of lagmatrix b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; * build the matrix for forecasts; * Variables must be what is supplied ; * Note that mars does not have to supply a constant; call lagmatrix(gasin{1 to 6} gasout{1 to 6} :noint ); hfuture=%xfuture; call names(all); call print(%xfuture); call tabulate(%lmatvar,%lmatlag); call mars(gasout gasin{1 to 6} gasout{1 to 6} :print :forecast hfuture); call print(%fore,%foreobs); call mars(gasout gasin{1 to 6} gasout{1 to 6} :nk 80 :mi 3 :print :forecast hfuture); call names(all); call print(%fore,%foreobs); b34srun; == ==MARS_FORE1 Recursive MARS Modeling - Nonlinear Case /$ Illustrates use of lagmatrix /$ OLS Beaten since Gas Data is highly Nonlinear /$ /$ Set iprint=0 to turn off output b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; * Recursive forecasting using VAR and VARMARS; * build the matrix for forecasts; * Variables must be what is supplied ; * Note that mars does not have to supply a constant; iprint=0; call echooff; maxback=20; nn =vector(maxback+1:); ff =vector(maxback+1:); ffols=vector(maxback+1:); actual=vector(maxback:); jjj =-1*maxback; icount=1; maxlag=12; minlag=1; do ii=jjj,0; idrop=dabs(ii); sample=array(norows(gasin)-maxlag:)+1.0; if(ii.ne.0)then; j=integers(norows(sample)-idrop+1,norows(sample)); sample(j)=0.0; endif; call lagmatrix(gasin{minlag to maxlag} gasout{minlag to maxlag} :noint :sample sample); hfuture=%xfuture; if(iprint.ne.0) call olsq(gasout gasin{minlag to maxlag} gasout{minlag to maxlag} :print :sample sample); if(iprint.eq.0) call olsq(gasout gasin{minlag to maxlag} gasout{minlag to maxlag} :sample sample); ffols(icount)=vfam(%xfuture)*%coef; if(iprint.ne.0) call mars(gasout gasin{minlag to maxlag} gasout{minlag to maxlag} :print :nk 80 :mi 2 :forecast hfuture :sample sample ); if(iprint.eq.0) call mars(gasout gasin{minlag to maxlag} gasout{minlag to maxlag} :nk 80 :mi 2 :forecast hfuture :sample sample ); nn(icount)=%foreobs(1); ff(icount)=%fore(1); jj=norows(gasout)-maxback+icount; if(jj.le.norows(gasout))actual(icount)=gasout(jj); icount=icount+1; enddo; call names; nnact=nn+maxlag; call tabulate(nn,nnact,ff,ffols,actual); j=integers(1,maxback); test1=sumsq(actual(j)-ff(j)); test2=sumsq(actual(j)-ffols(j)); call print('sumsq errors ols ',test2); call print('sumsq errors mars',test1); actual=actual(j); mars =ff(j); ols =ffols(j); call graph(actual,mars,ols :heading 'Out of sample forecasting'); b34srun; == ==MARS_FORE2 MARS Recursive Forecasting - RES79 Linear Model /$ Illustrates use of lagmatrix /$ Hear Model is more Linear than Gas Data. MARS Model beaten by OLS /$ /$ Set iprint=0 to reduce output b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; * Recursive forecasting using VAR and VARMARS; * build the matrix for forecasts; * Variables must be what is supplied ; * Note that mars does not have to supply a constant; iprint=0; call echooff; maxback=30; nn =vector(maxback+1:); ff =vector(maxback+1:); ffols=vector(maxback+1:); actual=vector(maxback:); jjj =-1*maxback; icount=1; maxlag=18; minlag=1; do ii=jjj,0; idrop=dabs(ii); sample=array(norows(pcrm2)-maxlag:)+1.0; if(ii.ne.0)then; j=integers(norows(sample)-idrop+1,norows(sample)); sample(j)=0.0; endif; call lagmatrix(pcrm2{minlag to maxlag} fycp{minlag to maxlag} :noint :sample sample); hfuture=%xfuture; if(iprint.ne.0) call olsq(fycp pcrm2{minlag to maxlag} fycp{minlag to maxlag} :print :sample sample); if(iprint.eq.0) call olsq(fycp pcrm2{minlag to maxlag} fycp{minlag to maxlag} :sample sample); ffols(icount)=vfam(%xfuture)*%coef; if(iprint.ne.0) call mars(fycp pcrm2{minlag to maxlag} fycp{minlag to maxlag} :print :nk 80 :mi 2 :forecast hfuture :sample sample ); if(iprint.eq.0) call mars(fycp pcrm2{minlag to maxlag} fycp{minlag to maxlag} :nk 80 :mi 2 :forecast hfuture :sample sample ); nn(icount)=%foreobs(1); ff(icount)=%fore(1); jj=norows(fycp)-maxback+icount; if(jj.le.norows(fycp))actual(icount)=fycp(jj); icount=icount+1; enddo; call names; nnact=nn+maxlag; call tabulate(nn,nnact,ff,ffols,actual); j=integers(1,maxback); test1=sumsq(actual(j)-ff(j)); test2=sumsq(actual(j)-ffols(j)); call print('sumsq errors ols ',test2); call print('sumsq errors mars',test1); actual=actual(j); mars =ff(j); ols =ffols(j); call graph(actual,mars,ols :heading 'Out of sample forecasting'); b34srun; == ==MARS_FORE3 MARS Recursive Forecasting - Leading Indicator /$ Illustrates use of lagmatrix /$ Leading Indicator Series which appears to be linear /$ /$ Set iprint=0 to reduce output b34sexec options ginclude('b34sdata.mac') member(bj_mx); b34srun; b34sexec matrix; call loaddata; * Recursive forecasting using VAR and VARMARS; * build the matrix for forecasts; * Variables must be what is supplied ; * Note that mars does not have to supply a constant; iprint=0; call echooff; maxback=20; nn =vector(maxback+1:); ff =vector(maxback+1:); ffols=vector(maxback+1:); actual=vector(maxback:); jjj =-1*maxback; icount=1; maxlag=5 ; minlag=1; do ii=jjj,0; idrop=dabs(ii); sample=array(norows(x)-maxlag:)+1.0; if(ii.ne.0)then; j=integers(norows(sample)-idrop+1,norows(sample)); sample(j)=0.0; endif; * sample(1)=0.0; * sample(2)=0.0; * sample(3)=0.0; call lagmatrix(x{minlag to maxlag} y{minlag to maxlag} :noint :sample sample ); hfuture=%xfuture; if(iprint.ne.0) call olsq(y x{minlag to maxlag} y{minlag to maxlag} :print :sample sample); if(iprint.eq.0) call olsq(y x{minlag to maxlag} y{minlag to maxlag} :savex :sample sample); ffols(icount)=vfam(%xfuture)*%coef; if(iprint.ne.0) call mars(y x{minlag to maxlag} y{minlag to maxlag} :print :nk 30 :mi 3 :forecast hfuture :sample sample ); if(iprint.eq.0) call mars(y x{minlag to maxlag} y{minlag to maxlag} :nk 30 :mi 3 :forecast hfuture :sample sample ); nn(icount)=%foreobs(1); ff(icount)=%fore(1); jj=norows(y)-maxback+icount; if(jj.le.norows(y))actual(icount)=y(jj); icount=icount+1; enddo; call names; nnact=nn+maxlag; call tabulate(nn,nnact,ff,ffols,actual); j=integers(1,maxback); test1=sumsq(actual(j)-ff(j)); test2=sumsq(actual(j)-ffols(j)); call print('sumsq errors ols ',test2); call print('sumsq errors mars',test1); actual=actual(j); mars =ff(j); ols =ffols(j); call graph(actual,mars,ols :heading 'Out of sample forecasting'); b34srun; == ==MARSPLINE1 Runs MARSPLINE Command %b34slet runr=1; /; /; This calls the older MARS program. This program is not enabled /; for versions of B34S that are distributed. See Stoles (20xx) /; Chapter 14 for details /; %b34slet runmars=0; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call load(marsdiag :staging); call echooff; m6=1; mm6=6; call olsq(gasout gasin{m6 to mm6} gasout{1 to mm6} :print); %res_ols = %res; %yhat_ols = %yhat; call marspline(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :mi 1 :nk 20 :xx); iprint=0; iplot=1; call marsdiag(%xx,c_sums,r_sums,iprint,iplot,'plot.wmf'); %res_m2 = %res; %yhat_m2 = %yhat; %b34sif(&runmars.eq.0)%then; call tabulate(%res_ols, %res_m2); call tabulate(%yhat_ols, %yhat_m2); call graph(%res_ols, %res_m2 :nolabel); %b34sendif; %b34sif(&runmars.ne.0)%then; call mars(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :mi 1 :nk 20); call dispmars; %res_m = %res; %yhat_m = %yhat; call tabulate(%res_ols, %res_m, %res_m2); call tabulate(%yhat_ols, %yhat_m, %yhat_m2); call graph(%res_ols, %res_m, %res_m2 :nolabel); %b34sendif; b34srun; b34sexec data set maxlag=6; build l1gasin l2gasin l3gasin l4gasin l5gasin l6gasin l1gasout l2gasout l3gasout l4gasout l5gasout l6gasout; gen l1gasin = lag1(gasin); gen l2gasin = lag2(gasin); gen l3gasin = lag3(gasin); gen l4gasin = lag4(gasin); gen l5gasin = lag5(gasin); gen l6gasin = lag6(gasin); gen l1gasout= lag1(gasout); gen l2gasout= lag2(gasout); gen l3gasout= lag3(gasout); gen l4gasout= lag4(gasout); gen l5gasout= lag5(gasout); gen l6gasout= lag6(gasout); b34srun; %b34sif(&runr.ne.0)%then; /; Unit 28 is the data b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') library(mda) # Building data input ; g_h <-array(c(l1gasin,l2gasin,l3gasin,l4gasin,l5gasin,l6gasin, l1gasout,l2gasout,l3gasout,l4gasout,l5gasout, l6gasout),dim=c(length(gasout),12)) test_mars_r=mars(x=g_h,y=gasout,degree=1,nk=20) crossprod(test_mars_r$residual) res = test_mars_r$residual coef = test_mars_r$coefficients factor = test_mars_r$factor fitted = test_mars_r$fitted cuts = test_mars_r$cuts coef cuts factor list(gasout,t(fitted),t(res)) quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos(' r rjob' ) unix(' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') unix('rm rjob.r', 'rm rjob.out','rm rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==MARSPLINE1B Uses stepwise and bestreg to test MARSPLINE Model /; /; Tests MARSPLINE using stepwise and bestreg on the transformed vector /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call echooff; call load(marsdiag :staging); call load(marsinfo :staging); iprint2=0; m6=1; mm6=6; call olsq(gasout gasin{m6 to mm6} gasout{1 to mm6} :print); %res_ols = %res; %yhat_ols = %yhat; call marspline(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :mi 2 :nk 20 :xx); %res_m2 = %res; %yhat_m2 = %yhat; call marsinfo; call marsdiag(%xx,c_sums,r_sums,1,1,' '); call stepwise(%y %xx :print :printsteps); if(iprint2.ne.0) call print( %means %nvar %cov %scale %hist %iend %aov %coef %swept ); call bestreg (%y %xx :print ); if(iprint2.ne.0) call print(%cov, %nvar, %nsize, %nbest, %ngood, %means, %ivarx, %crit, %ivarx, %indvar, %icoefx, %ntbest, %coef ); b34srun; == ==MARSPLINE2 Trees Data /; Shows MARS MARSPLINE and R(r) MARS /; /; Validate against GPL MARS in R if available %b34slet runr=0; %b34slet runmars=0; b34sexec options ginclude('b34sdata.mac') member(trees); * Data obtained from R(r) Test Case from Hastie-Tibshirani ; * input obs girth height volume; * label girth = 'Girth of a Tree'; * label height = 'Height of a Tree'; * label volume = 'Volume of the Tree'; b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; call olsq(volume girth height :print); %b34sif(&runmars.ne.0)%then; call mars(volume girth height :nk 20 :df 2. :mi 3 :print); call dispmars; call tabulate(%res,%y,%yhat); %b34sendif; call print(' ':); call print('++++++++++++ One Interaction ++++++++++++++':); call marspline(volume girth height :nk 21 :df 2. :mi 1 :print); call print(' ':); call print('++++++++++++ Fit penalty set = 2 ++++++++++':); call print('++++++++++++ Interactions = 2 ++++++++++':); call marspline(volume girth height :nk 21 :df 2. :mi 2 :print); call print(' ':); call print('++++++++++++ Fit penalty set = 3 ++++++++++':); call print('++++++++++++ Interactions = 2 ++++++++++':); call marspline(volume girth height :nk 21 :df 3. :mi 2 :print); call print(' ':); call print('++++++++++++ We go to degree =3 to see if a gain +++':); call marspline(volume girth height :nk 41 :df 2. :mi 3 :print); call print(%coef); call tabulate(%res,%Y,%yhat); b34srun; %b34sif(&runr.ne.0)%then; /; Unit 28 is the data b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') library(mda) # Building data input ; g_h <-array(c(girth,height),dim=c(length(girth),2)) test_mars_r=mars(x=g_h,y=volume) crossprod(test_mars_r$residual) res = test_mars_r$residual coef = test_mars_r$coefficients factor = test_mars_r$factor coef factor quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos(' r rjob' ) unix(' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') unix('rm rjob.r', 'rm rjob.out','rm rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==MARSPLINE3 Random Number Generator Examples MARSPLINE/ACE & R /$ macro file test MARS using various random number generator %b34slet runr=1; %b34slet noob=100$ %b34slet runmars=0; /$ b34sexec data noob=%b34seval(&noob)$ build y1 y2 x z e1 e2$ gen e1=rn()$ gen e2=rn()$ gen x =10*rn()$ gen z =10*rn()$ gen y1 = 10 + 5*x + 5*z + 50*e1 $ gen if(x .gt. 0) y2= 10 + 5*x + 5*z + 50*e2$ gen if(x .le. 0) y2= 10 -10*x + 5*z + 50*e2$ b34srun$ b34sexec matrix; call loaddata; call load(ace_ols :staging); call load(ace_plot :staging); call olsq(y1 x z :print); call echooff; %b34sif(&runmars.ne.0)%then; call mars(y1 x z :nk 20 :mi 2 :print); %b34sendif; call marspline(y1 x z :nk 20 :mi 2 :df 3. :print); call olsq(y2 x z :print); res_ols=%res; call marspline(y2 x z :nk 20 :mi 2 :df 3. :print); resnmars=%res; %b34sif(&runmars.ne.0)%then; call mars(y2 x z :nk 20 :mi 2 :print); res_mars=%res; call graph(res_ols,res_mars,resnmars :nolabel); %b34sendif; %b34sif(&runmars.eq.0)%then; call graph(res_ols,resnmars :nolabel); %b34sendif; call acefit(y2 x z :ns 1 :savex :print); call ace_ols; call ace_plot; b34srun$ %b34sif(&runr.ne.0)%then; /; Unit 28 is the data b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') library(mda) # Building data input ; g_h <-array(c(x,z),dim=c(length(y1),2)) test_mars_r=mars(x=g_h,y=y1) crossprod(test_mars_r$residual) res = test_mars_r$residual coef = test_mars_r$coefficients factor = test_mars_r$factor coef factor g_h <-array(c(x,z),dim=c(length(y1),2)) test_mars_r=mars(x=g_h,y=y2) crossprod(test_mars_r$residual) res = test_mars_r$residual coef = test_mars_r$coefficients factor = test_mars_r$factor coef factor quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos(' r rjob' ) unix(' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') unix('rm rjob.r', 'rm rjob.out','rm rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==MARSPLINE4 Friedman Data /; /; Test against R is available /; %b34slet runr=0; %b34slet runmars=0; b34sexec options ginclude('b34sdata.mac') member(friedman); b34srun; b34sexec matrix; call loaddata; call echooff; call load(dispmars :staging); call olsq( y x1 x2 x3 x4 x5 :print) $ %b34sif(&runmars.ne.0)%then; call mars( y x1 x2 x3 x4 x5 :nk 15 :mi 2 :print) $ call dispmars; %b34sendif; call marspline(y x1 x2 x3 x4 x5 :nk 50 :mi 2 :thresh .1e-13 :df 2.0 :print) $ /; call names(all); call print(%coef,%flag,%cut,%dir,%fullin,%bestin); call gamfit(y x1[predictor,3] x2[predictor,3] x3[predictor,3] x4[predictor,3] x5[predictor,3] :print); b34srun; %b34sif(&runr.ne.0)%then; /; Unit 28 is the data b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') library(mda) # Building data input ; g_h <-array(c(x1,x2,x3,x4,x5),dim=c(length(x1),5)) test_mars_r=mars(x=g_h,y=y) crossprod(test_mars_r$residual) res = test_mars_r$residual coef = test_mars_r$coefficients factor = test_mars_r$factor coef factor quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos(' r rjob' ) unix(' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') unix('rm rjob.r', 'rm rjob.out','rm rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==MARSPLINE5 Brieman Data %b34slet runr=0; %b34slet runmars=0; b34sexec options ginclude('b34sdata.mac') member(breiman); b34srun; /; data discussed page 133 in breiman (1991)$ /; data came from Cleveland and Devlin (1988)$ /; data transformed such that y = nox**(1/3) - median(nox**(1/3))$ /; y = 'nitrous oxides in exhaust'$ /; e_ratio = 'equivalence ratio '$ /; c_ratio = 'compression ratio '$ b34sexec matrix; call loaddata; call echooff; call load(dispmars :staging); call olsq( y e_ratio c_ratio :print); %b34sif(&runmars.ne.0)%then; call mars( y e_ratio c_ratio :print); call dispmars; %b34sendif; call print('Default Settings => Few Knots':); call marspline(y e_ratio c_ratio :print); call print('More Aggressive Settings Few Knots':); call marspline(y e_ratio c_ratio :df 2. :mi 2 :nk 20 :print); call print(%coef,%cut,%bestin); b34srun; %b34sif(&runr.ne.0)%then; /; Unit 28 is the data b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall; r; pgmcards; windows() source('rjob2.r') library(mda) # Building data input ; g_h <-array(c(e_ratio,c_ratio),dim=c(length(e_ratio),2)) test_mars_r=mars(x=g_h,y=y) crossprod(test_mars_r$residual) res = test_mars_r$residual coef = test_mars_r$coefficients factor = test_mars_r$factor coef factor quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos(' r rjob' ) unix(' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') dodos('erase rjob.r','erase rjob.out','erase rjob2.r') unix('rm rjob.r', 'rm rjob.out','rm rjob2.r') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==MARSPLINE6 Shows Forecasting /$ /$ macro file test MARS and MARSPLINE /$ /; Forecast limit is 400 for one x matrix to marspline /; %b34slet noob=300$ %b34slet errorm=2; %b34slet oldmars1=0; %b34slet oldmars2=0; %b34slet newmars =1; /$ b34sexec data noob=%b34seval(&noob)$ build y1 y2 x z e1 e2$ gen e1=rn()$ gen e2=rn()$ gen x =10*rn()$ gen z =10*rn()$ gen y1 = 10 + 5*x + 5*z + %b34seval(&errorm)*e1 $ gen if(x .gt. 0) y2= 10 + 5*x + 5*z + %b34seval(&errorm)*e2$ gen if(x .le. 0) y2= 10 -10*x + 5*z + %b34seval(&errorm)*e2$ b34srun$ %b34sif(&oldmars1.ne.0)%then; b34sexec mars nk=10 mi=2$ model y1 = x z$ b34srun$ b34sexec mars nk=10 mi=2$ model y2 = x z$ b34srun$ %b34sendif; b34sexec matrix; call loaddata; call echooff; call load(dispmars :staging); %b34sif(&oldmars2.ne.0)%then; call olsq(y1 x z :print); call mars(y1 x z :print); call dispmars; call mars(y2 x z :print); call dispmars; %b34sendif; %b34sif(&newmars.ne.0)%then; %x=catcol(x z); call marspline(y1 x z :print :forecast %x :fxx); call tabulate(%foreobs %fore %yhat %res %y); call print(%fxx); call marspline(y2 x z :print :forecast %x); call tabulate(%foreobs %fore %yhat %res %y); call print(%BESTIN,%FLAG,%DIR,%CUT,%YVAR,%NAMES,%TYPEVAR,%LAG, %COEF,%MINVAR,%MAXVAR,%K,%NOB,%RSS,%SUMRE,%REMAX,%RESVAR, %MARS_VR); %b34sendif; b34srun; == ==MARSPLINE7 Advanced Forecasting %b34slet runmars=0; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call load(marsinfo :staging); call echooff; iend=6; call olsq(gasout gasin{1 to iend} gasout{1 to iend} :print); %res_ols = %res; %yhat_ols = %yhat; %b34sif(&runmars.ne.0)%then; call mars(gasout gasin{1 to iend} gasout{1 to iend} :print :mi 2 :nk 20); %res_m = %res; %yhat_m = %yhat; %b34sendif; call lagmatrix( gasin{1 to iend} gasout{1 to iend} :matrix mm :noint); call marspline(gasout gasin{1 to iend} gasout{1 to iend} :print /; :trace :forecast mm :mi 1 :nk 20 :savemodel :savebx); call print(%coef,%se,%var); call marsinfo; %testres=afam(%y)-afam(%fore); call print(variance(%res),variance(%testres)); call tabulate(%yhat, %res %fore, %testres); %res_m2 = %res; %yhat_m2 = %yhat; %b34sif(&runmars.ne.0)%then; call graph(%res_ols, %res_m, %res_m2 :nolabel); %b34sendif; %b34sif(&runmars.eq.0)%then; call graph(%res_ols, %res_m2 :nolabel); %b34sendif; /; Getting Model back, printing and forecasting call free(%yhat); call lagmatrix(gasin{1 to 6} gasout{1 to 6} :matrix mm :noint); call marspline(gasout gasin{1 to iend} gasout{1 to iend} :getmodel :forecast mm :dispmars ); /; These vectors must be the same; call print('these must be the same!!',variance(%yhat_m2), variance(%fore) ); call tabulate(%yhat_m2, %fore); b34srun; == ==MARSPLINE8 MARSPLINE Probit b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call echooff; yvar=afam(d1); /; this sets model call character(cc,'t y lf nw'); call olsq(yvar argument(cc) :print); %yhatols=%yhat; call probit(yvar argument(cc) :print); %yhat_pb=%yhat; call marspline(yvar argument(cc) :probit :nk 20 :mi 2 :savebx :df 2. :print); %yhat1=%yhat; call probit(yvar %probitx :noint :print); %yhat2=%yhat; /; This tests %probitx call olsq(yvar %probitx :noint :print); call tabulate(%y,%yhatols,%yhat_pb,%yhat1,%yhat2); b34srun; == ==MARS_PRBT Advanced Marspline Probit /; /; This may be changed in the future /; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call echooff; program mars_p; /; /; Does Probit analysis and displays coef in the MARS Model /; * Adjust coef, se, a t-vals under Probit assumptions /; * -------------------------------------------------- call probit(yvar %probitx :noint :print); coefnew=%coef; senew=%se; tnew=%t; /; * Save adjusted probit information into Marspline model /; * ----------------------------------------------------- call restore(:file 'marss.psv'); %coef=coefnew; %se=senew; %t=tnew; call checkpoint(:file 'marszero.psv' :var %BESTIN %FLAG %DIR %CUT %YVAR %NAMES %TYPEVAR %LAG %COEF %T %MINVAR %MAXVAR %K %NOB %RSS %SUMRE %REMAX %RESVAR %MARS_VR %SE %MODTYPE %NK); /; * Display the final MarsProbit model /; * ------------------------------------------------------------------- call marspline(yvar argument(cc) :getmodel 'marszero.psv' :dispmars); return; end; yvar=afam(d1); /; this sets model call character(cc,'t y lf nw'); /; * Execute the initial Marspline model /; * ----------------------------------- call marspline(yvar argument(cc) :probit :nk 20 :mi 2 :savebx :savemodel :df 2. :print); call mars_p; b34srun; == ==MARSPLINE9 Experimental MARSPLINE LOGIT /; /; Shows how MARS logit and MARSPLINE on a catagolical left hand /; variable correlate with actual data and with each other. /; The tentative conclusion is that MARSPLINE using the adjustment will /; outperform OLS. More research is needed on this before "automatic" /; adjustments are made. A tentative version of f_marslg is in the /; staging library but is subject to major changes. The driving job is /; f_marslg. The complete job is marspline8 /; /; The first call to pribit is a linear model. /; The second call usse the marspline x variables. /; The call to olsx(yvar %probitx ) tests the marspline calculation. /; %b34slet runmars=1; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ /; b34sexec probit; model d1 = t y lf nw; b34srun; /; b34sexec loglin; model d1 = t y lf nw; b34srun; b34sexec matrix; call loaddata; call echooff; yvar=afam(d1); /; this sets model call character(cc,'t y lf nw'); call olsq(yvar argument(cc) :print); %yhatols=%yhat; call probit(yvar argument(cc) :print); %yhat_pb=%yhat; %b34sif(&runmars.ne.0)%then; call mars(yvar argument(cc) :logit :nk 40 :mi 2 :print); %yhat1=%yhat; %b34sendif; call marspline(yvar argument(cc) :probit :nk 20 :mi 2 :savebx :df 2. :print); %yhat2=%yhat; call probit(yvar %probitx :noint :print); %yhat5=%yhat; /; This tests %probitx call olsq(yvar %probitx :noint :print); %b34sif(&runmars.ne.0)%then; call print( '%yhat1 - mars, %yhat2 - marspline, %yhat5 - Marspline/probit':); call tabulate(%y,%yhat1,%yhat2,%yhat5); %b34sendif; %b34sif(&runmars.eq.0)%then; call print( '%yhat2 - marspline, %yhat5 - Marspline/probit':); call tabulate(%y,%yhat2,%yhat5); %b34sendif; subroutine f_marslg(raw_s,adj1,adj2); /; /; Normalizes a prediction in the range 0-1 /; /; /; raw_s => the output from matspline /; adj1 => Values > 1.0 and < 0.0 set to 1.0 and 0.0 /; adj2 => Series rescaled /; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ adj1 =dmin1(raw_s,1.0); adj1 =dmax1(adj1 ,0.0); mm1=min(raw_s); mm2=max(raw_s); range=mm2-mm1; if(mm1.lt.0.0)then; range=mm2+dabs(mm1); adj2 =raw_s+dabs(mm1); endif if(mm1.gt.0.0)adj2 =raw_s -mm1; adj2 =adj2 /range; return; end; call f_marslg(%yhat2,%yhat3,%yhat4); %b34sif(&runmars.ne.0)%then; call tabulate(%y,%yhatols,%yhat1,%yhat2,%yhat3,%yhat4,%yhat5); data=catcol( %y,%yhatols,%yhat_pb,%yhat1,%yhat2,%yhat3,%yhat4,%yhat5); call print('%yhat1 - old mars logit .. %yhat5 marspline/probit':); call print( 'Correlation %y,%yhatols,%yhat_pb,%yhat1,%yhat2,%yhat3,%yhat4,%yhat5', ccf(data)); call graph( %yhatols,%yhat_pb,%yhat1,%yhat2,%yhat3,%yhat4, %yhat5 :nolabel); %b34sendif; %b34sif(&runmars.eq.0)%then; call tabulate(%y,%yhatols,%yhat2,%yhat3,%yhat4,%yhat5); data=catcol( %y,%yhatols,%yhat_pb,%yhat2,%yhat3,%yhat4,%yhat5); call print( 'Correlation %y,%yhatols,%yhat_pb,%yhat2,%yhat3,%yhat4,%yhat5', ccf(data)); call graph( %yhatols,%yhat_pb,%yhat2,%yhat3,%yhat4,%yhat5 :nolabel); %b34sendif; b34srun; == ==MARSPLINEA MARS/PISPLINE on Generated Data with forecasting /$ /; Illustrates trapping holdout data and forecasting /; %b34slet noob =300; %b34slet errorm=20.; b34sexec data noob=%b34seval(&noob)$ build y1 y2 x z e1 e2$ gen e1=rn()$ gen e2=rn()$ gen x =10*rn()$ gen z =10*rn()$ gen y1 = 10 + 5*x + 5*z + %b34seval(&errorm)*e1 $ gen if(x .gt. 0) y2= 10 + 5*x + 5*z + %b34seval(&errorm)*e2$ gen if(x .le. 0) y2= 10 -10*x + 5*z + %b34seval(&errorm)*e2$ b34srun$ b34sexec matrix; call loaddata; call echooff; call load(dispmars :staging); iholdout=50; ioldmars=1; call olsq(y2 x z :print :holdout iholdout); call print(%xfuture); olsfore= %xfuture*%coef; if(ioldmars.ne.0)then; call mars(y2 x z :print :holdout iholdout); call dispmars; endif; call marspline(y2 x z :print :df 2. :savemodel :holdout iholdout); call print(%xfuture); call marspline(y2 x z :print :getmodel :forecast %xfuture); yy=y2(integers(norows(y2)-iholdout+1,norows(y2))); marsfore=%fore; call tabulate(%foreobs yy, marsfore,olsfore); call graph(yy,marsfore,olsfore :nolabel); call print(' '); call print('OLS out of sample squared error ', sumsq(afam(yy)-afam(olsfore)) :); call print('MARSPLINE out of sample squared error ', sumsq(afam(yy)-afam(marsfore)):); call free(%xfuture); call print(' '); call pispline(y2 x z :print :holdout 22); call print(%xfuture); b34srun; == ==MARSPLINEB SAS SO4 Data - MARS does well here /; Study of SO4 and Latitude and Longitude /; Data Studied byDong Xiang at SAS Institute /; 'Fitting Generalized Additive Models with GAM Procedure' /; SAS paper 256-26 b34sexec options ginclude('b34sdata.mac') member(gam_6); b34srun; b34sexec matrix; call loaddata; call load(ace_ols :staging); call load(ace_plot :staging); call load(gamplot); call echooff; call olsq(so4 latt long :print); %olsss=%rss; %olsyhat=%yhat; %olsres=%res; /; MARS + Suface Plots call marspline(so4 latt long :df 2. :nk 40 :mi 2 :savex :print :contrib array(2,2: min(latt) mean(long) max(latt) mean(long)) index(100) :surface array(2,2: min(latt) min(long) max(latt) max(long)) index(100,100) ); %marsss=%rss; %x_mars=%x; call graph(%xcrange %contrib :plottype xyplot :xlabel 'Latitude' :pgborder :nocontact :ylabelleft 'Contribution of Latitude to SO4' 'CR' :markpoint 1 1 3 14 :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :colors black bblue :file 'mars_cont.wmf' :heading 'Leverage Plot of Latitude vs SO4 based on MARS Model'); %x_mars=%x; x=%surface; /; :pgunits used to label x and y axis! call graph(x :plottype meshstepc :file 'mars_so4.wmf' :rotation 20. :angle 20. :xlabel 'Latitude' :pgunits array(:min(latt) min(long) max(latt) max(long)) :ylabelleft 'Longitude' 'cr' :zlabelleft 'SO4' :grid :d3axis :d3border :heading 'SO4 = f(Latitude and Longitude based on MARS Model)'); call acefit(so4 latt long :print :savex :xx); call ace_ols; call ace_plot; %acess =%ssres(imin(%ssres)); file='gam.fsv'; call gamfit(so4 latt[predictor,3] long[predictor,3] :print :punch_sur :punch_res :filename file); %gamss=%rss; call gamplot(%names,%lag,file,%olsyhat,%olsres,0); call print(%olsss,%marsss,%acess,%gamss); b34srun; == ==MARS_CONTB Automatic MARSPLINE Contrib Chart /; /; Generation of contrib charts automatically /; /; See contrib and contrib2 /; /; Job can be easily modified /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call load(marsdiag :staging); call load(marsinfo :staging); contrib2=1; if(contrib2.eq.0)call load(contrib :wbsuppl); /; more advanced version if(contrib2.ne.0)call load(contrib); m=6; _knots=20; _mi=2; _df=2.0; /; set left hand side call character(l_hand_s,'gasout'); /; Set right hand side call character(_args,'gasout{1 to m} gasin{1 to m}'); call olsq( argument(l_hand_s) argument(_args) :diag :print); olscoef=%coef; call marspline(argument(l_hand_s) argument(_args) :mathform :print :nk _knots :mi _mi :df _df :savemodel :xx); /; Analysis by observation of variables. call marsdiag(%xx,c_sums,r_sums,2,2,'test1.wmf'); call marsinfo; /$ **************************************************************$/ /$ Create contribution charts for righthand-side variables /$ **************************************************************$/ 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; /; 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 variable on YHat diff1(Yhat) /; 5 => cumulative contribution of target variable unit increase on /; YHat->YHat(t)-YHat(1) if(contrib2.eq.0)call contrib(_medians,_means,1); if(contrib2.ne.0)then; iopt=1; iols=1; ihp=0 ; isave=3; iversion=1; igrid=1; ishow=1; fsv_info='Basic GASOUT MARS Model Estimated'; /; 1234567890123456789012 message=', vector values used ]'; call contrib(iopt,message,_medians,iversion,isave,ihp,iols, olscoef,igrid,ishow,fsv_info); endif; b34srun; == ==MARSPROBIT Uses Lee Data to test MARSPLINE Probit /; /; Job built by Bill Lattyak of SCA /; Illustrates probit and MARS probit and full diagnostics /; %b34slet dosas=0; b34sexec options ginclude('b34sdata.mac') member(lee_probit); b34srun; b34sexec probit tola=.1e-14; model remiss = cell li temp; b34srun; b34sexec matrix; call loaddata; call echooff; call olsq(remiss cell li temp :print); call load(dispmars :staging); call load(disp_hin :wbsuppl); call load(dsp_acf :wbsuppl); call load(coint2 :wbsuppl); call load(dsp_tbl :wbsuppl); call load(contrib :wbsuppl); call load(catbuild :wbsuppl); call load(tlogit :staging); call load(liftgain :wbsuppl); call load(disp_lgt :wbsuppl); call print('-------------------------------------------------------':); call print('** Analysis Performed on Variable: REMISS':); call print('-------------------------------------------------------':); call dspdscrb('REMISS Dependent Variable',REMISS); /$ **************************************************************$/ /$ Set span for sample: REMISS /$ **************************************************************$/ iorigins=integers(1, 27); REMISS = REMISS(iorigins); CELL = CELL(iorigins); SMEAR = SMEAR(iorigins); INFIL = INFIL(iorigins); LI = LI(iorigins); BLAST = BLAST(iorigins); TEMP = TEMP(iorigins); /$ ******************************************************* /$ _holdout is the number of forecasts /$ _maxlag is the longest lag in model /$ _nlags is number of lags for diagnostics /$ _knots is the maximum number of basis function /$ _mi is the maximum number of interactions /$ _ms is the minimum span between each knot /$ _ffmars holds the MARS forecasts /$ _ffprbt holds the PROBIT forecasts for comparison /$ _actuals holds the actuals for comparison /$ _rxmdl holds the random X-variable model components /$ ******************************************************* _holdout=0; _nlags=12; if((_holdout.le._nlags).and.(_holdout.gt.0)) _nlags=_holdout-1; _maxlag=0; _upper=.501; _lower=.501; _knots=20; _mi=1; _ms=0; _df=2.0; call character(_desc1, 'Performance Evaluation for MARS'); call character(_desc2, 'Performance Evaluation for PROBIT'); imax=1; if(imax .le. _maxlag) imax=_maxlag+1; nn=integers(imax,norows(REMISS)); nnact=integers(imax,norows(REMISS)); _actuals=vfam(REMISS(nnact)); /$ **************************************************************** /$ Specify model components using character string variables /$ **************************************************************** call character(_rxmdl, 'LI TEMP CELL ' ); call probit(REMISS argument(_rxmdl) :print ); %lmatvar=%names; %lmatlag=%lag; _logparm=%coef; _logse=%se; _logt=%t; _func=%func; _ffprbt=goodrow(vfam(%yhat)); call disp_lgt(%lmatvar,%lmatlag,_logparm,_logse,_logt,_func,'PROBIT',0); _ffprbt=vfam(_ffprbt); _iprint=1; call tlogit(_actuals,_ffprbt,_upper,_lower,_desc2,_ntruer,_ntruep _nfalser,_nfalsep,_nunclear,_ptruer,_pfalser,_iprint); call character(_desc2b, 'PROBIT Lift-Gain Table'); call liftgain(_ffprbt,_actuals,_desc2b,npt,nt,lgtgain,lgtlift); /$ ******************************************************* /$ Specify MARS model /$ ******************************************************* call marspline(REMISS argument(_rxmdl) :probit :savebx :mathform :nk _knots :mi _mi :df _df :savemodel :print ); /$ **************************************************** /$ * Adjust coef, se, a t-vals under Probit assumptions /$ **************************************************** call probit(REMISS %probitx :noint :print); coefnew=%coef; senew=%se; tnew=%t; yhatnew=probnorm(%yhat); /$ **************************************************** /$ * Save adjusted probit information into Marspline model /$ **************************************************** call restore(:file 'marss.psv'); %coef=coefnew; %se=senew; %t=tnew; %yhat=yhatnew; call checkpoint(:file 'marszero.psv' :var %BESTIN %FLAG %DIR %CUT %YVAR %NAMES %TYPEVAR %LAG %COEF %T %MINVAR %MAXVAR %K %NOB %RSS %SUMRE %REMAX %RESVAR %MARS_VR %SE %MODTYPE %YHAT %NK); /$ **************************************************** /$ * Display the final MarsProbit model /$ **************************************************** call marspline(REMISS argument(_rxmdl) :probit :savebx :mathform :nk _knots :mi _mi :df _df :getmodel 'marszero.psv' :print ); call dispmars; _ffmars=goodrow(vfam(%yhat)); _dmat=array(3,norows(_actuals):); _dmat(1,)=_ffmars; _dmat(2,)=_ffprbt; _dmat(3,)=_actuals; nnames=c1array(3:); nnames(1)='MARS_'; nnames(2)='PROBIT_'; nnames(3)='REMISS'; call character(_desc, 'Table of Actual vs. Predicted'); _nbegn=_holdout+_maxlag; call dsp_tbl(_dmat,nnames,_nbegn,14,4,_desc); _iprint=1; call tlogit(_actuals,_ffmars,_upper,_lower,_desc1,_ntruer,_ntruep _nfalser,_nfalsep,_nunclear,_ptruer,_pfalser,_iprint); call character(_desc1b, 'MARS Lift-Gain Table'); call liftgain(_ffmars,_actuals,_desc1b,npt,nt,margain,marlift); res1=_ffmars - _actuals; res2=_ffprbt - _actuals; call graph(_actuals,_ffmars,_ffprbt :file 'yfit.wmf' :heading 'Original vs. Predicted' :nolabel :colors black black bblue bred); call grflift(margain,marlift,lgtgain,lgtlift,1,3,2); /$ ******************************************************* /$ Display graphics for Dependent Variable /$ ******************************************************* call graph(REMISS :file 'yvar.wmf' :noshow :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of REMISS'); /$******************************************************* /$ Display graphics for MARS Residuals /$ ******************************************************* call graph(res1 :file 'resa.wmf' :noshow :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of MARS Model Residuals'); /$******************************************************* /$ Display graphs for PROBIT model residuals /$ ******************************************************* call graph(res2 :file 'resb.wmf' :noshow :pspaceon :pgyscaleright 'i' :pgborder :pgxscaletop 'i' :nocontact :colors black bblue :heading 'Plot of PROBIT Model Residuals'); /$ **************************************************************$/ /$ Create contribution charts for righthand-side variables /$ **************************************************************$/ call lagmatrix( argument(_rxmdl) :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 contrib(_medians,_means,3); b34srun; %b34sif(&dosas.ne.0)%then; b34sexec options open('testsas.sas') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=29 icntrl=29$ sas $ * sas commands next ; pgmcards$ proc nlin data=remiss method=newton sigsq=1; parms a -2 b -1 c 6 int -10; /* Linear portion of model ------*/ eq1 = a*cell + b*li + c*temp +int; /* probit */ p = probnorm(eq1); if ( remiss = 1 ) then p = 1-p; model.like = sqrt(- 2 * log( p)); output out=p p=predict; run; b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos('start /w /r sas testsas' ) dounix('sas testsas' ) $ b34srun$ b34sexec options npageout noheader writeout(' ','output from sas',' ',' ') writelog(' ','output from sas',' ',' ') copyfout('testsas.lst') copyflog('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==MARS_VAR MARS_VAR Model on GAS Data /; /; runmars => run a "var" equation by equation using MARS /; runvar => run joint estimation of VAR modelk using MARS /; val_cmd => run var equation by equation with mars_VAR will replicate /; what is being calculated with marspline!!!! Usually /; not needed /; tests => Illustrates some of the saved data by the MARS_VAR /; command %b34slet runmars=1; %b34slet runvar =1; %b34slet val_cmd=1; %b34slet tests =0; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; iholdout=20; m6=1; mm6=6; nk=20; mi=2; df=2.; call print('********************************************************':); call print('*********************** OLS Base Case ******************':); call print('************* Equation by Equation Estimation **********':); call print('********************************************************':); call olsq(gasin gasin{m6 to mm6} gasout{1 to mm6} :print :holdout iholdout); call olsq(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :holdout iholdout); %b34sif(&runmars.ne.0)%then; call print(' ':); call print('********************************************************':); call print('************* Equation by Equation Estimation **********':); call print('********************************************************':); call marspline(gasin gasin{m6 to mm6} gasout{1 to mm6} :print :mi mi :nk nk :df df :holdout iholdout); call marspline(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :mi mi :nk nk :df df :holdout iholdout); %b34sif(&val_cmd.ne.0)%then; call print(' ':); call print('********************************************************':); call print('**** MARS_VAR for Equation by Equation Estimation ******':); call print('**** Validation of MARSPLINE vs MARS_VAR ******':); call print('********************************************************':); call mars_var(gasin gasin{m6 to mm6} gasout{1 to mm6} :print :mi mi :nk nk :df df :holdout iholdout); call mars_var(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :mi mi :nk nk :df df :holdout iholdout); %b34sendif; %b34sendif; %b34sif(&runvar.ne.0)%then; gg=catcol(gasin,gasout); call print(' ':); call print('********************************************************':); call print('************* Joint Estimation of right hand side ****':); call print('************* Note a More Vectors (17 vs 14) needed ****':); call print('********************************************************':); call mars_var(gg gasin{m6 to mm6} gasout{1 to mm6} :yvarnam c8array(:'GASIN','GASOUT') :setsig 2.00 :print :mi mi :nk nk :df df :holdout iholdout :savemodel :xx :fxx :savex :forecast %xfuture); call print(%fxx); if(iholdout.eq.0)then; call print(%xfuture,%fore); endif; if(iholdout.ne.0)then; ii=integers(norows(gg)-iholdout,norows(gg)); actual=gg(ii,); error=afam(actual)-afam(%fore); call print(%xfuture,%fore,actual); call print('obs fore actual error':); call print(catcol(dfloat(%foreobs) %fore,actual,error)); endif; %b34sif(&tests.ne.0)%then; call print(%res,%y,%yhat); call print(%coef,%se,%t,%tsig,%rss); call print(%sumre,%remax,%resvar,%sig); call print(sum(%res(,1))); call print(sum(%res(,2))); call print(%y(,1)-%yhat(,1),%res(,1)); call print(%y(,2)-%yhat(,2),%res(,2)); %b34sendif; %b34sendif; b34srun; == ==MARS_VAR2 Contrib, Forecasts and Surface Analysis /; /; Here contrib and surface analysis are hand programmed /; see mars_contb for easier setup /; /; runmars => run a "var" equation by equation using MARS /; val_cmd => run var equation by equation with mars_VAR will replicate /; what is being calculated with marspline!!!! Usually /; not needed /; runvar => run joint estimation of VAR model using MARS /; %b34slet runmars=1; %b34slet val_cmd=1; %b34slet runvar =1; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(dispmars :staging); call echooff; iholdout=20; m6=1; mm6=6; call print('********************************************************':); call print('*********************** OLS Base Case ******************':); call print('************* Equation by Equation Estimation **********':); call print('********************************************************':); call olsq(gasin gasin{m6 to mm6} gasout{1 to mm6} :print :holdout iholdout); call olsq(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :holdout iholdout); %b34sif(&runmars.ne.0)%then; call print(' ':); call print('********************************************************':); call print('************* Equation by Equation Estimation **********':); call print('********************************************************':); call marspline(gasin gasin{m6 to mm6} gasout{1 to mm6} :print :mi 2 :nk 20 :holdout iholdout); call marspline(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :mi 2 :nk 20 :holdout iholdout); %b34sif(&val_cmd.ne.0)%then; call print(' ':); call print('********************************************************':); call print('**** MARS_VAR for Equation by Equation Estimation ******':); call print('**** Validation of MARSPLINE vs MARS_VAR ******':); call print('********************************************************':); call mars_var(gasin gasin{m6 to mm6} gasout{1 to mm6} :print :mi 2 :nk 20 :holdout iholdout); call mars_var(gasout gasin{m6 to mm6} gasout{1 to mm6} :print :mi 2 :nk 20 :holdout iholdout); %b34sendif; %b34sendif; %b34sif(&runvar.ne.0)%then; gg=catcol(gasin,gasout); call print(' ':); call print('********************************************************':); call print('************* Joint Estimation of right hand side ****':); call print('************* Note a More Vectors (17 vs 14) needed ****':); call print('********************************************************':); call mars_var(gg gasin{m6 to mm6} gasout{1 to mm6} :yvarnam c8array(:'GASIN','GASOUT') :setsig 2.00 :print :mi 2 :nk 20 :holdout iholdout :savemodel :xx :savex :forecast %xfuture :contrib array(2,12: min(gasin) mean(gasin) mean(gasin) mean(gasin) mean(gasin) mean(gasin) mean(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) max(gasin) mean(gasin) mean(gasin) mean(gasin) mean(gasin) mean(gasin) mean(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) ) index(100) :surface array(2,12: mean(gasin) mean(gasin) min(gasin) mean(gasin) mean(gasin) mean(gasin) min(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasin) mean(gasin) max(gasin) mean(gasin) mean(gasin) mean(gasin) max(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) mean(gasout) ) index(100,100) ); call print(%xfuture,%fore); %marsss=%rss; %x_mars=%x; call graph(%xcrange(,1) vector(:%contrib(,1)) :plottype xyplot :xlabel 'gasin' :pgborder :nocontact :ylabelleft 'Contribution of lag gasin to gasin' :markpoint 1 1 3 14 :colors black bblue :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :file 'mars_cont1.wmf' :heading 'Leverage gasin from MARS_VAR'); call graph(%xcrange(,1) vector(:%contrib(,2)) :plottype xyplot :xlabel 'gasin' :pgborder :nocontact :ylabelleft 'Contribution of lag gasin to gasout' :markpoint 1 1 3 14 :colors black bblue :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :file 'mars_cont2.wmf' :heading 'Leverage gasout from MARS_VAR'); %x_mars=%x; x=%surf__1; /; :pgunits used to label x and y axis! call graph(x :plottype meshstepc :file 'surf_1.wmf' :rotation 20. :angle 20. :xlabel 'lag(gasin) ' :pgunits array(:min(gasin) min(gasout) max(gasin) max(gasout)) :ylabelleft 'lag(gasout) ' :zlabelleft 'gasin ' :grid :d3axis :d3border :heading 'MARS Model gasin = f(lag(gasin) and lag(gasout)'); x=%surf__2; /; :pgunits used to label x and y axis! call graph(x :plottype meshstepc :file 'surf_2.wmf' :rotation 20. :angle 20. :xlabel 'lag(gasin) ' :pgunits array(:min(gasin) min(gasout) max(gasin) max(gasout)) :ylabelleft 'lag(gasout) ' :zlabelleft 'gasout' :grid :d3axis :d3border :heading 'Mars Model gasout = f(lag(gasin) and lag(gasout)'); b34srun; == ==MASKADD Illustrates Mask Add b34sexec matrix; c1='a cdefg'; c2=' bcd fg'; newc=maskadd(c1,c2); call print(c1,c2,newc); call character(cc1,'abcd fghijklmnopqrst'); call character(cc2,'ab defghijklmnopqrst'); call print(cc1,cc2,maskadd(cc1,cc2)); newc=masksub(c1,c2); call print(c1,c2,newc); call print(cc1,cc2,masksub(cc1,cc2)); b34srun; == ==MASKSUB Illustrates Mask Subtract b34sexec matrix; c1='a cdefg'; c2=' bcd fg'; newc=maskadd(c1,c2); call print(c1,c2,newc); call character(cc1,'abcd fghijklmnopqrst'); call character(cc2,'ab defghijklmnopqrst'); call print(cc1,cc2,maskadd(cc1,cc2)); newc=masksub(c1,c2); call print(c1,c2,newc); call print(cc1,cc2,masksub(cc1,cc2)); b34srun; == ==MATH1 Illustrates matrix command math b34sexec matrix; * Math with matrix and vectors ; * For bigger problems, change n; n=3; right=integers(1,((n*n)-1))+10; call print('Right ',right); x=matrix(n,n:right,-7); x2=x*2.; v=vector(n:integers(1,n)); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)' ,x*2.) ; call print('Scaler times Matrix (3.*x)' ,3.*x) ; call print('Vector plus matrix (v+x)' ,v+x) ; call print('Matrix plus vector (x+v)' ,x+v) ; call print('Matrix plus matrix (x+x2)' ,x+x2) ; call print('Matrix plus scaler (x+2.)' ,x+2.) ; call print('Scaler plus matrix (3.+x)' ,3.+x) ; call print('Vector minus matrix (v-x)' ,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)' ,x-x2) ; call print('Matrix minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus matrix (3.-x)' ,3.-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=x*2.; call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*2.)' ,x*2.) ; call print('Scaler times Array(2) (3.*x)' ,3.*x) ; call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+2.)' ,x+2.) ; call print('Scaler plus Array(2) (3.+x)' ,3.+x) ; call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus Array(2) (3.-x)' ,3.-x) ; call print(' Complex Results ' '++++++++++++++++++++++++++++++++++++++++'); x=mfam(complex(x,x2)); v=vfam(complex(v,v+8.0)); x2=mfam(complex(x2)); call print('X, x2 v' ,x,x2,v) ; call print('Inverse of x (INV)' , (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)',x*complex(2.)) ; call print('Scaler times Matrix (3.*x)',complex(3.)*x) ; call print('Vector plus matrix (v+x)',v+x) ; call print('Matrix plus vector (x+v)',x+v) ; call print('Matrix plus matrix (x+x2)',x+x2) ; call print('Matrix plus scaler (x+2.)',x+complex(2.)) ; call print('Scaler plus matrix (3.+x)',complex(3.)+x) ; call print('Vector minus matrix (v-x)',,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)',x-x2) ; call print('Matrix minus scaler (x-2.)',x-complex(2.)) ; call print('Scaler minus matrix (3.-x)',complex(3.)-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=afam(x2); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)', (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*complex(2.))',x*complex(2.)); call print('Scaler times Array(2) (complex(3.)*x)',complex(3.)*x); call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+complex(2.))',x+complex(2.)); call print('Scaler plus Array(2) (complex(3.)+x)',complex(3.)+x); call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-complex(2.))',x-complex(2.)); call print('Scaler minus Array(2) (complex(3.)-x)',complex(3.)-x); * Matrix Power Calculations ; x=rn(matrix(3,3:)); call print(x,x*x,x**2.); e1=eig(x,c1); cc=c1(1,1); call print(cc,cc*complex(2.)); call print(c1); call print(c1**2.); call print(c1*c1); call print(c1**complex( 2.0)); call print(c1**complex( 2.2)); call print(c1**complex(-2.2)); * Array Tests ; x=afam(x); c1=afam(c1); call print(x,x*x,x**2.); cc=c1(1,1); call print(cc,cc*complex(2.)); call print(c1); call print(c1**complex(2.)); call print(c1*c1); * tests run with a defective matrix from Matlab ; defmat=matrix(3,3: 6., 12., 19. , -9.,-20.,-33., 4., 9., 15.); call print(defmat,defmat*defmat,defmat**2.); call print(complex(defmat)**complex( 2.)); call print(complex(defmat)**complex( 2.2)); call print(complex(defmat)**complex( -2.2)); call print(complex(defmat)**complex( 102.)); call print(complex(defmat)**complex( 102.2)); call print(complex(defmat)**complex(-102.2)); b34srun; == ==MATH2 Logic Math Examples b34sexec matrix; * Tests Logical math; x=2.0; y= x.eq.1.0; y2=x.eq.2.0; call print(x,y,y2); call names(all); a1=array(:0 1 1); a2=array(:0 1 2); test=a1.eq.a2; call print('Test will = 1 if a1 = a2'); call tabulate(a1 a2 test); a1=namelist(judy mary sue); a2=namelist(judy Diana sue); test=a1.eq.a2; call print('Test will = 1 if a1 = a2'); call tabulate(a1 a2 test); z=1.0; y3=1.0; isitone1=z.or.y3; isitzero=y2.and.y; isitone=z.and.y2; call print(isitone,isitone1,isitzero); * If this statemented is uncommented it will return an error; * since x ne 0 or 1; * bad=x.and.y; b34srun; == ==MATH3 Tests Logic Processing b34sexec matrix; x=array(:1,-2,3,-4,5,-6,7,-8,9,-10); y=array(:0,-2,1,-4,6,-6,2,-8,5,-10); z=array(:1, 2,3, 4,5, 6,7,9,90,-10); yhold=array(norows(x):); m99=yhold; call setcol(m99,1,-99.); xyz_and_=m99; xy_or_xz=m99; yhold=m99; where(x.ne.y)yhold=y; where(x.eq.y)q=y; x_eq_y=x.eq.y; xy_or_xz=x.eq.y.or.x.eq.z; xyz_and_=x.eq.y.and.x.eq.z; call tabulate(x,y,z,x_eq_y,xy_or_xz,xyz_and_); xyz_and_=m99; xy_or_xz=m99; where(x.eq.y.and.x.eq.z)xyz_and_=y; where(x.eq.y.or.x.eq.z)xy_or_xz=y; call print('We set yhold = -99 where x = y', 'We set yhold = y where x ne y', 'We set q = y where x = y', 'We set q = 0 where x ne y'); call tabulate(y,x,z,yhold,q,xyz_and_,xy_or_xz); x=array(:1 2 3 4 5 6 7 8 9 -10); y=array(:1 2 30 4 4 6 7 8 9 -10); x_gt_y=m99; x_ge_y=m99; x_eq_y=m99; x_lt_y=m99; x_le_y=m99; x_gt_y=x.gt.y; x_ge_y=x.ge.y; x_eq_y=x.eq.y; x_lt_y=x.lt.y; x_le_y=x.le.y; call tabulate(x,y,x_gt_y,x_ge_y,x_eq_y,x_lt_y,x_le_y); b34srun; == ==MATH4 Simple test cases showing variable storage /$ Job shows location of vector copies into existing /$ variable locations b34sexec matrix; x=dfloat(integers(20)); call print(x); call names(all); y=50.; x(3)=y; call names(all); call print(x); x(21)=y+10.; call names(all); call print(x); z=x; call names(all); x=x*2.; z=x; call names(all); call print(z); * show effect of integer placement; yi=50; x(3)=yi; call print('Note that array is all zero except location 3',x); b34srun; == ==MATH5 Array addressing Examples /$b34sexec options debugsubs(b34smat06,b34smat12b); b34srun; b34sexec matrix; nn=4; /$ itest1 and itest2 trap error conditions itest1=0; itest2=0; x=array(:1 2 3 4 5); call print(x); x(6)=99.; j=integers(5); call print(x); x(j)=5.; call print(x); x=rn(matrix(nn,nn:)); holdx=x; call print('x before copy ',x); x(2,)=1.0; call print('row scaler copy',x); x=holdx; call print('x before copy',x); x(2,)=vector(:integers(nn)); call print('row vector copy',x); x=holdx; call print('x before copy ',x); x(2,2)=99.; call print('x(2,2)=99.; copy',x); x=holdx; call print('x before copy ',x); x(,1)=99.; call print('col scaler copy',x); x=holdx; call print('x before copy'); x(,1)=vector(:integers(nn)); call print('col vector copy',x); x=rn(matrix(nn,nn:)); holdx=x; call print('x before structured copy',x); jj=integers(nn); x(2,jj)=88.; call print(x); x=holdx; x(jj,2)=77.; call print(x); jj=integers(2,nn); x(2,jj)=88.; call print('subset copy 2-4',x); x=holdx; x(jj,2)=77.; call print('subset copy 2-4',x); /$ Short case -- if run gets an error message if(itest1.eq.1)then; call print('Subset of y copied *************'); y=array(:11. 22. 33. .88888); ii=integers(2,4); x=array(:1 2 3 4 5 6 7); call print(x); x(ii)=y; call print('Subset of y copied',x,ii,y); endif; /$Long case -- if run gets an error message if(itest2.eq.1)then; call print('More than length of y copied ***************'); y=array(:11. 22. 33. .88888); ii=integers(2,10); x=array(:1 2 3 4 5 6 7); call print(x); x(ii)=y; call print('More than y copied',x,ii,y); endif; b34srun; == ==MATH6 Real*16 Complex*32 /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); do i=1,ncase; x=rn(x); r16x=r8tor16(x); c16x= complex(x); c32x=qcomplex(r16x); call print('In real*16 real*8 complex*32 complex*16',r16x,x,c32x,c16x); ix=inv(x); ir16x=inv(r16x); ic16x=inv(c16x); ic32x=inv(c32x); call print('Inverse real*16 real*8 complex*32 complex*16', ir16x,ix,ic32x,ic16x); call print('errors of inverse' x*ix,r16x*ir16x,c16x*ic16x,c32x*ic32x); /$ SM Problems x=rn(matrix(n,n:)); x=transpose(x)*x; r16x=r8tor16(x); call print(inv(x :smat)); call print(inv(r16x:smat)); cx=complex(x); cx32=c16toc32(cx); call print(inv(cx :smat)); call print(inv(cx32:smat)); call print((inv(cx) -inv(cx:smat))); call print((inv(cx32)-inv(cx32:smat))); /$ PD problems pdx=transpose(x)*x; pdxr16=transpose(r16x)*r16x; call print(inv(pdx), inv(pdxr16)); call print(inv(pdx:pdmat),inv(pdxr16:pdmat)); pdc16x=dconj(transpose(c16x))*c16x; pdc32x=dconj(transpose(c32x))*c32x; call print(inv(pdc16x), inv(pdc32x)); call print(inv(pdc16x:pdmat),inv(pdc32x:pdmat)); /$ Test inline inverse test1=kindas(r16x,1.0)/r16x; call print(test1,ir16x); test2=kindas(c16x,complex(1.0))/c16x; call print(test2,ic16x); enddo; b34srun; == ==MATH7 Illustrates Array/Matrix Expansion b34sexec matrix; x=vector(:1,2,3,4); xm1=rn(matrix(4,1:)); xm2=rn(matrix(4,1:)); do i=1,10; call print(x,xm1,xm2); nrow=norows(x) +1; ncol=nocols(xm1)+1; xm1(,ncol)=x; xm2=transpose(xm1); xm2(ncol,)=x; x(nrow)=dfloat(i); call print(x,xm1,xm2); enddo; call print('array tests'); x= array(:1,2,3,4); xm1=rn(array(4,1:)); xm2=rn(array(4,1:)); do i=1,10; call print(x,xm1,xm2); nrow=norows(x) +1; ncol=nocols(xm1)+1; xm1(,ncol)=x; xm2=transpose(xm1); xm2(ncol,)=x; x(nrow)=dfloat(i); call print(x,xm1,xm2); enddo; call print('x too big!!') x=vector(:1,2,3,4); xm1=rn(matrix(4,1:)); xm2=rn(matrix(4,1:)); do i=1,10; call print(x,xm1,xm2); nrow=norows(x) +1; ncol=nocols(xm1)+1; x(nrow)=dfloat(i); xm1(,ncol)=x; xm2=transpose(xm1); xm2(ncol,)=x; call print(x,xm1,xm2); enddo; call print('array tests'); x= array(:1,2,3,4); xm1=rn(array(4,1:)); xm2=rn(array(4,1:)); do i=1,10; call print(x,xm1,xm2); nrow=norows(x) +1; ncol=nocols(xm1)+1; x(nrow)=dfloat(i); xm1(,ncol)=x; xm2=transpose(xm1); xm2(ncol,)=x; call print(x,xm1,xm2); enddo; b34srun; == ==MATHR16C32 Math with Real*16 and Complex*32 b34sexec matrix showuse; do i=1,1; n=7; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(n:)); call print(v8,v8*v8,afam(v8)*afam(v8)); a8=afam(v8); a8_2=a8/kindas(a8,2.); call tabulate(a8,a8_2); two= 2.; four=4.; call print('Is this 6? ', r8tor16(two)+ r8tor16(four):); call print('Is this -2?',r8tor16(two)- r8tor16(four) :); call print('Is this 8? ',r8tor16(two)* r8tor16(four) :); call print('Is this .5?',r8tor16(two)/ r8tor16(four) :); call print('Is this 16?',r8tor16(two)**r8tor16(four) :); two =complex(two); four =complex(four); call print('Two and four',two,four); call names(all); call print(c16toc32(two)+ c16toc32(four)); call print(c16toc32(two)- c16toc32(four)); call print(c16toc32(two)* c16toc32(four)); call print(c16toc32(two)/ c16toc32(four)); call print(c16toc32(two)**c16toc32(four)); call print('Complex*16 math ok!!',two**four:); two= array(4:1 2 3 4); four=4.; call print(r8tor16(two)+ r8tor16(four)); call print(r8tor16(two)- r8tor16(four)); call print(r8tor16(two)* r8tor16(four)); call print(r8tor16(two)/ r8tor16(four)); call print(r8tor16(two)**r8tor16(four)); two =complex(two); four =complex(four); call print(c16toc32(two)+ c16toc32(four)); call print(c16toc32(two)- c16toc32(four)); call print(c16toc32(two)* c16toc32(four)); call print(c16toc32(two)/ c16toc32(four)); call print(c16toc32(two)**c16toc32(four)); call print('Complex*16 math ok!!',two**four); two= array(2:10 20); four=array(2:1 2); call print(r8tor16(two)+ r8tor16(four)); call print(r8tor16(two)- r8tor16(four)); call print(r8tor16(two)* r8tor16(four)); call print(r8tor16(two)/ r8tor16(four)); call print(r8tor16(two)**r8tor16(four)); two =complex(two); four =complex(four); call print(c16toc32(two)+ c16toc32(four)); call print(c16toc32(two)- c16toc32(four)); call print(c16toc32(two)* c16toc32(four)); call print(c16toc32(two)/ c16toc32(four)); call print(c16toc32(two)**c16toc32(four)); call print('Complex*16 math ok!! ',two**four); enddo; b34srun; == ==MATH16_32 Illustrates gain from real*16/Comples*32 b34sexec matrix; * Test case for Real Matrix from IMSL Math (10) pp 295-297; * eig => matlab notation; * eigenval => speakeasy notation; a=matrix(3,3:8.,-1.,-5.,-4., 4.,-2.,18.,-5.,-7.); call print('A Matrix',a); call print('eig(a)',eig(a)); e=eig(a,evec); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of General Martix A',sum(e), 'Trace of General Matrix A',trace(a), 'Product of the eigenvalues of Martix A',prod(e), 'Determinant of Matrix A',det(a) 'Test Factorization evec*diagmat(e)*inv(evec)' evec*diagmat(e)*inv(evec)); * real*16 case; r16a=r8tor16(a); call print('eig(r16a)',eig(r16a)); r16e=eig(r16a,r16evec); call print(r16e,r16a,r16evec); call print('Eigenvalues of r16a', r16e, 'Sum of the eigenvalues of General Martix A',sum(r16e), 'Trace of General Matrix A',trace(r16a), 'Product of the eigenvalues of Martix A',prod(r16e), 'Determinant of Matrix A',det(r16a) 'Test Factorization evec*diagmat(e)*inv(evec)' r16evec*diagmat(r16e)*inv(r16evec)); * Complex Case See IMSL Math (10) pp 302-304 ; r=matrix(4,4:5., 5.,-6.,-7., 3., 6.,-5.,-6., 2., 3.,-1.,-5., 1., 2.,-3.,0.0); i=matrix(4,4:9., 5.,-6.,-7., 3.,10.,-5.,-6., 2., 3., 3.,-5., 1., 2.,-3., 4.); ca=complex(r,i); call print('CA Complex Matrix',ca); call print('eig(ca)',eig(ca)); ce=eig(ca,cevec); call print('Eigenvectors of CA',cevec); call print('Eigenvalues of ca', ce, 'Sum of the eigenvalues of General Martix CA',sum(ce), 'Trace of General Matrix CA',trace(ca), 'Product of the eigenvalues of Martix CA',prod(ce), 'Determinant of Matrix CA',det(ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' cevec*diagmat(ce)*inv(cevec) ); * Complex*32 case; c32ca=c16toc32(ca); call print('CA Complex Matrix',c32ca); call print('eig(c32ca)',eig(c32ca)); c32ce=eig(c32ca,c32cevec); call print('Eigenvectors of c32CA',c32cevec); call print('Eigenvalues of c32ca', c32ce, 'Sum of the eigenvalues of General Martix CA',sum(c32ce), 'Trace of General Matrix CA',trace(c32ca), 'Product of the eigenvalues of Martix CA',prod(c32ce), 'Determinant of Matrix CA',det(c32ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' c32cevec*diagmat(c32ce)*inv(c32cevec) ); * Inversion tests ; n=6; x=rn(matrix(n,n:)); ix=inv(x); r16x=r8tor16(x); ir16x=inv(r16x); call print(x,ix,ir16x,x*ix,r16x*ir16x); b34srun; == ==MATH_POWER Matrix and Array Power Functions /; /; Matrix, array and Vector Power tests /; b34sexec matrix; aa=array(4:1 2 3 4); va=vfam(aa); aa16=r8tor16(aa); va16=r8tor16(va); caa=complex(aa); cva=complex(va); qcaa=qcomplex(aa16); qcva=qcomplex(va16); saa=sngl(aa); sva=vfam(saa); vpa_aa=vpa(aa); vpa_va=vpa(va); saa=sngl(aa); sva=vfam(saa); /; /; array and vector tests /; call print(saa, saa*saa, saa**sngl(2.)); call print(sva, sva*sva, sva**sngl(2.)); call print(aa16, aa16*aa16, aa16**r8tor16(2.)); call print(va16, va16*va16, va16**r8tor16(2.)); call print(caa, caa*caa, caa**complex(2.)); call print(cva, cva*cva, cva**complex(2.)); call print(qcaa, qcaa*qcaa, qcaa**qcomplex(r8tor16(2.)), qcva, qcva*qcva, qcva**qcomplex(r8tor16(2.))); call print(vpa_aa ,vpa_aa *vpa_aa, vpa_aa**vpa(2.), vpa_va ,vpa_va *vpa_va, vpa_va**vpa(2.)); call print('2 D Tests ++++++++++++++':); aa=array(3,3:1. 2. 30. 4. 5. 60. 7. 8. 90.); va=vfam(aa); aa16=r8tor16(aa); va16=r8tor16(va); caa=complex(aa); cva=complex(va); qcaa=qcomplex(aa16); qcva=qcomplex(va16); saa=sngl(aa); sva=vfam(saa); vpa_aa=vpa(aa); vpa_va=vpa(va); saa=sngl(aa); sva=vfam(saa); /; /; array and matrix /; call print(saa, saa*saa , saa**sngl(2.)); call print(sva, sva*sva , sva**sngl(2.)); call print( aa, aa* aa , aa**2.); call print( va, va* va , va**2.); /; /; This calculation will draw an error /; /; call print( va**2.5); /; call print(aa16, aa16*aa16, aa16**r8tor16(2.)); call print(va16, va16*va16, va16**r8tor16(2.)); call print(caa ,caa *caa, caa**complex(2.)); call print(cva ,cva *cva, cva**complex(2.)); call print(cva ,cva *cva*cva cva**complex(3.)); call print(qcaa, qcaa*qcaa, qcaa**qcomplex(r8tor16(2.))); call print(qcva, qcva*qcva, qcva**qcomplex(r8tor16(2.))); call print(vpa_aa ,vpa_aa *vpa_aa, vpa_aa**vpa(2.)); call print(vpa_aa ,vpa_aa *vpa_aa*vpa_aa, vpa_aa**vpa(3.)); call print(vpa_va ,vpa_va *vpa_va, vpa_va**vpa(2.)); call print(vpa_va ,vpa_va *vpa_va*vpa_va, vpa_va**vpa(3.)); /; /; this is an error since no eig capabilkity for vpa /; call print(vpa_va ,vpa_va *vpa_va*vpa_va, vpa_va**vpa(3.1)); /; /; Non integer power for complex*16 & complex*32 /; call print(eig(cva),eig(qcva)); call print('Non integer power complex*16', cva**complex(3.5)); call print('Non integer power complex*32',qcva**qcomplex(r8tor16(3.5))); /; /; Slow way to get an inverse /; * Test case for Real Matrix from IMSL Math (10) pp 295-297; * using eig( ) analysis to get inverse; x=complex(matrix(3,3:8.,-1.,-5.,-4., 4.,-2.,18.,-5.,-7.)); call print('X Matrix',x); call print(inv(x),x**complex(-1.)); call print(inv(c16toc32(x)),c16toc32(x)**c16toc32(complex(-1.))); b34srun; == ==MATRIX MATRIX function => input a matrix b34sexec matrix$ x=matrix(3,3:); call print(x); x1=matrix(3,3:1 2 3 4 5 6 7 8 9); tx=matrix(3,3:x1); call print(x1,tx); v=vector(4:1 2 3 4); xx=matrix(2,2:v); xx2=matrix(2,2:v+2.); cx=complex(xx,xx2); call print(xx); call print(cx); * Advanced tricks ; x=matrix(3,3:1 2 3 4 5 6 7 8 9); v=vector(:1 2 3 4 5 6 7 8 9); xx=matrix(3,3:v); xx2=matrix(9,1:xx); xx3=matrix(3,3:xx2); call print(x,v,xx,xx2,xx3); b34srun; == ==MAX2_C Maximize using User supplied Gradiant b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem uses user gradiant - goes fast !! ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; program der; g(1)= (400.0*(x2-x1*x1)*x1) + (2.*(1.0-x1)); g(2)= -200.0*(x2-x1*x1); return; end; call print(test,der); rvec=array(2:-1.2 1.0); call echooff; call maxf2(func g :name test der :parms x1 x2 :ivalue rvec :print); b34srun; == ==MAXF1_2A Uses OLS to validate solution found b34sexec options ginclude('gas.b34'); b34srun; /$ Using minimum to solve OLS problem /$ OLSQ used as a test b34sexec matrix; * This test run tests both commands maxf1 and maxf2 ; call loaddata; program test; func=(-1.0)*sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; call olsq(gasout gasin :print); rvec=array(2:-1.2, 1.0); call echooff; call maxf1(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); b34srun; == ==MAXF1_2B Generate Data for Maximize - 2 variables models /$ Using minimum to solve OLS problem /$ OLSQ used as a test /$ Simple Model used /$ Looking at pattern of estimated SE from MAXF2 b34sexec matrix; program test; func=(-1.0)*sumsq(y -(a+b*x)); call outstring(3, 3,'Function to be minimized'); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; n=1000; x=rn(array(n:)); y = 10. + 55. * x + 2.0*rn(x); call olsq(y x :print); rvec=array(2:-1.2, 1.0); call echooff; call maxf1(func :name test :parms a b :ivalue rvec :print); call print(1./mfam(%hessian)); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); call print(1./mfam(%hessian)); b34srun; == ==MAXF1_2C Using maximize to solve OLS 3 variable problem /$ Using minimum to solve OLS 3 variable problem /$ OLSQ used as a test /$ Simple Model used /$ Looking at pattern of estimated SE from MAXF2 b34sexec matrix; program test; func=(-1.0)*sumsq(y -(a+b1*x1+b2*x2)); call outstring(3, 3,'Function to be minimized'); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(36,5, b2); return; end; n=10000; x1=rn(array(n:)); x2=rn(array(n:)); y = 10. + 10.*x1 + 5.*x2 + 20.*rn(x1); call olsq(y x1 x2:print); rvec=array(3:-1.2, 1.0, 1.0); call echooff; call maxf1(func :name test :parms a b1 b2 :ivalue rvec :print); call print(1./mfam(%hessian)); rvec=array(3:-1.2, 1.0, 1.0); call maxf2(func :name test :parms a b1 b2 :ivalue rvec :print); call print(1./mfam(%hessian)); b34srun; == ==MAXF1_A Using MAXF1 to minimize a model /$ MAXF1 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF1 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function '); call outdouble(36,3 func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); call echooff; call maxf1(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; == ==MAXF1_B Minimization using grid search maxf1 tested /$ MAXF1 is used to minimize a function /$ NLSTART is used to investigate how answer changes /$ Given different starting values /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF1 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; call print(test); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); result=array(k:); ak =array(k:); bk =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf1(func :name test :parms x1 x2 :ivalue rvec :print); result(i)=%func; enddo; call tabulate(result,ak,bk); call graph(result); b34srun; == ==MAXF2_A Minimize function /$ MAXF2 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); call echooff; call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; == ==MAXF2_B Minimize function using range of starting values /$ MAXF2 is used to minimize a function /$ NLSTART is used to investigate how answer changes /$ Given different starting values /$ Answers should be x1=.9999 and x2=.9999 /$ b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; call print(test); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); result=array(k:); ak =array(k:); bk =array(k:); coef1 =array(k:); coef2 =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); result(i)=%func; coef1(i)=%coef(1); coef2(i)=%coef(2); enddo; call tabulate(result,ak,bk,coef1,coef2); call graph(result); call graph(coef1); call graph(coef2); b34srun; == ==MAXF2_D Min. func. using range of start. val. & user gradiant b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Since user gradiant supplied speed will be fast ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; program der; g(1)= (400.0*(x2-x1*x1)*x1) + (2.*(1.0-x1)); g(2)= -200.0*(x2-x1*x1); return; end; call print(test,der); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); result=array(k:); ak =array(k:); bk =array(k:); coef1 =array(k:); coef2 =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf2(func g :name test der :parms x1 x2 :ivalue rvec :print); result(i)=%func; coef1(i)=%coef(1); coef2(i)=%coef(2); enddo; call tabulate(result,ak,bk,coef1,coef2); call graph(result); call graph(coef1); call graph(coef2); b34srun; == ==MAXF2_E Minimize a two variable exponential Function /$ /$ MAXF2 is used to minimize an exponential function /$ b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.5 and x2=1.0 ; * Problem from Matlib Optimization toolbox page 1-6 ; * Problem used as a test case in MATLAB fmins function ; program test; func=-1.0*dexp(x1)*((4.*x1*x1)+(2.*x2*x2)+(4.*x1*x2)+(2.*x2)+1.0); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1., 1.0); call echooff; call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; == ==MAXF3_2A Uses OLS to validate solution found b34sexec options ginclude('gas.b34'); b34srun; /$ Using minimum to solve OLS problem /$ OLSQ used as a test b34sexec matrix; * This test run tests both commands maxf1 and maxf2 and maxf3; call loaddata; program test; func=(-1.0)*sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; call echooff; call olsq(gasout gasin :print); rvec=array(2:-1.2, 1.0); call maxf1(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf3(func :name test :parms a b :ivalue rvec :maxit 300 :print); b34srun; == ==MAXF3_2B Generate Data for Maximize /$ Using minimum to solve OLS problem /$ OLSQ used as a test /$ Simple Model used b34sexec matrix; program test; func=(-1.0)*sumsq(y -(a+b*x)); call outstring(3, 3,'Function to be minimized'); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; n=1000; x=rn(array(n:)); y = 10. + 55. * x + rn(x); call olsq(y x :print); rvec=array(2:-1.2, 1.0); call echooff; call maxf1(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf3(func :name test :parms a b :ivalue rvec :print); b34srun; == ==MAXF3_a Using MAXF3 to minimize a model /$ MAXF1 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF3 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function '); call outdouble(36,3 func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); call echooff; call maxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 400 :print); b34srun; == ==MAXF3_b Mimimization using grid search maxf3 tested /$ MAXF3 is used to minimize a function /$ NLSTART is used to investigate how answer changes /$ Given different starting values /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF3 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; call print(test); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); coef=array(k,2:); result=array(k:); ak =array(k:); bk =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 400 :print); result(i)=%func; coef(i,)=%coef; enddo; call tabulate(result,ak,bk); call print('Answers from various starting values',coef); call graph(result :heading 'Function value found'); b34srun; == ==MAXFTEST Tests OLS with MAXF1,2 /$ /$ OLS two ways /$ b34sexec matrix; nob=100000; y=array(nob:); x1=rn(array(nob:)); x2=rn(array(nob:)); y=1.+10.*x1+8.5*x2 + 10.*rn(x1); call olsq(y x1,x2 :print); program test; func=(-1.0)*sumsq(y -(a+b1*x1+b2*x2)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a ); call outdouble(26,4, b1); call outdouble(56,4, b2); return; end; call echooff; rvec=array(3:1. 1. 1.); call maxf1(func :name test :parms a b1 b2 :ivalue rvec :print); rvec=array(3:1. 1. 1.); call maxf2(func :name test :parms a b1 b2 :ivalue rvec :print); b34srun; == ==MAXFTEST_2 Illustrates a Break Point Test Case /; /; As setup runs MARS whicdh may notm be licensed. /; b34sexec options ginclude('b34sdata.mac') member(marsbrk); b34srun; /$ /$ Using minimum to solve OLS problem where there is a break at 5 /$ OLSQ used as a test /$ /$ Simplex is able to find points. When we use maxf2 to refine /$ /$ Model is y = 0.0 + 10.* x if X GT 5 /$ y = 0.0 + 5.* x if X LT 5 /$ /$ Data From Greg Sterijevski Break at 5.0 /$ MARS smooths the kink ************************* b34sexec MARS MI = 2 NK=5 ; model Y = X$ b34seend$ b34sexec reg; model y=x1 x2; b34srun; b34sexec sort; by x; b34srun; /$ /$ List will show that there is no x = 5.0 point !!!! /$ /$ b34sexec list; var x y ; b34srun; /$ b34sexec matrix; * This test run tests both commands maxf1 ,maxf2 and maxf3 ; * maxf3 is needed !!!!!!!!!!!!! ; call loaddata; program test; mask1 = x .gt. break ; mask2 = x .le. break ; func=(-1.0)*sumsq(y -(a+(b1*x*mask1)+(b2*x*mask2))); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4 5, b2); call outdouble(36,4, break); return; end; call print(test); call olsq(y x1 x2 :print); call olsq(y x :print); rvec=array(4: %coef(2),%coef(1),%coef(1),2. ); call print(rvec); call echooff; call maxf1(func :name test :parms a b1 b2 break :ivalue rvec :print); call maxf2(func :name test :parms a b1 b2 break :ivalue rvec :print); * Simplex then use these as starting values ; call maxf3(func :name test :parms a b1 b2 break :ivalue rvec :maxit 1000 :print); rvec=array(4: %coef(1),%coef(2),%coef(3), %coef(4)); call maxf2(func :name test :parms a b1 b2 break :ivalue rvec :print); call tabulate(x mask1,mask2); b34srun; == ==MAXF_4 Simple Function Maximixe from Greene Page 201 b34sexec matrix; * This test run tests both commands maxf1, maxf2 and maxf3 ; * See Greene 4ed page 201 ; * Greene page 202 suggests answer is 2.23607 ; program test; func=dlog(theta)-.1*theta*theta; call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, theta); return; end; call echooff; rvec=array(:1.); call maxf1(func :name test :parms theta :ivalue rvec :print); rvec=array(:1.0); call maxf2(func :name test :parms theta :ivalue rvec :print); call maxf3(func :name test :parms theta :ivalue rvec :print); b34srun; == ==MCOV %b34slet runrats=1; b34sexec options ginclude('gas.b34'); b34srun; /; Illustrate mcov function b34sexec matrix; call load(mcovf :staging); call loaddata; call echooff; call olsq(gasout gasin :savex); call print('Built in code ',mcov( %x,0.0,0,0.0,0)); call print('Function code ',mcovf(%x,0.0,0,0.0,0)); call print('test1a - usual case no lag',mcov(%x,%res,0,0.0,0)); call print('test1b - usual case v ',mcov(%x,%res,0,0.0,1)); call print('test2a - no residual ',mcov(%x,0.0 ,0,0.0,0)); call print('test2b - no residual lag=3',mcov(%x,0.0 ,3,0.0,0)); call print('test3 - lag = 1 ',mcov(%x,%res,1,0.0,0)); call print('test4 - lag = 3 ',mcov(%x,%res,3,0.0,0)); call print('test5 - lag = 2 damp=1. ',mcov(%x,%res,2,1.0,0)); /; Optionally save workspace to Speakeasy /; case1a=mcov(%x,%res,0,0.0,0); /; case1b=mcov(%x,%res,0,0.0,1); /; case2a=mcov(%x,0.0 ,0 0.0,0) /; case2b=mcov(%x,0.0 ,3 0.0,0) /; case3 =mcov%x,0.0 ,0,0.0,0); /; case4 =mcov(%x,%res,1,0.0,0); /; case5 =mcov(%x,%res,2,1.0,0); /; call checkpoint; b34srun; %b34sif(&runrats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * linreg gasout / resids # gasin constant display 'Default case' mcov(damp=0.0,lags=0,print) * * resids # gasin constant display 'Nosquare Case' mcov(damp=1.0,print,nosquare) * * resids # constant gasin display 'Case without residuals lag=0' mcov(damp=0.0,lags=0,print) * * # constant gasin display 'Case without residuals but lag=3' mcov(damp=0.0,lags=3,print) * * # constant gasin display 'Case with residuals lag=1' mcov(damp=0.0,lags=1,print) * * resids # constant gasin display 'Case with residuals lag=3' mcov(damp=0.0,lags=3,print) * * resids # constant gasin display 'Case with residuals lag=2 Damp=1.' mcov(damp=1.0,lags=2,print) * * resids # constant gasin b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==MCLEODLI Tests McLeod-Li Test b34sexec options ginclude('gas.b34'); b34srun; /; /; See McLeod-Li 'Diagnostic Checking of ARMA Time Series Models /; Using Square Residual Autocorrelations' /; McLeod, A. & Li, Journal of Time Series /; 4,:3:24 1983 b34sexec matrix; call loaddata; call load(mcleodli); call mcleodli(gasin, 12,12,1); call mcleodli(gasout,12,12,1); call print(%mltest); call tabulate(%res,%ressq2,%acf1); /; Random number tests x=rn(array(10000:)); call mcleodli(x, 12,12,1); call print(%mltest); call mcleodli(x, 100,100,1); call print(%mltest); b34srun; == ==MEAN MEAN function => average of an object b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; mgasin=mean(gasin); mgasout=mean(gasout); call print('Gasin Mean',mgasin); call print('Gasout Mean',mgasout); vgasin=variance(gasin); vgasout=variance(gasout); call print('Gasin Variance',vgasin); call print('Gasout Variance',vgasout); r4gasin =sngl(gasin); r16gasin =r8tor16(gasin); vpagasin=vpa(gasin); call print(mean(r4gasin),mean(gasin),mean(r16gasin),mean(vpagasin)); call print(variance(r4gasin),variance(gasin),variance(r16gasin), variance(vpagasin)); b34srun$ == ==MEDIAN Median Function for real*8 Data b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call describe(gasout :print); mm1=mean(gasout); mm2=median(gasout); q1_ =q1(gasout); q3_ =q3(gasout); call print('Mean ',mm1:); call print('Median ',mm2:); call print('Q1 ',q1_:); call print('Q3 ',q3_:); b34srun; == ==MELD Melds Vectors b34sexec matrix; * Illustrates Two cases; i=array(:1. 2. 3.); j=array(:4.,5.,6.); k=array(:7.,8.,9.); call tabulate(i,j,k); call meld(i,j,k); f=i**2. + j**2. + k**2.; call tabulate(i,j,k,f); i=array(:1. 2. 3. 4.); j=array(:5.,6.,7.,8.); k=array(:9.,10.,11.,12.); call tabulate(i,j,k); call meld(i,j,k); f=i**2. + j**2. + k**2.; call tabulate(i,j,k,f); i=array(:1. 2.); j=array(:1. 2. 3.); k=array(:1. 2. 3. 4. 5.); call meld(i,j,k); f=i**2. + j**2. + k**2.; call tabulate(i,j,k,f); i=array(:1. 2.); j=array(:1. 2. 3.); call meld(i,j); f2=i**2. + j**2.; call graph(i,j,f2:plottype contour3 :d3axis :heading 'f(i**2. + j**2.)':d3border); a1=-.5; a2= .5; b1= .6; b2= 1.8; * Four views of the Banana ; do i=1,4; x=grid(a1,a2,.125); y=grid(b1,b2,.125); call meld(x,y); z=100.*(y-x*x)**2. + (1.-x)**2.; call graph(x,y,z:plottype contour3 :d3border :d3axis :heading 'Rosenbrock Banana'); call graph(x,y,z:plottype contourc :d3border :d3axis :heading 'Rosenbrock Banana'); a1=a1-1.; a2=a2+1.; b1=b1-1.; b2=b2+1.; enddo; b34srun; == ==MEMORY Shows speed and Memory Savings /; b34sexec options debugsubs(b34smat01a,compress); b34srun; /$ show memory usage /$ Job # 1 is done for speed and memory savings. X is built /$ outside the loop. /$ Job # 2 requires a copy be made and the variable x /$ copied at each step. Holes placed in named storage /; Job # 1 only moves the new data into the array that is already /$ built. Job # 2 could be compressed if /$ desired by command call compress; /$ /; /; Job # 3 Does compression inside the do loop. b34sexec matrix; call echooff; n=100; x=array(n:); call print('Allocation before':); call names(all); do i=1,n; x(i)=dfloat(i); enddo; call names(all); b34srun; /; Job 2 b34sexec matrix; call echooff; n=100; call print('Allocation as loop runs':); call names(all); do i=1,n; x(i)=dfloat(i); enddo; call print('Named Storage before final Compress':); call names(all); call compress; call print('Names Storage after final Compress':); call names(all); b34srun; /; Job 3 b34sexec matrix; call echooff; n=100; call print('Allocation as loop runs but compress':); call names(all); do i=1,n; x(i)=dfloat(i); call compress; enddo; call names(all); b34srun; == ==MENU User Menus including Message b34sexec matrix; i1=1; call menu(i1 :menutype menutwo :text 'stop' :text 'go' :prompt 'Continue with graph =>' ); call print('Graph Control',i1:); call outstring(3,,5,'menutwo'); call outinteger(12,5,i1); i2=2; call menu(i2 :menutype menuhoriz :text 'file' :text 'save' :text 'stop' :heading 'Simulated message for menu horiz' ); call print('Process Control',i2:); call outstring(3, 7,'menuvert'); call outinteger(12,7,i2); i3=3; call menu(i3 :menutype menuvert :text 'Use raw data ' :text 'Use (1-B)*X ' :text 'Use (1-B)**2. * X' :heading 'ACF Control' ); call print('ACF Control i was ',i3); call outstring( 3,9,'menuvert'); call outinteger(12,9,i3); i=100; call menu(i :menutype inputint :prompt '# of cases =>' ); call print('Input integer was ',i:); call outstring(3, 11,'Integer*4'); call outinteger(12,11,i); r8=.01; call menu(r8 :menutype inputreal8 :prompt 'Tolerance =>' ); call print('Input real*8 ',r8:); call outstring(3,,13,'Real *8'); call outdouble(12,13,r8); call menu(cc :menutype inputtext :prompt 'Save file name.=>' ); call print('File input found was ',cc); call outstring(3, 15,'File =>'); call outstring(12,15,cc); call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call outinteger(3,17,jj); b34srun; == ==MESSAGE Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE b34sexec matrix; x=matrix(3,3:11 22 33 55 66 77 88 99 00); v=vector(3:1 2 3); call print(x,v); inv=(1./x); call print(inv); test=x*inv; call print(test); vx=v*x; call print(vx); xx=x*x; call print(xx); xv=x*v; call print(xv); call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); call outstring(3,3,'This is jj'); call outinteger(30,3,jj); call cls(4); call outstring(3,4,'This is 5'); call outinteger(30,4,5 ); call cls(5); call outstring(3,5,'This is 88.88!!'); call outdouble(40,5,88.8); call cls(6); call outstring(3,6,'We have paused!! Now hit enter.'); /$ This is a pause call stop(pause); b34srun; == ==MFAM MFAM function => Create a matrix from a 2D array b34sexec matrix$ x=array(3,3:); x=rn(x); call print(x); mx=mfam(x); call print(mx); b34srun; == ==MINIMAX Estimate Minimax with MAXF2 b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call olsq(gasout gasin :l1 :minimax :print); /$ This code gets SE for Minimax. Uses MAXF2 call load(minimax); call print(minimax); * See if can get minimax ; iprint=1; y=gasout; x=matrix(norows(gasin),2:); x(,1)=1.0; x(,2)=vfam(gasin); call minimax; call print('Sum absolute errors ',sumabs:); call print('Max absolute error ',maxerror:); b34srun; == ==MISSING1 Missing values b34sexec matrix; x=0.0; xmiss=missing(); call print(x,xmiss); y=grid(1.,20.,1.); oldy=y; do i=1,norows(y); if(dmod(y(i),2.).eq.0.0)y(i)=missing(); enddo; test=ismissing(y); call tabulate(oldy,y,test); b34srun; == ==MISSING2 Tests on Missing values b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; laggas=lag(gasout,1); test=1.0+laggas; call names; call tabulate(laggas,test); b34srun; b34sexec matrix; * Illustrates missing data calculations; x=rn(array(10:)); lagx=lag(x,1); y=x+(10.*lagx); goody=goodrow(y); test1=dsqrt(dabs(y)); test2=dlog10(dabs(y)); test3=dlog(dabs(y)); call tabulate(x,lagx,y,goody,test1,test2,test3); b34srun; == ==MISSPLOT Plot of Missing Data b34sexec matrix; call load(missplot); /; 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 /; ********************************************************** y=rn(array(20:)); call character(title,'Test missplot Plot'); y(3)=missing(); points=0; dots=0; noline=0; call missplot(y,points,dots,noline,title); call missplot(y,1 ,dots,noline,title); call missplot(y,points,1 ,noline,title); call missplot(y,1 ,1 ,0 ,title); call missplot(y,1 ,dots,1 ,title); b34srun; == ==MIXEDEST Mixed Estimation b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call echooff; call load(mixedest); call print(' ':); call print('This will replicate OLS Theil (1971,116) Textile Case.':); call print('------------------------------------------------------':); call olsq(log10ct log10rpt log10ri :print :savex); call print(' ':); call print('This will replicate Mixed Theil (1971,350) Textile Case.':); call print('--------------------------------------------------------':); 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); call print(' ':); call print('Assume Near Certainly of Prior Coefficients.':); call print('Prior Drives Mixed results towards Prior Values.':); call print('Compatibility Measure highly significant.':); call print('-----------------------------------------':); prior=vector(%k-1:-.7,1.); r=catcol(vector(%k-1:),diagmat(vector(%k-1:)+1.)); v=matrix(%k-1,%k-1:.0002, .0, .0,.0002); iprint=1; call mixedest(%y,%x,%coef,%se,%names,%lag,%rss,%nob, %k,r,prior,v,mixed_b,mixed_se,compat,compats,iprint); call print(' ':); call print('Prior not compatible with the OLS Coefficients.':); call print('Compatibility Measure highly significant.':); call print('-----------------------------------------':); prior=vector(%k-1:-7.,1.); r=catcol(vector(%k-1:),diagmat(vector(%k-1:)+1.)); v=matrix(%k-1,%k-1:.0225, .0, .0,.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; == ==MIXEDEST2 Arbitrary Mixed VAR Models /; Some Mixed estimation VAR tests. Arbitrate models estimated %b34slet runrats=1; b34sexec options ginclude('gas.b34'); b34srun; /$ Model run with b34s ROBUST command as a test b34sexec robust; model gasout gasin{1 to 6} gasout{1 to 6}; b34srun; b34sexec matrix; call loaddata; call echooff; call load(mixedest); nn=6; call olsq(gasout gasin{1 to nn} gasout{1 to nn} :print :savex); damp=1.; conf=.01; call print(' ':); call print('We are attempting to dampen the estimated values':); call print('------------------------------------------------':); call print('Assumed Damp ',damp:); call print('Assumed Confidence ',conf:); call print('------------------------------------------------':); call print('Model assumes no confidence in our prior':); prior=vector(%k-1:%coef(integers(1,%k-1)))/damp; r=catcol(vector(%k-1:),diagmat(vector(%k-1:)+1.)); vv=vfam(afam(%se(integers(1,%k-1)))**2.); v=diagmat((1./conf)*vv); iprint=1; call mixedest(%y,%x,%coef,%se,%names,%lag,%rss,%nob, %k,r,prior,v,mixed_b,mixed_se,compat,compats,iprint); damp=10.; conf=10.; call print(' ':); call print('We are attempting to dampen the estimated values':); call print('------------------------------------------------':); call print('Assumed Damp ',damp:); call print('Assumed Confidence ',conf:); call print('------------------------------------------------':); call print('Model assumes confidence in our prior':); prior=vector(%k-1:%coef(integers(1,%k-1)))/damp; r=catcol(vector(%k-1:),diagmat(vector(%k-1:)+1.)); vv=vfam(afam(%se(integers(1,%k-1)))**2.); v=diagmat((1./conf)*vv); iprint=1; call mixedest(%y,%x,%coef,%se,%names,%lag,%rss,%nob, %k,r,prior,v,mixed_b,mixed_se,compat,compats,iprint); b34srun; %b34sif(@runrats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * linreg gasout # constant gasin{1 to 6} gasout{1 to 6} system(model=gas) variables gasin gasout lags 1 to 6 det constant specify(type=symmetric,tightness=.15) .5 end(system) estimate(print) * * b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==MLSUM MLSUM function => sum log of elements b34sexec matrix; * mlsum useful in ML estimation ; * Can also be used to trap bad dlog values ; a=array(5:1 2 3 4 5); s=sum(dlog(a)); call print('Sum of log of 1 2 3 4 5',s,'MLSUM',mlsum(a)); a(2)=-10.; s2=mlsum(a,n); call print('Sum of bad data ',s2,' # bad cases ',n); s2=mlsum(a,n,0.0); call print('Sum of bad data using zero ',s2,' # bad cases ',n); * log 10 cases ; a=array(5:1 2 3 4 5); s=sum(dlog10(a)); call print('Sum of log10 of 1 2 3 4 5',s,'MLSUM',mlsum(a :dlog10)); a(2)=-10.; s2=mlsum(a,n:dlog10); call print('Sum of bad data ',s2,' # bad cases ',n); s2=mlsum(a,n,0.0:dlog10); call print('Sum of bad data using zero ',s2,' # bad cases ',n); * dexp cases ; a=array(5:1 2 3 4 5); s=sum(dexp(a)); call print('Sum of log of 1 2 3 4 5',s,'MLSUM',mlsum(a :dexp)); a(2)=800d+00; s2=mlsum(a,n :dexp); call print('Sum of bad data ',s2,' # bad cases ',n); s2=mlsum(a,n,0.0:dexp); call print('Sum of bad data using zero ',s2,' # bad cases ',n); b34srun$ == ==MOVEAVE Tests Moving average moving variance b34sexec matrix; call echooff; call load(moveave); call load(movevar); n=20; a=array(n:integers(n)); call print('Mean of a',mean(a)); call moveave(a,norows(a),test); call print('Test of MA where use whole period',test); call moveave(a,2,test2); call moveave(a,3,test3); call print('Two & Three period Moving average'); call tabulate(a,test2,test3); call print(a); call print('Variance of a',variance(a)); call movevar(a,norows(a),test); call print('Test of MVAR where use whole period',test); call movevar(a,4,test4); call movevar(a,5,test5); call print('4 & 5 period Moving Variance'); call tabulate(a,test4,test4); b34srun; == ==MOVEBJ Moving Forecasting Example b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(movebj); call print(movebj); call echooff; nout=1; iseas=0; ibegin=200; iprint=0; rdif=0; sdif=0; iwindow=0; call movebj(gasout,iseas,ibegin,actual,fore,obs,nout,iprint,rdif,sdif, iwindow); iwindow=50; call movebj(gasout,iseas,ibegin,actual,fore2,obs,nout,iprint,rdif,sdif, iwindow); call tabulate(obs,actual,fore,fore2); obs=dfloat(obs); call graph(obs fore fore2 actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast - fore2 => moving window'); nout=3; iwindow=0; call movebj(gasout,iseas,ibegin,actual,fore,obs,nout,iprint,rdif,sdif, iwindow); call tabulate(obs,actual,fore,fore2); iwindow=50; call movebj(gasout,iseas,ibegin,actual,fore2,obs,nout,iprint,rdif,sdif, iwindow); call tabulate(obs,actual,fore,fore2); obs=dfloat(obs); call graph(obs fore fore2 actual :nolabel :nocontact :plottype xyplot :heading '3 step ahead moving forecast - fore2 => moving window'); b34srun; == ==MOVECOR Tests Moving Correlation b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(movecorr); call echooff; n=60; call movecorr(gasin,gasout,n,cvec,0); call print(cvec); call graph(cvec(,1)); call movecorr(gasin,gasout,n,cvec,10); call print(cvec); call echoon; b34srun; == ==MOVEH82 Tests moving Hinich 82 test b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call load(moveh82); n=200; call moveh82(gasout,n,g1,l1,1); call tabulate(g1,l1); call graph(g1,l1); call echoon; b34srun; == ==MOVEH96 Tests Moving Hinich 96 test b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(moveh96); call echooff; call olsq(gasout gasout{1 to 12}); call graph(gasout); call graph(%res); n=200; call moveh96(%res,n,0.0,v,h); call tabulate(v,h); call graph(v,h); call echoon; b34srun; == ==MOVELEFT Tests moveleft / moveright b34sexec matrix; call character(cc2,'abcdefghijklmnop'); test='12345678'; call print(test,'right 4',moveright(test,4),'left 3',moveleft(test,3)); do i=1,10; newcc2=moveleft(cc2,i); call print('Moveleft',cc2,i,newcc2); enddo; do i=1,10; newcc2=moveright(cc2,i); call print('Moveright',cc2,i,newcc2); enddo; b34srun; == ==MOVEOLS Tests Moving OLS b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(moveols); call echooff; n=60; call moveols(gasout,gasin,n,rss,rsq,resvar,6,1); call tabulate(rss,rsq,resvar); call graph(rss :heading 'Moving rss for gasout'); call graph(rsq :heading 'Moving R**2 for gasout'); call graph(resvar :heading 'Moving resvar for gasout'); call echoon; b34srun; == ==MSMOOTH Moving SMOOTH calls for forecasts b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(msmooth); call echooff; nout=1; iseas=0; ibegin=250; iprint=0; rdif=0; sdif=0; iwindow=0; alpha=0.0; beta=0.0; nma=4; call tabulate(gasout); call msmooth(gasout,'nce',ibegin,actual,fore,obs, nout,iprint,iwindow,alpha,beta,nma); call tabulate(obs,actual,fore); iwindow=50; call msmooth(gasout,'nce',ibegin,actual,fore2,obs,nout,iprint,iwindow, alpha,beta,nma); call tabulate(obs,actual,fore,fore2); obs=dfloat(obs); call graph(obs fore fore2 actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast - fore2 nce=> moving window'); call msmooth(gasout,'ncept',ibegin,actual,fore,obs,nout,iprint,iwindow, alpha,beta,nma); obs=dfloat(obs); call graph(obs fore actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast ncept '); call msmooth(gasout,'mave',ibegin,actual,fore,obs,nout,iprint,iwindow, alpha,beta,nma); obs=dfloat(obs); call graph(obs fore actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast mave '); call msmooth(gasout,'es',ibegin,actual,fore,obs,nout,iprint,iwindow, alpha,beta,nma); obs=dfloat(obs); call graph(obs fore actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast es '); call msmooth(gasout,'des',ibegin,actual,fore,obs,nout,iprint,iwindow, alpha,beta,nma); obs=dfloat(obs); call graph(obs fore actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast des '); call msmooth(gasout,'holt',ibegin,actual,fore,obs,nout,iprint,iwindow, alpha,beta,nma); obs=dfloat(obs); call graph(obs fore actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast holt'); call msmooth(gasout,'winters',ibegin,actual,fore,obs,nout,iprint,iwindow, alpha,beta,nma); obs=dfloat(obs); call graph(obs fore actual :nolabel :nocontact :plottype xyplot :heading '1 step ahead moving forecast winters'); b34srun; == ==MOVERIGHT Tests moveleft / moveright b34sexec matrix; call character(cc2,'abcdefghijklmnop'); test='12345678'; call print(test,'right 4',moveright(test,4),'left 3',moveleft(test,3)); do i=1,10; newcc2=moveleft(cc2,i); call print('Moveleft',cc2,i,newcc2); enddo; do i=1,10; newcc2=moveright(cc2,i); call print('Moveright',cc2,i,newcc2); enddo; b34srun; == ==MOVEVAR Tests Moving average moving variance b34sexec matrix; call echooff; call load(moveave); call load(movevar); n=20; a=array(n:integers(n)); call print('Mean of a',mean(a)); call moveave(a,norows(a),test); call print('Test of MA where use whole period',test); call moveave(a,2,test2); call moveave(a,3,test3); call print('Two & Three period Moving average'); call tabulate(a,test2,test3); call print(a); call print('Variance of a',variance(a)); call movevar(a,norows(a),test); call print('Test of MVAR where use whole period',test); call movevar(a,4,test4); call movevar(a,5,test5); call print('4 & 5 period Moving Variance'); call tabulate(a,test4,test4); b34srun; == ==MQSTAT Multivariate Q Statistic b34sexec scaio readsca /$ file('/usr/local/lib/b34slm/findat01.mad') file('c:\b34slm\examples\findat01.mad') dataset(m_ibmln2); b34srun; /$ /$ For further detail on this procedure see Tsay (2002) page 302-308 b34sexec matrix; call loaddata; x=array(norows(ibmln),2:); x(,1)=ibmln; x(,2)=spln; call mqstat(x,12 :print :squared :npar 4); call tabulate(%df %qorg1 %sqorg1 %qnew1 %sqnew1 %qstar1 %sqstar1); call tabulate(%df %qorg2 %sqorg2 %qnew2 %sqnew2 %qstar2 %sqstar2); b34srun; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(varest); call load(buildlag); call echooff; x=catcol(gasin,gasout); call print('Looking at raw data':); call mqstat(x,12 :print); nlag=6; ibegin1=1; iend2=norows(x); iprint=1; call print('Looking at the residuals':); call varest(x,nlag,ibegin1,iend2,beta,t,sigma,corr,resid,iprint, a,ia,varx,varxhat,rsq); call varstab(beta,compmat,eigdata,modulus,1); call mqstat(resid,nlag :print); b34srun; == ==M_MATLAB Matlab / Matrix Script /$ Running Matlab script under B34S Matrix b34sexec options; pgmcards; x=rand(6) xi=inv(x); x*xi yy=[1 2 3 2 1] plot(yy) pause quit b34sreturn; b34srun; b34sexec matrix; call open(77,'test.m'); call rewind(77); call rewind(4); call copyf(4,77); call close(77); call dodos('matlab /r test /logfile test.out':); call dounix('matlab < test.m > test.out'); call dodos('pause'); call copyout('test.out'); b34srun; == ==MVNLTEST Multivariate Nonlinear Test /; /; Example from Stokes-Hinich /; "Detecting and Modeling Nonlinearity in the Gas Furnace Data" /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call olsq(gasin gasin{1 to 6} gasout{1 to 6} :print); res1=%res; call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); res2=%res; call mvnltest(res1,res2 :print); call mvnltest(res1,res2 :window 20 :print); call tabulate(%b_obs,%e_obs,%hx,%hy,%hxy,%hyx,%px,%py,%pxy); call graph(%hx %hy %hxy %hyx :nolabel); call mvnltest(res1,res2 :window 30 :print); call tabulate(%b_obs,%e_obs,%hx,%hy,%hxy,%hyx,%px,%py,%pxy); call graph(%hx %hy %hxy %hyx :nolabel); b34srun; == ==NAMELIST NAMELIST function => Save names b34sexec matrix; * Note: if use form names=namelist( ) will lose call names( ) ; weight=array(4:180.,120.,125.,128.); namesl=namelist(John Sue Carol Diana); call names; call names(all); call tabulate(namesl,weight); b34srun$ == ==NAMELIST_2 Advanced Eval/Namelist Use b34sexec matrix; /$ illustrate namelist to argument x=namelist(x1 x2 x3); y =rn(array(10:)); x1=rn(array(10:)); x2=rn(array(10:)); x3=rn(array(10:)); call olsq(y,x1,x2,x3:print); /$ : not needed here xnew=eval(x(1)); do i=2,norows(x); xnew=catcol(xnew,eval(x(i))); enddo; call olsq(y,xnew :print); /$ : needed here to get names! call olsq(y,eval(x(1):),eval(x(2):),eval(x(3):) :print); b34srun; == ==NAMES List Names in storage b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(moveh82); n=200; call names(all:); call names; call print(%names%); call print(%namesL%); subroutine test(i); call print('in test'); call names(dostat); call print(%down,%donow,%dowhile,%ifnow); return; end; call names(dostat); call print(%down,%donow,%dowhile,%ifnow); do i=1,2; call names(dostat); call print(%down,%donow,%dowhile,%ifnow); if(i.eq.1)then; call names(dostat); call print(%down,%donow,%dowhile,%ifnow); endif; call test(1); enddo; b34srun; == ==NCCHISQ Noncentral Chi-Square b34sexec matrix; * Test problem from IMSL page 923 ; chsq=8.642; df=2.0; alam=1.0; p=ncchisq(chsq,df,alam); call print('Prob. that a noncentral chi-square random var. with', 'DF and noncentrality ',df,alam,' is less than ', chsq,' is ',p,' Answer should be .950'); b34srun; == ==NEAREST Nearest distinct number of a given type b34sexec matrix; i=1; i8=i4toi8(i); x=1.; x16=r8tor16(x); y=sngl(x); call print('Largest integer*4 ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Largest real*16 ',huge(x16):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Smallest real*16 ',tiny(x16):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); call print('Epsilon real*16 ',epsilon(x16):); call print('Precision real*4 ',precision(y):); call print('Precision real*8 ',precision(x):); call print('Precision real*16 ',precision(x16):); x=.1d+00; x16=r8tor16(x); y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; x16=x16*r8tor16(dfloat(i)); spx(j) =spacing(x); spy(j) =spacing(y); spx16(j) =spacing(x16); nearpr8(j) =nearest(x, 1.); nearmr8(j) =nearest(x,-1.); nearpr16(j)=nearest(x16, r8tor16(1.)); nearmr16(j)=nearest(x16,r8tor16(-1.)); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8, Real*16 and Real*4'); call tabulate(testnum,spx,spy,spx16,nearpr8, nearmr8,nearpr4,nearmr4 nearpr16,nearmr16); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; == ==NL2SOL Madsen Problem for NL2SOL real*8 vs Real*16 /$ /$ Run1 nl2sol with out gradiant /$ Run2 nl2sol with gradiant /$ Run3 maxf1 and maxf2 on same problem /$ %b34slet run1=1; %b34slet run2=1; %b34slet run3=0; b34sexec matrix; * answers can switch sign; * Results replicated by maxf1 & maxf2 for coefficients; * SEs differ; program test; r(1)=x1**kindas(r,2.0)+ x2**kindas(r,2.0) +x1*x2; r(2)=dsin(x1); r(3)=dcos(x2); return; end; program test2; j(1,1) = kindas(r, 2.0)*x1 + x2 ; j(1,2) = kindas(r, 2.0)*x2 + x1 ; j(2,1) = dcos(x1) ; j(2,2) = kindas(r, 0.0) ; j(3,1) = kindas(r, 0.0) ; j(3,2) = (kindas(r,-1.0))*dsin(x2) ; return; end; %b34sif(&run1.ne.0)%then; rvec=array(2:3.,11.0); call echooff; r=array(3:); /$ x1=.1; x2=.2; call nl2sol(r :name test :parms x1 x2 :ivalue rvec :print /$ :itprint ); call print('+++++++++++++++':); call print('Real*16 Results':); call print('+++++++++++++++':); r=r8tor16(array(3:)); rvec=array(2:3.,10.0); * rvec=r8tor16(rvec); call nl2sol(r :name test :parms x1 x2 :ivalue rvec :print /$ :itprint ); %b34sendif; %b34sif(&run2.ne.0)%then; rvec=array(2:3., 1.0); call echooff; r=array(3:); j=array(3,2:); two=kindas(r,2.0); call nl2sol(r j :name test test2 :parms x1 x2 :ivalue rvec :print /$ :itprint ); call print('+++++++++++++++':); call print('Real*16 Results':); call print('+++++++++++++++':); r=r8tor16(array(3:)); j=r8tor16(j); rvec=r8tor16(array(2:3., 1.0)); call nl2sol(r j :name test test2 :parms x1 x2 :ivalue rvec :print /$ :itprint ); %b34sendif; b34srun; /$ /$ Using minimum of sum of squares to solve /$ by nonlinear LS Madsen Problem /$ %b34sif(&run3.ne.0)%then; b34sexec matrix; * answers can switch sign; * Results replicated by nl2sol for coefficients; * SEs differ; program test; r(1)=x1**2. + x2**2. +x1*x2; r(2)=dsin(x1); r(3)=dcos(x2); func=(-1.0)*sumsq(r); return; end; rvec=array(2:3., 1.0); call echooff; call maxf1(func :name test :parms x1 x2 :ivalue rvec :print); rvec=array(2:3., 1.0); call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; %b34sendif; == ==NL2SOL2 NLLSQ vs NL2SOL /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ Illustrates Nonlinear Estimation using NL2SOL Command under matrix /$ /$ For Problem # 4 NL2SOL gets False Convergencve /$ %b34slet nl2sol=1; %b34slet nllsq =1; %b34slet prob1 =1; %b34slet prob2 =1; %b34slet prob3 =1; %b34slet prob4 =1; %b34slet plot =0; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; %b34sif(&prob1.ne.0)%then; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; program res72; call echooff; yhat=a*(g1*k**r+(1.0-g1)*l**r)**(v/r); res =q-yhat; call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 v r'); call outdouble(14,4,g1); call outdouble(34,4,v); call outdouble(50,4,r); return; end; rvec =array(:.3053 1.0 1.85 .03); call print(res72); %b34sif(&nllsq.ne.0)%then; call timer(t1); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue rvec :print result ); call timer(t2); call print('NLLSQ took ',t2-t1:); res1=%res; %b34sendif; %b34sif(&nl2sol.ne.0)%then; call timer(t1); call nl2sol(res :name res72 :parms g1 a v r :ivalue rvec :print /$ :itprint ); call timer(t2); call print('NL2SOL took ',t2-t1:); res2=%res; %b34sendif; %b34sif(&nl2sol.ne.0.and.&nllsq.ne.0.and.&plot.ne.0)%then; call graph(res1,res2); %b34sendif; b34srun; %b34sendif; %b34sif(&prob2.ne.0)%then; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem 2 ; program res72; call echooff; yhat=a*(g1*k**r+g2*l**r+(1.0-g1-g2)*(m1/p)**r)**(v/r); res=q-yhat; call cls(2); call cls(3); call cls(6); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(34,4,g1); call outdouble(50,4,g2); call outdouble(34,5,v); call outdouble(50,5,r); return; end; call print(res72); rvec=array(:.27698 .7754 1.,-.05 1.8); %b34sif(&nllsq.ne.0)%then; call timer(t1); call nllsq(q,yhat :name res72 :parms g1 g2 a r v :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue rvec :print result); call timer(t2); call print('NLLSQ took ',t2-t1:); res1=%res; %b34sendif; %b34sif(&nl2sol.ne.0)%then; call timer(t1); call nl2sol(res :name res72 :parms g1 g2 a r v :ivalue rvec :print /$ :itprint ); call timer(t2); call print('NL2SOL took ',t2-t1:); res2=%res; %b34sendif; %b34sif(&nl2sol.ne.0.and.&nllsq.ne.0.and.&plot.ne.0)%then; call graph(res1,res2); %b34sendif; b34srun; %b34sendif; %b34sif(&prob3.ne.0)%then; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem 3; program res72; call echooff; i=integers(norows(q)-2); yhat=((a*(g1*k(i+2)**r+g2*l(i+2)**r+ (1.0-g1-g2)*(m1(i+2)/p(i+2))**r)**(v/r)) + lam1*q(i+1) + lam2*q(i) - (lam1*a*(g1*k(i+1)**r+g2*l(i+1)**r+ (1.0-g1-g2)*(m1(i+1)/p(i+1))**r)**(v/r)) - (lam2*a*(g1*k(i )**r+g2*l(i )**r+ (1.0-g1-g2)*(m1(i )/p(i ))**r)**(v/r))); qnew=q(i+2); res=qnew-yhat; /$ Shows how coefficients change as model is estimated call cls(2); call cls(3); call cls(5); call cls(6); call outstring( 3,3,'g1 g2 v r'); call outdouble(20,3,g1); call outdouble(40,3,g2); call outdouble(60,3,v); call outstring( 3,4,'r lam1 lam2'); call outdouble(20,4,r); call outdouble(40,4,lam1); call outdouble(60,4,lam2); return; end; call print(res72); rvec=array(:.27698 .7754 1.00 .05 1.8 .8, -.6); %b34sif(&nllsq.ne.0)%then; call timer(t1); call nllsq(q,yhat :name res72 :parms g1 g2 a r v lam1 lam2 :maxit 500 :flam .1 :flu 10. :eps2 .004 :ivalue rvec :print result ); call timer(t2); call print('NLLSQ took ',t2-t1:); res1=%res; %b34sendif; %b34sif(&nl2sol.ne.0)%then; call timer(t1); call nl2sol(res :name res72 :parms g1 g2 a r v lam1 lam2 :ivalue rvec :print /$ :itprint ); call timer(t2); call print('NL2SOL took ',t2-t1:); res2=%res; %b34sendif; %b34sif(&nl2sol.ne.0.and.&nllsq.ne.0.and.&plot.ne.0)%then; call graph(res1,res2); %b34sendif; b34srun; %b34sendif; %b34sif(&prob4.ne.0)%then; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem=4; program res72; call echooff; i=integers(norows(q)-2); yhat=((dexp(tt*dfloat(i+2))*a*(g1*k(i+2)**r+g2*l(i+2)**r+ (1.0-g1-g2)*(m1(i+2)/p(i+2))**r)**(v/r)) + lam1*q(i+1) + lam2*q(i) - (lam1*dexp(tt*dfloat(i+1))*a*(g1*k(i+1)**r+g2*l(i+1)**r+ (1.0-g1-g2)*(m1(i+1)/p(i+1))**r)**(v/r)) - (lam2*dexp(tt*dfloat(i)) *a*(g1*k(i )**r+g2*l(i )**r+ (1.0-g1-g2)*(m1(i )/p(i ))**r)**(v/r))); qnew=q(i+2); res=qnew-yhat; call cls(2); call cls(3); call cls(6); call outstring( 3,3,'Coefficients g1 g2 v r lam1 lam2'); call outdouble(3 ,4,g1); call outdouble(23,4,g2); call outdouble(53,4,v); call outdouble(3 ,5,r); call outdouble(23,5,lam1); call outdouble(53,5,lam2); return; end; call print(res72); rvec = array(:.27698 .7754 1.00 .05 1.8 .0004 .8, -.6); %b34sif(&nllsq.ne.0)%then; call timer(t1); call nllsq(q,yhat :name res72 :parms g1 g2 a r v tt lam1 lam2 :maxit 500 :flam .1 :flu 10. :eps2 .004 :ivalue rvec :print result); call timer(t2); call print('NLLSQ took ',t2-t1:); res1=%res; %b34sendif; %b34sif(&nl2sol.ne.0)%then; call timer(t1); call nl2sol(res :name res72 :parms g1 g2 a r v tt lam1 lam2 :ivalue rvec :print /$ :itprint ); call timer(t2); call print('NL2SOL took ',t2-t1:); res2=%res; %b34sendif; %b34sif(&nl2sol.ne.0.and.&nllsq.ne.0.and.&plot.ne.0)%then; call graph(res1,res2); %b34sendif; b34srun; %b34sendif; == ==NL2SOL3 Real*8 vs Real*16 study /$ Illustrates Nonlinear Estimation using NLLSQ & NL2SOL Commands /$ using real*8 and real*16 paths. /$ However note that when terrible starting values are used (.1) the /$ Real*16 approach will recover while the real*8 dies. BUT note that /$ many problems occure while getting answers /$ /$ NL2SOL also shown. With bad starting values NL2SOL fails /$ /$ This suggests that real*16 may be more "robust" to starting values /$ rvec2 => bad values!!!! /$ /$ As setup with rvec3 => All solve but NLLSQ enters complex and /$ recovers /$ With rvec1 all work!! /$ %b34slet showgraph=yes; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; program res72; call echooff; yhat=a*(g1*k**r+(one-g1)*l**r)**(v/r); res =q-yhat; call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 a v r res_sumsq'); call outdouble(14,5,g1); call outdouble(34,5,a); call outdouble(14,6,v); call outdouble(34,6,r); call outdouble(14,7,sumsq(res)); return; end; call print(res72); one=kindas(q,1.0); /$ rvec1 is a proper starting value /$ rvec2 is a bad start /$ rvec3 is a bad start but works dfor nl2sol real*16 rvec1=array(:.3053 1.0 1.85 .03); rvec2=array(:.1 .1 .1 .1 ); rvec3=array(:.1 1. 1. .1 ); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 500 :flam 1. :flu 10. :eps2 .1e-14 /$ :ivalue rvec1 /$ :ivalue rvec2 :ivalue rvec3 :print result); resr8=%res; call nl2sol(res :name res72 :parms g1 a v r :ivalue rvec3 :print /$ :itprint ); call print('real*16 results',:); q=r8tor16(q); k=r8tor16(k); l=r8tor16(l); /$ Will enter complex domain but will recover one=kindas(q,1.0); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 500 /$ :flam 1. :flu 10. :eps2 .1e-24 /$ :ivalue rvec1 /$ :ivalue rvec2 :ivalue rvec3 :print result); resr16=r16tor8(%res); diff= resr8-resr16 ; call tabulate(resr8,resr16,diff); call nl2sol(res :name res72 :parms g1 a v r /$ :ivalue rvec1 :ivalue rvec3 :print /$ :itprint ); %b34sif(&showgraph.eq.yes)%then; call graph(resr16 :heading 'Residual from Real*16'); call graph((resr8-resr16) :heading 'Residual differences Real*8 vs Real*16'); %b34sendif; b34srun; == ==NL2SOL4 Fooling NL2SOL to solve banana /; /; Fooling Nl2sol to solve Banana /; b34sexec matrix; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); t=func; t=-1.*dsqrt(dabs(t)); funcv=vector(3:t,0.0,0.0); call outstring(3,3,'Function '); call outdouble(36,3 func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); call echooff; /$ call maxf1(func :name test :parms x1 x2 :ivalue rvec :print); x1=rvec(1); x2=rvec(2); call test; call nl2sol(funcv:name test :parms x1 x2 :ivalue rvec :print :itprint); b34srun; == ==NLEQ_1A Solve a System of Nonlinear Equations nsig = default /$ Solution to 0.0 = x1 + exp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27. /$ 0.0 = exp(x2-2.0)/x1+x3*x3 -10. /$ 0.0 = x3+sin(x2-2.0)+x2*x2 -7. /$ /$ with answers FNORM = 0.0 /$ x1 = 1.00001, x2 = 2.0000 x3 = 3.00000 /$ /$ can be found with the commands: /$ b34sexec matrix; * answers ; * x1 = 1.00001 ; * x2 = 2.00000 ; * x3 = 3.00000 ; program test; func(1)=x1 + dexp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27.0; func(2)=dexp(x2-2.0)/x1+x3*x3 - 10.; func(3)=x3+dsin(x2-2.0)+x2*x2 - 7.; return; end; call print(test); call echooff; rvec=array(3:4.0 4.0 4.0); call nleq(func :name test :parms x1 x2 x3 :ivalue rvec :print); b34srun; == ==NLEQ_1B Solve a System of Nonlinear Equations Here nsig=7 /$ Solution to 0.0 = x1 + exp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27. /$ 0.0 = exp(x2-2.0)/x1+x3*x3 -10. /$ 0.0 = x3+sin(x2-2.0)+x2*x2 -7. /$ /$ with answers FNORM = 0.0 /$ x1 = 1.00001, x2 = 2.0000 x3 = 3.00000 /$ /$ can be found with the commands: /$ /$ Note that here we have nsig 7 /$ b34sexec matrix; * answers ; * x1 = 1.00001 ; * x2 = 2.00000 ; * x3 = 3.00000 ; program test; func(1)=x1 + dexp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27.0; func(2)=dexp(x2-2.0)/x1+x3*x3 - 10.; func(3)=x3+dsin(x2-2.0)+x2*x2 - 7.; return; end; call print(test); call echooff; rvec=array(3:4.0 4.0 4.0); call nleq(func :name test :parms x1 x2 x3 :maxit 100 :nsig 7 :ivalue rvec :print); b34srun; == ==NLEQ_2 MATLAB(r) Test Problem # 1 /$ Solution to 0.0 = 2.*x1 - x2-dexp((-1.)*x1) /$ 0.0 = -1.*x1 + 2.*x2-dexp((-1.)*x2) /$ /$ with answers FNORM = 0.0 /$ x1 = .5671, x2 = .5671 /$ /$ Problem discussed in MATLAB(r) Optimization Toolbox p 4-81 /$ /$ can be found with the commands: /$ b34sexec matrix; * answers ; * x1 = .5671 ; * x2 = .5671 ; program test; func(1)= 2. *x1 - x2-dexp((-1.)*x1); func(2)=(-1.)*x1 + 2.*x2-dexp((-1.)*x2); return; end; call print(test); call echooff; rvec=array(2:-5.0,-5.0); call nleq(func :name test :parms x1 x2 :nsig 7 :ivalue rvec :print); b34srun; == ==NLEQ_3 MATLAB(r) Test Problem # 3 /$ Solution to 2,2 matrix X such that /$ /$ X*X*X=matrix(2,2:1. 2. 3. 4.); /$ /$ with answers x=matrix(2,2:-.1291, .8602, 1.2903, 1.1612); /$ /$ Problem discussed in MATLAB(r) Optimization Toolbox p 4-83 /$ can be found with the commands: /$ b34sexec matrix; * answers x11 = -.1291; * x12 = .8602; * x21 = 1.2903; * x22 = 1.1612; testx=matrix(2,2:); right=matrix(2,2:1. 2. 3. 4.); program test; testx(1,1)=x11; testx(1,2)=x12; testx(2,1)=x21; testx(2,2)=x22; testx=(testx*testx*testx)-right; func(1)= testx(1,1); func(2)= testx(1,2); func(3)= testx(2,1); func(4)= testx(2,2); return; end; call print(test); call echooff; rvec=array(4:1.,1.,1.,1.); call nleq(func :name test :parms x11 x12 x21 x22 :nsig 7 :ivalue rvec :print); b34srun; == ==NLEQ_4 MATLAB(r) Test Problem # 4 /$ Solution to 0.0 = 3.*x1 + 11.*x2 -2.*x3 -7. /$ 0.0 = x1 + x2 -2.*x3 -4. /$ 0.0 = x1 - x2 + x3 -19. /$ /$ with answers FNORM = 0.0 /$ x1 = 13.2188, x2 =-2.3438 x3 = 3.4375 /$ /$ can be found with the commands: /$ /$ Problem discussed in Matlab(r) Optimization Toolbox page 4-83,4-84 /$ b34sexec matrix; * Solution to 0.0 = 3.*x1 + 11.*x2 -2.*x3 -7. ; * 0.0 = x1 + x2 -2.*x3 -4. ; * 0.0 = x1 - x2 + x3 -19. ; * ; * with answers FNORM = 0.0 ; * x1 = 13.2188, x2 =-2.3438 x3 = 3.4375 ; program test; func(1)= 3.*x1 + 11.*x2 -2.*x3 -7.; func(2)= x1 + x2 -2.*x3 -4.; func(3)= x1 - x2 + x3 -19.; return; end; call print(test); call echooff; rvec=array(3:1., 1., 1.); call nleq(func :name test :parms x1 x2 x3 :nsig 7 :ivalue rvec :print); b34srun; == ==NLLS1 NLLS using Subroutines /$ This illustrates power of Matrix Command but is slow b34sexec matrix cbuffer=10000; call echooff; call load(dud); call load(marq); program prob1; /$ /$ test marquardt method of nonlinear estimation /$ calls marquardt subroutine marq /$ user supplied resid and deriv /$ /$ imar=0 marquardt , =1 = dud /$ call message('enter=> deriv. method, Cancel=> deriv. free method', 'Estimation Options', itest); imar=0; if(itest.eq.23)imar=1; /$ get data call uspopdat; /$ initial values call free(deriv,resid,beta,r); resid=resid1 ; deriv=deriv1 ; /$ /$ rename routines on the fly /$ call subrename(resid); call subrename(deriv); call makeglobal(resid,deriv) ; beta(1)=3.9 ; beta(2)=.022 ; beta=vfam(beta) ; year=mfam(year) ; pop=mfam(pop) ; lamda=.1e-8 ; iprint=0 ; iout=1 ; /$call print('IMAR',imar); if(imar .eq. 0) call marq(year,pop,beta,r,f,sse,seb,covb,corrb, lamda,iprint,iout); if(imar .eq. 1) call dud(year,pop,beta,r,f,sse,seb,covb,corrb, iprint,iout); return; end; subroutine resid1(beta,f,r,sse,xvar,yvar); /$ /$ user supplied routine with model /$ sas tech report a-102 page 8-7 /$ f=vfam(beta(1)* exp(beta(2)*afam(xvar-1790.))); r=yvar-f; sse=sumsq(r); return ; end ; subroutine deriv1(der,f,beta,xvar); /$ /$ user routine to calculate derivatives /$ der=matrix(norows(f),norows(beta):); der(,1)=vfam(afam(f)/beta(1)); der(,2)=vfam(afam(xvar-1790.)*afam(f)); return; end; program uspopdat; /$ data from sas technical report page 9-2 year=dfloat(integers(179,197)); year=year*10. ; pop=array(:3.929 5.308 7.239 9.638 12.866 17.069 23.191 31.443 39.818 50.155 62.947 75.994 91.972 105.710 122.775 131.669 151.325 179.323 203.211 ); call tabulate(year pop); return; end; call print(prob1,resid1,deriv1); call prob1; b34srun; == ==NLLS2 Illustrates NLLS Using Subroutines b34sexec matrix cbuffer=10000; call load(dud); call echooff; subroutine resid2(beta,f,r,sse,xvar,yvar); /$ user supplied routine for model listed page 7-6 of /$ sas tech report a-102 x=xvar-1790. ; z=exp(beta(2) + (beta(3)*afam(x))) ; f=vfam(beta(1) / (1. + afam(z))) ; r=yvar-f ; sse=sumsq(r) ; return ; end ; program prob2; /$ /$ test marquardt method of nonlinear estimation /$ user supplied resid /$ /$ get data call uspopdat; /$ initial values call free(deriv,resid,beta,r); resid=resid2 ; /$ /$ Rename the routines on the fly /$ call subrename(resid) ; call makeglobal(resid) ; beta(1)=400. ; beta(2)=4. ; beta(3)=-.03 ; beta=vfam(beta) ; year=vfam(year) ; pop=mfam(pop) ; iprint=0 ; iout=1 ; call print('Initial Beta',beta); /$call echooff; call dud(year,pop,beta,r,f,sse,seb,covb,corrb,iprint,iout); return; end; program uspopdat; /$ data from sas technical report page 9-2 year=dfloat(integers(179,197)); year=year*10. ; pop=array(:3.929 5.308 7.239 9.638 12.866 17.069 23.191 31.443 39.818 50.155 62.947 75.994 91.972 105.710 122.775 131.669 151.325 179.323 203.211 ); call tabulate(year pop); return; end; call print(resid2,prob2); call prob2; b34srun; == ==NLLS3 Sinai-Stokes (1972) b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix cbuffer=10000; call echooff; call load(dud); subroutine resid3(beta,f,r,sse,xvar,yvar); /$ /$ estimate a ces production function /$ /$ see sinai & stokes res may 1981 /$ beta=afam(beta) ; xvar=afam(xvar) ; f=(beta(2)*(xvar(,1)**beta(4)))+ ((1.-beta(2))*(xvar(,2)**beta(4))); f=beta(1)*(f**(beta(3)/beta(4))) ; beta=vfam(beta) ; f=vfam(f) ; r=vfam(yvar) - vfam(f) ; sse=sumsq(r) ; return ; end ; program prob3; /$ uses data on q, l and k in period 1929 - 1967 to estimate ces model call print('see Sinai - Stokes res(1981) page 315 equation ces 6'); call free(deriv,resid); resid=resid3; /$ /$ Rename on the fly /$ call subrename(resid); call makeglobal(resid) ; /$ deriv=deriv3; call free(beta); beta(1)=.05 ; beta(2)=.3 ; beta(3)=1.5 ; beta(4)= .3 ; beta=vfam(beta); lamda=.1e-12 ; iprint=0 ; iout =1 ; call loaddata ; call tabulate(q,l,k) ; call print('Initial Beta',beta); x=matrix(norows(q),2:) ; x(,1)=vfam(k) ; x(,2)=vfam(l) ; q=vfam(q) ; call dud(x,q,beta,r,f,sse,seb,covb,corrb,iprint,iout); return; end; call print(resid3,prob3); call prob3; b34srun; == ==NLLS3_A Real*8 / Real*16 Version of NLLS3 /$ Can be run real*8 or real*16 %b34slet use_r16=1; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix cbuffer=10000; call echooff; call load(dud2); call print(dud2); subroutine resid3(beta,f,r,sse,xvar,yvar); /$ /$ estimate a ces production function /$ /$ see sinai & stokes res may 1981 /$ beta=afam(beta) ; xvar=afam(xvar) ; f= ( beta(2)*(xvar(,1)**beta(4)))+ ((kindas(yvar,1.)-beta(2))* (xvar(,2)**beta(4))); f=beta(1)*(f**(beta(3)/beta(4))) ; beta=vfam(beta) ; f=vfam(f) ; r=vfam(yvar) - vfam(f) ; sse=sumsq(r) ; return ; end ; program prob3; /$ uses data on q, l and k in period 1929 - 1967 to estimate ces model call print('see Sinai - Stokes res(1981) page 315 equation ces 6'); call free(deriv,resid); resid=resid3; /$ /$ Rename on the fly /$ call subrename(resid); call makeglobal(resid) ; /$ deriv=deriv3; call free(beta); beta(1)=.05 ; beta(2)=.3 ; beta(3)=1.5 ; beta(4)= .3 ; lamda=.1e-12; beta=vfam(beta); iprint=0 ; iout =1 ; call loaddata ; call tabulate(q,l,k) ; call print('Initial Beta',beta); x=matrix(norows(q),2:) ; x(,1)=vfam(k) ; x(,2)=vfam(l) ; q=vfam(q) ; eps1=1.001; eps2= .0000001; /$ Run in real*16 mode %b34sif(&use_r16.ne.0)%then; beta =r8tor16(beta); lamda=r8tor16(lamda); x =r8tor16(x); q =r8tor16(q); /$ eps1=1.0000001; /$ eps2=.00000000001; eps1 =r8tor16(eps1); eps2 =r8tor16(eps2); %b34sendif; call names(all); call dud2(x,q,beta,r,f,sse,seb,covb,corrb,iprint, iout,eps1,eps2); return; end; call print(resid3,prob3); call prob3; b34srun; == ==NLLS4 Illustrates NLLS Using Subroutines b34sexec matrix cbuffer=10000; call load(dud); call load(marq); * ---------------------------------------------------------; * setup for Ron Gallant (1987) example 1 problem page 35 ; * Gallant answers using SAS were: ; * Coef SE ; * -.02588970 .01262384 ; * 1.01567967 .00993793 ; * -1.11569714 .16354199 ; * 0.50490286 .02565721 ; * ---------------------------------------------------------; call echooff; subroutine resid4(beta,f,r,sse,x,y); beta=afam(beta) ; x=afam(x) ; f=(beta(1)*x(,1))+ (beta(2)*x(,2)) + (beta(4)*exp(beta(3)*x(,3))); r=afam(y)-f ; f=vfam(f) ; r=vfam(r) ; beta=vfam(beta) ; sse=sumsq(r) ; return ; end ; subroutine deriv4(der,f,beta,x); /$ setup for Ron Gallant(1987) example 1 problem page 35 der=matrix(norows(x),norows(beta):) ; der(,1)=vfam(x(,1)) ; der(,2)=vfam(x(,2)) ; der(,3)=vfam(afam(beta(4))*afam(x(,3))*exp(afam(beta(3))*afam(x(,3)))); der(,4)=vfam(exp(afam(beta(3))*afam(x(,3)))); return; end; program prob4; Call print('See gallant(1987 page 4) example 1 - answers on page 35'); call free(y,x1,x2,x3); call free(deriv,resid); call free(f,r,beta,sse,seb,covb,corrb); resid=resid4 ; deriv=deriv4 ; call subrename(resid); call subrename(deriv); call rgex1; call makeglobal(resid,deriv) ; call free(beta) ; beta(1)=-0.04866; beta(2)=1.03884 ; beta(3)=-0.73792; beta(4)=-0.51362; beta=vfam(beta) ; lamda=.1e-8 ; iprint=0 ; /$ iprint = 1 > print intermediate results /$ iout = 1 > print table of results iout=1 ; call message('enter=> deriv. method, Cancel=> deriv. free method', 'Estimation Options', itest); imar=0; if(itest.eq.23)imar=1; x=matrix(norows(y),3:); i=integers(norows(y)); x(i,1)=x1(i) ; x(i,2)=x2(i) ; x(i,3)=x3(i) ; call echooff; if(imar .eq. 0) call marq(x,y,beta,r,f,sse,seb,covb,corrb,lamda,iprint,iout); if(imar .eq. 1) call dud(x,y,beta,r,f,sse,seb,covb,corrb,iprint,iout); return; end; program rgex1; /$ loads data from gallant(1987) page 4 * Test comment; t=integers(1,30); y=array(:.98610 1.03848 .95482 1.04184 1.02324 .90475 .96263 1.05026 .98861 1.03437 .98982 1.01214 .66768 .55107 .96822 .98823 .59759 .99418 1.01962 .69163 1.04255 1.04343 .97526 1.04969 .80219 1.01046 .95196 .97658 .50811 .91840 ); x1=array(:1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0); x2=array(norows(x1):); x2=x2+1.; x3=array(:6.28 9.86 9.11 8.43 8.11 1.82 6.58 5.02 6.52 3.75 9.86 7.31 .47 .07 4.07 4.61 .17 6.99 4.39 .39 4.73 9.42 8.9 3.02 .77 3.31 4.51 2.65 .08 6.11); call tabulate(t y x1 x2 x3); return; end; call print(rgex1,resid4,prob4,deriv4); call prob4; b34srun; == ==NLLSQ1 OLS using NLLSQ and REG Shows Lags /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec reg; model lnq=lnk lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; call tabulate (q l k m1dp time); program res72; call echooff; yhat=a+g1*lnk + g2*lnl +r*lnrm1 + v*time; call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); return; end; call print(res72); call nllsq(lnq,yhat :name res72 :parms a r g1 g2 v :print result residuals); call graph(%res); * Show that other commands can be run; x=matrix(3,3:1. 2. 3. 4. 5. 6. 7. 8. .9); call print(x); c=1./x; call print(c,c*x); b34srun; /$ Illustrate lags using both commands b34sexec reg; model lnq=lnk lnk{1} lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Cannot use subscripted approach if model is recursive ; program res72; call echooff; i=integers(norows(lnk)-1); yhat(i)= g1*lnk(i+1)+ gnew*lnk(i)+g2*lnl(i+1)+r*lnrm1(i+1)+ v*time(i+1) +a; call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); return; end; call print(res72); call nllsq(lnq,yhat :name res72 :parms a r g1 gnew g2 v :print result residuals); call graph(%res); call print(yhat); b34srun; == ==NLLSQ2 CES Production Function using NLLSQ /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ CES Model estimated using nonlinear methods /$ /$ Illustrates use of visual readout of model estimation /$ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; program res72; call echooff; yhat=a*((g1*(k**r)) + (g2*(l**r)) + ((1.0-g1-g2)*(m1dp**r)) )**(v/r); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.0,-.05 1.8 ) :print result residuals); call graph(%res); call print(mean(%res)); call names; call print(%corrmat); call tabulate(%coef,%se,%t); * Illustrate other commands can be run; x=matrix(3,3:1. 2. 3. 4. 5. 6. 7. 8. .9); call print(x); c=1./x; call print(c,c*x); b34srun; == ==NLLSQ3 Nonlinear Least Squares using NLLSQ Command /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix %b34slet showgraph=no; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; program res72; call echooff; yhat=a*(g1*k**r+(1.0-g1)*l**r)**(v/r); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 v r'); call outdouble(14,4,g1); call outdouble(34,4,v); call outdouble(50,4,r); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.3053 1.0 1.85 .03) :print result residuals); %b34sif(&showgraph.eq.yes)%then; call graph(%res); %b34sendif; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem 2 ; program res72; call echooff; yhat=a*(g1*k**r+g2*l**r+(1.0-g1-g2)*(m1/p)**r)**(v/r); call cls(2); call cls(3); call cls(6); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(34,4,g1); call outdouble(50,4,g2); call outdouble(34,5,v); call outdouble(50,5,r); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.,-.05 1.8) :print result residuals); %b34sif(&showgraph.eq.yes)%then; call graph(%res); %b34sendif; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem 3; program res72; call echooff; i=integers(norows(q)-2); yhat=((a*(g1*k(i+2)**r+g2*l(i+2)**r+ (1.0-g1-g2)*(m1(i+2)/p(i+2))**r)**(v/r)) + lam1*q(i+1) + lam2*q(i) - (lam1*a*(g1*k(i+1)**r+g2*l(i+1)**r+ (1.0-g1-g2)*(m1(i+1)/p(i+1))**r)**(v/r)) - (lam2*a*(g1*k(i )**r+g2*l(i )**r+ (1.0-g1-g2)*(m1(i )/p(i ))**r)**(v/r))); /$ Shows how coefficients change as model is estimated call cls(2); call cls(3); call cls(5); call cls(6); call outstring( 3,3,'g1 g2 v r'); call outdouble(20,3,g1); call outdouble(40,3,g2); call outdouble(60,3,v); call outstring( 3,4,'r lam1 lam2'); call outdouble(20,4,r); call outdouble(40,4,lam1); call outdouble(60,4,lam2); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v lam1 lam2 :maxit 500 :flam .1 :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.00 .05 1.8 .8, -.6) :print result iter residuals); %b34sif(&showgraph.eq.yes)%then; call graph(%res); %b34sendif; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem=4; program res72; call echooff; i=integers(norows(q)-2); yhat=((dexp(tt*dfloat(i+2))*a*(g1*k(i+2)**r+g2*l(i+2)**r+ (1.0-g1-g2)*(m1(i+2)/p(i+2))**r)**(v/r)) + lam1*q(i+1) + lam2*q(i) - (lam1*dexp(tt*dfloat(i+1))*a*(g1*k(i+1)**r+g2*l(i+1)**r+ (1.0-g1-g2)*(m1(i+1)/p(i+1))**r)**(v/r)) - (lam2*dexp(tt*dfloat(i)) *a*(g1*k(i )**r+g2*l(i )**r+ (1.0-g1-g2)*(m1(i )/p(i ))**r)**(v/r))); call cls(2); call cls(3); call cls(6); call outstring( 3,3,'Coefficients g1 g2 v r lam1 lam2'); call outdouble(3 ,4,g1); call outdouble(23,4,g2); call outdouble(53,4,v); call outdouble(3 ,5,r); call outdouble(23,5,lam1); call outdouble(53,5,lam2); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v tt lam1 lam2 :maxit 500 :flam .1 :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.00 .05 1.8 .0004 .8, -.6) :print result iter residuals); %b34sif(&showgraph.eq.yes)%then; call graph(%res); %b34sendif; b34srun; == ==NLLSQ4 Restricted OLS Using NLLSQ Command /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ Restricted OLS Model estimated using nonlinear methods /$ Results tested against full OLS model /$ Results graphed /$ /$ OLS model run inside and outside matrix command /$ /$ Note that :ivalue needed to start v at a low number to avoid /$ overflow. /$ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec reg; model lnq=lnk lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; call tabulate (q l k m1dp time); call olsq(lnq lnk lnl lnrm1 time:print); rssols=dexp(afam(lnq))-dexp(afam(%yhat)); yhatols=dexp(afam(%yhat)); call tabulate(q,dexp(%yhat),rssols); program res72; call echooff; yhat=a*((k**g1)*(l**g2)*(m1dp**(1.0-g1-g2)))*dexp(v*time); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms a g1 g2 v :ivalue array(:.1 .1 .1 .00001) :print result residuals); call graph(%res,rssols); yhat=q-%res; call graph(q,yhatols,yhat); call tabulate(q,yhatols,yhat,rssols,%res); b34srun; == ==NLLSQ5 NLLSQ vs NL2SOL Real*8 vs Real*16 /$ Illustrates Nonlinear Estimation using NLLSQ & NL2SOL Commands /$ using real*8 and real*16 paths. /$ However note that when terrible starting values are used (.1) the /$ Real*16 approach will recover while the real*8 dies. BUT note that /$ many problems occure while getting answers. Using real*16 the t /$ scores for NL2SOL are simular to NLLSQ. However at real*8 this is /$ not the case. /$ /$ NL2SOL also shown. With bad starting values NL2SOL fails /$ /$ This suggests that real*16 may be more "robust" to starting values /$ rvec2 => bad values!!!! /$ /$ As setup with rvec3 => All solve but NLLSQ enters complex and /$ recovers /$ With rvec1 all work!! /$ %b34slet showgraph=yes; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; program res72; call echooff; yhat=a*(g1*k**r+(one-g1)*l**r)**(v/r); res =q-yhat; call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 a v r res_sumsq'); call outdouble(14,5,g1); call outdouble(34,5,a); call outdouble(14,6,v); call outdouble(34,6,r); call outdouble(14,7,sumsq(res)); return; end; call print(res72); one=kindas(q,1.0); /$ rvec1 is a proper starting value /$ rvec2 is a bad start /$ rvec3 is a bad start but works dfor nl2sol real*16 rvec1=array(:.3053 1.0 1.85 .03); rvec2=array(:.1 .1 .1 .1 ); rvec3=array(:.1 1. 1. .1 ); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 500 :flam 1. :flu 10. :eps2 .1e-14 /$ :ivalue rvec1 /$ :ivalue rvec2 :ivalue rvec3 :print result); resr8=%res; call nl2sol(res :name res72 :parms g1 a v r :ivalue rvec3 :print /$ :itprint ); call print('real*16 results',:); q=r8tor16(q); k=r8tor16(k); l=r8tor16(l); /$ Will enter complex domain but will recover one=kindas(q,1.0); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 500 /$ :flam 1. :flu 10. :eps2 .1e-24 /$ :ivalue rvec1 /$ :ivalue rvec2 :ivalue rvec3 :print result); resr16=r16tor8(%res); diff= resr8-resr16 ; call tabulate(resr8,resr16,diff); call nl2sol(res :name res72 :parms g1 a v r /$ :ivalue rvec1 :ivalue rvec3 :print /$ :itprint ); %b34sif(&showgraph.eq.yes)%then; call graph(resr16 :heading 'Residual from Real*16'); call graph((resr8-resr16) :heading 'Residual differences Real*8 vs Real*16'); %b34sendif; b34srun; == ==NLPMIN1A Nonlinear Programming /$ /$ Uses IMSL dn2onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; program test; func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=((-1.)*(x1**2.)/4.) - (x2**2.) + 1. ; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; == ==NLLSQ_GLS GLS Using NLLSQ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; /$ /$ Illustrated GLS a number of ways /$ b34sexec regression toll=.1e-6 maxgls=1; model lnq=lnk lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; call tabulate (q l k m1dp time); program res72; call echooff; yhat(jj2)=a*(1.-rho)+rho*lnq(jj2)+g1*lnk(jj) -g1*rho*lnk(jj2) +g2*lnl(jj) -g2*rho*lnl(jj2) +r* lnrm1(jj) - r*rho*lnrm1(jj2) +v* time(jj) - v*rho*time(jj2); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); call outdouble(34,5,rho); return; end; call print(res72); jj=integers(2,norows(lnq)); jj2=jj-1; lnq2=lnq(jj); call nllsq(lnq,yhat :name res72 :parms a r g1 g2 v rho :print result residuals); call graph(%res); b34srun; /$ user places RATS commands between /$ PGMCARDS$ /$ note: user RATS commands here /$ B34SRETURN$ /$ B34SEXEC OPTIONS OPEN('rats.dat') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * ar1(method=maxl) lnq * * # constant lnl lnk lnrm1 time ar1(method=corc) lnq * * # constant lnl lnk lnrm1 time B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(28)$ B34SRUN$ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ B34SEXEC OPTIONS /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ == ==NLLSQ_R16 Real*8 vs Real*16 Starting Values /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ using real*8 and real*16 paths. This case does not make a diffference /$ However note that when terrible starting values are used (.1) the /$ Real*16 approach will recover while the real*8 dies. /$ /$ This suggests that real*16 may be more "robust" to starting values /$ %b34slet showgraph=yes; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; program res72; call echooff; yhat=a*(g1*k**r+(one-g1)*l**r)**(v/r); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 v r'); call outdouble(14,4,g1); call outdouble(34,4,v); call outdouble(50,4,r); return; end; call print(res72); one=kindas(q,1.0); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 500 :flam 1. :flu 10. :eps2 .1e-14 :ivalue array(:.3053 1.0 1.85 .03) /$ :ivalue array(: .1 .1 .1 .1) :print result); resr8=%res; call print('real*16 results',:); q=r8tor16(q); k=r8tor16(k); l=r8tor16(l); /$g1=r8tor16(g1); /$ a=r8tor16(a); /$ v=r8tor16(v); /$ r=r8tor16(r); /$ Will enter complex domain but will recover one=kindas(q,1.0); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 500 :flam 1. :flu 10. :eps2 .1e-14 /$ :ivalue array(:.3053 1.0 1.85 .03) :ivalue array(: .1 .1 .1 .1) :print result); resr16=%res; diff=(resr8-r16tor8(%res)); call tabulate(resr8,resr16,diff); %b34sif(&showgraph.eq.yes)%then; call graph(r16tor8(%res)); call graph((resr8-r16tor8(%res))); %b34sendif; b34srun; == ==NLPMIN1B Uses NLPMIN1 to solve OLS Model b34sexec options ginclude('gas.b34'); b34srun; /$ Using NLPMIN to solve OLS problem /$ OLSQ used as a test /$ Uses IMSL dn2onf /$ Note that M and ME set = 0. G(1)=0.0d+00 is a dummy b34sexec matrix; call loaddata; program test; func=sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); g(1)=0.0d+00; return; end; call print(test); call olsq(gasout gasin :print); call echooff; call NLPMIN1(func g :name test :parms a b :ivalue array(:2.,2.) :nconst 0 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; == ==NLLSQR16B Very Difficult Test Problem %b34slet dorats=0; /$ /$ Real*8 nllsq will not solve problem with starting values # 1 /$ Real*16 nllsq will solve problem for coef /$ /$ NL2SOL does a good job on this problem /$ Rats does a good job on this problem /$ b34sexec options copyf(4,6,1,999999,1,80,0,1); datacards; NIST/ITL StRD Dataset Name: Eckerle4 (Eckerle4.dat) File Format: ASCII Starting Values (lines 41 to 43) Certified Values (lines 41 to 48) Data (lines 61 to 95) Procedure: Nonlinear Least Squares Regression Description: These data are the result of a NIST study involving circular interference transmittance. The response variable is transmittance, and the predictor variable is wavelength. Reference: Eckerle, K., NIST (197?). Circular Interference Transmittance Study. Data: 1 Response Variable (y = transmittance) 1 Predictor Variable (x = wavelength) 35 Observations Higher Level of Difficulty Observed Data Model: Exponential Class 3 Parameters (b1 to b3) y = (b1/b2) * exp[-0.5*((x-b3)/b2)**2] + e Starting values Certified Values Start 1 Start 2 Parameter Standard Deviation b1 = 1 1.5 1.5543827178E+00 1.5408051163E-02 b2 = 10 5 4.0888321754E+00 4.6803020753E-02 b3 = 500 450 4.5154121844E+02 4.6800518816E-02 Residual Sum of Squares: 1.4635887487E-03 Residual Standard Deviation: 6.7629245447E-03 Degrees of Freedom: 32 Number of Observations: 35 b34sreturn; b34seend; b34sexec data heading('Eckerle Transmission Data'); input y x; datacards; 0.0001575E0 400.000000E0 0.0001699E0 405.000000E0 0.0002350E0 410.000000E0 0.0003102E0 415.000000E0 0.0004917E0 420.000000E0 0.0008710E0 425.000000E0 0.0017418E0 430.000000E0 0.0046400E0 435.000000E0 0.0065895E0 436.500000E0 0.0097302E0 438.000000E0 0.0149002E0 439.500000E0 0.0237310E0 441.000000E0 0.0401683E0 442.500000E0 0.0712559E0 444.000000E0 0.1264458E0 445.500000E0 0.2073413E0 447.000000E0 0.2902366E0 448.500000E0 0.3445623E0 450.000000E0 0.3698049E0 451.500000E0 0.3668534E0 453.000000E0 0.3106727E0 454.500000E0 0.2078154E0 456.000000E0 0.1164354E0 457.500000E0 0.0616764E0 459.000000E0 0.0337200E0 460.500000E0 0.0194023E0 462.000000E0 0.0117831E0 463.500000E0 0.0074357E0 465.000000E0 0.0022732E0 470.000000E0 0.0008800E0 475.000000E0 0.0004579E0 480.000000E0 0.0002345E0 485.000000E0 0.0001586E0 490.000000E0 0.0001143E0 495.000000E0 0.0000710E0 500.000000E0 b34sreturn; b34srun; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix b34sexec matrix; call loaddata; * b1 = 1 1.5 1.5543827178E+00 1.5408051163E-02; * b2 = 10 5 4.0888321754E+00 4.6803020753E-02; * b3 = 500 450 4.5154121844E+02 4.6800518816E-02; call cls(-1); /$ setup to run real*16 or real*8 program test; call echooff; yhat = (b1/b2) * dexp(kindas(x,-0.5)*( ((x-b3)/b2)**kindas(x,2.))); r=y-yhat; call outstring(3, 2,'b1 b2 b3'); call outdouble(14,2,b1); call outdouble(34,2,b2); call outdouble(50,2,b3); return; end; c=matrix(3,2: 1.5543827178E+00 1.5408051163E-02 4.0888321754E+00 4.6803020753E-02 4.5154121844E+02 4.6800518816E-02); testss=1.4635887487E-03; call print(test); * bad starting values go to a problem with dexp range; * diff setting gets it to work !! ; call nllsq(y,yhat :name test :parms b1 b2 b3 :ivalue array(: 1. 10. 500.) /$ :ivalue array(: 1.5 5. 450.) :diff array(: .0001 .0001 .0001) :maxit 1000 :print result); /$ call graph(%res); call print('NLLSQ on Eckerle4 :starting # 1':); call lre(c(,1),11,%coef,lretest,bits :print); call print('SE Tests':); call lre(c(,2),11,%se, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nllsq(y,yhat :name test :parms b1 b2 b3 /$ :ivalue array(: 1. 10. 500.) :ivalue array(: 1.5 5. 450.) :maxit 1000 :print result); call print('NLLSQ on Eckerle4 :starting # 2':); call lre(c(,1),11,%coef,lretest,bits :print); call print('SE Tests':); call lre(c(,2),11,%se, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nl2sol(r :name test :parms b1 b2 b3 :ivalue array(: 1. 10. 500.) /$ :ivalue array(: 1.5 5. 450.) :maxit 1000 :maxfun 1000 :print); call print('NL2SOL on Eckerle4 :starting # 1':); call lre(c(,1),11,%coef,lretest,bits :print); call print('SE Tests':); call lre(c(,2),11,%se, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nl2sol(r :name test :parms b1 b2 b3 /$ :ivalue array(: 1. 10. 500.) :ivalue array(: 1.5 5. 450.) :maxit 1000 :maxfun 1000 :print); call print('NL2SOL on Eckerle4 :starting # 1':); call lre(c(,1),11,%coef,lretest,bits :print); call print('SE Tests':); call lre(c(,2),11,%se, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call print(' ':); call print('+++++++++++++++++++++++++++++++++++++':); call print(' Real*16 ':); call print('+++++++++++++++++++++++++++++++++++++':); y=r8tor16(y); x=r8tor16(x); c=r8tor16(c); testss=r8tor16(testss); call nllsq(y,yhat :name test :parms b1 b2 b3 :ivalue array(: 1. 10. 500.) /$ :ivalue array(: 1.5 5. 450.) /$ :diff array(: .0001 .0001 .0001) :maxit 1000 :eps2 .1d-15 :print result); /$ call graph(%res); call print('NLLSQ on Eckerle4 :starting # 1':); call lre(c(,1),11,%coef,lretest,bits :print); call print('SE Tests':); call lre(c(,2),11,%se, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); call nllsq(y,yhat :name test :parms b1 b2 b3 /$ :ivalue array(: 1. 10. 500.) :ivalue array(: 1.5 5. 450.) :maxit 1000 :eps2 .1d-15 :print result); call print('NLLSQ on Eckerle4 :starting # 2':); call lre(c(,1),11,%coef,lretest,bits :print); call print('SE Tests':); call lre(c(,2),11,%se, lretest,bits :print); call print('Test Residual sum of squares':); call lre(testss, 11,%fss,lretest,bits :print); b34srun; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* data passed from b34s(r) system to rats', '* ') $ pgmcards$ * nonlin b1 b2 b3 input b1 b2 b3 1. 10. 500. frml mod = (b1/b2) * exp(-0.5*((x-b3)/b2)**2); nlpar(subiterations=100) nlls(frml=mod,vcv,iterations=200) y * * e coef * better values nonlin b1 b2 b3 input b1 b2 b3 1.5 5. 450. frml mod = (b1/b2) * exp(-0.5*((x-b3)/b2)**2); nlpar(subiterations=100) nlls(frml=mod,vcv,iterations=200) y * * e coef b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ b34srun$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; == ==NLPMIN1C Uses NLPMIN1 to minimize a function /$ Answers should be x1=.9999 and x2=.9999 b34sexec matrix; * dn2onf is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=100.*(x2-x1*x1)**2. + (1.-x1)**2.; call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); g(1)=0.0d+00; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms x1 x2 :ivalue array(:.1 ,.1 ) :nconst 0 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; == ==NLPMIN1D Minimize a two var. constrained exponential function b34sexec matrix; * NLPMIN1 is used to minimize a function ; * Answers should be x1=-9.5474 and x2=1.0474 ; * Problem from Matlib Optimization toolbox page 1-9 ; * Test problem illustrates a nonlinear function and nonlienar constraints ; * Min dexp(x1)*((4.*x1*x1)+(2.*x2*x2)+(4.*x1*x2)+(2.*x2)+1.0); * s. t. x1*x2 -x1-x2 le -1.5 ; * x1*x2 GE -10 ; program test; func=dexp(x1)*((4.*x1*x1)+(2.*x2*x2)+(4.*x1*x2)+(2.*x2)+1.0); if(%active(1)) g(1) =-1.*(((x1*x2)-x1-x2)+1.5) ; if(%active(2)) g(2) =(x1*x2)+10. ; call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1., 1.0); call echooff; call nlpmin1(func g :name test :parms x1 x2 :ivalue rvec :nconst 2 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; == ==NLPMIN1E IGARCH(1,1) solved with NLPMIN1 /$ IGARCH(1,1) using NLPMIN1 - shows general case /$ /$ Note that SE are not available b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; b34sexec matrix ; call loaddata; y=sp500; vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); call print('mean y ',mean(y):); call print('vstart ',vstart :); program test; call garch(res,arch,y,func,1,nbad :gar array(:gar) idint(array(:1)) :gma array(:gma) idint(array(:1)) :constant array(:a0 b0) ); if(%active(1)) g(1)=gar+gma-1.; func=(-1.)*func; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms gar gma a0 b0 :ivalue array(:.5,.5,mean(y),vstart) :nconst 1 0 :lower array(: 1.d-6, 1.d-6, 1.d-6, 1.d-6) :upper array(: 1.d+2, 1.d+2, 1.d+2, 1.d+2) :print :maxit 100 :iprint final); b34srun; == ==NLPMIN2 Nonlinear Programming - User Gradiant /$ /$ Uses IMSL dn2ong /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; program test; func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; return; end; call print(test,grad); call echooff; call nlpmin2(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; == ==NLPMIN3 Nonlinear Programming - User Gradiant - Gets Hessian /$ /$ Uses IMSL dn0onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; program test; func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; return; end; call print(test,grad); call echooff; call nlpmin3(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; == ==NLSTART Generate Nonlinear Starting values b34sexec matrix; n=2; k=10; a=array(n:1. 1.); b=array(n:3. 2.); call nlstart(a,b,k,s); call print(s); b34srun; == ==NOCOLS Number of columns in an object b34sexec matrix; i=integers(1,20); x=rn(matrix(5,6:)); call print(norows(i),norows(x), nocols(i),nocols(x), noels(i), noels(x)); b34srun; == ==NOELS Number of elements in an object b34sexec matrix; i=integers(1,20); x=rn(matrix(5,6:)); call print(norows(i),norows(x), nocols(i),nocols(x), noels(i), noels(x)); b34srun; == ==NORMDEN NORMDEN function => Density of Normal Distribution b34sexec matrix$ z=grid(-4.5,4.5,.01); prob =probnorm(z); den =normden(z); z16 =r8tor16(z); prob16=probnorm(z16); den16 =normden(z16); call tabulate(z,prob,den,prob16,den16); call graph(z,prob,den:htitle 1.5 1.5 :plottype xyplot :nocontact :pgborder :nolabel :heading ' Normal Probabily and Density'); b34srun; == ==NORMDIST 1-norm, 2-norm and i-norm distance b34sexec matrix; x=array(:1.,-1.,0.0, 2.); y=array(:4., 2.,1. ,-3.); call tabulate(x,y); call print('1-norm ',normdist(x,y,1)); call print('2-norm ',normdist(x,y,2)); call print('i-norm ',normdist(x,y)); call print(' '); call print('answers should be 12., 6.63325 and 5.0'); b34srun; == ==NOROWS Number of columns in an object b34sexec matrix; i=integers(1,20); x=rn(matrix(5,6:)); call print(norows(i),norows(x), nocols(i),nocols(x), noels(i), noels(x)); b34srun; == ==NOTFIND Illustrates Not find b34sexec matrix; * note that namelist makes all names upper case; cc=namelist(mary sue aron); nota =notfind(cc,'a'); nota2=notfind(cc,'A'); call tabulate(nota,cc,nota2); call character(cc2,'abcdefghijklmnop'); call print('Where is a not?',cc2,notfind(cc2,'a')); b34srun; == ==OBJECT Object function => merging objects b34sexec matrix; test1=object(x,y); test2=object(x,y,1); call names; call names(all); call print(test1,test2); b34srun; == ==OLSQ_RES Testing restrictions in OLS Models b34sexec options ginclude('gas.b34'); b34srun; b34sexec reg; model gasout = gasout{1 to 1} gasin{1 to 1}; test gasin{1 to 1}; b34srun; b34sexec matrix; call loaddata; call load(olsq_res); call echooff; _arg1='gasout gasout{1 to k} gasin{1 to k} :print'; _arg2='gasout gasout{1 to k} :print'; k=1; _noprint=0; call olsq_res; b34srun; == ==OLSQ_RES2 Testing effect of lag on the Granger Significance /; /; Job takes a large region to run /; b34sexec options ginclude('b34sdata.mac') member(dmsf); b34srun; b34sexec reg; model swissf = dm{1 to 2} swissf{1 to 2}; test dm{1 to 2}; test swissf{1 to 2}; b34srun; b34sexec matrix; call loaddata; call load(olsq_res); call echooff; /; 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 of options /; place them in _arg1 and _arg2 _arg1='swissf swissf{1 to k} dm{1 to k}'; _arg2='swissf swissf{1 to k} '; n=36; sig=array(n:); ftest=array(n:); do k=1,n; call olsq_res; ftest(k)=%fstat; sig(k) =%fprob; enddo; nlags=dfloat(integers(1,n)); call tabulate(nlags,ftest,sig); call graph(nlags sig :heading 'Effect of lag on Granger Test of DM=>SF' :nocontact :pgborder :plottype xyplot); _arg1='dm swissf{1 to k} dm{1 to k}'; _arg2='dm dm{1 to k} '; call compress; sig=array(n:); ftest=array(n:); do k=1,n; call olsq_res; ftest(k)=%fstat; sig(k) =%fprob; enddo; nlags=dfloat(integers(1,n)); call tabulate(nlags,ftest,sig); call graph(nlags sig :heading 'Effect of lag on Granger Test of SF=>DM' :nocontact :pgborder :plottype xyplot); b34srun; == ==OLS4_TTEST Illustrates Distribution of T statistic /$ Illustrates Problems of significance tests using OLS /$ /$ Illustrates T score distribution /$ b34sexec matrix; call echooff; listfreq=0; n=1000; nob=10000; y=array(nob:); x=array(nob:); t1=array(n:); t2=array(n:); do i=1,n; call outinteger(3,20,i); x=rn(x); /$ Note that x is not in the Y variable calculation y=1.+rn(x); call olsq(y x); t1(i)=%t(1); t2(i)=%t(2); enddo; call graph(t2(ranker(t2)) :heading 'T scores for constant'); call graph(t1(ranker(t1)) :heading 'T scores for random x variable'); q=array(8:.25,.50,.75,.90,.95,.975,.99,1.0); call quantile(t1,q,qvalue1); call quantile(t2,q,qvalue2); call tabulate(q,qvalue1,qvalue2); if(listfreq.ne.0)then; call load(cfreq); call cfreq(t1,tt1,ttt1); call cfreq(t2,tt2,ttt2); call tabulate(t1,tt1,ttt1,t2,tt2,ttt2); endif; b34srun; == ==OLSPLOT Plots of OLS Y, Yhat and Residual b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(olsplot); call olsq(gasout gasin{1 to 6} gasout{1 to 6}); call character(cc,'Gasout Model'); call olsplot(%yhat, %y, %res, cc); b34srun; == ==OLSPLOT2 Plots of OLS Y, Yhat and Residual with date b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(olsplot); call olsq(gasout gasin{1 to 6} gasout{1 to 6}); call character(cc,'Gasout Model'); date=dfloat(1799 + integers(1,296)); /; /; remove obs from front due to lags /; n1=norows(%yhat); n2=norows(gasout); if(n2.gt.n1)then; i=integers(1,(n2-n1)); date(i)=missing(); date=goodrow(date); endif; call olsplot2(date,%yhat, %y, %res, cc); b34srun; == ==OLSQ1 Ordinary Least Squares using Matrix Command /$ Illustrates OLS Capability under Matrix Command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec reg; model gasout=gasin; b34srun; b34sexec robust; model gasout=gasin; b34srun; b34sexec reg; model gasout=gasin{0 to 1} gasout{1}; b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin:print :diag); call graph(%res :heading 'Residual'); call graph(%y %yhat :heading 'Fitted and Actual'); call olsq(gasout gasin{0 to 1} gasout{1} :print); call names; call print('Model of ',%yvar); call tabulate(%names,%lag,%coef,%se,%t); call tabulate(gasout,%y,%yhat,%res); call graph(%res,:heading 'Residuals'); call graph(%y,%yhat :heading 'Fitted and Actual Values.'); maxi=24; do i=1,maxi; call olsq(gasout gasin{0 to i} gasout{1 to i}:print); call print(acf(%res,24)); enddo; b34srun; == ==OLSQ2 Effect of # Lags on R**2 and RSS /$ Illustrates OLS Capability under Matrix Command /$ /$ Shows Effect of Lag on RSS, RES and RSQ /$ /$ We only adjust gasin lags /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; maxi=24; fit=array(maxi:); holdrss=array(maxi:); do i=1,maxi; call olsq(gasout gasin{0 to i} gasout{1}); fit(i)=%rsq; holdrss(i)=%rss; call graph(%res); enddo; call tabulate(fit,holdrss); call graph(fit); call graph(holdrss); b34srun; == ==OLSQ3 OLS - L1 - MINIMAX /$ Illustrates OLS / L1 / Minimax Capability under Matrix Command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec robust; model gasout=gasin{0 to 6} gasout{1 to 6}; b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin{0 to 6} gasout{1 to 6}:print :diag :l1 :minimax); call names(all); call graph(%res,%l1res,%mmres :heading 'Residual'); call graph(%y %yhat %l1yhat %mmyhat :heading 'Fitted and Actual'); call graph(%y %yhat :heading 'OLS Fitted and Actual'); call graph(%y %l1yhat :heading 'L1 Fitted and Actual'); call graph(%y %mmyhat :heading 'MM Fitted and Actual'); call print('Model of ',%yvar); call tabulate(%names,%lag,%coef,%se,%t,%l1coef %mmcoef); call tabulate(gasout,%y,%yhat,%res,%l1yhat,%l1res,%mmyhat,%mmres); b34srun; == ==OLSQ4 Subset sample /$ Illustrates OLS Capability under Matrix Command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; mask = (gasin .gt. 0.0); call olsq(gasout gasin :sample mask :print :diag :qr); call olsq(gasout gasin :sample mask :print :diag); call graph(%res :heading 'Residual'); call graph(%y %yhat :heading 'Fitted and Actual'); == ==OLSQ5 Illustrates effect on RSS of Lags /$ /$ See also MARS_6 example /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; nn=15; lag=15; rss=array(nn,lag:); do j=1,lag; do i=1,nn; call olsq(gasout gasout{1 to j} gasin{1 to i}); rss(i,j)=%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,10; /$ 123456789012345678901234567890123456 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; call print(rss); call checkpoint; b34srun; == ==OLSQ6 Forecasting with AR(k) model b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; r16gasin=r8tor16(gasin); r16gasot=r8tor16(gasout); idumpmat=0; call olsq(gasout gasin :savex :print); xxr8=%x; call olsq(r16gasot r16gasin :savex :print); xxr16=%x; if(idumpmat.ne.0)call print(xxr8,xxr16); maxlag=9; do i=1,4; call print('******** Forecasts out ',i:); call olsq(gasout gasout{i to maxlag},gasin{i to maxlag} :savex :print); xx1=%x; if(idumpmat.ne.0)call print(xx1,%xfobs,%xfuture); f1=%xfuture*%coef; call tabulate(%xfobs,f1); call olsq(r16gasot r16gasot{i to maxlag} r16gasin{i to maxlag} :savex :print); xx2=%x; if(idumpmat.ne.0)call print(xx2,%xfobs,%xfuture); ff1=%xfuture*%coef; ff1=r16tor8(ff1); call tabulate(%xfobs,ff1); enddo; b34srun; == ==OLSQ7 White SE Tests /$ /$ Illustrates Robust Options in Matrix and optionally REG and Rats /$ Se see both OLS and /$ %b34slet dorats=0; %b34slet doreg=0; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin{0 to 3} gasout{1 to 3} :print); call olsq(gasout gasin{0 to 3} gasout{1 to 3} :white :print); call tabulate(%coef %se %t %whitese %whitet); gasin =r8tor16(gasin); gasout=r8tor16(gasout); call olsq(gasout gasin{0 to 3} gasout{1 to 3} :print); call olsq(gasout gasin{0 to 3} gasout{1 to 3} :white :print); call tabulate(%coef %se %t %whitese %whitet); b34srun; %b34sif(&doreg.ne.0)%then; b34sexec reg white; model gasout = gasin{0 to 3} gasout{1 to 3}$ b34srun$ %b34sendif; %b34sif(&dorats.ne.0)%then; B34SEXEC OPTIONS OPEN('rats.dat') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * linreg(robusterrors) gasout # constant gasin{0 to 3} gasout{1 to 3} B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(28)$ B34SRUN$ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ B34SEXEC OPTIONS /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==OLSQ8 Alternate White Tests /$ /$ Note Greene (2003) page 215 uses 72 observations /$ /$ :white1 and :white2 reults in Greene(2003) Table 11.1 /$ Note that SE for :white2 for ownrent is 95.672 not 95.632 /$ /$ Davidson & MacKinnon (2004) 199-200 discuss these tests which /$ are also discussed in Greene (2003) page 219=221 /$ b34sexec options ginclude('greene.mac') member(a5_1); b34srun; /$ b34sexec data set dropmiss; build incomesq; gen incomesq=income*income; gen if(exp.le.0.0)exp=missing(); b34srun; b34sexec matrix; call loaddata; call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white1 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white2 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white3 :print); call tabulate(%coef %se %t %whitese %whitet); exp =r8tor16(exp); age =r8tor16(age); ownrent =r8tor16(ownrent); income =r8tor16(income); incomesq=r8tor16(incomesq); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white1 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white2 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white3 :print); call tabulate(%coef %se %t %whitese %whitet); b34srun; == ==OLSQ_QR QR Test /$ First a major problem case then a more normal case. /$ Test proglem show value of QR in some cases. b34sexec options ginclude('b34sdata.mac') member(wampler); b34srun; b34sexec matrix; call loaddata; * y1 = 1+ x1 + x1**2 + x1**3 + x1**4 + x1**5 $ * y2 = 1 + .1*x1 +.01*x1**2 +.001*x1**3 + .0001*x1**4 + .00001*x1**5$ * y3 = y1 + delta $ * y4 = y1 + 100*delta $ * y5 = y1 + 10000*delta $ call olsq(y1 x1 x2 x3 x4 x5 :print ); call olsq(y1 x1 x2 x3 x4 x5 :print :qr); call olsq(y2 x1 x2 x3 x4 x5 :print ); call olsq(y2 x1 x2 x3 x4 x5 :print :qr); call olsq(y3 x1 x2 x3 x4 x5 :print ); call olsq(y3 x1 x2 x3 x4 x5 :print :qr); call olsq(y4 x1 x2 x3 x4 x5 :print ); call olsq(y4 x1 x2 x3 x4 x5 :print :qr); call olsq(y5 x1 x2 x3 x4 x5 :print ); call olsq(y5 x1 x2 x3 x4 x5 :print :qr); b34srun; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /; Use QR command b34sexec qr; model gasout=gasin; b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin :print); call olsq(gasout gasin :print :qr); call olsq(gasout gasout{1 to 40} gasin{1 to 40} :print); call olsq(gasout gasout{1 to 40} gasin{1 to 40} :print :qr); b34srun; == ==OLS_L1MM Shows OLS, MINIMAX and L1 where an outlier b34sexec matrix; * outlier analysis ; n=1000; k=6; vv=2.; x=rn(matrix(n,k:)); x(,1)=1.; beta=vector(k:)+10.; y=x*beta+vv*rn(vector(n:)); call olsq(y x :noint :print :l1 :minimax); y(1)=200.; call olsq(y x :noint :print :l1 :minimax); b34srun; == ==OLSQ_RR Recursive Residual Analysis /$ /$ This job validates the rrplots routine and the /$ RR option on the OLSQ command /$ %b34slet dorr =0; %b34slet dor16=0; b34sexec options ginclude('b34sdata.mac') macro(eeam88)$ b34seend$ %b34sif(&dorr.ne.0)%then; b34sexec rr ntest=2 irb=1 irrls=list ibcls=list icum=list icumsq=list iquant=list$ model lnq = lnk lnl $ b34seend$ %b34sendif; b34sexec matrix; call loaddata; call load(rrplots); call olsq( lnq lnk lnl :rr 1 :print); call tabulate(%rrobs,%ssr1,%ssr2,%rr,%rrstd,%res); call print('Sum of squares of std RR ',sumsq(goodrow(%rrstd)):); call print('Sum of squares of OLS RES ',sumsq(goodrow(%res)):); call print(%rrcoef,%rrcoeft); call rrplots(%rrstd,%rss,%nob,%k,%ssr1,%ssr2,1); call names(all); grid=0; list=1; call rrplots2(%rrcoef,%rrcoeft,%names,%lag,'c___',list,grid); %b34sif(&dor16.ne.0)%then; call print('REAL*16 *******************************':); lnq=r8tor16(lnq); lnk=r8tor16(lnk); lnl=r8tor16(lnl); call olsq( lnq lnk lnl :rr 1 :print); call tabulate(%rrobs,%ssr1,%ssr2,%rr,%rrstd,%res); call print('Sum of squares of std RR ',sumsq(goodrow(%rrstd)):); call print('Sum of squares of OLS RES ',sumsq(goodrow(%res)):); call print(%rrcoef,%rrcoeft); %rrstd=r16tor8(%rrstd); %rss =r16tor8(%rss ); %ssr1 =r16tor8(%ssr1 ); %ssr2 =r16tor8(%ssr2 ); call rrplots(%rrstd,%rss,%nob,%k,%ssr1,%ssr2,1); call names(all); %b34sendif; b34srun; == ==OLSQ_16 Real*8 and Real*16 results b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ Illustrates real*8 and Real*16 OLSQ b34sexec matrix; call loaddata; call olsq(gasout gasin{0 to 3} :l1 :minimax :print :diag); call olsq(gasout gasin{0 to 3} :qr :print :diag); call olsq(gasout gasin{0 to 3} :rr 3 :print :diag); rr1 =r8tor16(%rr); rrcoef1=r8tor16(%rrcoef); gasout=r8tor16(gasout); gasin =r8tor16(gasin); call print('++++++++++++++ Real*16 +++++++++++++++++++':); call olsq(gasout gasin{0 to 3} :l1 :minimax :print :diag); call olsq(gasout gasin{0 to 3} :qr :print :diag); call olsq(gasout gasin{0 to 3} :rr 3 :print :diag); rr2 =%rr; rrcoef2=%rrcoef; d1=rr1-rr2; d2=rrcoef1-rrcoef2; call print(d1,d2); b34srun; == ==OLSQ_MASK Illustration of MASK b34sexec scaio readsca /$ file('/usr/local/lib/b34slm/findat01.mad') file('c:\b34slm\examples\findat01.mad') dataset(d_gnp82); b34srun; b34sexec matrix; call loaddata; call names; call olsq(d_gnp82 d_gnp82{1 to 2} :savex :print); * replicate Pena-Tiao-Tsay (2002) page 276 - 279 ; mask1=(%x(,2).le.0.0); mask2=(%x(,2).gt.0.0); * replicate Pena-Tiao-Tsay(2002) page 279 ; mask11=((%x(,1).le.%x(,2)).and.(%x(,2).le.0.0)); mask21=((%x(,1).gt.%x(,2)).and.(%x(,2).le.0.0)); mask31=((%x(,1).le.%x(,2)).and.(%x(,2).gt.0.0)); mask41=((%x(,1).gt.%x(,2)).and.(%x(,2).gt.0.0)); * adjust mask11,mask31, mask41 for length; * Note that these equations have only one lag!!; * 0.0 in obs # 1 of mask => that that obs is killed; nnew=norows(mask11)+1; mask11(nnew)=0.0; mask11=rolldown(mask11); mask31(nnew)=0.0; mask31=rolldown(mask31); mask41(nnew)=0.0; mask41=rolldown(mask41); call tabulate(mask11,mask21,mask31,mask41); call olsq(d_gnp82 d_gnp82{1 to 2} :sample mask1 :print); call olsq(d_gnp82 d_gnp82{1 to 2} :sample mask2 :print); call olsq(d_gnp82 d_gnp82{1 } :sample mask11 :print); call olsq(d_gnp82 d_gnp82{1 to 2} :sample mask21 :print); call olsq(d_gnp82 d_gnp82{1 } :sample mask31 :print); call olsq(d_gnp82 d_gnp82{1 } :sample mask41 :print); b34srun; == ==OLSQ_FOR Illustrates HOLDOUT capability /$ Illustrates holdout forecasting b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; dor16=0; printx=0; maxi=9; holdback=40; j=integers(norows(gasout)-holdback,norows(gasout)); actual=gasout(j); sumsqe =vfam(maxi:); sumsqe2=vfam(maxi:); do i=1,maxi; call olsq(gasout gasin{1 to i} gasout{1 to i} :holdout holdback :savex :print); if(printx.ne.0)then; call print(%xfuture,%x); call names; endif; fore=%xfuture*%coef; call tabulate(%xfobs,fore); error=fore-vfam(actual); call graph(fore,actual); call graph(error); call print('for lag ',i:); call print('Sum squared out of sample Error ',sumsq(error)); sumsqe(i)=sumsq(error); sumsqe2(i)=%rss; enddo; nlags=integers(1,maxi); call print('sumsqe out of sample - sumsqe2 in sample':); call tabulate(nlags,sumsqe,sumsqe2); if(dor16.ne.0)then; gasin16 =r8tor16(gasin); gasout16=r8tor16(gasout); actual16=r8tor16(actual); sumsqe =r8tor16(sumsqe); sumsqe2 =r8tor16(sumsqe2); call print('Real*16 results':); call print('+++++++++++++++++++++++++++++++++++++++':); do i=1,maxi; call olsq(gasout16 gasin16{1 to i} gasout16{1 to i} :holdout holdback :savex :print); if(printx.ne.0)then; call names; call print(%xfuture,%x); endif; fore=%xfuture*%coef; call tabulate(%xfobs,fore); call print('for lag ',i:); call print('Sum squared out of sample Error ',sumsq(error)); enddo; call print('sumsqe out of sample - sumsqe2 in sample':); call tabulate(nlags,sumsqe,sumsqe2); endif; b34srun; == ==OLS_DOLS Illustrates Future on right /; /; DOLS Models are of the form /; y = f(x{-6 to 6}) /; /; This job illustrates a number of real*8 and real*16 jobs that /; have such a structure. /; %b34slet dorats=1; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; /; usual case call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); /; future only call olsq(gasout gasin{-1} :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); /; Lags both directions m6=-6; m1=-1; call olsq(gasout gasin{m6 to 6} gasout{m6 to m1} gasout{1 to 6} :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); /; alternative Call call olsq(gasout gasin{-6 to 6} gasout{-6 to sfam(-1)} gasout{1 to 6} :print :savex); /; holdout call print('****************************************************':); call print('**************** Holdout Test Cases ****************':); call print('****************************************************':); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :holdout 10 :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); call print(%xfuture,%xfobs); predict=%xfuture*%coef; call tabulate(%xfobs predict); /; future only call olsq(gasout gasin{-1} :print :savex :holdout 10); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); call print(%xfuture,%xfobs); predict=%xfuture*%coef; call tabulate(%xfobs predict); /; Lags both directions call olsq(gasout gasin{-6 to 6} gasout{-6 to sfam(-1)} gasout{1 to 6} :print :savex :holdout 10); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); call print(%xfuture %xfobs); predict=%xfuture*%coef; call tabulate(%xfobs predict); gasout=r8tor16(gasout); gasin =r8tor16(gasin); call olsq(gasout gasin{-6 to 6} gasout{-6 to sfam(-1)} gasout{1 to 6} :print :savex :holdout 10); call print(%xfuture %xfobs); predict=%xfuture*%coef; call tabulate(%xfobs predict); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('++++++++++++++++++++ Real*16 +++++++++++++++++++++++':); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++':); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); /; future only call olsq(gasout gasin{-1} :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); /; Lags both directions call olsq(gasout gasin{-6 to 6} gasout{-6 to sfam(-1)} gasout{1 to 6} :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); /; holdout call print('****************************************************':); call print('**************** Holdout Test Cases ****************':); call print('****************************************************':); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :holdout 10 :print :savex); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); call print(%xfuture,%xfobs); predict=%xfuture*%coef; call tabulate(%xfobs predict); /; future only call olsq(gasout gasin{-1} :print :savex :holdout 10); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); call print(%xfuture %xfobs); predict=%xfuture*%coef; call tabulate(%xfobs predict); /; Lags both directions call olsq(gasout gasin{-6 to 6} gasout{-6 to sfam(-1)} gasout{1 to 6} :print :savex :holdout 10); call print(inv(transpose(%x)*%x)*transpose(%x)*%y); call print(%xfuture %xfobs); predict=%xfuture*%coef; call tabulate(%xfobs predict); b34srun; %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 'Version ' %ratsversion()" '* ') $ PGMCARDS$ * linreg gasout # constant gasin{1 to 6} gasout{1 to 6} linreg gasout # constant gasin{-1} linreg gasout # constant gasout{-6 to -1} gasout{1 to 6} gasin{-6 to 6} b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ == ==OLSQ_OUT Outlier Detection /; /; This job identifies that observation 19 seems to make a difference /; The Jackknife Coef bias and SE is also listed /; %b34slet runsas=0; %b34slet runr16=1; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call olsq(lnq lnl lnk :print :outlier ); /; get SAS defits and std of error newt=afam(%coef)/afam(%se_jack); call tabulate(%coef,%b_bias,%se,%se_jack,%t,newt); %defits2=(afam(%yhat)-afam(%yhat_i))/dsqrt(afam(%resvari)*afam(%hi)); %std2_e =afam(%y-%yhat)/dsqrt(afam(%resvari)*afam(1.0-%hi)); call tabulate(%hi,%hi_i,%std_e,%std2_e,%e_i,%defits,%defits2,%e2_i, %yhat_i,%resvari); call print(%beta_i); call graph(%hi,%hi_i :nolabel); call graph(%std_e,%std2_e :nolabel); call graph(%defits %defits2 :nolabel); call graph(%resvari :nolabel); call graph(%e_i %e2_i :nolabel); %b34sif(&runr16.eq.1)%then; lnq=r8tor16(lnq); lnl=r8tor16(lnl); lnk=r8tor16(lnk); call olsq(lnq lnl lnk :print :outlier :print); newt=afam(%coef)/afam(%se_jack); call tabulate(%coef,%b_bias,%se,%se_jack,%t,newt); call tabulate(%hi,%hi_i,%std_e,%std2_e,%e_i,%defits,%defits2,%e2_i, %yhat_i,%resvari); call print(%beta_i); %b34sendif; b34srun; %b34sif(&runsas.eq.1)%then; b34sexec options open('testsas.sas') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=29 icntrl=29$ sas $ * sas commands next ; pgmcards$ proc reg; model lnq=lnk lnl/ influence; run; b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos('start /w /r sas testsas' ) dounix('sas testsas' ) $ b34srun$ b34sexec options npageout noheader writeout(' ','output from sas',' ',' ') writelog(' ','output from sas',' ',' ') copyfout('testsas.lst') copyflog('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==OLSQ_ALT Alternate Approaches to OLS Estimation /$ /$ Illustrates various approaches to obtaining OLS /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(svd_ols :staging); call load(svd2_ols :staging); /; svd_ols uses LINPACK /; svd2_ols uses LAPACK call print(svd_ols); call print(svd2_ols); /; call svd_ols(y,x,u,v,s,beta_svd,se_svd,pc_coef,sigmasq,ibad); /; /; y => left hand side /; x => right hand side /; u => left hand side of SVD /; v => transpose of right hand side svd. /; x => u * diagmat(s)*V /; s => singular values /; beta_svd => SVD Beta Coef /; se_svd => SE of SVD beta coef /; pc_coef => PC Coef /; sigmasvd => sigmasq from SVD /; call echooff; subroutine try(y,x,beta,type); if(type.eq.1)then; beta=inv(transpose(x)*x ) *transpose(x)*y; endif; if(type.eq.2)then; beta=inv(transpose(x)*x :gmat ) *transpose(x)*y; endif; if(type.eq.3)then; beta=inv(transpose(x)*x :refine) *transpose(x)*y; endif; if(type.eq.4)then; beta=inv(transpose(x)*x :refinee)*transpose(x)*y; endif; if(type.eq.5)then; beta=inv(transpose(x)*x :pdmat2) *transpose(x)*y; endif; if(type.eq.6)then; beta=inv(transpose(x)*x :pdmat ) *transpose(x)*y; endif; if(type.eq.7)then; beta=inv(transpose(x)*x :smat ) *transpose(x)*y; endif; if(type.eq.8)then; call svd_ols(y,x,u,v,s,beta,se_svd,pc_coef,sigmasq,ibad); endif; if(type.eq.9)then; call svd2_ols(y,x,u,v,s,beta,se_svd,pc_coef,sigmasq,ibad); endif; return; end; call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Testing Eleven ways to get OLS Coef'); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print(' ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8. ':); call print('All Calculations in real*8 ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call real16off; call real16info; call print(' ':); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print ); coef1=%coef; se1=%se; call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print :qr :savex); call svd_ols(%y,%x,u,v,s, beta1svd,se1svd,pc_coef,resvar1,ibad); call svd2_ols(%y,%x,u,v,s,beta2svd,se2svd,pc_coef,resvar2,ibad); call tabulate(coef1, %coef,beta1svd,beta2svd,se1,%se,se1svd,se2svd :title 'OLS Coef and SE using four methods'); call print(%resvar,resvar1,resvar2); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); hold=matrix(norows(%coef),11:); hold(,1)= coef1; hold(,2)=%coef; rss=array(11:); do i=1,9; call try(%y,%x,beta,i); j=i+2; hold(,j)=beta; enddo; testdiff=matrix(norows(hold),nocols(hold)-2:); if(kind(beta).eq.8)then; do i=1,9; testdiff(,i)=hold(,2)-hold(,i+2); enddo; call print(hold); call print('Shows how far from QR result', 'col1 = inv(transpose(x)*x ) *transpose(x)*y' 'col2 = inv(transpose(x)*x :gmat ) *transpose(x)*y' 'col3 = inv(transpose(x)*x :refine ) *transpose(x)*y' 'col4 = inv(transpose(x)*x :refine ) *transpose(x)*y' 'col5 = inv(transpose(x)*x :pdmat2 ) *transpose(x)*y' 'col6 = inv(transpose(x)*x :pdmat ) *transpose(x)*y' 'col7 = inv(transpose(x)*x :smat ) *transpose(x)*y' 'col8 = SVD Linpack ' 'col9 = SVD Lapack ' testdiff); call print('Residual Sum of Squares for various approaches' 'col1 = B34S call OLSQ using Linpack Chosleky ' 'col2 = B34S call OLSQ using LINPACK QR ' 'col3 = inv(transpose(x)*x ) *transpose(x)*y' 'col4 = inv(transpose(x)*x :gmat ) *transpose(x)*y' 'col5 = inv(transpose(x)*x :refine ) *transpose(x)*y' 'col6 = inv(transpose(x)*x :refinee) *transpose(x)*y' 'col7 = inv(transpose(x)*x :pdmat2 ) *transpose(x)*y' 'col8 = inv(transpose(x)*x :pdmat ) *transpose(x)*y' 'col9 = inv(transpose(x)*x :smat ) *transpose(x)*y' 'col10= SVD Linpack ' 'col11= SVD Lapack '); do i=1,11; rss(i)=afam(sumsq(%y-%x*hold(,i))); call fprint(:clear :col 10 :display i :col 30 :display rss(i) '(g25.16)' :print); enddo; endif; b34srun; == ==OLSQ_LAGS Shows future lags /; /; Shows y = a + b*x{-n to n} /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; n=2; lagout=lag(gasout,n); call tabulate(gasout,gasin); call olsq(lagout gasin{0 to 2*n} : print :savex ); k=nocols(%x)+1; %x(,k)=%y; call print(%x); b34srun; == ==OLSQ_WLS Weighted Regression using B34S, Stata, RATS /; /; B34S-Stata-Rats /; b34sexec matrix; * tests weighted regression ; * illustrates how weighted least squares can give "significance"; n=10000; k=4; y=rn(array(n:)); w=abs(rn(array(n:))); x=rn(array(n,k:)); /; /; OLS Model /; /; quick way to go t0 weighted least squares assuming /; vector or matrix input call olsq(y x :print :savex); ww=1./afam(sqrt(w)); %xnew=transpose(transpose(afam(%x))*ww); %ynew=afam(%y)*ww; call print('Weighted Least Squares':); call olsq(%ynew %xnew :noint :print); /; pass data to test WLS with Stata and Rats call dmfput(y,w :file 'file_1.dmf' :member file1 :comment 'y and w for weighted regression test' ); call dmfput(x :file 'file_2.dmf' :member file2 ); b34srun; /; /; test reading the save /; b34sexec data file('file_1.dmf') filef=fdmf dmfmember(file1) ; b34srun; b34sexec data file('file_2.dmf') filef=fdmf dmfmember(file2) ; b34srun; /; /; Merge the two DMF files /; b34sexec merge file1('file_1.dmf') file2('file_2.dmf') file3('file_3.dmf') member1(file1) member2(file2) member3(file3) outfmt=formatted /; comment('Test of effect of Weighted Regression') ; b34srun; /; /; illustrate a read of a DMF into the matrix Command /; b34sexec matrix; call dmfget(:file 'file_3.dmf' :member file3 :print); b34srun; /; b34sexec data file('file_3.dmf') filef=fdmf; b34srun; /; /; This is the best way to go /; b34sexec options open('statdata.do') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options open('stata.do') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall idata=28 icntrl=29$ stata$ pgmcards$ // uncomment if do not use /e // log using stata.log, text // describe regress y m1* regress y m1* [aw=1/w] b34sreturn$ b34seend$ b34sexec options close(28); b34srun; b34sexec options close(29); b34srun; b34sexec options dodos('stata /e do stata.do stata.log'); b34srun; b34sexec options npageout writeout('output from stata',' ',' ') copyfout('stata.log') dodos('erase stata.do','erase stata.log','erase statdata.do') $ b34srun$ /$ user places RATS commands between /$ PGMCARDS$ /$ note: user RATS commands here /$ B34SRETURN$ /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * linreg y # constant m1col__1 m1col__2 m1col__3 m1col__4 linreg(spread=w) y # constant m1col__1 m1col__2 m1col__3 m1col__4 b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun; == ==OLSQ_GLS OLS-NW tests-GLS-MARSPLINE-NW-tests-GLS b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; /; b34sexec options /; OLS /; NE stat on the OLS /; GLS /; MARSPLINE /; Do NW on the MARSPLINE coef /; GLS on the MARSPLINE vectors b34sexec matrix; call loaddata; call load(gls :staging); call load(rnw_se :staging); call echooff; call olsq(lnq lnl lnk lnrm2 :print :savex); iprint=2; damp=1.; lagnw=4; call rnw_se; call glsset; %maxgls=2; %nl2sol=0; %plot=1; call gls; call print('Now look at MARSPLINE':); _knots=20; _mi=1; _df=2.0; call marspline(lnq lnl lnk lnrm2 :mathform :print :nk _knots :mi _mi :df _df :savemodel :xx); call olsq(lnq %xx :print :noint :qr :savex); iprint=2; damp=1.; lag=4; call rnw_se; call print('GLS on the MARS vectors':); call glsset; call gls; b34srun; == ==OUTDOUBLE Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE b34sexec matrix; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); /$ clear message call cls(2); call outstring(3,3,'This is at 3,3',:); call cls(4); call outstring(3,4,'This is at 3,4'); call cls(5); call outstring(3,5,'This is at 3,5'); call cls(6); call outstring(3,6,'int 123 at 40,6'); jj=123; call outinteger(40,6,jj); call stop(pause); xx=dsqrt(12.88); call outstring(3,2,'(12.88)**.5 printed on 3-6 rows'); do i=3,6; call cls(i); call outdouble(3,i,xx); enddo; call stop(pause); b34srun; == ==OLSQWEIGHT Weighted Regression b34sexec data heading('Rats/NIST LOWESS Data'); * LOWESS.PRG ; * Example from the NIST Engineering Statistics Handbook ; * http://www.itl.nist.gov/div898/handbook/pmd/section1/dep/dep144.htm; * ; input seq x y; datacards; 1 0.5578196 18.63654 2 2.0217271 103.49646 3 2.5773252 150.35391 4 3.4140288 190.51031 5 4.3014084 208.70115 6 4.7448394 213.71135 7 5.1073781 228.49353 8 6.5411662 233.55387 9 6.7216176 234.55054 10 7.2600583 223.89225 11 8.1335874 227.68339 12 9.1224379 223.91982 13 11.9296663 168.01999 14 12.3797674 164.95750 15 13.2728619 152.61107 16 14.2767453 160.78742 17 15.3731026 168.55567 18 15.6476637 152.42658 19 18.5605355 221.70702 20 18.5866354 222.69040 21 18.7572812 243.18828 b34sreturn; b34srun; b34sexec matrix; call loaddata; xx=x*x; call olsq(y x xx :print :savex); call olsq(y x xx :print :savex :weight seq); call olsq(y x xx :print :savex :weight seq :qr); call print(y,%y,x,%x); y16=r8tor16(y); x16=r8tor16(x); xx16 = r8tor16(xx); seq16=r8tor16(seq); call olsq(y16 x16 xx16 :print :savex); call olsq(y16 x16 xx16 :print :savex :weight seq16); call olsq(y16 x16 xx16 :print :savex :weight seq16 :qr); call names(all); /; /; Test model estimation - Note Constant is adjusted!! /; adj= (1./dsqrt(seq)) ; ny = y * adj ; nx = x * adj ; nxx= xx* adj ; call tabulate(y,ny,x,nx,xx,nxx,adj); call olsq(ny nx nxx adj :print :noint); /; lags call olsq(y x xx{1 to 2} :print :savex :weight seq); call olsq(y16 x16 xx16{1 to 2} :print :savex :weight seq16); ny(1) = missing(); ny(2) = missing(); nx(1) = missing(); nx(2) = missing(); nxxl1 = nxx; nxxl2 = nxx; nxxl1(1) = missing(); nxxl1(21)= missing(); nxxl2(20)= missing(); nxxl2(21)= missing(); adj(1) = missing(); adj(2) = missing(); ny = goodrow(ny); nx = goodrow(nx); nxxl1 = goodrow(nxxl1); nxxl2 = goodrow(nxxl2); adj = goodrow(adj); call tabulate(y,ny x,nx,xx,nxx,nxxl1,nxxl2,adj); call olsq(ny nx nxxl1 nxxl2 adj :print :noint); b34srun; == ==OLSQ_CONST Constrained OLS b34sexec matrix; /; /; Constraint is of the form r=R*Bstar /; Bstar is the new coef vector. /; Bstar=Con_b defined below. /; We assume b1+b2+b3=1 and b1=-b2 /; /; Example where we use Theil (1971 page 44) to illustrate /; Constrained Least squares. OLS Coef should be 1.0 /; n=10000; k=3; x=rn(matrix(n,k:)); beta=matrix(k,1:); beta(,1)=1.0; y=10.*rn(matrix(n,1:))+x*beta; ols_b=inv(transpose(x)*x)*transpose(x)*y; ols_e=y-x*ols_b; /$ Constraint is where all coef sum to 1.0 /$ coef 2 = -1 * coef 1 small_r=matrix(2,1:1.0,0.0); r =matrix(2,3:1. 1. 1. 1.,1. 0.); xpxinv = inv(transpose(x)*x); con_b = ols_b + xpxinv*transpose(r)*inv(r*xpxinv*transpose(r)) * (small_r-r*ols_b); con_e=y-x*con_b; call print(small_r r,ols_b,con_b,sumsq(ols_e),sumsq(con_e)); b34srun; == ==OUTINTEGER Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE b34sexec matrix; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); /$ clear message call cls(2); call outstring(3,3,'This is at 3,3',:); call cls(4); call outstring(3,4,'This is at 3,4'); call cls(5); call outstring(3,5,'This is at 3,5'); call cls(6); call outstring(3,6,'int 123 at 40,6'); jj=123; call outinteger(40,6,jj); call stop(pause); xx=dsqrt(12.88); call outstring(3,2,'(12.88)**.5 printed on 3-6 rows'); do i=3,6; call cls(i); call outdouble(3,i,xx); enddo; call stop(pause); b34srun; == ==OUTSTRING Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE b34sexec matrix; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); /$ clear message call cls(2); call outstring(3,3,'This is at 3,3',:); call cls(4); call outstring(3,4,'This is at 3,4'); call cls(5); call outstring(3,5,'This is at 3,5'); call cls(6); call outstring(3,6,'int 123 at 40,6'); jj=123; call outinteger(40,6,jj); call stop(pause); xx=dsqrt(12.88); call outstring(3,2,'(12.88)**.5 printed on 3-6 rows'); do i=3,6; call cls(i); call outdouble(3,i,xx); enddo; call stop(pause); b34srun; == ==OUTPUTON Turn on output b34sexec matrix; call echooff; call epprint('This will show in log'); call logoff; call epprint('This will show in the output only'); call outputoff; call epprint('This will never be seen.'); call logon; call outputon; call epprint('This will be seen in both log and output'); b34srun; == ==OUTPUTOFF Turn off output b34sexec matrix; call echooff; call epprint('This will show in log'); call logoff; call epprint('This will show in the output only'); call outputoff; call epprint('This will never be seen.'); call logon; call outputon; call epprint('This will be seen in both log and output'); b34srun; == ==OVERVIEW Shows Programing with Object Oriented Language b34sexec matrix; /$ call echooff; call print('The B34S MATRIX Command is demonstrated.', 'Objects are built and transformed.'); n=4; a= array(n:integers(1,n)); v=vector(n:integers(1,n)); ax=rn(array(4,4:)); mx=rn(matrix(4,4:)); call print(a,v,ax,mx ' ' 'Inverse of mx (1./mx)' (1./mx), ' ' 'Test inverse by mx * (1./mx) ' mx * (1./mx) ' ' 'Better test. See largest error' 'dmax((matrix(n,n:)+1.)-(mx*(1./mx))) ' dmax((matrix(n,n:)+1.)-(mx*(1./mx))) ); call print(' ','Structured Index'); n=6; x=rn(matrix(n,n:)); call print(x); row1mean=mean(x(1,)); col1mean=mean(x(,1)); row2sum=sum(x(2,)); col2sum=sum(x(,2)); call tabulate(row1mean col1mean row2sum col2sum); call print(' '); call print('Matrix Commands are illustrated with complete jobs.'); call print('The file c:\b34slm\lib\matrix2.mac contains subroutines.'); * Variable Expansion - Real*8 and Character*8 examples; r(1)=10.; c(1)='test1234'; call print('Printing char*8 and real*8',c,r); r(2)=20.; c(2)='aa'; call print('Printing char*8 and real*8',c,r); * simple graphics; n=100; x=dfloat(integers(1,n)); ss=dsin(x); cc=dcos(x); call graph(ss,cc); b34srun; == ==OVERVIEW_1 Illustrates Structured Index b34sexec matrix; /$ Illustrates structured index i=integers(10,20); test=array(20:); x=rn(test); j=i-9; test(j)=x(i); call tabulate(i,test,x); /$ Complex Case c=complex(x,dsqrt(dabs(x))); cc=c*complex(1.0,0.0); call print('Before ',c,cc); cc(j)=c(i); call print('After cc(j)=c(i)'); call tabulate(i,j,c,cc); x=matrix(2,2:1. 2. 3. 4.); c=complex(x,dsqrt(x)); cc1=c*complex(0.,1.); cc2=c*complex(1.,0.); cc3=c*complex(1.,1.); cc4=c*complex(0.,0.); call print(c,cc1,cc2,cc3,cc4); b34srun; == ==OVERVIEW_2 Advanced Structured Index Processing Examples /$ Illustrates Structural Index Processing b34sexec matrix; x =rn(matrix(6,6:)); y =matrix(6,6:); yy =matrix(6,6:); z =matrix(6,6:); zz =matrix(6,6:); i=integers(4,6); j=integers(1,3); xhold=x; hold=x(,i); call print('cols 4-6 x go to hold',x,hold); y(i, )=xhold(j,); call print('Rows 1-3 xhold in rows 4-6 y ',xhold,y); y=y*0.0; j2 =xhold(j,); y(i, )=j2 ; call print('Rows 1-3 xhold in rows 4-6 y ',xhold,y); z(,i)=xhold(,j); call print('cols 1-3 xhold in cols 4-6 z ',xhold,z); j55 =xhold(,j); z=z*0.0; z(,i)=j55; call print('cols 1-3 xhold in cols 4-6 z ',xhold,z); yy=yy*0.0; yy(i,)=xhold; call print('rows 1-3 xhold in rows 4-6 yy',xhold,yy); zz=zz*0.0; do ii=1,3; jj=ii+3; zz(,jj)=xhold(ii,); enddo; /; i=integers(4,6); /; j=integers(1,3); call print('Note that zz(,i)= xhold(j,) will not work':); call print('Testing zzalt(,i)= transpose(xhold(j,))':); /; Use of Transpose speeds things up over do loop zzalt=zz*0.0; zzalt(,i)= transpose(xhold(j,)) ; call print('rows 1-3 xhold in cols 4-6 zz',xhold,zz,zzalt); zz=zz*0.0; zzalt=zz; do ii=1,3; jj=ii+3; zz(jj,)=xhold(,ii); enddo; call print('Note that zz(i,)=xhold(,j) will not work':); call print('Testing zzalt(i,)= transpose(xhold(,j))':); zzalt(i,)=transpose(xhold(,j)); call print('cols 1-3 xhold in rows 4-6 zz',xhold,zz,zzalt); oldx=rn(matrix(20,6:)); newx= matrix(20,5:); i=integers(4); newx(,i)=oldx(,i); call print('Col 1-4 in oldx goes to newx',oldx,newx); oldx=rn(matrix(20,6:)); newx= matrix(20,5:); i=integers(4); newx(1,i)=oldx(1,i); call print('This puts the first element in col ',oldx,newx); newx=newx*0.0; newx(i,1)=oldx(i,1); call print('This puts the first element in row ',oldx,newx); newx=newx*0.0; newx( ,i)=oldx( ,i); call print('Whole col copied here',oldx,newx); oldx=rn(matrix(10,5:)); newx= matrix(20,5:); i=integers(4); newx(i,1)=oldx(i,1); call print('This puts the first element in row ',oldx,newx); newx=newx*0.0; newx(i,)=oldx(i,); call print('Whole row copied',oldx,newx); * We subset a matrix here ; a=rn(matrix(10,5:)); call print('Pull off rows 1-3, cols 2-4', a,a(integers(1,3),integers(2,4))); b34srun; == ==OVERVIEW_3 Looks at Regression Calculations using Moment Matrix b34sexec data heading('Goldberger(1964) page 187'); * This Job is Based on a classic example in Goldberger (1964) ; * From the Raw Moment Matrix we get OLS Coef, SE, Res Var etc.; * All calculations are inside matrix mm defined as; * Transpose(bigx)*bigx where we define bigx as ; * bigx = catcol(constant x1 x2 x3 y) ; input x1 x2 x3 y; * x3 changed from 113 to 118 to make it agree with Checksum; build check; gen check=1. + x1 + x2 + x3 + y; datacards; 47 54 1 142 43 59 2 127 39 57 3 118 34 48 4 98 34 36 5 94 36 24 6 102 38 19 7 116 41 18 8 128 42 22 9 140 37 24 10 131 40 23 11 143 42 27 12 157 47 36 13 182 51 9 18 209 53 25 19 214 53 39 20 225 50 51 21 221 52 62 22 243 54 75 23 257 54 94 24 265 55 108 25 276 52 118 26 271 54 124 27 291 b34sreturn; b34srun; b34sexec matrix; call loaddata; call tabulate(constant,x1 x2 x3,y,check); call olsq(y x1 x2 x3 :print); y=mfam(y); x1=mfam(x1); x2=mfam(x2); x3=mfam(x3); constant=mfam(constant); x =catcol(constant,x1,x2,x3); bigx=catcol(constant,x1,x2,x3,y); cprod=transpose(bigx)*bigx; xpx=transpose(x)*x; call print(bigx); ols1=inv(transpose(x)*x)*transpose(x)*y; /$ /$ Get b from raw moment matrix see Golberger page 188 /$ call print('Partition cprod as ' 'm(xx) m(xy) ' ' 0 tranpose(y)*y '); k=norows(cprod)-1; call print('Raw Moment Matrix as discussed in Goldberger',cprod); m_xx=submatrix(cprod,1,k,1,k); m_xy=submatrix(cprod,1,k,k+1,k+1); m_yy=cprod(k+1,k+1); call print('M_xx & M_xy M_yy',m_xx,m_xy,m_yy); ols2=inv(submatrix(cprod,1,k,1,k))*submatrix(cprod,1,k,k+1,k+1); call print('Getting OLS from the moment matrix',ols1,ols2); Call print('Get the Total Sum of squares as transpose(beta)*m_xy'); call print('Total Sum of Squares ',transpose(ols2)*m_xy:); tss=transpose(ols2)*m_xy; call Print('Residual Sum of squares ',m_yy-tss:); call print('Now we get the Residual Variance ', (m_yy-tss)/dfloat(norows(x1)-k):); sigmasq=(m_yy-tss)/dfloat(norows(x1)-k); call print('Get SE of coef still using Moment Matrix', 'First we get Variance Covariance of Beta'); v_c_beta=sfam(sigmasq)*inv(m_xx); call print(v_c_beta); call print('SE from the diagonal' dsqrt(diag(v_c_beta))); /$ Now we look at x and make some more calculations xpy=transpose(x)*y; call print(cprod,xpx,xpy,ols1); /$ Get Variance Covariance using M call print(' ' 'Define Idempotent matrix M. Diagonal = 1-(1/n). Off Diag -(1/n)':); n=norows(x1); i=matrix(n,1:vector(n:)+1.); /$ Get mean two ways using M mm1=mean(x1); mm2=mean(x2); mm3=mean(x3); mmy=mean(y); call print('Means from the Mean Command ',mm1,mm2,mm3,mmy); meanmm1=i*transpose(i)*x1/dfloat(norows(x1)); meanmm2=i*transpose(i)*x2/dfloat(norows(x1)); meanmm3=i*transpose(i)*x3/dfloat(norows(x1)); meanmmy=i*transpose(i)*y /dfloat(norows(x2)); call print('Means from M ',meanmm1,meanmm2,meanmm2,meanmm3,meanmmy); bigi=matrix(n,n:)+1.; m=bigi-(1.0/dfloat(n))*i*transpose(i); sumsqdev=x1*transpose(m)*m*x1; call print(' ' 'We test if M is idempotent':); call print('m',m,transpose(m)*m,m*m, ' ' 'Have we calculated the sum of squared deviations about mean using M?' sumsqdev,variance(x1)*(dfloat(n)-1.) ' ' 'Now we use M to get the variance-covariance' ' '); vcov=transpose(bigx)*m*bigx; call print('Varcov ',vcov); call print('We test if the varcov is correct':); call print('We look at x1 x2 and y':); call print('sum(x1(i)-mean(x1))**2.)',sumsq(x1-mean(x1)):); call print('sum(x2(i)-mean(x2))**2.)',sumsq(x2-mean(x2)):); call print('sum(x3(i)-mean(x3))**2.)',sumsq(x3-mean(x3)):); call print('sum(y(i)-mean(y))**2.)', sumsq(y-mean(y)):); call print('sum(((x(i)-mean(x))*(y(i)-mean(y)))', ddot((x1-mean(x1)),(y -mean(y ))), ddot((x2-mean(x2)),(y -mean(y ))), ddot((x3-mean(x3)),(y -mean(y ))), ddot((x1-mean(x1)),(x2-mean(x2))), ddot((x1-mean(x1)),(x3-mean(x3))), ddot((x2-mean(x2)),(x3-mean(x3))) ); b34srun; == ==PC_REG Principle Component Regression /; Illustrates use of PC as a shrinkage technique 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; == ==PLS_REG PLS Regression Vs PC Regression b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(pls_reg); call load(pc_reg); call echooff; nn=6; call olsq(gasout gasin{1 to nn} gasout{1 to nn} :print :savex); ols_coef=%coef; ols_rss =%rss; iprint=1; iprint=1; call pc_reg(%y,%x,ols_coef,ols_rss,tss,pc_coef, pcrss,pc_size,u,iprint); jj=integers(norows(pcrss),1,-1); pc_rss=pcrss(jj); ncompmax=13; call pls_reg(%y,%x,pls_coef,xload,yload,xscores, yscores,weights,yhat,error_pls,pls_rss,ncompmax,iprint); call tabulate(pc_rss,pls_rss); call print(pls_coef); call graph(pls_rss pc_rss :nocontact :pgborder :grid :nolabel :file 'pc_pls_rss.wmf' :heading 'Residual Sum of Squares vs # PLS/PC components'); b34srun; == ==PLS_REG2 PLS Regression when no multicollinearity b34sexec matrix; call echooff; call load(pls_reg); call load(pc_reg); nn=10000; kk=25; x= rn(array(nn,kk:)); y=sumrows(x)+1.0 +rn(array(nn:)); call olsq(y x :print :savex); ols_coef=%coef; ols_rss =%rss; iprint=1; iprint=1; call pc_reg(%y,%x,ols_coef,ols_rss,tss,pc_coef, pcrss,pc_size,u,iprint); jj=integers(norows(pcrss),1,-1); pc_rss=pcrss(jj); ncomp=13; call pls_reg(%y,%x,plscoef,xload,yload,xscores, yscores,weights,yhat,error_pls,pls_rss,ncomp,iprint); b34srun; == ==PLS1_REG Substantially faster code b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(pls1_reg); call load(pc_reg); call echooff; nn=6; call olsq(gasout gasin{1 to nn} gasout{1 to nn} :print :savex); ols_coef=%coef; ols_rss =%rss; iprint=1; call pc_reg(%y,%x,ols_coef,ols_rss,tss,pc_coef, pcrss,pc_size,u,iprint); jj=integers(norows(pcrss),1,-1); pc_rss=pcrss(jj); /; /; Note: Use caution changing gamma for pls1_reg /; gamma = 0 => OLS /; gamma = 1 => PLS /; gamma > 1 => increasing multicolinearity in /; dataset /; gamma < 1 => decrease multicolinearity in /; dataset /; ncompmax=13; /; /; Setup for pls /; gamma=1.0; call pls1_reg(%y,%x,y0,x0,r,c,,u,v,s,pls2coef,yhat, pls_res,pls_rss, ncompmax,gamma,iprint); /; /; Various tests of internal calculations /; /; t=x0*r; /; call print('cmh ',(y0*T)); /; call print(y0,t); /; yhat2=(t*(y0*t)) + mean(%y); /; yhat3=(x0*r)*(y0*(x0*r))+mean(%y); /; call tabulate(yhat,yhat2,yhat3); call tabulate(pc_rss,pls_rss); call graph(pls_rss pc_rss :nocontact :pgborder :grid :nolabel :file 'pc_pls_rss.wmf' :heading 'Residual Sum of Squares vs # PLS/PC components'); b34srun; == ==PLS1_REG2 Alternative PLS Regression Code b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(pls_reg); call load(pls1_reg); call load(pc_reg); call echooff; nn=6; call olsq(gasout gasin{1 to nn} gasout{1 to nn} :print :savex); ols_coef=%coef; ols_rss =%rss; iprint=1; call pc_reg(%y,%x,ols_coef,ols_rss,tss,pc_coef, pcrss,pc_size,u,iprint); jj=integers(norows(pcrss),1,-1); pc_rss=pcrss(jj); /; /; Note: Use caution changing gamma for pls1_reg /; gamma = 0 => OLS /; gamma = 1 => PLS /; gamma > 1 => increasing multicolinearity in dataset /; gamma < 1 => decrease multicolinearity in dataset /; ncompmax=13; gamma=1.0; call pls1_reg(%y,%x,y0,x0,r,c,,u,v,s,pls_coef,yhat,pls_res,pls_rss, ncompmax,gamma,iprint); /; /; Various tests of internal calculations /; /; t=x0*r; /; call print('cmh ',(y0*T)); /; call print(y0,t); /; yhat2=(t*(y0*t)) + mean(%y); /; yhat3=(x0*r)*(y0*(x0*r))+mean(%y); /; call tabulate(yhat,yhat2,yhat3); call tabulate(pc_rss,pls_rss); call graph(pls_rss pc_rss :nocontact :pgborder :grid :nolabel :file 'pc_pls_rss.wmf' :heading 'Residual Sum of Squares vs # PLS/PC components'); b34srun; == ==PLS1_REG3 Spectral Data. PLS Used to reduce problem /; /; Spectra data used in Matlab Test Example /; b34sexec matrix; call echooff; call load(pls1_reg); call load(pc_reg); testmod=1; /; Data on near infrared (NIR) spectral Intensities at 401 wavelengths /; 60 samples. Octane rating is in col 1. Matrix is 60,402 /; call getmatlab(dd :file 'c:\b34slm\mfiles\spectra.dat'); y=dd(,1); x=submatrix(dd,1,norows(dd),2,nocols(dd)); call graph(x :plottype meshc :d3axis :d3border :grid :rotation 180. :pgborder :file 'Spectra_data.wmf' :xlabel 'Sample #' :ylabelleft 'NIF Frequency' :heading 'Spectra NIR vs Octane' ); /; Test model if(testmod.ne.0)then; iprint=2; noshow=0; ncomp=5; gammag=grid(.1, 2.5,.1); call print(gammag); rote=180.; call crmtest(y,x, ncomp,gammag,rsstest,rote,iprint,noshow); call print(rsstest); call stop; endif; /; Model test using PC Model iprint=2; call pc_reg(y,x,ols_coef,ols_rss,tss,pc_coef, pcrss,pc_size,u,iprint); /; PLS Model ncomp=6; gamma=1.0; call pls1_reg(y,x,y0,x0,r,c,,u,v,s,pls2coef,yhat, pls_res,pls_rss, ncomp,gamma,iprint); T=x*r; call print(r); call print(t); call graph(T :plottype meshc :d3axis :d3border :grid :pgborder :xlabel 'Sample' :ylabelleft 'PLS Latent Vector' :file 'pls_latent_v.wmf' :heading 'PLS Latent Vector matrix T'); /; 2D graphs of latent vectors /; t1=t(,1); /; t2=t(,2); /; t9=t(,9); /; call graph(t1,t2,t9); scale=array(4: 1.,1.,dfloat(nocols(x)),dfloat(ncomp)); call graph(r :plottype meshc :d3axis :d3border :grid :pgborder :xlabel 'X Data Mapping' :pgunits scale /; :rotation 90. :ylabelleft 'PLS Latent Vector' :file 'pls_loading.wmf' :heading 'PLS Loading Matrix R'); /; r1=r(,1); /; r2=r(,2); /; r9=r(,9); /; call graph(r1 r2 r9); call olsq(y t :print ); b34srun; == ==PCOPY Pointer Copy b34sexec matrix; x=array(:integers(20)); newx=array(30:); ip1=pointer(x); ip2=pointer(newx); call print('pointer(x)',ip1,'pointer(newx)',ip2); call print(pointer(x,4)); * places x 1-10 in locations starting at 4 in newx; call pcopy(10,pointer(x),1,pointer(newx,4),1,8); call tabulate(x,newx); /$ /$ Character Example /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); b34srun; b34sexec matrix; * Illustrates pointer and pcopy ; n=3; x=matrix(n,n:1 2 3 4 5 6 7 8 9); call print(x); y=55.; call pcopy(1,pointer(y),1,pointer(x,2),1,8); call print(x); call pcopy(2,pointer(y),0,pointer(x,4),2,8); call print(x); b34srun; == ==PCOPY_2 Displays Buffer - Advanced use /$ /$ Shows moving a real*16 value in a real*8 work array /$ Uses a real*8 array to look at bits!! /$ b34sexec matrix; x=array(2:); y=10.0; y=r8tor16(y); yy=y; y=r8tor16(12.8); call print('is yy 10.? ',yy); call pcopy(2,pointer(y),1,pointer(x), 1,8); call pcopy(2,pointer(x),1,pointer(yy),1,8); call print('is yy 12.8.? ',yy); call displayb(x); call names(all); call displayb(yy); b34srun; == ==PDFAC pdfac function => Factor Positive Definite Matrix b34sexec matrix; * Problem from 'Applied Numerical Analysis using Matlab'; * by Laurene Fausett page 174; a=matrix(3,3:1. 4. 5. 4. 20. 32. 5. 32. 64.); call print('real*8 case',a, pdfac(a)); call print('real*4 case', pdfac(sngl(a))); n=4;x=rn(matrix(n,n:));pdx=transpose(x)*x; r=pdfac(pdx); call print('Positive Definite Matrix',pdx, 'Factorization',r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, ' ','Complex Case'); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; cr=pdfac(cpdx); i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); call print('Positive Definite Matrix',cpdx, 'Factorization', cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr,' '); r=pdfac(pdx,r1);cr=pdfac(cpdx,r2); call print(' ', 'Condition of Real Matrix ',r1, ' ', 'Condition of Complex Matrix',r2); * Problem from Introduction to Scientific Computing by Charles VN Loan (page 242 ; test=matrix(3,3: 4.,-10., 2., -10., 34.,-17., 2.,-17.,18. ); call print(test); p=pdfac(test); call print(p); call print('Validate ',transpose(p)*p); x=r8tor16(x); pdx=transpose(x)*x; r=pdfac(pdx); call print('Real*16 case' 'Positive Definite Matrix',pdx, 'Factorization',r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, ' ','Complex Case'); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; cr=pdfac(cpdx); i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); call print('Complex*32 Case', 'Positive Definite Matrix',cpdx, 'Factorization', cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr,' '); r=pdfac(pdx,r1);cr=pdfac(cpdx,r2); call print(' ', 'Condition of Real*16 Matrix ',r1, ' ', 'Condition of Complex*32 Matrix',r2); b34srun; == ==PDFACDD pdfacdd function => downdate Fac. of PD Matrix b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; r=pdfac(pdx); v = rn(vector(norows(pdx):)); npdx=pdx; nn=norows(pdx)+1; npdx(nn,)=v; npdx= transpose(npdx)*npdx; call print('Positive Definite Matrix', pdx, 'Factorization', r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, 'Update of factorization of pdx' pdfacud(r,v), 'Test if update was OK' 'pdfac(npdx)' pdfac(npdx) 'Other tests involving update/downdate' 'pdfac(pdx)' pdfac(pdx) 'pdfac(sngl(pdx))' pdfac(sngl(pdx)) 'pdfacud(r,v)' pdfacud(r,v) 'pdfacud(sngl(r),sngl(v))' pdfacud(sngl(r),sngl(v)) 'pdfacdd(pdfacud(r,v),v)' pdfacdd(pdfacud(r,v),v)) 'pdfacdd(pdfacud(sngl(r),sngl(v)),sngl(v)))' pdfacdd(pdfacud(sngl(r),sngl(v)),sngl(v))) ); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cv=complex(v,2.0*v); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr, 'Update of factorization' 'pdfacud(cr,cv)', pdfacud(cr,cv), 'Test if update was OK' 'pdfac(cpdx)' pdfac(cpdx) 'pdfacdd(pdfacud(cr,cv),cv)' pdfacdd(pdfacud(cr,cv),cv)); x=r8tor16(x); pdx=transpose(x)*x; call print(eig(pdx)); r=pdfac(pdx); v = r8tor16(rn(vector(norows(pdx):))); npdx=pdx; nn=norows(pdx)+1; npdx(nn,)=v; npdx= transpose(npdx)*npdx; call print('Positive Definite Matrix', pdx, 'Factorization', r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, 'Update of factorization of pdx' pdfacud(r,v), 'Test if update was OK' 'pdfac(npdx)' pdfac(npdx) 'Other tests involving update/downdate' 'pdfac(pdx)' pdfac(pdx) 'pdfacud(r,v)' pdfacud(r,v) 'pdfacdd(pdfacud(r,v),v)' pdfacdd(pdfacud(r,v),v) ); call names(all); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); cr=pdfac(cpdx); cv=qcomplex(v,r8tor16(2.0)*v); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr, 'Update of factorization' 'pdfacud(cr,cv)', pdfacud(cr,cv), 'Test if update was OK' 'pdfac(cpdx)' pdfac(cpdx) 'pdfacdd(pdfacud(cr,cv),cv)' pdfacdd(pdfacud(cr,cv),cv)); b34srun; == ==PDFACDD2 Example from IMSL on Downdate of PD Matrix b34sexec matrix; * IMSL # 10 Page 274; a=matrix(3,3:10., 3., 5. , 3., 14., -3. , 5., -3., 7. ); x=vector(3:3.0 ,2.0 , 1.0); b=vector(3:53.0,20.0,31.0); fac=pdfac(a); call print(a,fac); call print('Solve system ',pdsolv(fac,b)); newfac=pdfacdd(fac,x); call print('New Factorization',newfac); call print('Solve New system ',pdsolv(newfac,b)); b34srun; == ==PDFACUD pdfacud function => Update Fac. of PD Matrix b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; r=pdfac(pdx); v = rn(vector(norows(pdx):)); npdx=pdx; nn=norows(pdx)+1; npdx(nn,)=v; npdx= transpose(npdx)*npdx; call print('Positive Definite Matrix', pdx, 'Factorization', r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, 'Update of factorization of pdx' pdfacud(r,v), 'Test if update was OK' 'pdfac(npdx)' pdfac(npdx) 'Other tests involving update/downdate' 'pdfac(pdx)' pdfac(pdx) 'pdfacud(r,v)' pdfacud(r,v) 'pdfacdd(pdfacud(r,v),v)' pdfacdd(pdfacud(r,v),v) ); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cv=complex(v,2.0*v); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr, 'Update of factorization' 'pdfacud(cr,cv)', pdfacud(cr,cv), 'Test if update was OK' 'pdfac(cpdx)' pdfac(cpdx) 'pdfacdd(pdfacud(cr,cv),cv)' pdfacdd(pdfacud(cr,cv),cv)); x=r8tor16(x); pdx=transpose(x)*x; call print(eig(pdx)); r=pdfac(pdx); v = r8tor16(rn(vector(norows(pdx):))); npdx=pdx; nn=norows(pdx)+1; npdx(nn,)=v; npdx= transpose(npdx)*npdx; call print('Positive Definite Matrix', pdx, 'Factorization', r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, 'Update of factorization of pdx' pdfacud(r,v), 'Test if update was OK' 'pdfac(npdx)' pdfac(npdx) 'Other tests involving update/downdate' 'pdfac(pdx)' pdfac(pdx) 'pdfacud(r,v)' pdfacud(r,v) 'pdfacdd(pdfacud(r,v),v)' pdfacdd(pdfacud(r,v),v) ); call names(all); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); cr=pdfac(cpdx); cv=qcomplex(v,r8tor16(2.0)*v); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr, 'Update of factorization' 'pdfacud(cr,cv)', pdfacud(cr,cv), 'Test if update was OK' 'pdfac(cpdx)' pdfac(cpdx) 'pdfacdd(pdfacud(cr,cv),cv)' pdfacdd(pdfacud(cr,cv),cv)); b34srun; == ==PDFACUD2 Example from IMSL on Update of PD Matrix b34sexec matrix; * IMSL # 10 Page 271; a=matrix(3,3:1., -3., 2. , -3., 10., -5. , 2., -5., 6.0); x=vector(3:3.0 ,2.0 , 1.0); b=vector(3:53.0,20.0,31.0); fac=pdfac(a); call print(a,fac); call print('Solve system ',pdsolv(fac,b)); newfac=pdfacud(fac,x); call print('New Factorization',newfac); call print('Solve New system ',pdsolv(newfac,b)); b34srun; == ==PDINV pdinv function => Invert Positive Definite Matrix b34sexec matrix; n=4;x=rn(matrix(n,n:));pdx=transpose(x)*x; r=pdfac(pdx);inv=pdinv(r); r4=pdfac(sngl(pdx));inv4=pdinv(r4); call print('Positive Definite Matrix',pdx,'Factorization',r, 'Inverse ',inv, 'Inverse real*4',inv4, 'Inverse using MATRIX math',(1.0/pdx), 'Test if inverse was OK', inv*pdx,' ','Complex Case'); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cinv=pdinv(cr); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Inverse ',cinv, 'Inverse using MATRIX math',(complex(1.0)/cpdx), 'Test if inverse was OK', cinv*cpdx,' '); inv1=pdinv(pdfac(pdx),d1);inv2=pdinv(pdfac(cpdx),d2); call print('Determinate of pdx ',d1, 'Determinate of cpdx',d2); call print('Determinate of pdx using det(pdx) ', det(pdx), 'Determinate of cpdx using det(cpdx)', det(cpdx)); /$ Real*16 pdx=r8tor16(pdx); r=pdfac(pdx);inv=pdinv(r); call print('Real*16 Case', 'Positive Definite Matrix',pdx,'Factorization',r, 'Inverse ',inv, 'Inverse using MATRIX math',(r8tor16(1.0)/pdx), 'Test if inverse was OK', inv*pdx,' ','Complex Case*32'); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); cr=pdfac(cpdx); cinv=pdinv(cr); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Inverse ',cinv, 'Inverse using MATRIX math',(qcomplex(r8tor16(1.0))/cpdx), 'Test if inverse was OK', cinv*cpdx,' '); inv1=pdinv(pdfac(pdx),d1);inv2=pdinv(pdfac(cpdx),d2); call print('Determinate of pdx ',d1, 'Determinate of cpdx',d2); call print('Determinate of pdx using det(pdx) ', det(pdx), 'Determinate of cpdx using det(cpdx)', det(cpdx)); b34srun; == ==PDINV_2 Shows Speed Differences b34sexec matrix; * Tests speed of Linpack vs LAPACK vs svd (pinv) vs ; * Requires a large size ; call echooff; icount=0; n=0; upper=600; mesh=50; top continue; icount=icount+1; n=n+mesh; if(n .gt. upper)go to done; call print('Doing size ',n:); x=rn(matrix(n,n:)); x=transpose(x)*x; ii=matrix(n,n:)+1.; call timer(base1); call gminv(x,xinv1,info); call timer(base2); error1(icount)=sum(dabs(ii-(xinv1*x))); call timer(base3); xinv1=inv(x); call timer(base4); error2(icount)=sum(dabs(ii-(xinv1*x))); call timer(base5); xinv1=pinv(x); call timer(base6); error3(icount)=sum(dabs(ii-(xinv1*x))); call timer(base7); xinv1=inv(x :pdmat); call timer(base8); error4(icount)=sum(dabs(ii-(xinv1*x))); size(icount) =dfloat(n); lapack(icount) =(base2-base1); linpack(icount)=(base4-base3); svdt(icount) =(base6-base5); chol(icount) =(base8-base7); call free(x,xinv1,ii) call compress; go to top; done continue; call tabulate(size,lapack,linpack,svdt,chol,error1,error2,error3,error4); call graph(size lapack,linpack :heading 'Lapack Vs Linpack' :plottype xyplot); call graph(size lapack,linpack svdt :heading 'LAPACK vs Linpack vs SVD' :plottype xyplot); b34srun; == ==PDSOLV Solve Symetric System using factorization b34sexec matrix; n=4;x=rn(matrix(n,n:));pdx=transpose(x)*x; * nn is number of right hand sides; nn = 3; r = pdfac(pdx); v = rn(matrix(norows(pdx),nn:)); ans= pdsolv(r,v); ans4=pdsolv(sngl(r),sngl(v)); call print('Real*8 & Real*4 answers',ans,ans4); call print('Positive Definite Matrix',pdx,'Factorization',r); call print('Right hand side',v); call print('Solution ', 'pdsolv(pdfac(pdx),v)', pdsolv(pdfac(pdx),v)); call print('test of solution', (1.0/pdx)*v); call print(' ','Complex Case'); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cv=complex(v,2.0*v); ans=pdsolv(cr,cv); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Right hand side',cv 'Solution ', 'pdsolv(pdfac(cpdx),cv)', pdsolv(pdfac(cpdx),cv), 'test of solution', (complex(1.0)/cpdx)*cv); /$ Real*16 pdx=r8tor16(pdx); r=pdfac(pdx); v = r8tor16(v); ans=pdsolv(r,v); call print('Real*16 ', 'Positive Definite Matrix',pdx,'Factorization',r, 'Right hand side',v 'Solution ', 'pdsolv(pdfac(pdx),v)', pdsolv(pdfac(pdx),v) 'test of solution', (r8tor16(1.0)/pdx)*v, ' ','Complex*32 Case'); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); cr=pdfac(cpdx); cv=qcomplex(v,r8tor16(2.0)*v); ans=pdsolv(cr,cv); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Right hand side',cv 'Solution ', 'pdsolv(pdfac(cpdx),cv)', pdsolv(pdfac(cpdx),cv), 'test of solution', (qcomplex(r8tor16(1.0))/cpdx)*cv); b34srun; == ==PERMUTE Reorder Moment Matrix b34sexec matrix; call load(permute); * Problem 5 in Greene (2003) Chapter 15; * Illustrates ols from moment matrix; * Assume 25 obs; * y1=g1*y2 + b11*x1 ; * y2=g2*y1 + b22*x2 + b32*x3 ; * matrix order is y1 y2 x1 x2 x3 ; mm=matrix(5,5: 20 6 4 3 5 6 10 3 6 7 4 3 5 2 3 3 6 2 10 8 5 7 3 8 15); * OLS ; x1 =submatrix(mm,2,3,2,3); x1py1=submatrix(mm,2,3,1,1); call print(x1,x1py1); d1=inv(x1)*x1py1; call print('OLS eq 1 ',d1 ); call print('Answers should be .439024 .536585':); * We reorder Moment Matrix; * New Order y2 y1 x2 x3 x1; call echooff; call permute(mm,mm2, 1,2); call permute(mm2,mm3,3,4); call permute(mm3,mm4,4,5); call print(mm,mm2,mm3,mm4); call echoon; x2 =submatrix(mm4,2,4,2,4); x2py2=submatrix(mm4,2,4,1,1); call print(x2,x2py2); d2=inv(x2)*x2py2; call print('OLS eq 2 ',d2 ); call print('Answers should be .193016 .384127 .19746',:); b34srun; == ==PI Set values to pi b34sexec matrix; /; /; Note: pi = 4. *atan(1) = imag(log(-1)) /; pi_r8=pi(); y=array(4:); y=pi(y); call print(pi_r8,y); /; real*16 x=0.0; pi_r16=pi(r8tor16(x)); call print(pi_r16:); /; VPA pi_vpa =pi(vpa(2.0)); vv=vpa(array(4:)); call print(pi_vpa,pi(vv)); call print(' ':); call print('Testing how close pi() is to real pi using sin(pi)~0':); call print('real*8 ',sin(pi(1.0)) :); call print('real*16 ',sin(pi(real16('1.0'))):); call print('VPA 64 ',sin(pi( vpa('1.0'))) ); call vpaset(:ndigits 1000); call print('VPA at 1000 ',sin(pi( vpa('1.0'))) ); call print('VPA at 1000 ',cos(pi( vpa('1.0'))) ); b34srun; == ==PINV Generalized Inverse b34sexec matrix; * IMSL example ; a=matrix(3,2:1., 0., 1., 1., 100.,-50.); ginv=pinv(a); call print(a,ginv); s=svd(a,ibad,21,u,v); call print('Testing svd'); call print(v*inv(diagmat(s))*transpose(u)); * Test with a full rank system; n=5; xx=rn(matrix(n,n:)); inv1=inv(xx); inv2=pinv(xx,rank); call print(rank,xx,inv1,inv2,xx*inv1,xx*inv2); s=svd(xx,ibad,21,u,v); call print('Testing svd'); call print(v*inv(diagmat(s))*transpose(u)); b34srun; == ==PINV_2 Shows properties of PINV b34sexec matrix; n=8; k=4; x=rn(matrix(n,k:)); y=rn(vector(n:)); pinv_x=pinv(x); call print('x*pinv_x*x = x':); call print(x*pinv_x*x,x); call print('pinv_x*x*pinv_x = pinv_x':); call print(pinv_x*x*pinv_x, pinv_x); call print('pinv_x*x => symmetric':); call print(pinv_x*x ); call print('x *pinv_x => symmetric':); call print(x *pinv_x); call print('if x n by k pinv(x)=inv(transpose(x)*x)*transpose(x)':); call print(pinv(x),inv(transpose(x)*x)*transpose(x)); b34srun; == ==PINV_3 Shows slow speed of GINV b34sexec matrix; * Tests speed of Linpack vs LAPACK vs svd (pinv); call echooff; icount=0; n=0; upper=600; mesh=50; top continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done; x=rn(matrix(n,n:)); ii=matrix(n,n:)+1.; call timer(base1); call gminv(x,xinv1,info); call timer(base2); error1(icount)=sum(dabs(ii-(xinv1*x))); call timer(base3); xinv1=inv(x); call timer(base4); error2(icount)=sum(dabs(ii-(xinv1*x))); call timer(base5); xinv1=pinv(x); call timer(base6); error3(icount)=sum(dabs(ii-(xinv1*x))); size(icount) =dfloat(n); lapack(icount) =(base2-base1); linpack(icount)=(base4-base3); svdt(icount) =(base6-base5); call free(x,xinv1,ii) call compress; go to top; done continue; call tabulate(size,lapack,linpack,svdt,error1,error2,error3); call graph(size lapack,linpack :heading 'Lapack Vs Linpack' :plottype xyplot); call graph(size lapack,linpack svdt :heading 'LAPACK vs Linpack vs SVD' :plottype xyplot); b34srun; == ==PINV_4 Altman-Gill-McDonald Problem b34sexec matrix; * Altman-Gill-McDonald 2004 page 154 ; * Do not get problems they find ; call load(cor :staging); call load(cov :staging); call echooff; x=matrix(4,3: 5. 2. 5. 2. 1. 2. 3. 2. 3. 2.95 1. 3.); y=vector(4:9.,11.,-5., -2.); b1_hat = inv(transpose(x)*x)*transpose(x)*y; y1_hat = x*b1_hat; c1 =cov(transpose(x)*x); c1_cor=cor(x); x2=x; x2(4,1)=2.99; b2_hat = inv(transpose(x2)*x2)*transpose(x2)*y; y2_hat = x2*b2_hat; call print(b1_hat,b2_hat,y1_hat,y2_hat); c2 =cov(transpose(x2)*x2); c2_cor=cor(x2); x3=x; x3(4,1)=2.999; b3_hat = inv(transpose(x3)*x3)*transpose(x3)*y; b3_hat2= pinv(transpose(x3)*x3)*transpose(x3)*y; y3_hat = x3*b3_hat; c3 =cov(transpose(x3)*x3); c3_cor=cor(x3); call print(b3_hat,b3_hat2, y3_hat); call print(c1,c2,c3); call print(c1_cor,c2_cor,c3_cor); b34srun; == ==PISPLINE PISPLINE Under Matrix b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ Both PISPLINE Commands shown b34sexec pispline; model gasout = gasin; b34srun; b34sexec matrix; call loaddata; call pispline(gasout gasin :print); call names(all); call graph(%res :heading 'Residual from pispline' :nocontact :pgborder); call graph(%y %yhat:heading 'Fit from pispline' :nocontact :pgborder :nolabel); b34srun; == ==PISPLINE2 Data from Breiman b34sexec options ginclude('b34sdata.mac') member(breiman); b34srun; /$ Both PISPLINE Commands shown B34SEXEC PISPLINE CENTER=2.526 $ FORECAST C_RATIO(12. 12.) E_RATIO(.907 .761)$ MODEL Y = E_RATIO C_RATIO$ B34SEEND$ b34sexec matrix; call loaddata; call pispline( y e_ratio c_ratio :center 2.526 :print); call graph(%res :heading 'Residual from pispline' :nocontact :pgborder); call graph(%y %yhat:heading 'Fit from pispline' :nocontact :pgborder :nolabel); b34srun; == ==PISPLINE3 Illustrates Forecasting b34sexec options ginclude('b34sdata.mac') member(breiman); b34srun; /$ Both PISPLINE Commands shown B34SEXEC PISPLINE CENTER=2.526 PMODEL$ FORECAST C_RATIO(12. 12.) E_RATIO(.907 .761)$ MODEL Y = E_RATIO C_RATIO$ B34SEEND$ b34sexec matrix; call loaddata; * We forecast 2 insample data points ; npred=2; xin=matrix(npred,2:); xin(1,1)=.907 ; xin(1,2)= 12. ; xin(2,1)=.761 ; xin(2,2)= 12. ; call print(xin ); call names(all); call pispline(y e_ratio c_ratio :pmodel :print :center 2.526 :forecast xin ); call tabulate(%y %yhat %res y e_ratio c_ratio); call tabulate(%fore %foreobs); /$ Now we show forecasting using a saved model call open(60,'junk.mod'); call pispline(y e_ratio c_ratio :print :center 2.526 :savemodel :murewind); call pispline(y e_ratio c_ratio :print :center 2.526 :getmodel :forecast xin ); call tabulate(%fore %foreobs); b34srun; == ==PLACE Tests Place b34sexec matrix; call character(cc2,'abcdefghijklmnop'); do i=1,10; j=10; newc=extract(cc2,i,j); call print(cc2,i,j,newc); enddo; do i=1,8; newc=place(cc2,1,i); call print(cc2,newc,i); enddo; /$ Tests 4th argument call character(cc2,'abcdefghijklmnop'); call character(cc3,'1234567890987654'); do i=1,8; newc=place(cc2,1,i,cc3); call print(cc2,cc3,newc,i); enddo; name='Mary'; name2='Rho'; call names(all); newname1=place(name2,6,8,name); newname2=place('Sue',6,8,name); call print(name,newname1,newname2); b34srun; == ==PLOT Call plot to do line printer graphs b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; ccf1=ccf(gasin gasout,24); call plot(gasout,gasin); call plot(ccf1 :heading 'CCF1 of gasin & Gasout' :xlabel 'Lags ' :ylabel 'Cross Correlation Values'); end=20.; inc=.1; x=grid(1.,end,inc); y=dsin(x); call plot(x,y :xyplot :heading 'Sine Function'); b34srun; == ==POIDF Evaluate Poisson Distribution Function b34sexec matrix; k=7; theta=10.; pr=poidf(k,theta); call print('Evaluate Poisson Distribution Function':); call print('Probability that X is LE 7 = ',pr:); Call print('Note: Answer should be .2202':); b34srun; == ==POINTER Pointer Capability b34sexec matrix; x=array(:integers(20)); newx=array(30:); ip1=pointer(x); ip2=pointer(newx); call print('pointer(x)',ip1,'pointer(newx)',ip2); call print(pointer(x,4)); * places x 1-10 in locations starting at 4 in newx; call pcopy(10,pointer(x),1,pointer(newx,4),1,8); call tabulate(x,newx); * Character examples including dup copies ; n=namelist(mary sue Diana); nn=namelist(a b c d e); nn2=nn; call pcopy(4,pointer(n),0,pointer(nn),1,-8); call pcopy(3,pointer(n),1,pointer(nn2),1,-8); call tabulate(n,nn,nn2); /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); b34srun; b34sexec matrix; * Illustrates pointer and pcopy ; n=3; x=matrix(n,n:1 2 3 4 5 6 7 8 9); call print(x); y=55.; call pcopy(1,pointer(y),1,pointer(x,2),1,8); call print(x); call pcopy(2,pointer(y),0,pointer(x,4),2,8); call print(x); b34srun; == ==POIPR Evaluate Poisson Probability Function b34sexec matrix; k=7; theta=10.; pr=poipr(k,theta); call print('Evaluate Poisson Probability Function':); call print('Probability that X is 7= ',pr:); Call print('Note: Answer should be .0901':); b34srun; == ==POLYDV Divide two polynomials b34sexec matrix; top=1.0; bot=array(2:1.0, -.9); result=polydv(top,bot,20); i=integers(20); call tabulate(i,result); call print('Prove Multiplier',sum(polydv(top,bot,200)):); /; as a test get close to unit root by making ar1 = .99, .99999 /; MA1 form will not die out very fast!!!!!! ar1=-.9; ma1= .9; nterms=40; top=array(2:1.,ar1); bot=array(2:1.,ma1); call print(' (1-ar1*B)*y(t)=(1.-ma1*B)*e(t) '); call print('AR1 = ',ar1); call print('MA1 = ',ma1); ar=polydv(top,bot,nterms); ma=polydv(bot,top,nterms); call print('AR is arma(1,1) AR form ':); call print('MA is arma(1,1) MA form ':); call tabulate(ar,ma); call graph(ar :heading 'arma(1,1) AR form '); call graph(ma :heading 'arma(1,1) MA form '); b34srun; == ==POLYFIT Fit an nth degree polynomial b34sexec matrix; call load(polyfit); call load(polyval); call print(polyfit,polyval); * Polyfit test case - See Mastering Matlab 6 page 327; x=dfloat(integers(0,10))/10.; y=array(11:-.447,1.978,3.28,6.16,7.08,7.34,7.66,9.56, 9.48,9.30,11.2); xx=x*x; call olsq(y,x,xx:print); call tabulate(%yhat); call echooff; call polyfit(x,y,2,coef,1); call polyval(coef,x,yhat); call tabulate(x,y,yhat); b34srun; == ==POLYMCONV Convert storage of a polynomial matrix b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call echooff; ibegin=1; iend=296; nlag=2; call olsq(gasin gasin{1 to nlag} gasout{1 to nlag} :print); b1=%coef; call olsq(gasout gasin{1 to nlag} gasout{1 to nlag} :print); b2=%coef; beta=matrix(2,norows(%coef):); beta(1,)=vfam(b1); beta(2,)=vfam(b2); /$ /$ Convert both ways /$ call polymconv(:byvarin beta new inew); call polymconv(:byorderin new inew beta2); call print(beta,new,inew,beta2); call polymdisp(:display new inew); b34srun; == ==POLYDV_2 Illustrates getting closer to unit root b34sexec matrix; /; as a test get close to unit root by making ar1 = .99, /; .99999 etc. MA1 form will not die out very fast!!!!! call echooff; subroutine test(ar1,ma1,nterms,ar,ma); top=array(2:1.,ar1); bot=array(2:1.,ma1); call print(' ':); call print(' (1-ar1*B)*y(t)=(1.-ma1*B)*e(t) ':); call print('AR1 = ',ar1:); call print('MA1 = ',ma1:); ar=polydv(top,bot,nterms); ma=polydv(bot,top,nterms); call graph(ar :heading 'arma(1,1) AR form '); call graph(ma :heading 'arma(1,1) MA form '); call print(' ':); return; end; nterms=500; call test(-.9, .9, nterms,ar1,ma1); call test(-.99, .9, nterms,ar2,ma2); call test(-.99999, .9, nterms,ar3,ma3); call tabulate(ar1,ma1,ar2,ma2,ar3,ma3 :title 'MA Form for close to unit root'); b34srun; == ==POLYMDISP Display/Extract a polynomial matrix b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call echooff; ibegin=1; iend=296; nlag=3; x=catcol(gasin,gasout); call olsq(gasin gasin{1 to nlag} gasout{1 to nlag} :print); beta=array(2,(nlag+nlag+1):); beta(1,)=%coef; call olsq(gasout gasin{1 to nlag} gasout{1 to nlag} :print); beta(2,)=%coef; call polymconv(:byvarin beta new inew); call print(new,inew); call polymconv(:byorderin new inew beta2); call print(beta,new,inew,beta2); call polymdisp(:display new inew); call polymdisp(:extract new inew oldterm index(2 1 2)); call print('row 2 col 1 order 2-1 ',oldterm); oldterm=oldterm*3.; call polymdisp(:load new inew oldterm index(2 1 2)); call print('row 2 col 1 order 2-1 ',oldterm); call polymdisp(:extract new inew oldtermv index(2 1 0)); call print('This is a vector pulled out ',oldtermv); call polymdisp(:display new inew); b34srun; == ==POLYMINV Invert a Polynomial Matrix b34sexec matrix; * problem from Enders Robinson page 158; a=array(:2,1,0,6,1,0,1,1); ia=index(2,2,2); nterms=10; call echooff; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call names(all); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); call polymdisp(:extract ainv iainv vec1 index(1,1,0)); call polymdisp(:extract ainv iainv vec2 index(2,1,0)); call polymdisp(:extract ainv iainv vec3 index(1,2,0)); call polymdisp(:extract ainv iainv vec4 index(2,2,0)); call names(all); call tabulate(vec1,vec2,vec3,vec4); b34srun; b34sexec matrix; * problem from Enders Robinson page 159; * Here Det = constant ; a=array(:2,0,5,1,3,1,6,1); ia=index(2,2,2); nterms=20; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call names(all); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); b34srun; b34sexec matrix; * problem from Enders Robinson page 164; a=array(:1,0,0,1,-3,14,21,1,2,5,-6,14); ia=index(2,2,3); nterms=10; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call names(all); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); * testing division using Enders answers; top11=array(:1,1,14); term1_1=polydv(top11,%det,10); top12=array(:0,-21,6); term1_2=polydv(top12,%det,10); top21=array(:0,-14,-5); term2_1=polydv(top21,%det,10); top22=array(:1,-3,2); term2_2=polydv(top22,%det,10); call tabulate(term1_1,term1_2,term2_1,term2_2); b34srun; == ==POLYMINV_1 Psi Weights using OLSQ 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=3; nterms=12; x=catcol(gasin,gasout); /$ /$ From Beta forms the (I-L(B)) matrix. If this is /$ inverted, we get Psi weights /$ call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ia,var1,varxhat1,rsq1); call varstab(beta,compmat,eigdata,modulus,1); call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call polymdisp(:display ainv iainv); call polymdisp(:extract ainv iainv col1_1 index(1,1,0)); call polymdisp(:extract ainv iainv col2_1 index(2,1,0)); call polymdisp(:extract ainv iainv col1_2 index(1,2,0)); call polymdisp(:extract ainv iainv col2_2 index(2,2,0)); call tabulate(col1_1,col2_1,col1_2,col2_2); b34srun; == ==POLYMINV_2 Psi Weights from a VAR Model - Test Cases /$ /$ Illustrates Calculation of Psi Weights from a VAR Model /$ These are tested indirectly with BTEST and Directly by /$ inverting the BTEST coefficients /$ /$ Cofficients are calculated two ways!!!! /$ /$ VAREST is used and validated against a direct call. /$ Note: Beta needs to be transformed in VAREST not used. /$ 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); /$ /$ From Beta forms the (I-L(B)) matrix. If this is /$ inverted, we get Psi weights /$ call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ia,var1,varxhat1,rsq1); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); call polymdisp(:extract ainv iainv col1_1 index(1,1,0)); call polymdisp(:extract ainv iainv col2_1 index(2,1,0)); call polymdisp(:extract ainv iainv col1_2 index(1,2,0)); call polymdisp(:extract ainv iainv col2_2 index(2,2,0)); call tabulate(col1_1,col2_1,col1_2,col2_2); /$ an alternative way to go requiring more work and use /$ of dispmconv to get a and ia nlag=2; x=catcol(gasin,gasout); call olsq(gasin gasin{1 to nlag} gasout{1 to nlag} :print); beta=array(2,(nlag+nlag+1):); beta(1,)=%coef; call olsq(gasout gasin{1 to nlag} gasout{1 to nlag} :print); beta(2,)=%coef; call print(beta); call polymconv(:byvarin beta a ia); /$ /$ form [I-B(L)] then invert /$ call print(a); a=-1.*afam(a); a(1,1)=1.0; a(2,2)=1.0; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call print(%p,%det); call polymdisp(:display ainv iainv); b34srun; /$ /$ Test against BTEST calculation of psi !!!! /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec btest$ title=('Estimation run with gas data') $ seriesn var=gasin name=('b-j gas input data') $ seriesn var=gasout name=('b-j gas output data') $ ar(1,1,1)=.1 $ ar(1,1,2)=.1 $ ar(1,2,1)=.1 $ ar(1,2,2)=.1 $ ar(2,1,1)=.1 $ ar(2,1,2)=.1 $ ar(2,2,1)=.1 $ ar(2,2,2)=.1 $ output iprint lagrho=12 nfmat=12 $ constant=(yes,yes) $ forecast nt=(296,250) nf=(24,20) se actual $ b34seend$ /$ Test BTEST Coefficients b34sexec matrix; a=array(:1.,0. 0.,1., -1.81304, -.234096, .075556,-1.44623, .960862, .642300,-.046309, .579840); ia=index(2 2 3); nterms=12; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call print(%p,%det); call polymdisp(:display ainv iainv); b34srun; == ==POLYMINV_3 Illustrate lower VAR => Lower VMA /; Illustrates that if VAR is lower triangular, /; VMA will be lower triangular b34sexec matrix; * problem if var lower T => vma will be lower T; a=array(:1.,.0, .0,1.,-.3,.4,.0,-.1,.2 .3 .0 .1); ia=index(2,2,3); nterms=20; call echooff; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call names(all); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); call polymdisp(:extract ainv iainv vec1 index(1,1,0)); call polymdisp(:extract ainv iainv vec2 index(2,1,0)); call polymdisp(:extract ainv iainv vec3 index(1,2,0)); call polymdisp(:extract ainv iainv vec4 index(2,2,0)); call names(all); call tabulate(vec1,vec2,vec3,vec4); b34srun; == ==POLYMMULT Multiply a Polynomial Matrix b34sexec matrix; * Test cases from Enders Robinson page 155-156; a=array(:0,1,0,-1, 2,0,1,1, 1,1,0,0,); ia=index(2 2 3); b=array(:0,1,0,0,0,1,1,1,1,0,1,0); ib=index(2 2 3); call polymmult(a,ia,b,ib,c,ic); call polymdisp(:display c ic); call polymmult(b,ib,a,ia,c2,ic2); call polymdisp(:display c2 ic2); call print(a,ia,b,ib,c,ic,c2,ic2); b34srun; == ==POLYMULT Multiply two polynomials b34sexec matrix; a=array(2:1., .9); b=array(3:1., -.4, .3); c=polymult(a,b); call print('(1+.9B)*(1.-.4B+.3B**2)', '= (1.-.4B+.3B**2+.9B-.36B**2+.27B**3)', '= (1.+.5B-.06B**2-.27B**3)', a,b,c); top=1.; long=polydv(top,a,200); test=polymult(long,a); call print(test,long); b34srun; == ==POLYROOT Polyroot function => solve Real*8 & Complex*16 Polyno /$ Tests Polyroot command b34sexec matrix$ * Simple Case ; coef=array(:-12.,-1.,1.); roots=polyroot(coef); call print('Tests Real Polynomial Solution' 'x**2-x-12=0', coef,roots); * Problem from Enters Robinson page 171; coef=array(:120,-154,71,-14,1); roots=polyroot(coef); call print('Enders Robinston Edition 2 page 171',coef,roots); ccoefr=array(4:10., -8.,-3.,1. ); ccoefi=array(4:0.0, 12.,-6.,0.0); ccoef=complex(ccoefr,ccoefi); croots=polyroot(ccoef); call print('Tests Complex Polynomial Solution' 'x**3-(3+6i)*x**2-(8-12i)*x+10.=0', ccoef,croots); * Big problem ; n=30; coef=rn(array(n:)); roots=polyroot(coef); call print('Tests Large Real Polynomial Solution' coef,roots); ccoefi=rn(array(n:)); ccoef=complex(coef,ccoefi); croots=polyroot(ccoef); call print('Tests Large Complex Polynomial Solution' ccoef,croots); b34srun$ == ==POLYROOT1 Tests Stability of AR models b34sexec matrix$ * Polyroot Equation used to test if AR model is stable ; * Following Enders Model is stable if Characteristic roots < 1; * or inside unit circle.; * For high order systems necessary condition is sum (coef) < 1; * Sufficient condition is sum (abs(coef)) < 1 ; * At least one root is unity if sum(coef) = 1; * test y(t) = -.9*y(t-1) + u(t) ; coef=array(2:.9,1.); roots=polyroot(coef); call print('Tests y(t) = -.9*y(t-1) + u(t)', coef,roots); * test y(t) = -1.1*y(t-1) + u(t) ; coef=array(2:1.1,1.); roots=polyroot(coef); call print('Tests y(t) = -1.1*y(t-1) + u(t)' coef,roots); * test y(t) = .2*y(t-1) + .35*y(t-2) + u(t) ; * Enders page 26 case 1 ; coef=array(3:-.35,-.2,1.); roots=polyroot(coef); call print('Tests y(t) -.2*y(t-1) - .35*y(t-2)= u(t)' coef,roots); * test y(t) = .7*y(t-1) + .35*y(t-2) + u(t) ; * Enders page 27 case 2; coef=array(3:-.35,-.7,1.); roots=polyroot(coef); call print('Tests y(t) -.7*y(t-1) - .35*y(t-2)= u(t)' coef,roots); * Enders page 30 Imaginary case 1; coef=array(3:.9,-1.6,1.); roots=polyroot(coef); call print('Tests y(t) -1.6*y(t-1) + .9*y(t-2)= u(t)' coef,roots); * Enders page 30 Imaginary case 2; coef=array(3:.9,.6,1.); roots=polyroot(coef); call print('Tests y(t) +.6*y(t-1) + .9*y(t-2)= u(t)' coef,roots); b34srun$ == ==POLYROOT2 Outside and inside unit corcle tests of AR(1) b34sexec matrix$ /$ Model y(t) = .9*y(t-1) + u(t) ; /$ Roots of COEF test using form of inside unit circle ; /$ Roots of COEF2 test using form of outside unit circle; coef =array(2:-.9, 1. ); coef2=array(2:1., -.9); call print('Test of Model y(t) = .9*y(t-1) + u(t)', 'Inside unit circle test ',polyroot(coef), ' ', 'Outside unit circle test', polyroot(coef2)); b34srun$ == ==POLYVAL Evaluate an nth degree polynomial b34sexec matrix; call load(polyfit); call load(polyval); call print(polyfit,polyval); * Polyfit test case - See Mastering Matlab 6 page 327; x=dfloat(integers(0,10))/10.; y=array(11:-.447,1.978,3.28,6.16,7.08,7.34,7.66,9.56, 9.48,9.30,11.2); xx=x*x; call olsq(y,x,xx:print); call tabulate(%yhat); call echooff; call polyfit(x,y,2,coef,1); call polyval(coef,x,yhat); call tabulate(x,y,yhat); b34srun; == ==PP Phillips-Perron Test b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call print('Phillips-Perron Tests on Gasout'); call pp(gasout,p :print); n=30; app=array(n+1:); appt=array(n+1:); lag=array(n+1:); papp=array(n+1:); pappt=array(n+1:); do i=0,n; j=i+1; call pp(gasout,a1:app i); app(j)=a1; papp(j)=%ppprob; call pp(gasout,a2:appt i); appt(j)=a2; pappt(j)=%ppprob; lag(j)=dfloat(i); enddo; call print('Phillips-Perron test':); call tabulate(lag,app,papp,appt,pappt); b34srun; /; test case b34sexec matrix; n=10000; x=rn(array(n:)); root=cusum(x); call df(x,d :print); call df(root,d :print); call pp(x,d :print); call pp(root,d :print); b34srun; == ==PP1 Looks at Phillips-Perron Table /$ /$ /$ Job establishes critical values for PP test /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12332.; call echooff; * ncase=1000; ncase=10; n =5000; unit=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); call pp(unit, d); call pp(unit, d1 :app 4); call pp(unit, d2 :appt 4); call pp(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase:); call print('# observations ',n:); Call Print('DF Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root app Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root appt Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); * For a discussion of why we cannot use these methods for Case # 4 in some cases see Hamilton page 497 ; b34srun; == ==PP2 Negative unit root /$ /$ /$ Job establishes critical values for DF test /$ "unit root with negative" <= /$ /$ PP test does not detect ########### /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12332.; call echooff; * ncase=1000; ncase=10; n =5000; unit=array(n:); hold=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); jj=integers(1,n); hold(jj)=(-1.)**dfloat(jj); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); unit=afam(unit)*afam(hold); call pp(unit, d); call pp(unit, d1 :app 4); call pp(unit, d2 :appt 4); call pp(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase,' # observations ',n); Call Print('PP Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root adf Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root adf Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); * For a discussion of why we cannot use these methods for Case # 4 in some cases see Hamilton page 497 ; b34srun; == ==PPEXP Exploritory Projection Pursuit b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ppexp_p); call echooff; call olsq(cpeptide age bdeficit :print); ols_res=%res; call ppexp(cpeptide age bdeficit :print); call names(all); call print(%A,%xpa); call ppexp(cpeptide age bdeficit :print :mm 2 :nei 1); call print(%a,%xpa); call ppexp_p(%xpa,%mm,%nob,0,'t2',%ppindex); call ppexp_p(%xpa,%mm,%nob,1,'t2',%ppindex); b34srun; == ==PPEXP2 PPEXP on Gas Data b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ppexp_p); call echooff; nlag=6; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print); ols_res=%res; call ppexp(gasout gasout{1 to nlag} gasin{1 to nlag} :mm 10 :nei 12); call ppexp_p(%xpa,%mm,%nob,0,'t2',%ppindex); call ppexp_p(%xpa,%mm,%nob,1,'t2',%ppindex); b34srun; == ==PPEXP3 PPEXP on simulated data b34sexec data noob=1000 heading('Wang-Murphy Sim Data'); * 'Estimating Optimal Transformations for the Multiple Regression Using the ACE Algorithm' Journal of Data Science 2(2004) pp 329-346 ; /; ''' build error y x1 x2 x3 x4 x5 work; gen error=rn(); gen x1 = (2.*rec())-1.; gen x2 = (2.*rec())-1.; gen x3 = (2.*rec())-1.; gen x4 = (2.*rec())-1.; gen x5 = (2.*rec())-1.; gen y= dlog(4.0 + dsin(4*x1) +dabs(x2) + (x3*x3) + (x4*x4*x4) + x5 + (.1 * error)); b34srun; b34sexec matrix; call loaddata; call load(ppexp_p); call echooff; nlag=6; call olsq(y x1 x2 x3 x4 x5 :print); ols_res=%res; call ppexp(y x1 x2 x3 x4 x5 :mm 5 :nei 12 :print /; :trm .1 ); call names(all); /; %a = array(1,norows(%a):%a); /; call print(%A,%xpa); call print(%mm,%k,%nob); call ppexp_p(%xpa,%mm,%nob,0,' ',%ppindex); call ppexp_p(%xpa,%mm,%nob,1,'t ',%ppindex); call print(' ':); call print('---------------------------------------------':); call print('---------------- PPREG with 20 trees --------':); call print('---------------------------------------------':); call ppreg(y x1 x2 x3 x4 x5 :print :m 20 :mu 1); call print(' ':); call print('---------------------------------------------':); call print('---------------- PPREG held to 1 tree -------':); call print('---------------------------------------------':); call ppreg(y x1 x2 x3 x4 x5 :print :m 1 :mu 1); call print(' ':); call print('---------------------------------------------':); call print('---------------- GAM ------------------------':); call print('---------------------------------------------':); call gamfit(y x1 x2 x3 x4 x5 :print); call print(' ':); call print('---------------------------------------------':); call print('--------------- Two MARS Routines -----------':); call print('---------------------------------------------':); call mars( y x1 x2 x3 x4 x5 :print); call marspline(y x1 x2 x3 x4 x5 :print); b34srun; == ==PPEXP4 Nonlinearity in last 50% of model /; /; The data y1 is 100% linear /; The data y2 is set so that first 50% is nonlinear /; %b34slet noob = 1000; %b34slet noise = 20.; %b34slet nonlin = 5.; b34sexec data noob=%b34seval(&noob)$ build y1 y2 x z e1 noise$ gen noise=%b34seval(&noise); gen e1=rn()$ /; turn on one or the other pair to generate x and z gen x =10*rn()$ gen z =10*rn()$ gen x =10*rec()$ gen z =10*rec()$ gen y1= 10 + 5*x + 5*z + noise*e1 $ gen y2=y1; gen if(kount().gt.(%b34seval(&noob)/2.)) y2=y1+%b34seval(&nonlin)*(abs(x)**3); b34srun$ b34sexec matrix; call echooff; call loaddata; call load(ppexp_p); /; sets number of projections mm=5; /; sets order of legenre. Larger => smoother jj=2; fei=.1e-4; fei=1. ; nei = 1 ; /; nei = 2 ; trm=.1; /; trm=.8; mod1=1; mod2=1; if(mod1.ne.0)then; call ppexp(y1 x z :mm mm :jj jj :fei fei :nei nei :trm trm :print); ppi_m1=%ppindex; call ppexp_p(%xpa,%mm,%nob,0,'a',%ppindex); call dodos('copy ppexp_1.wmf model_1a.wmf',:); call dodos('copy ppexp_2.wmf model_1b.wmf',:); call dodos('copy ppindex.wmf ppindex1.wmf',:); endif; if(mod2.ne.0)then; call ppexp(y2 x z :mm mm :jj jj :fei fei :nei nei :trm trm :print); ppi_m2=%ppindex; call ppexp_p(%xpa,%mm,%nob,0,'b',%ppindex); call dodos('copy ppexp_1.wmf model_2a.wmf':); call dodos('copy ppexp_2.wmf model_2b.wmf':); call dodos('copy ppindex.wmf ppindex2.wmf':); call ppexp_p(%xpa,%mm,%nob,1 ,'b',%ppindex); endif; b34srun$ == ==PPEXP5 Tests of a good and Bad OLS Model /; Known Model y1 /; Bad Model y2 b34sexec options noheader; b34srun; b34sexec matrix; call load(ppexp_p); call load(gamplot); call echooff; /; This model is 100% ok and is linear n=10000; x1=rn(array(n:)); x2=rn(array(n:)); e=rn(array(n:)); y1=10. + (5.*x1 )+ (7.*x2 ) + e; y2=10. + (5.*abs(x1))+ (7.*abs(x2)) + e; call ppexp(y1 x1 x2 :mm 4 :nei 4 :trm 0. :print); call ppexp_p(%xpa,%mm,%nob,0,'t2',%ppindex); call ppexp_p(%xpa,%mm,%nob,1,'t2',%ppindex); file='gamsave.fsv'; call olsq( y1 x1 x2 :print); %olsyhat=%yhat; %olsres =%res; call print(' ':); call print('----------------------------------------------------':); call print('---------------- PPREG allows more than 1 tree -----':); call print('----------------------------------------------------':); call ppreg( y1 x1 x2 :print); call print(' ':); call print('----------------------------------------------------':); call print('---------------- PPREG held to one tree ------------':); call print('----------------------------------------------------':); call ppreg( y1 x1 x2 :print :m 1 :mu 1); call gamfit(y1 x1 x2 :punch_sur :punch_res :filename file :print); %gamyhat=%yhat; %gamres =%res; call gamplot(%names,%lag,file,%olsyhat,%olsres,0); call print('Model not correct for OLS ------------':); call olsq( y2 x1 x2 :print); %olsyhat=%yhat; %olsres =%res; call ppexp(y2 x1 x2 :mm 4 :nei 4 :trm 0. :print); call ppexp_p(%xpa,%mm,%nob,0,'t2',%ppindex); call ppexp_p(%xpa,%mm,%nob,1,'t2',%ppindex); /; See how a number of techniques would do on this poor model call olsq( y2 x1 x2 :print); call print(' ':); call print('----------------------------------------------------':); call print('---------------- PPREG allows more than 1 tree -----':); call print('----------------------------------------------------':); call ppreg( y2 x1 x2 :print :m 20 :mu 1); call print(' ':); call print('----------------------------------------------------':); call print('---------------- PPREG held to one tree ------------':); call print('----------------------------------------------------':); call ppreg( y2 x1 x2 :print :m 1 :mu 1); call gamfit( y2 x1 x2 :punch_sur :punch_res :filename file :print); %gamyhat=%yhat; %gamres =%res; call gamplot(%names,%lag,file,%olsyhat,%olsres,0); call marspline(y2 x1 x2 :print); call acefit( y2[order] x1[order] x2[order] :print); b34srun; == ==PPEXP_P Exploritory Projection Pursuit b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ppexp_p); call echooff; call olsq(cpeptide age bdeficit :print); ols_res=%res; call ppexp(cpeptide age bdeficit :print); call names(all); call print(%A,%xpa); call ppexp(cpeptide age bdeficit :print :mm 2 :nei 1); call print(%a,%xpa); call ppexp_p(%xpa,%mm,%nob,0,'t2',%ppindex); call ppexp_p(%xpa,%mm,%nob,1,'t2',%ppindex); b34srun; == ==PPREG Projection Pursuit Regression /; /; Illustrates a number of options /; b34sexec options ginclude('b34sdata.mac') member(gam_3); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call load(cfreq); call echooff; call olsq(cpeptide age bdeficit : print); %olsres =%res; %olsyhat=%yhat; olsrss=%rss; tests=1; /; if set = 1 runs afternative ppreg models r_ppr =0; if(r_ppr.ne.0)then; call ppreg(cpeptide age bdeficit :print :m 1 :alpha 0.0); call ppreg(cpeptide age bdeficit :print :m 1 :alpha 1.0); call ppreg(cpeptide age bdeficit :print :m 1 :alpha 2.0); call ppreg(cpeptide age bdeficit :print :m 1 :alpha 3.0); call ppreg(cpeptide age bdeficit :print :m 1 :alpha 0.0 ); call ppreg(cpeptide age bdeficit :print :m 1 :alpha 0.0 :conv .000002); call ppreg(cpeptide age bdeficit :print :m 1 :alpha 0.0 :span .001 :conv .000002); call ppreg(cpeptide age bdeficit :print :m 1 :alpha 0.0 :span .0001 :conv .000002); * testing forecasting ; call ppreg(cpeptide age bdeficit :savemodel :modname %test :print :m 4 :holdout 10 ); holdyhat=%yhat; call ppreg(:forecast %xfuture :modname %test :print); call tabulate(%foreobs %fore); /; this code tests "insample forecasting" ii=array(norows(age):)+1.0; call print(catcol(age bdeficit ii)); call ppreg(:forecast catcol(age bdeficit ii) :modname %test :print); call tabulate(%foreobs %fore holdyhat); call names(all); call ppreg(cpeptide age bdeficit :print :m 10 :eprint :lf 1); call ppreg(cpeptide age bdeficit :print :m 10 :eprint :lf 2); call ppreg(cpeptide age bdeficit :print :m 50 :lf 0); call ppreg(cpeptide age bdeficit :print :m 50 :lf 1); call ppreg(cpeptide age bdeficit :print :m 50 :lf 2); call ppreg(cpeptide age bdeficit :print :m 50 :lf 3); endif; if(tests.ne.0)then; call gamfit(cpeptide age[predictor,3] bdeficit[predictor,3] :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); %gamyhat=%yhat; %gamres=%res; gamrss =%rss; call acefit( cpeptide[order ] age[order] bdeficit[order] :maxit 20 :nterm 10 :ns 1 :tol .1e-8 :print); %aceres=%res(,1); %aceyhat=%yhat(,1); acerss=%ssres; call ppreg(cpeptide age bdeficit :print :m 30); %ppryhat=%yhat; %pprres=%res; pprrss =%rss; call print(' ':); call print('Residual sum of squares from OLS ',olsrss:); call print('Residual sum of squares from ACE ',acerss:); call print('Residual sum of squares from GAM ',gamrss:); call print('Residual sum of squares from PPR ',pprrss:); call graph(%y %olsyhat %aceyhat %gamyhat %ppryhat :nocontact :nolabel :heading 'Testing OLS, GAM, ACE and PPREG Models' ); call graph( %olsres %aceres %gamres %pprres :nocontact :nolabel :heading 'Testing OLS, GAM, ACE and PPREG Models' ); endif; b34srun; == ==PPREG2 Projection Pursuit Regression /; /; Illustrates a number of methods to estimate the Gas Data /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call load(cfreq); call echooff; maxlag=6; call olsq(gasout gasin{1 to maxlag} gasout{1 to maxlag} :print); %olsres =%res; %olsyhat=%yhat; olsrss=%rss; call gamfit(gasout gasin[predictor,3]{1 to maxlag} gasout[predictor,3]{1 to maxlag} :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); %gamyhat=%yhat; %gamres=%res; gamrss =%rss; call acefit( gasout gasin[order]{1 to maxlag} gasout[order]{1 to maxlag} :maxit 200 :nterm 10 :ns 1 :tol .1e-8 :print); %aceres=%res(,1); %aceyhat=%yhat(,1); acerss=%ssres; call ppreg(gasout gasin{1 to maxlag} gasout{1 to maxlag} :print :m 30 :mu 3); %ppryhat=%yhat; %pprres=%res; pprrss =%rss; call marspline(gasout gasin{1 to maxlag} gasout{1 to maxlag} :print :nk 50 :mi 2); marsyhat=%yhat; mars_res=%res; mars_rss =%rss; call print(' ':); call print('Residual sum of squares from OLS ',olsrss: ); call print('Residual sum of squares from ACE ',acerss: ); call print('Residual sum of squares from GAM ',gamrss: ); call print('Residual sum of squares from MARS ',mars_rss:); call print('Residual sum of squares from PPR ',pprrss: ); call graph(%y %olsyhat %aceyhat %gamyhat marsyhat %ppryhat :nocontact :nolabel :heading 'Testing OLS, GAM, ACE, MARS and PPREG Models'); call graph( %olsres %aceres %gamres mars_res %pprres :nocontact :nolabel :heading 'Testing OLS, GAM, ACE, MARS and PPREG Models'); call print('VAR Models':); call print('----------':); bigy=catcol(gasin gasout); call ppreg(bigy gasin{1 to maxlag} gasout{1 to maxlag} :print); call mars_var(bigy gasin{1 to maxlag} gasout{1 to maxlag} :print :nk 50 :mi 2); b34srun; == ==PPREG3 0-1 on left b34sexec options ginclude('b34sdata.mac') member(gam); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call echooff; call acefit(y[cat] age[order] start_v[order ] numvert[order] :tol .1e-9 :print); call ace_ols; call gamfit(y age[predictor,3] start_v[predictor,3] numvert[predictor,3] :link logit :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call names; call print(%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); y=y+1.; call ppreg(y age start_v numvert :print :reg); yhatreg = %yhat; call ppreg(y age start_v numvert :print :class 2); yhat_cl = %yhat; call olsq(y age start_v numvert :print); yhat_ols = %yhat; /; call tabulate(%y,yhatreg,yhat_cl,yhat_ols); b34srun; == ==PPREG4 Probit Model of Murder data /$ b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ /; b34sexec probit; model d1 = t y lf nw; b34srun; /; b34sexec loglin; model d1 = t y lf nw; b34srun; b34sexec matrix; call loaddata; yvar=afam(d1); /; this sets model call character(cc,'t y lf nw'); call marspline(yvar argument(cc) :logit :nk 80 :mi 3 :print); call olsq(yvar argument(cc) :print); call probit(yvar argument(cc) :print); call ppreg(yvar argument(cc) :m 20 :print :reg); yvar=yvar+1.; call ppreg(yvar argument(cc) :m 20 :print :class 2); b34srun; == ==PPREG5 PPREG :class model on iris data /; /; Illustrates ppreg :class options /; b34sexec options ginclude('b34sdata.mac') member(iris); b34srun; b34sexec matrix; call loaddata; call echooff; ippreg=1; ippc=1; testm=1; call olsq( species sepal_w sepal_l petal_l petal_w :print); if(ippreg.ne.0)then; call ppreg(species sepal_w sepal_l petal_l petal_w :print); call tabulate(%y %yhat %res); call print('Out of sample using REG on a 1 2 3 variable':); call ppreg(species sepal_w sepal_l petal_l petal_w :print :savemodel :holdout 50); %actual=species(integers(101:150)); call ppreg(:forecast %xfuture); call tabulate(%foreobs %fore %actual); endif; if(ippc.ne.0)then; call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 3 :mu 3 :class 3); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 20 :mu 1 :class 3); class1=%class_p(,1); class2=%class_p(,2); class3=%class_p(,3); call tabulate(%y %yhat %res %risk class1 class2 class3); /; testing forecasting with a holdout call print('Out of sample Forecasting':); call print('-------------------------':); call print(' ':); i=integers(101,150); actual=species(i); call ppreg(species sepal_w sepal_l petal_l petal_w :print :savemodel :m 8 :class 3 :holdout 50); /; call print(%xfuture); /; call names(all); call ppreg(:forecast %xfuture :print :class 3); class1=%class_p(,1); class2=%class_p(,2); class3=%class_p(,3); error=(afam(actual) .ne. afam(%fore)); call tabulate(%foreobs actual %fore error %risk class1 class2 class3); rate=sum(error)/dfloat(norows(error)); call print(' '); call print('# Errors out of sample ',sum(error):); call print('Error Percentage ',rate:); endif; /; /; Try a number of m values to see how things go out of sample /; if(testm.ne.0)then; call print(' ':); call print('Out of Sample Forecasting':); call print(' ':); itest=18; m =array(itest:); n_error=array(itest:); rate =array(itest:); m=array(itest:); do i=1,itest; call ppreg(species sepal_w sepal_l petal_l petal_w :print :savemodel :m i :class 3 :holdout 50); /; call print(%xfuture); /; call names(all); call ppreg(:forecast %xfuture :class 3); class1=%class_p(,1); class2=%class_p(,2); class3=%class_p(,3); error=(afam(actual) .ne. afam(%fore)); rate1 =sum(error)/dfloat(norows(error)); call print(' '); m(i)=dfloat(i); n_error(i)=sum(error); rate(i) =rate1; enddo; call tabulate(m,n_error,rate); endif; b34srun; == ==PPREG6 PPREG on RES Data. Out of sample Forecasting /; /; Very Hard problem since population shifts /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call echooff; call olsq(lnq time lnl lnk lnrm2 :print); m =15; mu=1; call ppreg(lnq time lnl lnk lnrm2 :print :m m :mu mu :lf 0); call ppreg(lnq time lnl lnk lnrm2 :print :m m :mu mu :lf 1); call ppreg(lnq time lnl lnk lnrm2 :print :m m :mu mu :lf 2); call ppreg(lnq time lnl lnk lnrm2 :print :m m :mu mu :lf 3); call tabulate(%y %yhat %res); call print('Out of sample using PPREG on RES 1972 Data':); holdout=10; call ppreg(lnq time lnl lnk lnrm2 :print :m m :mu mu :savemodel :holdout holdout); %actual=lnq( integers(norows(lnq)-holdout+1,norows(lnq)) ); call ppreg(:forecast %xfuture); error=%actual-afam(%fore); call tabulate(%foreobs %fore %actual error); call graph(error); call graph(%fore %actual); b34srun; == ==PPREG7 PPREG/ACE/GAM/OLS on a 7 class model b34sexec options ginclude('b34sdata.mac') member(satimage); b34srun; b34sexec matrix; call loaddata; /; sets for out of sample forecasting ifore=100; call olsq(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print); olsres =%res; olsyhat =%yhat; call print('# of correct predictions ',sum((%res.eq.0.0))); /; Look for optimum m * call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print :m 30 :mu 1); call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print :m 7); call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print :m 7 :class 7); call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print :m 16 :class 7); * call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print :m 30 :mu 1); call acefit(y[cat] x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :tol .1e-9 :ns 1 :print); *call ace_ols; call print('# of correct predictions ',sum((%res.eq.0.0))); y1=y-1.0; call gamfit(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call print('# of correct predictions ',sum((abs(%res).le..499))); * call tabulate(%y %yhat %res); if(ifore.ne.0)then; /; out of sample call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print :m 16 :class 7 :savemodel :holdout ifore); %actual=y( integers(norows(y)-ifore+1,norows(y)) ); call ppreg(:forecast %xfuture :class 7); error=(%actual.ne.afam(%fore)); call tabulate(%foreobs %fore %actual); call graph(%fore %actual :nolabel :nocontact); call print('Sum error / # forecasts ',sum(error)/dfloat(norows(error))); endif; b34srun; == ==PRINT call print => Print objects and strings b34sexec matrix; x=matrix(3,3:11 22 33 55 66 77 88 99 00); v=vector(3:1 2 3); call print(x,v); inv=(1./x); call print(inv); cc=complex(inv,inv+3.); call print(cc); cv=complex(v,v-2.); call print(cv); test=x*inv; call print('This is the Identity Matrix',test); b34srun; == ==PPREGTEST Testing OLS, MARS, GAM PPEXP PPREG /; Illustrates Nonlinear Modeling /; one nonlinear series. One linear series /; Experiment with settings /; Suggested use: /; First try mod=1, mod=2, mod=3 /; Next experiment with bend setting /; Finally experiment with Coef and noise settings /; b34sexec matrix; call load(contrib); call echooff; call contribi; program nonltest; x=rn(array(n:)); z=rn(array(n:)); /; /; alternative models /; if(mod.eq.1)y=coef1*cos(x**bend) +coef2*z+coef3+noise*rn(array(n:)); if(mod.eq.2)y=coef1*dlog(abs(x**bend)) +coef2*z+coef3+noise*rn(array(n:)); if(mod.eq.3)y=coef1*(x**bend) +coef2*z+coef3+noise*rn(array(n:)); /; /; specific settings /; _mi=3; _m=10; iols=3; isave=0; call character(fsv_info,'8. Misralb Model'); call character(l_hand_s,'y'); call character(_args, 'x z'); call character(_argsg, 'x[predictor,3] z[predictor,3]'); call contribl; call contribd; return; end; bend=2.; coef1=10.; coef2=10.; coef3=10.; n=1000; noise=1.; mod=2; do_ppexp=1; /; fit case call nonltest; /; perfect fit case noise=0.; /; call nonltest; b34srun; == ==PRINT1 Tests and Illustrates Print Formats /$ Tests various print formats b34sexec matrix display=col80fixed ; /$ b34sexec matrix display=col80medium ; /$ b34sexec matrix display=col80high ; /$ b34sexec matrix display=col129fixed ; /$ b34sexec matrix display=col129medium; /$ b34sexec matrix display=col129high ; * math with matrix and vectors ; n=30; call print('This is n',n); right=integers(1,((n*n))); call print('Integer',right); x=matrix(n,n:);x=rn(x); call print(x,afam(x)); v=vector(n:integers(1,n));call print('v',v) ; call names; call print(' Real*4 Results ' '++++++++++++++++++++++++++++++++++++++++'); rx=sngl(x+300.); call print(rx,afam(rx)); rv=sngl(v+300.); call print(rv,afam(rv)); call names; call print(' Integer Results ' '++++++++++++++++++++++++++++++++++++++++'); ix=idint(x+300.); call print(ix,afam(ix)); iv=idint(v+300.); call print(iv,afam(iv)); call names; call print(' Complex Results ' '++++++++++++++++++++++++++++++++++++++++'); x2=x+2.; x=mfam(complex(x,x2)); call print(x,afam(x)); v=mfam(complex(v,v+8.0)); call print(v,afam(v)); call names; call names(all); call print(' Character*8 Results ' '++++++++++++++++++++++++++++++++++++++++'); nn=namelist(Dan Jay Sarah Diana Carol Sylvia Judy Minna Liz); call print(nn); nn33=array(3,3:nn); call print(nn33); call names(all); b34srun; == ==PRINT2 Printing Simulated output b34sexec matrix; call echooff; call print('Test of line 1':line); call print('Test of line 2':line); call print('Real Number ',.99 :line); call print('An integer ',11 :line); xx=.99; xx=sngl(xx); call print('A real*4 ',xx :line); call print(' ':line); call print('Print number with and without a header':line); call print(' ',.99:line); call print(.99:line); b34srun; == ==PRINTALL Prints all variables in storage b34sexec matrix; x=rn(matrix(4,4:)); cc=inv(x); c=complex(1.2,3.3); call printall; b34srun; == ==PRINTOFF Turn off all output b34sexec matrix; do i=1,10; call print(i); enddo; * Now we run silently ; call echooff; call printoff; do i=1,10; call print(i); enddo; call printon; call print('We are done!!'); b34srun; == ==PRINTON Start Printing again b34sexec matrix; do i=1,10; call print(i); enddo; * Now we run silently ; call echooff; call printoff; do i=1,10; call print(i); enddo; call printon; call print('We are done!!'); b34srun; == ==PRINTVASV Resets so that vectors/arrays print as vectors/arrays b34sexec matrix; x=rn(array(50:)); x4=sngl(x); x16=r8tor16(x); cx=complex(x,5.*x); cx32=c16toc32(cx); ix=idint(x); ix8=i4toi8(ix); vpax=vpa(x); call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvasrmat; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvascmat; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvasv; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); b34srun; == ==PRINTVASCMAT Vectors/Arrays print as Column Matrix/Array b34sexec matrix; x=rn(array(50:)); x4=sngl(x); x16=r8tor16(x); cx=complex(x,5.*x); cx32=c16toc32(cx); ix=idint(x); ix8=i4toi8(ix); vpax=vpa(x); call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvasrmat; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvascmat; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvasv; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); b34srun; == ==PRINTVASRMAT Vectors/Arrays print as Row Matrix/Array b34sexec matrix; x=rn(array(50:)); x4=sngl(x); x16=r8tor16(x); cx=complex(x,5.*x); cx32=c16toc32(cx); ix=idint(x); ix8=i4toi8(ix); vpax=vpa(x); call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvasrmat; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvascmat; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); call printvasv; call print(x,x4,x16,cx,cx32,ix,ix8,vpax); b34srun; == ==PROBIT Probit function b34sexec matrix; n=20; * Generate Rec variable in range 0.0 - 1.0 ; test=rec(array(n:)); pp=probit(test); call tabulate(test,pp); test=array(: 0.0 .01 .05 .1 .2 .3 .4 .5 .6 .7 .8 .9 .95 .99 1.0); pp=probit(test); call tabulate(test,pp); b34srun; == ==PROBIT_MOD Illustrated call probit( ) /; /; Probit Model Tests /; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; call probit(d1 t y lf nw :print ); call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 1'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call probit(d1 t y lf nw :print :secd :tola .1e-14 :iitlk :iiesk :savex :holdout 2); call print('Testing Y yhat error'); %error=%y-%yhat; yyhat=probnorm(%x*%coef); error=%y-yyhat; call names(all); call tabulate(%y,%yhat,%error,yyhat,error); call print(%xfuture); call print(probnorm(%xfuture*%coef)); b34srun; == ==PROBIT_EST Estimation of Probit/Logit/Mars Logit /$ b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ /; b34sexec probit; model d1 = t y lf nw; b34srun; /; b34sexec loglin; model d1 = t y lf nw; b34srun; b34sexec matrix; call loaddata; yvar=afam(d1); /; this sets model call character(cc,'t y lf nw'); /; Set up for probit and logit mask1 = afam((yvar.eq.1.)); mask2 = afam((yvar.eq.0.)); call lagmatrix(argument(cc ) :matrix xdata); call olsq(yvar argument(cc) :print); rvec= vector(nocols(xdata): )+%coef; ll= vector(nocols(xdata):)-.1e+30; uu= vector(nocols(xdata):)+.1e+30; call echooff; * probit ; program probit; xb=afam(xdata*beta); func= mlsum((mask1*probnorm(xb))+(mask2*probnorm((-1.)*xb))); call outstring(3,3,'Function'); call outdouble(36,3,func); return; end; * logit ; program logit; term=1.0/(1.0+dexp((-1.0)*afam(xdata*beta))); func= mlsum((mask1*term)+(mask2*(1.0-term))); call outstring(3,3,'Function'); call outdouble(36,3,func); return; end; call print(probit,logit) call echooff; call print('PROBIT Model +++++++++++++++++++++++++++++++++':); beta=rvec; call cmaxf2(func :name probit :parms beta :ivalue rvec :maxfun 20000 :maxg 20000 :maxit 100000 :lower ll :upper uu :print); beta1=%coef; se1=%se; t1=%t; call tabulate(%lmatvar %lmatlag beta1 se1 t1); call print('Logit Model ++++++++++++++++++++++++++++++++':); call cmaxf2(func :name logit :parms beta :ivalue rvec :maxfun 20000 :maxg 20000 :maxit 100000 :lower ll :upper uu :print); beta2=%coef; se2=%se; t2=%t; call tabulate(%lmatvar %lmatlag beta2 se2 t2); call mars(yvar argument(cc) :logit :nk 80 :mi 3 :print); b34srun; == ==PROBIT_2 Call probit( ) Example /; Test job /; dob34s => uses probit and loglin /; loglin => 2 times * -1. %b34slet dob34s =1$ %b34slet dorats =0$ %b34slet domatrix =0; %b34slet domatrix2=1; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ %b34sif(&dob34s.ne.0)%then$ B34SEXEC PROBIT tola=.1e-14 $ MODEL D1 = T Y LF NW; B34Srun$ /; b34sexec loglin $ model d1 = T y lf nw; b34srun; /; B34SEXEC MLOGLIN IP=1 $ MODEL D1= T Y LF NW $ /; LEVEL D1(HAVELAW)$ B34SEEND$ %b34sendif$ %b34sif(&dorats.ne.0)%then$ b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec data set; rename t=tt; rename n=nn; b34srun; B34SEXEC OPTIONS HEADER$ B34SRUN$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * smpl lgt d1 # constant Tt Y LF NW prb d1 # constant Tt Y LF NW b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif$ %b34sif(&domatrix.ne.0)%then; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(p_l_est :staging); call load(tlogit :staging); call echooff; %yin=d1; %xin=mfam(catcol(constant t y lf nw)); call print(%xin); call p_l_est('probit',%yin,%xin,%func,%coef,%se,%t,%yhat,'print',0); call print('Probit model':); call tabulate(%coef,%se,%t); call tabulate(%yin,%yhat); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model'); call tlogit(%yin,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call p_l_est('logit', %yin,%xin,%func,%coef,%se,%t,%yhat,'print',0); call print('Logit model':); call tabulate(%coef,%se,%t); call tabulate(%yin,%yhat); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on Logit Model'); call tlogit(%yin,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call print(' ':); call print(' Results with max2 ******************************':); call p_l_est('probit',%yin,%xin,%func,%coef,%se,%t,%yhat,'print',1); call print('Probit model':); call tabulate(%coef,%se,%t); call tabulate(%yin,%yhat); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model'); call tlogit(%yin,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call p_l_est('logit', %yin,%xin,%func,%coef,%se,%t,%yhat,'print',1); call print('Logit model':); call tabulate(%coef,%se,%t); call tabulate(%yin,%yhat); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on Logit Model'); call tlogit(%yin,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); b34srun; %b34sendif; /; Matrix probit command %b34sif(&domatrix2.ne.0)%then; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; call probit(d1 t y lf nw :print ); call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 1'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call probit(d1 t{1} y{1} lf{1} nw{1} :print :printvcv); call print('Probit model':); call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 2'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call print( %func %funcsig %dffunc %limits %rcond %hessian); call probit(d1 t y lf nw :print :secd :tola .1e-14 :iitlk :iiesk :savex :holdout 2); call print('Testing Y yhat error'); %error=%y-%yhat; yyhat=probnorm(%x*%coef); error=%y-yyhat; call names(all); call tabulate(%y,%yhat,%error,yyhat,error); call print(%xfuture); call print(probnorm(%xfuture*%coef)); b34srun; %b34sendif; == ==PROBNORM Probnorm function => Normal Probability b34sexec matrix$ z=grid(-4.5,4.5,.01); prob =probnorm(z); den =normden(z); z16 =r8tor16(z); prob16=probnorm(z16); den16 =normden(z16); call tabulate(z,prob,den,prob16,den16); call graph(z,prob,den:htitle 1.5 1.5 :plottype xyplot :nocontact :pgborder :nolabel :heading ' Normal Probabily and Density'); b34srun; == ==PROBNORM2 Bivariate Normal Probability b34sexec matrix$ * IMSL Test Problem; x=-2.0; y=0.0; rho=.90; prob=probnorm2(x,y,rho); call print('Probability ',prob); x =array(:0.0 0.0 0.0); y =array(:0.0 0.0 0.0); rho=array(:0.0 1.0 .5); prob=probnorm2(x,y,rho); call tabulate(x,y,rho,prob); b34srun; == ==PROD Prod function => shows dot product b34sexec matrix; x=vector(5:1 2 3 4 5); call print(x,prod(x)); xx=rn(matrix(6,6:)); e=eigenval(xx); call print('We note: Product of eigenvalues = det',det(xx),prod(e)); call print('We note: Sum of eigenvalues = trace',sum(e),trace(xx)); b34srun; == ==PROGTEST1 Illustrates Program Calls /$ Tests of one programing calling another /$ Multiple calls are made b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call print('Means of gasout and gasin in root', mean(gasout),mean(gasin)); program meanp; * test program ; xmean1=mean(gasout); xmean2=mean(gasin); call print('Mean in Program for gasout was',xmean1); call print('Mean in Program for gasin was',xmean2); call matops; call graph(gasin,gasout); return; end; program matops; * Test program to be called by meanp or stand alone; x=matrix(4,4:); x=rec(x); call print(x); ix=1./x; call print(ix); call print('Did the Inverse work?',ix*x); return; end; call names(all); call print(meanp,matops); call meanp; call meanp; call meanp; b34srun; == ==PROGTEST2 Illustrates use of programs at different levels b34sexec matrix showuse; * Illustrates how a program can access variables at current level; n=4; call names(all); x=rn(matrix(n,n:)); program listx; * this lists x at the level where it is called; call print('This is x as known at this point',x); return; end; subroutine level2(i); call print('Subroutine level2 called. I was ',I); x=rn(matrix(i,i:)); call print('x from print statement in level2',x); call listx; call print('We are leaving level2'); call names(all); return; end; call print('x from print statement at base level',x); call listx; j=3; call level2(j); call names(all); b34srun$ == ==PVALUE_1 Present Value of $1 recieved at end of n years b34sexec matrix; call print('PV of $1 recieved at end of n years'); call print('See Douglas table 1',:); call echooff; call load(pvalue_1); interest=.06; n=20; years=integers(n); pv=array(n:); do i=1,n; call pvalue_1(i,interest,a); pv(i)=a; enddo; call tabulate(years,pv :noobslist :title 'Present value of 6% recieved after n years'); b34srun; == ==PVALUE_2 Present Value of an Annuity of $1 b34sexec matrix; call print('PV of an Annuity of $1 after n years'); call print('See Douglas table 2',:); call echooff; call load(pvalue_2); call load(pvalue_1); sum=0.0; n=20; interest=.06; aa=array(n:); do i=1,n; call pvalue_2(i,interest,a); aa(i)=a; enddo; yearpays=integers(n); call tabulate(yearpays,aa :noobslist :title 'Present value of 6% annuity after n years'); b34srun; == ==PVALUE_3 Present Value of $1 recieved thoughout year b34sexec matrix; call print('PV of $1 recieved througout year on daily basis',:); call print('Years Hence',:); call print('See Douglas table 3',:); call echooff; call load(pvalue_3); interest=.06; n=20; years=integers(n); pv=array(n:); do i=1,n; call pvalue_3(i,i,interest,a); pv(i)=a; enddo; call tabulate(years,pv :noobslist :title 'Present value of 6% annuity $1 daily'); b34srun; == ==Q1 Q1 Function for real*8 Data b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call describe(gasout :print); mm1=mean(gasout); mm2=median(gasout); q1_ =q1(gasout); q3_ =q3(gasout); call print('Mean ',mm1:); call print('Median ',mm2:); call print('Q1 ',q1_:); call print('Q3 ',q3_:); b34srun; == ==Q3 Q3 Function for real*8 Data b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call describe(gasout :print); mm1=mean(gasout); mm2=median(gasout); q1_ =q1(gasout); q3_ =q3(gasout); call print('Mean ',mm1:); call print('Median ',mm2:); call print('Q1 ',q1_:); call print('Q3 ',q3_:); b34srun; == ==QCOMPLEX Make a Complex*32 Number from Real*16 b34sexec matrix; r=.3; ii=.4; cc=complex(r,ii); x=rec(matrix(4,4:)); cx =complex(x); cx2=complex(x,dsqrt(dabs(x))); call names; call print(r,ii,cc,x,cx,cx2); call print('real*16 cases ************************':); r =r8tor16(r); ii=r8tor16(ii); cc=qcomplex(r,ii); x=r8tor16(rec(matrix(4,4:))); cx =qcomplex(x); cx2=qcomplex(x,dsqrt(dabs(x))); call names; call print(r,ii,cc,x,cx,cx2); b34srun; == ==QFLOAT Integer to real*16 b34sexec matrix; r16g=r8tor16(grid(.1,6.,.3)) ; i=integers(norows(r16g)); r4i =float(i); r16i=qfloat(i) ; i4iqint=iqint(r16g) ; i4iqnint=iqnint(r16g) ; i4fromr4=int(r4i) ; r16qint=qint(r16g) ; call names(all) ; call tabulate(i,r4i,r16i,r16g,i4iqint,i4iqnint,i4fromr4 r16qint); b34srun; == ==QIMAG imag (saved as real*16) part of Complex*32 variable b34sexec matrix; xr=matrix(2,2:1 2 3 4); xi=dsqrt(xr); cc=complex(xr,xi); cc=c16tor32(cc); call print(cc,qreal(cc),qimag(cc)); b34srun; == ==QINT Integer part of real*16 b34sexec matrix; r16g=r8tor16(grid(.1,6.,.3)) ; i=integers(norows(r16g)); r4i =float(i); r16i=qfloat(i) ; i4iqint=iqint(r16g) ; i4iqnint=iqnint(r16g) ; i4fromr4=int(r4i) ; r16qint=qint(r16g) ; r16qnint=qnint(r16g) ; call names(all) ; call tabulate(i,r4i,r16i,r16g,i4iqint,i4iqnint, i4fromr4 r16qint r16qnint); b34srun; == ==QNINT Integer part of real*16 in a real*16 b34sexec matrix; r16g=r8tor16(grid(.1,6.,.3)) ; i=integers(norows(r16g)); r4i =float(i); r16i=qfloat(i) ; i4iqint=iqint(r16g) ; i4iqnint=iqnint(r16g) ; i4fromr4=int(r4i) ; r16qint=qint(r16g) ; r16qnint=qnint(r16g) ; call names(all) ; call tabulate(i,r4i,r16i,r16g,i4iqint,i4iqnint, i4fromr4 r16qint r16qnint); b34srun; == ==QPMIN Quadratic Programing test case b34sexec matrix; * answers should be vector of 1. ; * Problem came from IMSL ; ncon=2; nvar=5; neq= 2; a=matrix(ncon,nvar: 1., 1., 1., 1., 1., 0., 0., 1.,-2.,-2. ); b=vector(ncon : 5.,-3.); g=vector(nvar :-2., 0., 0., 0.,0. ); h=matrix(nvar,nvar: 2., 0., 0., 0., 0. 0., 2.,-2., 0., 0. 0.,-2., 2., 0., 0. 0., 0., 0., 2.,-2. 0., 0., 0.,-2., 2. ); call qpmin(g,a,b,h,neq :print); b34srun; == ==QR_2 QR Factorization with LAPACK b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; sp_pdx=sngl(pdx); sp_x=sngl(x); r1 =pdfac(transpose(x)*x); sp_r1=pdfac(transpose(sp_x)*sp_x); call print(x,sp_x,r1,sp_r1); r2 =qr(x); sp_r2=qr(sp_x); rr2=qr(x,q); sp_rr2=qr(sp_x,sp_q); call print('test Q from real*8 LAPACK',transpose(q)*q); call print('test Q from real*4 LAPACK',transpose(sp_q)*sp_q); call print(r2,rr2,q, sp_r2,sp_rr2,sp_q); call print('Positive Definite Matrix',pdx, 'Factorization from pdfac',r1, 'Factorization from qr ',r2, 'Test if the Factorization was OK', 'linpack transpose(r1)*r1', transpose(r1)*r1, 'lapack transpose(r2)*r2', transpose(r2)*r2, ' ','Complex Case'); cpdx2 = complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx = dconj(transpose(cpdx2))*cpdx2; call print(cpdx); cr1 = qrfac(cpdx); cr2 = qr(cpdx); call print(cpdx, 'Factorization from qrfac', cr1, 'Factorization from qr ', cr2); r2=qr(cpdx); rr2=qr(cpdx,q); call print('test Q from LAPACK using complex',transpose(q)*q); call print('q*rr2',q*rr2,'cpdx',cpdx); call print(r2,rr2,q); b34srun; b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; r1=pdfac(transpose(x)*x); call print(x); r2=qr(x); rr2=qr(x,q); call print('test Q from LAPACK',transpose(q)*q); call print(r2,rr2,q); call print('Positive Definite Matrix',pdx, 'Factorization from pdfac',r1, 'Factorization from qr ',r2, 'Test if the Factorization was OK', 'linpack transpose(r1)*r1', transpose(r1)*r1, 'lapack transpose(r2)*r2', transpose(r2)*r2, ' ','Complex Case'); cpdx2 = complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx = dconj(transpose(cpdx2))*cpdx2; call print(cpdx); i = integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); call print('Eigen values of cpdx ',eig(transpose(cpdx)*cpdx)); cr1 = pdfac(transpose(cpdx)*cpdx); cr2qrfac = qrfac(cpdx); cr2 = qr(cpdx); call print('Positive Definite Matrix',cpdx, 'Factorization from pdfac', cr1, 'Factorization from qrfac', cr2qrfac, 'Factorization from qr ', cr2, 'Test if the Factorization was OK', 'linpack dconj(transpose(cr1))*cr1', dconj(transpose(cr1))*cr1,' ', 'lapack dconj(transpose(cr2))*cr2', dconj(transpose(cr2))*cr2,' '); r2=qr(cpdx); rr2=qr(cpdx,q); call print('test Q from LAPACK using complex',transpose(q)*q); call print(r2,rr2,q); b34srun; == ==QR_3 Using QR Analysis to detect outliers /; Illustrates outlier effects b34sexec data heading('Davidson-MacKinnon (1993,37)'); input t x_1 y; build x_2; gen x_2=x_1; gen if(t.eq.7)x_2=7.68; datacards; 1 1.51 2.88 2 2.33 3.62 3 3.57 5.64 4 2.12 3.43 5 1.54 3.21 6 1.71 4.49 7 2.68 4.50 8 2.25 4.28 9 1.32 2.98 20 2.80 5.57 b34sreturn; b34srun; b34sexec matrix; call loaddata; call echooff; call olsq(y x_1 :print :savex :outlier); x1_mat=%x; r1=qr(x1_mat,q_1); h_1=diag(q_1*transpose(q_1)); res_1=%res; hi_1=%hi; hi_i_1=%hi_i; call olsq(y x_2 :print :savex :outlier); x2_mat=%x; r2=qr(x2_mat,q_2); h_2=diag(q_2*transpose(q_2)); res_2=%res; hi_2=%hi; hi_i_2=%hi_i; effect_1=afam(res_1)*(afam(h_1)/(1.-afam(h_1))); effect_2=afam(res_2)*(afam(h_2)/(1.-afam(h_2))); call tabulate(y,x_1,x_2,res_1,h_1,effect_1,res_2,h_2,effect_2); call print('Looking at h from two angles ':); call tabulate(hi_1, hi_i_1, h_1, hi_2, hi_i_2, h_2); call print(' ':); call print('Obtaining beta, yhat and res from QR Directly':); yhat_2=q_2*transpose(q_2)*%y; res_2b=to_vector(to_cmatrix(%y)-to_cmatrix(yhat_2)); call print('QR Beta ',inv(r2)*transpose(q_2)*to_cmatrix(%y)); call tabulate(%yhat,%res,yhat_2,res_2b); b34srun; == ==QR_4 Illustrates Error using Cholesky /$ Illustrates OLS Capability under Matrix Command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call load(qr_small :staging); call echooff; call loaddata; nlag=4; call olsq(gasout gasin{0 to nlag} gasout{1 to nlag} :print :savex); call print(ccf(%y, %res)); call print(ccf(%yhat,%res)); /; /; Large QR used for illustration. Q2 is large!!! /; error2 equation uses q1 => uses the economy qr. This is the /; best way to proceed /; r=qr(%x,q:); call qr_small(%x,q,r,q1,q2,r_small); /; call print(q,q1,q2); yhat =q1*transpose(q1)*%y; error =q2*transpose(q2)*%y; error2=%y - yhat; beta=inv(r_small)*transpose(q1)*%y; call print('Beta from QR ',beta); call print(ccf(%y,error)); call print(ccf(yhat,error)); /; call tabulate(%y,%yhat,yhat,%res,error,error2); call print(' ':); call print('Study Error Buildup using Cholesky':); call print(' ':); /; excessive problem maxlag=40; chol_r=vector(maxlag:); qr_r =vector(maxlag:); do i=1,maxlag; /; /; :qr call uses linpack to get OLS. This is close to LAPACK QR( ) /; /; call olsq(gasout gasin{0 to i} gasout{1 to i} :qr :savex); call olsq(gasout gasin{0 to i} gasout{1 to i} :savex); /; /; Use economy size qr to save space!! /; r=qr(%x,q); qr_yhat =q*transpose(q)*%y; qr_error =%y - qr_yhat; chol_r(i)=ccf(%yhat , %res); qr_r(i) =ccf(qr_yhat,qr_error); enddo; call tabulate(chol_r,qr_r :title 'As maxlag increases accuracy declines'); b34srun; == ==QR_5 Validates Complex*16 QR( ) b34sexec matrix; x=matrix(3,3: 22 33 44 55 44 33 88 77 99); xn=sqrt(complex((-1.*x),0.)); x=complex(x,0.0)+xn; call print(x); r=qr(x,q); call print(r,q); /$ Shows Matlab running under matrix /$ /$ Matlab can be called in a loop!! call makematlab(x :file 'xdat.m'); call load(rmatlab); call rmatlab; /$ Running Matlab script under B34S Matrix /$ Tasks: 1. Pass Data from B34S to Matlab /$ 2. Do work in Matlab /$ 3. Bring data back from Matlab to B34S /$ not implemented /$ user needs to type quit in matlab to get /$ back to b34s /$ /$ Matlab Commands /$ pgmcards; x=getb34s('xdat.m'); [q,r]=qr(x) % Next two commands pass Matlab data back to Matrix % makeb34s('e3.dat',e3); % makeb34s('evec3.dat',evec3); % quit b34sreturn; b34srun; == ==QRFACT QR Factorization b34sexec matrix; n=4;x=rn(matrix(n,n:)); pdx=transpose(x)*x; r1=pdfac(transpose(x)*x); r2=qrfac(x); call print('Positive Definite Matrix',pdx, 'Factorization from pdfac',r1, 'Factorization from qrfac',r2, 'Test if the Factorization was OK', 'transpose(r1)*r1', transpose(r1)*r1, 'transpose(r2)*r2', transpose(r2)*r2, ' ','Complex Case'); cpdx2=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx =dconj(transpose(cpdx2))*cpdx2; cr1=pdfac(cpdx); cr2=qrfac(cpdx2); i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); call print('Positive Definite Matrix',cpdx, 'Factorization from pdfac', cr1, 'Factorization from qrfac', cr2, 'Test if the Factorization was OK', 'dconj(transpose(cr1))*cr1', dconj(transpose(cr1))*cr1,' ', 'dconj(transpose(cr2))*cr2', dconj(transpose(cr2))*cr2,' '); pdx=transpose(x)*x; /$ real*16 x=r8tor16(x); pdx=r8tor16(pdx); r1=pdfac(transpose(x)*x); r2=qrfac(x); call print('Real*16 Case', 'Positive Definite Matrix',pdx, 'Factorization from pdfac',r1, 'Factorization from qrfac',r2, 'Test if the Factorization was OK', 'transpose(r1)*r1', transpose(r1)*r1, 'transpose(r2)*r2', transpose(r2)*r2, ' ','Complex Case*32'); cpdx2=c16toc32(cpdx2); cpdx =dconj(transpose(cpdx2))*cpdx2; cr1=pdfac(cpdx); cr2=qrfac(cpdx2); i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); call print('Positive Definite Matrix',cpdx, 'Factorization from pdfac', cr1, 'Factorization from qrfac', cr2, 'Test if the Factorization was OK', 'dconj(transpose(cr1))*cr1', dconj(transpose(cr1))*cr1,' ', 'dconj(transpose(cr2))*cr2', dconj(transpose(cr2))*cr2,' '); b34srun; == ==QREAL Real*16 part of Complex*32 variable b34sexec matrix; xr=matrix(2,2:1 2 3 4); xi=dsqrt(xr); cc=complex(xr,xi); cc=c16tor32(cc); call print(cc,qreal(cc),qimag(cc)); b34srun; == ==QRSOLVE QR Approach to OLSQ b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call olsq(ct ri rpt :print); res1=%res; yhat1=%yhat; x=array(norows(ct),3:); x(,1)=ri ; x(,2)=rpt; x(,3)=1. ; x=mfam(x); r=qrfac(x,qr,pivot); * here we use qr to get beta ; call print(qr,pivot); beta=qrsolve(qr,pivot,ct,info); diffbeta=%coef-beta; call tabulate(%coef,beta,diffbeta); diffyhat=%yhat-yhat1; diffres =%res -res1; call tabulate(%qy,%qty,%res,%yhat,res1,yhat1,diffyhat,diffres); call print('Real*16 results':); r16x=r8tor16(x); r=qrfac(r16x,qr,pivot); * here we use qr to get beta ; call print(r,qr,pivot); betar16=qrsolve(qr,pivot,r8tor16(ct),info); call print('beta',betar16); /; Now we use real*4 r4x=sngl(x); r=qrfac(r4x,qr,pivot); * here we use qr to get beta ; call print(r,qr,pivot); betar4=qrsolve(qr,pivot,sngl(ct),info); call print('beta',betar4); Call tabulate(beta,betar16,betar4); b34srun; == ==QUANTILE Quantile of Data b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; dd=grid(.00 1. ,.01); * Note that the 50% quantile is the median ; q=array(4:.25,.50,.75,.99); call quantile(dd,q,qvalue); call tabulate(q,qvalue); call quantile(gasout,q,qvalue); call tabulate(q,qvalue); call load(cfreq); call cfreq(gasout,sgasout,cc); call echoon; call tabulate(gasout,sgasout,cc); b34srun; == ==QUANTREG Test LI and Quantile Regression b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call olsq(gasout gasin :l1 :minimax :print :savex); call load(quantreg); * See if can get L1; /$ l1 ********************************************** iprint=1; theta=.5; call quantreg; call print('Sum absolute errors L1 (Theta = .5)',sumabs:); /$ Theta = .1 theta=.1; call quantreg; call print('Sum absolute errors (Theta = .1)',sumabs:); /$ Theta = .9 theta=.9; call quantreg; call print('Sum absolute errors (Theta = .9)',sumabs:); /$ Look at a range of Thetas beta1=array(9:); beta2=array(9:); fit =array(9:); iprint=0; do i=1,9; theta=dfloat(i)/10.; call quantreg; ttheta(i)=theta; beta1(i)=%coef(1); beta2(i)=%coef(2); fit(i)=sumabs; enddo; call tabulate(ttheta,beta1,beta2,fit:title 'Regression Quantiles for Various Theta'); call graph(ttheta,fit :plottype xyplot :Heading 'Fit Vs Quantile'); call graph(ttheta,beta1 :plottype xyplot :heading 'Beta1 vs Quantile'); call graph(ttheta,beta2 :plottype xyplot):heading 'Beta2 vs Quantile'); b34srun; == ==QUANTREG_2 Quantile Autogressive Model /; /; Implementing aspects of "Quantile Autoregression," /; by Roger Koenker and Zhijie Xiao JASA September 2006, Vol 101 /; No. 475 pp 980-990. comments 991-1006 /; /; Zero finder from IMSL used /; /; Key Idea: Lag parameters differ by quantile /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; /; k=3; k=6; call olsq(gasout gasout{1 to k} gasin{1 to k} :l1 :minimax :print :savex); call load(quantreg); * See if can get L1; /$ l1 ********************************************** iprint=1; theta=.5; call quantreg; call print('Sum absolute errors L1 (Theta = .5)',sumabs:); /$ Theta = .1 theta=.1; call quantreg; call print('Sum absolute errors (Theta = .1)',sumabs:); /$ Theta = .9 theta=.9; call quantreg; call print('Sum absolute errors (Theta = .9)',sumabs:); /$ Look at a range of Thetas beta =array(9,nocols(%x):); fit =array(9:); ttheta =array(9:); iprint=0; do i=1,9; theta=dfloat(i)/10.; call quantreg; ttheta(i)=theta; beta(i,)=%coef; fit(i)=sumabs; enddo; call tabulate(ttheta,fit:title 'Regression Quantiles for Various Theta'); call print('Beta',beta); call graph(ttheta,fit :plottype xyplot :Heading 'Fit Vs Quantile'); b34srun; == ==RANDOM1 Random function => random number generation b34sexec matrix; n=5; c= rn(array(n:)); c2 = rn(vector(n:)); r =rec(array(n:)); r2 = rec(vector(n:)); call tabulate(c,c2,r,r2); b34srun; == ==RANDOM2 Graphically Inspects Values Generated b34sexec matrix; n=100000; x=rn(array(n:)); x=x(ranker(x)); call graph(x :Heading '100,000 Random Normal Numbers'); x=rec(array(n:)); x=x(ranker(x)); call graph(x :Heading '100,000 Rectangular Numbers'); b34srun; == ==RANDOM3 Tests IMSL-10 Gnerators /$ Tests IMSL Version 10 REC and Randon Number Generators /$ b34sexec matrix; n=20; x=array(n:); r1=rec(x); r2=rec(x:); rn1=rn(x); rn2=rn(x:drnnoa); rn3=rn(x:drnnor); call tabulate(r1,r2,rn1,rn2,rn3); b34srun; == ==RANDOM4 Looks at Three RN Generators via ACF /$ Tests IMSL Version 10 REC and Randon Number Generators /$ Program will not run on RS/6000 + Sun since IMSL-10 /$ not supported /$ b34sexec matrix; n=200000; nacf=200; x=array(n:); rn1=rn(x); rn2=rn(x:drnnoa); rn3=rn(x:drnnor); call graph(rn1 rn2,rn3); acfrn1=acf(rn1:nacf); acfrn2=acf(rn2:nacf); acfrn3=acf(rn3:nacf); call graph(acfrn1,acfrn2,acfrn3); b34srun; == ==RANFOREST Random Forest Test case b34sexec options ginclude('b34sdata.mac') member(satimage); b34srun; b34sexec matrix; call loaddata; dools =0; doppreg1=0; doppreg2=0; domars =0; dogam =0; dorf1 =1; bigrf =0; if(dools.ne.0) call olsq(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print); if(doppreg1.ne.0) call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print); if(doppreg2.ne.0) call ppreg(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :class 7 :print); if(domars.ne.0) call marspline(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :nk 40 :mi 2 :print); if(dogam.ne.0) call gamfit(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :print); jbt=30; if(dorf1.ne.0)then; call ranforest(y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 :class 7 :print :vote_yhat :maxtree jbt :info /; huge space needs here /; proxon /; :proxout ); call print('Total number of cases not classified correct ',%error:); perror= %error/dfloat(norows(y)); call print('Percentage error ',perror:); /; /; call print(%classp); /; call tabulate(%res,%y,%yhat); endif; if(bigrf.ne.0)then; bigx = catcol( x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 ); yy=y; call ranforest(:xinput bigx :yinput yy :print :class 7 :vote_yhat :maxtree jbt :savemodel); endif; call names(all); b34srun; == ==RANFOREST2 Murder Data Using Probit, ppreg and ranforest /; Test job /; dob34s => uses probit and loglin /; loglin => 2 times * -1. %b34slet dob34s =1$ %b34slet dorats =0$ %b34slet domatrix =1; /; b34sexec options debugsubs(traceback); b34srun; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ %b34sif(&dob34s.ne.0)%then$ B34SEXEC PROBIT tola=.1e-14 $ MODEL D1 = T Y LF NW; B34Srun$ /; b34sexec loglin $ model d1 = T y lf nw; b34srun; /; B34SEXEC MLOGLIN IP=1 $ MODEL D1= T Y LF NW $ /; LEVEL D1(HAVELAW)$ B34SEEND$ %b34sendif$ %b34sif(&dorats.ne.0)%then$ b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec data set; rename t=tt; rename n=nn; b34srun; B34SEXEC OPTIONS HEADER$ B34SRUN$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * smpl lgt d1 # constant Tt Y LF NW prb d1 # constant Tt Y LF NW b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif$ /; Matrix probit command plus ranforest and ppreg %b34sif(&domatrix.ne.0)%then; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; call probit(d1 t y lf nw :print ); call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 1'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); d1p1=d1+1.0; call ppreg( d1p1 t y lf nw :print :class 2 ); %yhatppr=%yhat; %resppr=%res; call ranforest(d1p1 t y lf nw :print :info :class 2 :maxtree 10 :vote_yhat :imp :impgraph); call tabulate(%y,%yhat,%res %resppr %yhatppr); call print(%varimp %vargra); call ranforest(d1p1 t y lf nw :print :info :class 2 :vote_yhat :maxtree 10 :pcomp 1); call tabulate(%y,%yhat,%res %resppr %yhatppr); b34srun; %b34sendif; == ==RANFOREST3 0-1 case using probit, ppreg, rda and ranforest b34sexec options ginclude('b34sdata.mac') member(gam); b34srun; b34sexec options noheader; b34srun; b34sexec matrix; call loaddata; call load(ace_ols :staging); call load(tlogit :staging); call load(liftgain :wbsuppl); call load(disp_lgt :wbsuppl); call echooff; call acefit(y[cat] age[order] start_v[order ] numvert[order] :tol .1e-9 :print); call ace_ols; call gamfit(y age[predictor,3] start_v[predictor,3] numvert[predictor,3] :link logit :dist gauss :maxit index(2000,1500) :tol array(:.1d-13,.1d-13) :print); call names; call print(%rss,%sigma2); call tabulate(%coef,%z,%nl_p,%ss_rest); call ppreg(y age start_v numvert :print); call olsq(y age start_v numvert :print); call probit(y age start_v numvert :print); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 1'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); y=y+1.; call ranforest(y age start_v numvert :print :class 2 :vote_yhat); call rda( y age start_v numvert :print :nk 2); upper=.501; lower=.501; iprint=1; call character(_desc2b, 'RDC Analysis'); call tlogit((%y-1.),(%yhat-1.),upper,lower,_desc2b,_ntruer,_ntruep _nfalser,_nfalsep,_nunclear,_ptruer,_pfalser,iprint); call character(_desc2b, 'RDC Lift-Gain Table'); call liftgain((%y-1.),(%yhat-1.),_desc2b,npt,nt,lgtgain,lgtlift); b34srun; == ==RANFOREST4 ppreg and ranforest on iris data. Three classes /; /; Illustrates ppreg :class options and ranforest /; b34sexec options ginclude('b34sdata.mac') member(iris); b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call load(tlogit :staging); call echooff; ippreg=0; ippc=0; iranf=1; testm=0; call olsq( species sepal_w sepal_l petal_l petal_w :print); /; /; forecasting done here /; if(ippreg.ne.0)then; call ppreg(species sepal_w sepal_l petal_l petal_w :print); call tabulate(%y %yhat %res); call print('Out of sample using REG on a 1 2 3 variable':); call ppreg(species sepal_w sepal_l petal_l petal_w :print :savemodel :holdout 50); %actual=species(integers(101:150)); call ppreg(:forecast %xfuture); call tabulate(%foreobs %fore %actual); endif; if(ippc.ne.0)then; call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 3 :mu 3 :class 3); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 20 :mu 1 :class 3); class1=%class_p(,1); class2=%class_p(,2); class3=%class_p(,3); call tabulate(%y %yhat %res %risk class1 class2 class3); /; testing forecasting with a holdout call print('Out of sample Forecasting':); call print('-------------------------':); call print(' ':); i=integers(101,150); actual=species(i); call ppreg(species sepal_w sepal_l petal_l petal_w :print :savemodel :m 8 :class 3 :holdout 50); /; call print(%xfuture); /; call names(all); call ppreg(:forecast %xfuture :print :class 3); class1=%class_p(,1); class2=%class_p(,2); class3=%class_p(,3); error=(afam(actual) .ne. afam(%fore)); call tabulate(%foreobs actual %fore error %risk class1 class2 class3); rate=sum(error)/dfloat(norows(error)); call print(' '); call print('# Errors out of sample ',sum(error):); call print('Error Percentage ',rate:); endif; /; /; Try a number of m values to see how things go out of sample /; if(testm.ne.0)then; call print(' ':); call print('Out of Sample Forecasting':); call print(' ':); itest=18; m =array(itest:); n_error=array(itest:); rate =array(itest:); m=array(itest:); do i=1,itest; call ppreg(species sepal_w sepal_l petal_l petal_w :print :savemodel :m i :class 3 :holdout 50); /; call print(%xfuture); /; call names(all); call ppreg(:forecast %xfuture :class 3); class1=%class_p(,1); class2=%class_p(,2); class3=%class_p(,3); error=(afam(actual) .ne. afam(%fore)); rate1 =sum(error)/dfloat(norows(error)); call print(' '); m(i)=dfloat(i); n_error(i)=sum(error); rate(i) =rate1; enddo; call tabulate(m,n_error,rate); endif; if(iranf.ne.0)then; call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 3 :mu 3 :class 3); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 20 :mu 1 :class 3); call ranforest(species sepal_w sepal_l petal_l petal_w :vote_yhat :outlier :print :class 3); call print(%outlier); call ranforest(species sepal_w sepal_l petal_l petal_w :listoutlier :print :class 3); call print(%outlier); endif; b34srun; == ==RANFOREST5 Tests Against R /; /; Illustrates ppreg :class options and ranforest /; %b34slet run_r =1; %b34slet run_rf=1; /; /; This the one with 500 trees - What R does /; %b34slet run_rf2=1; b34sexec options ginclude('b34sdata.mac') member(iris); b34srun; %b34sif(&run_rf.ne.0)%then; b34sexec matrix; call loaddata; call load(ace_ols); call load(tlogit :staging); call echooff; call olsq( species sepal_w sepal_l petal_l petal_w :print); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 3 :mu 3 :class 3 ); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 20 :mu 1 :class 3); call ranforest(species sepal_w sepal_l petal_l petal_w :savemodel :print :vote_yhat :class 3 :holdout 30); call print(%xfuture); call ranforest(:listmodel ); /; call stop; call ranforest(:forecast %xfuture :print); b34srun; %b34sendif; %b34sif(&run_rf2.ne.0)%then; b34sexec matrix; call loaddata; call load(ace_ols); call load(tlogit :staging); call echooff; call olsq( species sepal_w sepal_l petal_l petal_w :print); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 3 :mu 3 :class 3 ); * call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 20 :mu 1 :class 3); call ranforest(species sepal_w sepal_l petal_l petal_w :class 3 :print :maxtree 500 :mtry 2 :vote_yhat :prior array(3:.7 .2 .1) ); b34srun; %b34sendif; %b34sif(&run_r.ne.0)%then; /; /; Running R from one script for commands and one for data /; Uses r.bat file /; b34sexec options open('rjob2.r') unit(28) disp=unknown$ b34srun$ b34sexec options clean(28) $ b34seend$ b34sexec options open('rjob.r') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=28; r; pgmcards; ## windows() source('rjob2.r') library(randomForest) set.seed(1) ## data(iris) iris.rf <- randomForest(Species ~ ., iris, proximity=TRUE, keep.forest=FALSE) print(iris.rf) MDSplot(iris.rf, iris$Species) ## using different symbols for the classes MDSplot(iris.rf, iris$Species, plalette=rep(1,3), pch=as.numeric(iris$Species)) set.seed(111) ind <- sample(2, nrow(iris), replace=TRUE, prob=c(.8,.2)) iris.rf <- randomForest(Species ~ ., data=iris[ind == 1,]) iris.pred <- predict(iris.rf, iris[ind == 2, ]) table(observed = iris[ind==2, "Species"], predicted = iris.pred) ## quit() quit() b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos(' r rjob' ) unix( ' R rjob') $ b34srun$ b34sexec options npageout noheader writeout(' ','output from r',' ',' ') copyfout('rjob.out') /;dodos('erase rjob.r','erase rjob.R.Rout') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==RANFOREST6 Out of Sample Forecasts on Iris Data /; /; Illustrates ppreg :class options and ranforest /; /; Illustrates Ranforest :validate b34sexec options ginclude('b34sdata.mac') member(iris); b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call load(tlogit :staging); call echooff; call olsq( species sepal_w sepal_l petal_l petal_w :print); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 3 :mu 3 :class 3 ); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 20 :mu 1 :class 3); i30=30; call ranforest(species sepal_w sepal_l petal_l petal_w :vote_yhat :savemodel :print :class 3 :holdout i30 :maxtree 20); /; this is not needed call ranforest(:listmodel ); call ranforest(:forecast %xfuture :print); n=norows(species); actual=species(integers(n-i30+1,n)); * rule out problems if 1 step ahead forecast; if(norows(%fore).eq.1)%fore=sfam(%fore); error=(%fore.ne.actual); pc_error=sum(error)/dfloat(i30); call print('Random Forest out of sample % error ',pc_error); call print('Note: error set = 1 if not perfect prediction':); call tabulate(%foreobs %fore actual error); /; illustrating validate call print(' ':); call print('Does not use voting':); call print(' ':); do i=1,5; call ranforest(:forecast %xfuture :validate actual :modelused i :print) ; enddo; call print(' ':); call print('Uses voting':); call print(' ':); call ranforest(:forecast %xfuture :validate actual :print :vote_yhat); call names(all); b34srun; == ==RANFOREST7 Tests of ranforest on mlogit test case b34sexec options ginclude('b34sdata.mac') member(mloglindat); b34srun; b34sexec mloglin ip=0; model A_21 = wage hour ch_3 ch_6 ch12 teenage catholic black south norcenn norteast ousm; level A_21(MD.1,MD.2)$ values hour(.5); b34srun; b34sexec matrix; call loaddata; call olsq(A_21 wage hour ch_3 ch_6 ch12 teenage catholic black south norcenn norteast ousm :print); call ranforest(A_21 wage hour ch_3 ch_6 ch12 teenage catholic black south norcenn norteast ousm :class 3 :print :maxtree 1 :vote_yhat :setseed); call ranforest(A_21 wage hour ch_3 ch_6 ch12 teenage catholic black south norcenn norteast ousm :class 3 :print :maxtree 500 :cat index(1 1 3 4 5 10 2 2 2 2 2 2) :setseed :vote_yhat /; :prior array(3:.1 .3 .6) ); b34srun; == ==RANFOREST8 Various Tests of Ranforest Capability /; /; Illustrates ppreg :class options and ranforest /; b34sexec options ginclude('b34sdata.mac') member(iris); b34srun; b34sexec matrix; call loaddata; call load(ace_ols); call load(tlogit :staging); call echooff; call olsq( species sepal_w sepal_l petal_l petal_w :print); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 3 :mu 3 :class 3 ); call ppreg(species sepal_w sepal_l petal_l petal_w :print :m 20 :mu 1 :class 3); i30=30; maxmodel=20; call ranforest(species sepal_w sepal_l petal_l petal_w :savex :vote_yhat:savemodel :print :class 3 :holdout i30 :jbt maxmodel); /; this is not needed call ranforest(:listmodel ); /; use original data replicate the internal forecasts do i=1,20; call ranforest(:forecast %x :print :modelused i); error=(%fore.ne.%y); call print('sum of errors inside sample using forecast tree',i); call print('Percent error inside the sample', (100.*sum(error)/dfloat(150-i30))); enddo; call ranforest(:forecast %xfuture :print); n=norows(species); actual=species(integers(n-i30+1,n)); error=(%fore.ne.actual); pc_error=100.*(sum(error)/dfloat(i30)); call print('Random Forest out of sample % error ',pc_error); call print('Note: error set = 1 if not perfect prediction':); call tabulate(%foreobs %fore actual error); call print('Looking at 1-20 Tree Models and % out of sample error':); ntest=20; pc_error=array(ntest:); sumerror=array(ntest:); tree =array(ntest:); ff=array(i30,ntest:); n=norows(species); actual=species(integers(n-i30+1,n)); do i=1,ntest; call ranforest(:forecast %xfuture :modelused i); error=(%fore.ne.actual); sumerror(i)=sum(error); pc_error(i)=100.*(sumerror(i)/dfloat(i30)); tree(i)=i; ff(1,i)=%fore; enddo; call print('This shows alternative models':); ff=idint(ff); * ff=catcol(idint(actual),ff); call tabulate(tree,sumerror,pc_error); Call print('Shows correct answer and 1-20 alternative forecasts':); call print( actual,ff); /; test validation call print('Testing Validation.':); do i=1,ntest; call ranforest(:forecast %xfuture :modelused i :validate actual :print); enddo; b34srun; == ==RANFOREST9 Diabetes Test Case. Various models used b34sexec options ginclude('b34sdata.mac') member(diabetes); b34srun; /; Creates /; NPREG 1 Number of times pregnant /; GLUCOSE 2 Plasma glucose concentration /; DIASTOL 3 Diastolic blood pressure (mm Hg) /; TRICEPS 4 Triceps skin fold thickness (mm) /; INSULIN 5 2-Hour serum insulin (mu U/ml) /; BODYMASS 6 Body mass index /; DIAB_P_F 7 Diabetes pedigree function /; AGE 8 Age (years) /; CLASSVAR 9 Class variable (0 or 1 b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; ynew=classvar+1.; call olsq( classvar npreg glucose diastol triceps insulin bodymass diab_p_f age :print); call probit( classvar npreg glucose diastol triceps insulin bodymass diab_p_f age :print); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on PROBIT Model'); call tlogit(%y,%yhat,upper,lower,cc,ntruer,ntruep, nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); /; call rda( ynew npreg glucose diastol triceps insulin /; bodymass diab_p_f age :print :nk 2); call marspline( classvar npreg glucose diastol triceps insulin bodymass diab_p_f age :print :nk 40 :mi 2); call character(cc,'Tests on MARS Model'); call tlogit(%y,%yhat,upper,lower,cc,ntruer,ntruep, nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call ranforest( ynew npreg glucose diastol triceps insulin bodymass diab_p_f age :print :class 2 :vote_yhat :maxtree 40); call ppreg( ynew npreg glucose diastol triceps insulin bodymass diab_p_f age :print :class 2); call character(cc,'Tests on PPREG Model'); call tlogit((%y-1.),(%yhat-1.),upper,lower,cc,ntruer,ntruep, nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); b34srun; == ==RANFOREST10 Probit vs Random-Forest on spam dataset /; /; Test of RF on :CLASS data. /; See Hastie-Tibshirani-Friedman (2009, 587-604). Page 594 especially /; b34sexec options ginclude('learndat.mac') member(spam); b34srun; b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; call probit(x58 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 :print); call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 1'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); jbt = 20; x58=x58+1.; call ranforest(x58 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 :class 2 :print :vote_yhat :maxtree jbt); b34srun; == ==RANFOREST11 Random Forest test case for a regression model /; /; Test of RF on REG data. /; See Hastie-Tibshirani-Friedman (2009, 587-604) /; b34sexec options ginclude('b34sdata.mac') member(bostonh); b34srun; /; b34sexec list; b34srun; b34sexec matrix; call loaddata; call echooff; call olsq(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print); olsres=%res; olsyhat=%yhat; maxtree=200; ihold=0; call ranforest(medv crim zn indus nox rm age dis rad tax ptratio b lstat :imp :savex :savemodel :yhatav :reg :maxtree maxtree :print :holdout ihold); y1=%yhat; y2=%yhat2; y3=%yhat3; bigx=%x; call tabulate(%y %yhat %yhat2 %yhat3 %res %res2 %res3); call print(' ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++':); call ranforest(:forecast bigx :validate medv :reg :print); /; call names(all); /; call tabulate(%foreobs, %fore %fore2 y1 y2); test=sumsq( medv -%fore ); test2=sumsq(medv-%fore2); call print('Test out of sample sum of squares %fore ',test :); call print('Test out of sample sum of squares %fore2 ',test2:); call print(%moderr); /; different model ihold=100; testy=medv(integers(norows(medv)-ihold+1,norows(medv))); call ranforest(medv crim zn indus nox rm age dis rad tax ptratio b lstat :imp :reg :maxtree maxtree :print :savemodel :yhatav :holdout ihold :yhatav); yy=medv(integers(norows(medv)-ihold+1,norows(medv))); call print(' ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++':); call ranforest(:forecast %xfuture :validate yy :reg); call names(all); /; call tabulate(%y %yhat %yhat2 %res %res2); /; call tabulate(%foreobs, %fore %fore2); call gamfit(medv crim[predictor,3] zn[predictor,3] indus[predictor,3] nox[predictor,3] rm[predictor,3] age[predictor,3] dis[predictor,3] rad[predictor,3] tax[predictor,3] ptratio[predictor,3] b[predictor,3] lstat[predictor,3] :print); gamres=%res; gamyhat=%yhat; call marspline(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print :nk 50 :mi 1); marsres1=%res; marsyh1 =%yhat; call marspline(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print :nk 50 :mi 2); marsres2=%res; marsyh2 =%yhat; call marspline(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print :nk 50 :mi 3); marsres3=%res; marsyh3 =%yhat; do ndsize=2,10; call ranforest(medv crim zn indus nox rm age dis rad tax ptratio b lstat :reg :maxtree maxtree :ndsize ndsize :yhatav); call print(' '); call print('++++++++++++++++++++++++++++++++++++++++':); call print('ndsize set as ',ndsize:) ; call print('Last model rss ',%rss:) ; call print('Averaged OOB rss ',%rss2:) ; call print('Averaged rss ',%rss3:) ; enddo; call ranforest(medv crim zn indus nox rm age dis rad tax ptratio b lstat :imp :reg :maxtree 1000 :print :yhatav); ssolsres=sumsq(olsres); ssmars1 =sumsq(marsres1); ssmars2 =sumsq(marsres2); ssmars3 =sumsq(marsres3); ssgam =sumsq(gamres); ssrfres =sumsq(%res); ssrfres2 =sumsq(%res2); ssrfres3 =sumsq(%res3); call print('sumsq(olsres) ', ssolsres :); call print('sumsq(ssgam ', ssgam :); call print('sumsq(ssmars1)', ssmars1 :); call print('sumsq(ssmars2)', ssmars2 :); call print('sumsq(ssmars3)', ssmars3 :); call print('sumsq(%res) ', ssrfres :); call print('sumsq(%res2) ', ssrfres2 :); call print('sumsq(%res3) ', ssrfres3 :); call graph(olsres,%res,%res2 %res3 :heading 'OLS vs RF' :nolabel :nocontact :grid :pgborder); b34srun; == ==RANFOREST12 California Housing Problem /; /; This job requires 12000000 memory /; b34sexec options ginclude('learndat.mac') member(cal_house); b34srun; b34sexec matrix; call loaddata; call olsq( houseval m_income houseage n_rooms n_bed pop ave_occ latitude long :print); call gamfit(houseval m_income houseage n_rooms n_bed pop ave_occ latitude long :print); call marspline(houseval m_income houseage n_rooms n_bed pop ave_occ latitude long :print :nk 40 :mi 1); call marspline(houseval m_income houseage n_rooms n_bed pop ave_occ latitude long :print :nk 40 :mi 2); call marspline(houseval m_income houseage n_rooms n_bed pop ave_occ latitude long :print :nk 40 :mi 3); call ranforest(houseval m_income houseage n_rooms n_bed pop ave_occ latitude long :reg :print :maxtree 200 :print :yhatav); b34srun; == ==RANFOREST13 Boston Housing Market /; /; Test of RF on REG data. /; See Hastie-Tibshirani-Friedman (2009, 587-604) /; b34sexec options ginclude('b34sdata.mac') member(bostonh); b34srun; /; b34sexec list; b34srun; b34sexec matrix; call loaddata; call echooff; call olsq(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print); olsres=%res; olsyhat=%yhat; maxtree=200; ihold=0; call ranforest(medv crim zn indus nox rm age dis rad tax ptratio b lstat :imp :savex :savemodel :yhatav :reg :maxtree maxtree :print :holdout ihold); call gamfit(medv crim[predictor,3] zn[predictor,3] indus[predictor,3] nox[predictor,3] rm[predictor,3] age[predictor,3] dis[predictor,3] rad[predictor,3] tax[predictor,3] ptratio[predictor,3] b[predictor,3] lstat[predictor,3] :print); call marspline(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print :nk 50 :mi 1); marsres1=%res; marsyh1 =%yhat; call marspline(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print :nk 50 :mi 2); marsres2=%res; marsyh2 =%yhat; call marspline(medv crim zn indus nox rm age dis rad tax ptratio b lstat :print :nk 50 :mi 3); marsres3=%res; marsyh3 =%yhat; b34srun; == ==RANFOREST14 Automated Version of RANFOREST13 /; /; Test of OLS MARSPLINE GAM PPREG Randon Forest On Boston Housing Data /; See Hastie-Tibshirani-Friedman (2009, 587-604) /; /; Illustrates different types of forecasts /; b34sexec options ginclude('b34sdata.mac') member(bostonh); b34srun; /; b34sexec list; b34sr b34sexec matrix; call loaddata; call echooff; call load(contrib); /; start ------------------------------------------ call contribi; /; /; specific settings /; _mi=2; _m=30; iols=4; isave=1; _mtry=4; _mtree=20; call character(fsv_info,'bostonh Test Case'); call character(l_hand_s,'medv'); call character(_args, 'crim zn indus nox rm age dis rad tax ptratio b lstat'); _argsg=_args; call contribl; call contribd; b34srun; == ==RANK Rank of a matrix b34sexec matrix; n=10; r8 =rn(matrix(n,n:)); r16=r8tor16(r8); c16=sqrt(complex(r8*r8,r8)); c32=c16toc32(c16); call print(r8,r16,c16,c32); call print(svd(sngl(r8)),svd(r8),svd(r16),svd(c16),svd(c32)); rankr4 = rank(sngl(r8)); rankr8 = rank(r8); rankr16 = rank(r16); rankc16 = rank(c16); rankc32 = rank(c32); call print('Rank r4',rankr4:); call print('Rank r8',rankr8:); call print('Rank r16',rankr8:); call print('Rank c16',rankc16:); call print('Rank c32',rankc32:); b34srun; == ==RANKER ranker function => sort pointers b34sexec matrix; n=10; v=rn(vector(n:)); r=ranker(v); test=v(r); call tabulate(v r v(r) test); b34srun; == ==RCOND 1 / Condition of Matrix b34sexec matrix; x=matrix(3,3:0.1 1. 2. 9. 8. 7. 5. 4. 0.2); call print(x,inv(x),det(x),det(r8tor16(x)),det(r8tor4(x))); cx=complex(x,dsqrt(x)); call print(cx,inv(cx),det(cx),det(c16toc32(cx))); call print(rcond(x),rcond(r8tor16(x)),rcond(r8tor4(x))); /$ /$ High Accuracy printing /$ call fprint(:clear :display rcond(r8tor16(x)) '(g48.32)' :print); call print(rcond(cx),rcond(c16toc32(cx))); call fprint(:clear :display rcond(c16toc32(cx)) '(g48.32)' :print); b34srun; == ==RCOVER Recursive Covering Analysis /; /; Murder Data estimated with: /; OLS - PROBIT - RCOVER - RDA - PPREG - RANFOREST /; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; call olsq(d1 t y lf nw :print ); call probit(d1 t y lf nw :print ); call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on Murder Data using probit Model '); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call rcover(d1 t y lf nw :print ); call character(cc,'Tests on Murder Data rcover Model '); call tlogit(d1 ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); /; recode d1 1-2 d11=d1+1.; call rda(d11 t y lf nw :nk 2 :print ); call character(cc,'Tests on Murder Data using rda Model'); %yhat_1=%yhat-1.; call tlogit(d1,%yhat_1,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call ppreg(d11 t y lf nw :class 2 :print); %yhat_1=%yhat-1.; call character(cc,'Tests on Munder Data using ppreg Model'); call tlogit(d1,%yhat_1,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call print('Tests on Murder Data using Random Forest Model':); call ranforest(d11 t y lf nw :class 2 :print :maxtree 20 :vote_yhat); b34srun; == ==RDA Regularized Discriminate Analysis b34sexec options ginclude('b34sdata.mac') member(iris); b34srun; b34sexec matrix; call loaddata; ippreg=0; call olsq( species sepal_w sepal_l petal_l petal_w :print); if(ippreg.ne.0)then; call ppreg(species sepal_w sepal_l petal_l petal_w :print); call tabulate(%y %yhat %res); call ppreg(species sepal_w sepal_l petal_l petal_w :print :savemodel :holdout 50); %actual=species(integers(101:150)); call ppreg(:forecast %xfuture); call tabulate(%foreobs %fore %actual); call names(all); endif; call rda(species sepal_w sepal_l petal_l petal_w :print :nk 3); call tabulate(%y %yhat %res); call rda(species sepal_w sepal_l petal_l petal_w /; :eprint :print :holdout 100 :nk 3); /; Forecasting Done here. %sp and %dp in work space call rda(:nk 3 :forecast %xfuture :print); y=species(integers(51,150)); e= afam(%fore)-afam(y); call tabulate(%foreobs %fore y e); call rda(species sepal_w sepal_l petal_l petal_w :print :nk 3 :rule array(:.5 .5) ); call tabulate(%y %yhat %res); b34srun; == ==RDA2 RDA vs PPREG vs Probit /; Test job %b34slet dob34s =1$ %b34slet dorats =0$ %b34slet domatrix =1; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ %b34sif(&dob34s.ne.0)%then$ B34SEXEC PROBIT tola=.1e-14 $ MODEL D1 = T Y LF NW; B34Srun$ /; b34sexec loglin $ model d1 = T y lf nw; b34srun; /; B34SEXEC MLOGLIN IP=1 $ MODEL D1= T Y LF NW $ /; LEVEL D1(HAVELAW)$ B34SEEND$ %b34sendif$ %b34sif(&dorats.ne.0)%then$ b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec data set; rename t=tt; rename n=nn; b34srun; B34SEXEC OPTIONS HEADER$ B34SRUN$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * smpl lgt d1 # constant Tt Y LF NW prb d1 # constant Tt Y LF NW b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif$ /; Matrix probit command %b34sif(&domatrix.ne.0)%then; b34sexec options ginclude('b34sdata.mac') macro(murder)$ b34seend$ b34sexec matrix; call loaddata; call load(tlogit :staging); call echooff; call probit(d1 t y lf nw :print ); %pbyhat=%yhat; call tabulate(%names,%lag,%coef,%se,%t); upper=.5; lower=.5; iprint=1; call character(cc,'Tests on probit Model 1'); call tlogit(%y ,%yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); dd1=d1+1.; call rda(dd1 t y lf nw :print :nk 2 :rule array(: .9 .9)); call character(cc,'Tests on RDA Model 1'); upper=.5; lower=.5; iprint=1; %yhatrda=%yhat-1.; call tlogit((%y-1.) ,(%yhat-1.),upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); dd1=d1+1.; call ppreg(dd1 t y lf nw :print :class 2); %pp_yhat=%yhat-1.; call character(cc,'Tests on PPREG Model 1'); upper=.5; lower=.5; iprint=1; call tlogit(d1 ,%pp_yhat,upper,lower,cc,ntruer,ntruep nfalser,nfalsep,nunclear,ptruer,pfalser,iprint); call tabulate(%y %yhatrda %pbyhat %pp_yhat); b34srun; %b34sendif; == ==RDA3 RDA vs PPREG vs RANFOREST out of sample b34sexec options ginclude('b34sdata.mac') member(iris); b34srun; b34sexec matrix; call loaddata; ippreg =1; iranfor=1; i50=50; call olsq( species sepal_w sepal_l petal_l petal_w :print); if(ippreg.ne.0)then; call print('Estimating without setting :class ':); call ppreg(species sepal_w sepal_l petal_l petal_w :print); call print('Correct setup':); call ppreg(species sepal_w sepal_l petal_l petal_w :print :class 3); /; call tabulate(%y %yhat %res); call print('Holdout Sample':); call ppreg(species sepal_w sepal_l petal_l petal_w :holdout 50 :print :class 3 :savemodel); %actual=species(integers(101:150)); call print('Forecasting of a classification Example':); call ppreg(:forecast %xfuture :class 3); call tabulate(%foreobs %fore %actual); sum_err=sum(afam(%actual) .ne. afam(%fore)); call print('Total number of out of sample errors for ppreg',sum_err); endif; if(iranfor.ne.0)then; call ranforest(species sepal_w sepal_l petal_l petal_w :print :class 3); call ranforest(species sepal_w sepal_l petal_l petal_w :class 3 :holdout i50 :savemodel :print ); %actual=species(integers((150-i50+1):150)); call ranforest(:forecast %xfuture :print); sum_err=sum(%actual .ne. %fore); call print('Total number of out of sample errors for ranfore',sum_err); endif; /; rda testing and forecasting call rda( species sepal_w sepal_l petal_l petal_w :print :nk 3); call tabulate(%y %yhat %res); call rda(species sepal_w sepal_l petal_l petal_w /; :eprint :print :holdout i50 :nk 3); /; Forecasting Done here. %sp and %dp in work space call rda(:nk 3 :forecast %xfuture :print); y=species(integers(150-i50+1,150)); e= afam(%fore)-afam(y); call tabulate(%foreobs %fore y e); call rda(species sepal_w sepal_l petal_l petal_w :print :nk 3 :rule array(:.5 .5) ); call tabulate(%y %yhat %res); b34srun; == ==READ Simple Read where > 98 variables read b34sexec matrix; * Simple read where a matrix on 10 by 200 is built and read back; * Data is real*8; * Job shows how to beat 98 variable limit; * Note: Before reading, structure of object must be known!!!! ; call echooff; nobs=10; nvar=200; test=rn(array(nobs,nvar:)); call open(70,'testdata'); call rewind(70); call write(test,70); tmean=array(nvar:); do i=1,nvar; tmean(i)=mean(test(,i)); enddo; call print('Means of data that is built',tmean); call rewind(70); call free(test); call rewind(70); call close(70); /; This is what a user who had a flat file would input /; User knows what he/she is reading call open(71,'testdata'); call rewind(71); /; user knows nobs=10; nvar=200; test2=array(nobs,nvar:); call read(test2,71); tmean2=array(nvar:); do i=1,nvar; tmean2(i)=mean(test2(,i)); enddo; call print('Means of data that is read',tmean2); call print('Error on data transfer ',(tmean-tmean2)); call rewind(71); call close(71); /; User makes desired calculation here /; simple way to proceed - Staging getdata routine in job subroutine getdata(file,nobs,nvar,data); /; /; Easy to use Matrix Data Read; /; /; file => File of real*8 data with nobs rows and nvar cols /; nobs => # of rows of data /; nvar => # of cols of data /; data => Array of Data /; /; Built 24 February 2007 /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; call open(71,file); call rewind(71); data=array(nobs,nvar:); call read(data,71); call rewind(71); call close(71); return; end; file='testdata'; nrows=nobs; ncols=nvar; call getdata(file,nrows,ncols,x); call print(x); b34srun; == ==READ_B Simple Read using GETDATA routine b34sexec matrix; * Simple read where a matrix on 10 by 200 is built and read back; * Data is real*8; * Job shows how to beat 98 variable limit; * Note: Before reading, structure of object must be known!!!! ; /; This section builds the test data call echooff; nobs=10; nvar=200; test=rn(array(nobs,nvar:)); call open(70,'testdata'); call rewind(70); call write(test,70); tmean=array(nvar:); do i=1,nvar; tmean(i)=mean(test(,i)); enddo; call print('Means of data that is built',tmean); call rewind(70); call free(test); call rewind(70); call close(70); /; Test Data now Built /; simple way to proceed call load(getdata :staging); /; subroutine getdata(file,nobs,nvar,data); /; /; Easy to use Matrix Data Read; /; /; file => File of real*8 data with nobs rows and nvar cols /; nobs => # of rows of data /; nvar => # of cols of data /; data => Array of Data /; /; Built 24 February 2007 /; /; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ /; file='testdata'; nrows=nobs; ncols=nvar; call getdata(file,nrows,ncols,x); /; User makes calculations here call print(x); b34srun; == ==READ1 READ/WRITE/OPEN/REWIND/CLOSE b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; * Note how integer*4 is written and read back as integer*8 ; n=50; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call open(71,'testdata'); test2=array(n:); call character(cc,'this is less '); call read(test2,71); /$ /$ test real*16 IO /$ call rewind(71); r16=r8tor16(test2); call read(r16,71); call tabulate(test2,r16); i=i+100; call read(i,71); call print(i); call read(cc,71); call print(cc); a(1)='bob'; call read(a,71); call print(a); tmean2=mean(test2); call print(tmean2); call names(all); call close(71); /; /; test integer*8 read /; i=integers(30); call close(70); call open(70,'testdata'); call rewind(70); call write(i,70); i=i*0; i8=i4toi8(i); call rewind(70); call read(i8,70); call print('This is a integer*8 from 1-30',i8); /; b34srun; == ==READ2 End of file trapping b34sexec matrix; * Tests I/O package - attempting a read for more data that is there; n=10; test=rn(array(n:)); ii=integers(n); call open(70,'testdata'); call rewind(70); call write(test,70); tmean=mean(test); call print(tmean); call free(test); call rewind(70); call close(70); call open(71,'testdata'); n=20; test2=array(n:); call read(test2,71); call print(test2); tmean2=mean(goodrow(test2)); call print(tmean2); call names(all); call close(71); call open(70,'testdata'); call rewind(70); call write(ii,70); call print(ii); call free(ii); call rewind(70); call close(70); call open(71,'testdata'); n=20; test2=array(n:); call read(test2,71,'null',iseof); call print(test2); call names(all); call close(71); b34srun; == ==READ3 Illustrates Read/Write Implementation of MATLAB I/O b34sexec matrix ; /$ Shows Matrix subroutine implementations of built in /$ makematlab and getmatlab commands /$ /$ Job illustrates read / write i/o /$ subroutine gmatlab(c,xx); n=70; call open(n,c); call character(line,' '); call read(line,n); call print(line); xi=1.; xj=1.; call read(xi,n,'(20x,e16.8)'); call read(xj,n,'(20x,e16.8)'); xx=array(idint(xi),idint(xj):); call read(xx,n,'(5e16.8)'); call close(n); return; end; subroutine mmatlab(c,xx); n=70; call open(n,c); call character(ccc,'--File built by B34S(r) MATRIX Facility'); call write(ccc,n); i=norows(xx); j=nocols(xx); call write(dfloat(i),n,'(20x,e16.8)'); call write(dfloat(j),n,'(20x,e16.8)'); call write(xx,n,'(5e16.8)'); call close(n); return; end; xx=rn(array(100,50:)); call character(ccc,'c:\junk\test.mmm'); call mmatlab(ccc,xx); call gmatlab(ccc,crap); call print(crap); b34srun; == ==READ4 Illustrates reads of data into various precisions /; /; Various data precision reads /; b34sexec matrix; datacards; 1.25 4.11 4. 2. b34sreturn; call load(ntokin :staging); call load(getvpa :staging); call echooff; x8=array(4:); x4=sngl(x8); x16=r8tor16(x8); x_vpa=vpa(x8); call read(x4,4); call rewind(4); call read(x8,4); call rewind(4); call read(x16,4); call rewind(4); c=c1array(72:); call read(c,4); call print(c); call ntokin(c,nn,0,ibad); call getvpa(c,nn,x_vpa,i); call print(x4,x8,x16,x_vpa); b34srun; == ==REAL Real*8 from Complex*16 b34sexec matrix; xr=matrix(2,2:1 2 3 4); xi=dsqrt(xr); cc=complex(xr,xi); call print(cc,real(cc),imag(cc)); cc32=c16toc32(cc); call print(cc32,real(cc32),imag(cc32)); vpacc=vpa(cc); call print(vpacc,real(vpacc),imag(vpacc)); b34srun; == ==REAL16 Creates a real*16 variable from Character string b34sexec matrix; r16= real16('.9q+00'); r16a=r8tor16(.9); call print('R16', r16:); call print('R16A' r16a:); call print('Difference ',(r16a-r16):); b34srun; == ==REAL16ON Test Case showing effect of accuracy changes /$ /$ Illustrates real*8 & Real*16 OLS Model building using QR, Cholesky /$ and SVD using both LINPACK and LAPACK b34sexec options copyf(4,6,1,999999,1,80,0,1); datacards; NIST/ITL StRD Dataset Name: Filippelli (filippelli.dat) File Format: ASCII Data (lines 61 to 142) Procedure: Linear Least Squares Regression Reference: Filippelli, A., NIST. Data: 1 Response Variable (y) 1 Predictor Variable (x) 82 Observations Higher Level of Difficulty Observed Data Model: Polynomial Class 11 Parameters (B0,B1,...,B10) y = B0 + B1*x + B2*(x**2) + ... + B9*(x**9) + B10*(x**10) Certified Regression Statistics Standard Error Parameter Estimate of Estimate B0 -1467.48961422980 298.084530995537 B1 -2772.17959193342 559.779865474950 B2 -2316.37108160893 466.477572127796 B3 -1127.97394098372 227.204274477751 B4 -354.478233703349 71.6478660875927 B5 -75.1242017393757 15.2897178747400 B6 -10.8753180355343 2.23691159816033 B7 -1.06221498588947 0.221624321934227 B8 -0.670191154593408E-01 0.142363763154724E-01 B9 -0.246781078275479E-02 0.535617408889821E-03 B10 -0.402962525080404E-04 0.896632837373868E-05 Residual Standard Deviation 0.334801051324544E-02 R-Squared 0.996727416185620 Certified Analysis of Variance Table Source of Degrees of Sums of Mean Variation Freedom Squares Squares F Stat Regression 10 0.242391619837339 0.242391619837339E-01 2162.439 Residual 71 0.795851382172941E-03 0.112091743968020E-04 b34sreturn; b34seend; b34sexec data heading('Filippelli Data'); input y x; build x2 x3 x4 x5 x6 x7 x8 x9 x10; gen x2=x*x; gen x3=x2*x; gen x4=x3*x; gen x5=x4*x; gen x6=x5*x; gen x7=x6*x; gen x8=x7*x; gen x9=x8*x; gen x10=x9*x; datacards; 0.8116 -6.860120914 0.9072 -4.324130045 0.9052 -4.358625055 0.9039 -4.358426747 0.8053 -6.955852379 0.8377 -6.661145254 0.8667 -6.355462942 0.8809 -6.118102026 0.7975 -7.115148017 0.8162 -6.815308569 0.8515 -6.519993057 0.8766 -6.204119983 0.8885 -5.853871964 0.8859 -6.109523091 0.8959 -5.79832982 0.8913 -5.482672118 0.8959 -5.171791386 0.8971 -4.851705903 0.9021 -4.517126416 0.909 -4.143573228 0.9139 -3.709075441 0.9199 -3.499489089 0.8692 -6.300769497 0.8872 -5.953504836 0.89 -5.642065153 0.891 -5.031376979 0.8977 -4.680685696 0.9035 -4.329846955 0.9078 -3.928486195 0.7675 -8.56735134 0.7705 -8.363211311 0.7713 -8.107682739 0.7736 -7.823908741 0.7775 -7.522878745 0.7841 -7.218819279 0.7971 -6.920818754 0.8329 -6.628932138 0.8641 -6.323946875 0.8804 -5.991399828 0.7668 -8.781464495 0.7633 -8.663140179 0.7678 -8.473531488 0.7697 -8.247337057 0.77 -7.971428747 0.7749 -7.676129393 0.7796 -7.352812702 0.7897 -7.072065318 0.8131 -6.774174009 0.8498 -6.478861916 0.8741 -6.159517513 0.8061 -6.835647144 0.846 -6.53165267 0.8751 -6.224098421 0.8856 -5.910094889 0.8919 -5.598599459 0.8934 -5.290645224 0.894 -4.974284616 0.8957 -4.64454848 0.9047 -4.290560426 0.9129 -3.885055584 0.9209 -3.408378962 0.9219 -3.13200249 0.7739 -8.726767166 0.7681 -8.66695597 0.7665 -8.511026475 0.7703 -8.165388579 0.7702 -7.886056648 0.7761 -7.588043762 0.7809 -7.283412422 0.7961 -6.995678626 0.8253 -6.691862621 0.8602 -6.392544977 0.8809 -6.067374056 0.8301 -6.684029655 0.8664 -6.378719832 0.8834 -6.065855188 0.8898 -5.752272167 0.8964 -5.132414673 0.8963 -4.811352704 0.9074 -4.098269308 0.9119 -3.66174277 0.9228 -3.2644011 b34sreturn; b34srun; b34sexec matrix; call loaddata; call load(svd_ols :staging); call load(svd2_ols :staging); call load(ntokin :staging); call load(getr16 :staging); call print(svd_ols); call print(svd2_ols); /; call svd_ols(y,x,u,v,s,beta_svd,se_svd,pc_coef,sigmasq,rss,ibad); /; /; Uses SVD to get OLS coef. Works for real*8 & real*16. /; For a discussion of methods, see Stokes (1997) pages 262-263 /; /; Uses Linpack code. See SVD2_OLS for LAPACK code. /; /; y => left hand side /; x => right hand side /; u => left hand side of SVD /; v => transpose of right hand side svd. /; x => u * diagmat(s)*V /; s => singular values /; beta_svd => SVD Beta Coef /; se_svd => SE of SVD beta coef /; pc_coef => PC Coef /; sigmasvd => sigmasq from SVD /; rss => Residual sum of squares /; /; Built 1 August 2004 /; call echooff; ans=matrix(11,2: -1467.48961422980, 298.084530995537, -2772.17959193342, 559.779865474950, -2316.37108160893, 466.477572127796, -1127.97394098372, 227.204274477751, -354.478233703349, 71.6478660875927, -75.1242017393757, 15.2897178747400, -10.8753180355343, 2.23691159816033, -1.06221498588947, 0.221624321934227, -0.670191154593408E-01, 0.142363763154724E-01, -0.246781078275479E-02, 0.535617408889821E-03, -0.402962525080404E-04, 0.896632837373868E-05 ); ans=rollup(ans); testss=0.795851382172941E-03; r8coefle=array(12:); r8se__le=array(12:); r8ss__le=array(12:); subroutine try(y,x,beta,type); if(type.eq.1)beta=inv(transpose(x)*x :refine) *transpose(x)*y; if(type.eq.2)beta=inv(transpose(x)*x :refinee)*transpose(x)*y; if(type.eq.3)beta=inv(transpose(x)*x :pdmat2) *transpose(x)*y; return; end; call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Testing the effect of mods to ddot, dsum and dasum':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print(' ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8. ':); call print('All Calculations in real*8 ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call real16off; call real16info; call print(' ':); call print('Using Real16off ******************':); call print('OLSQ on Filippelli - Coef Using QR':); call print(' ':); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :qr :savex); call lre(ans(,1),15,%coef,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using QR':); call lre(ans(,2),15,%se, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,%rss, lrerss ,bits :print); call print(' ':); r8coefle(1)=mean(lrecoef); r8se__le(1)=mean(lrese); r8rss_le(1)=mean(lrerss); /$ shows effect of various inversion options on RCOND /$ call try(%y,%x,beta1,1); call print(beta1); /$ call try(%y,%x,beta2,2); call print(beta2); /$ call try(%y,%x,beta3,3); call print(beta3); call print('Using Real16off ******************':); call print('OLSQ on Filippelli - Coef Using SVD - LINPACK/LAPACK':); call print(' ':); call svd_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD-LINPACK':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,rss,lrerss ,bits :print); r8coefle(6)=mean(lrecoef); r8se__le(6)=mean(lrese); r8rss_le(6)=mean(lrerss); call svd2_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD-LAPACK':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,rss,lrerss ,bits :print); r8coefle(10)=mean(lrecoef); r8se__le(10)=mean(lrese); r8rss_le(10)=mean(lrerss); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8. ':); call print('All Calculations in real*8 - accumulate in real*16 ':); call print('Using call real16on; +++++++++++++++++++++++++++++++':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call real16on; call real16info; call print('Using Real16addon *******************':); call print('OLSQ on Filippelli - Coef Using QR':); call print(' ':); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :qr :savex); call lre(ans(,1),15,%coef,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using QR':); call lre(ans(,2),15,%se, lrese ,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lrerss ,bits :print); call print(' ':); r8coefle(2)=mean(lrecoef); r8se__le(2)=mean(lrese); r8rss_le(2)=mean(lrerss); call print('Using Real16addon *******************':); call print('OLSQ on Filippelli - Coef Using SVD':); call print(' ':); call svd_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,rss,lterss ,bits :print); r8coefle(7)=mean(lrecoef); r8se__le(7)=mean(lrese); r8rss_le(7)=mean(lrerss); call print(' ':); call svd2_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD-LAPACK & real16add':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); testrss=rss; call lre(testss,15,rss,lrerss ,bits :print); r8coefle(11)=mean(lrecoef); r8se__le(11)=mean(lrese); r8rss_le(11)=mean(lrerss); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8. ':); call print('All Calculations in real*8 - accumulate in real*16 ':); call print('DSUM and DDOT use real*16 addition and Multiplication':); call print('Using call real160n(:realmath); +++++++++++++++++++++':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call real16on(:real16math); call real16info; call print('Using Real16on *******************':); call print('OLSQ on Filippelli - Coef Using QR':); call print(' ':); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :qr :savex); call lre(ans(,1),15,%coef,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using QR':); call lre(ans(,2),15,%se, lrese ,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lrerss ,bits :print); call print(' ':); r8coefle(3)=mean(lrecoef); r8se__le(3)=mean(lrese); r8rss_le(3)=mean(lrerss); call print('Using Real16math *******************':); call print('OLSQ on Filippelli - Coef Using SVD':); call print(' ':); call svd_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,rss,lrerss ,bits :print); r8coefle(8)=mean(lrecoef); r8se__le(8)=mean(lrese); r8rss_le(8)=mean(lrerss); call print(' ':); call svd2_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD-LAPACK & real16MATH':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,rss,lrerss ,bits :print); r8coefle(12)=mean(lrecoef); r8se__le(12)=mean(lrese); r8rss_le(12)=mean(lrerss); call real16off; call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8 Then converted to Real*16 ':); call print('All Calculations after conversion in real*16 ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); y =r8tor16(y); x =r8tor16(x ); x2=r8tor16(x2); x3=r8tor16(x3); x4=r8tor16(x4); x5=r8tor16(x5); x6=r8tor16(x6); x7=r8tor16(x7); x8=r8tor16(x8); x9=r8tor16(x9); x10=r8tor16(x10); call print('OLSQ on Filippelli - Coef Using PDFAC':); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :savex ); /$ Loading Answers into Character then reading in real*16 call character(cc,' -1467.48961422980 298.084530995537 -2772.17959193342 559.779865474950 -2316.37108160893 466.477572127796 -1127.97394098372 227.204274477751 -354.478233703349 71.6478660875927 -75.1242017393757 15.2897178747400 -10.8753180355343 2.23691159816033 -1.06221498588947 0.221624321934227 -0.670191154593408E-01 0.142363763154724E-01 -0.246781078275479E-02 0.535617408889821E-03 -0.402962525080404E-04 0.896632837373868E-05' ); call ntokin(cc,nfind,0,ibad); call print(nfind ); call getr16(cc,nfind,ans,ibad); ans=matrix(11,2: ans); ans=rollup(ans); testss=real16('0.795851382172941E-03'); /$ Uncomment next 2 line2 to real*8 to real*16 conversion costs /$ ans=r8tor16(ans); /$ testss=r8tor16(testss); call lre(ans(,1),15,%coef,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using PDFAC':); call lre(ans(,2),15,%se, lrese ,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lrerss ,bits :print); call print(' ':); r8coefle(4)=r16tor8(mean(lrecoef)); r8se__le(4)=r16tor8(mean(lrese)); r8rss_le(4)=r16tor8(mean(lrerss)); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :qr :savex); call print('OLSQ on Filippelli - Coef Using QR':); call lre(ans(,1),15,%coef,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using QR':); call lre(ans(,2),15,%se, lrese ,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lrerss ,bits :print); call print(' ':); r8coefle(5)=r16tor8(mean(lrecoef)); r8se__le(5)=r16tor8(mean(lrese)); r8rss_le(5)=r16tor8(mean(lrerss)); call print('Using Real*16 Data from Real*8 data ******************':); call print('OLSQ on Filippelli - Coef Using SVD':); call print(' ':); call svd_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,rss,lrerss ,bits :print); r8coefle(9)=r16tor8(mean(lrecoef)); r8se__le(9)=r16tor8(mean(lrese)); r8rss_le(9)=r16tor8(mean(lrerss)); type=c8array(12:'QR','ACC_1','ACC_2','R16_CHOL','R16_QR' 'SVD ','SVD_ACC1','SVD_ACC2','SVD_R16','SVD_LAPK' 'SVD2ACC1','SVD2ACC2'); call tabulate(type,r8coefle,r8se__le,r8rss_le :title 'Various options of real*8 data'); b34srun; b34sexec matrix; /$ heading('Filippelli Data'); datacards; 0.8116 -6.860120914 0.9072 -4.324130045 0.9052 -4.358625055 0.9039 -4.358426747 0.8053 -6.955852379 0.8377 -6.661145254 0.8667 -6.355462942 0.8809 -6.118102026 0.7975 -7.115148017 0.8162 -6.815308569 0.8515 -6.519993057 0.8766 -6.204119983 0.8885 -5.853871964 0.8859 -6.109523091 0.8959 -5.79832982 0.8913 -5.482672118 0.8959 -5.171791386 0.8971 -4.851705903 0.9021 -4.517126416 0.909 -4.143573228 0.9139 -3.709075441 0.9199 -3.499489089 0.8692 -6.300769497 0.8872 -5.953504836 0.89 -5.642065153 0.891 -5.031376979 0.8977 -4.680685696 0.9035 -4.329846955 0.9078 -3.928486195 0.7675 -8.56735134 0.7705 -8.363211311 0.7713 -8.107682739 0.7736 -7.823908741 0.7775 -7.522878745 0.7841 -7.218819279 0.7971 -6.920818754 0.8329 -6.628932138 0.8641 -6.323946875 0.8804 -5.991399828 0.7668 -8.781464495 0.7633 -8.663140179 0.7678 -8.473531488 0.7697 -8.247337057 0.77 -7.971428747 0.7749 -7.676129393 0.7796 -7.352812702 0.7897 -7.072065318 0.8131 -6.774174009 0.8498 -6.478861916 0.8741 -6.159517513 0.8061 -6.835647144 0.846 -6.53165267 0.8751 -6.224098421 0.8856 -5.910094889 0.8919 -5.598599459 0.8934 -5.290645224 0.894 -4.974284616 0.8957 -4.64454848 0.9047 -4.290560426 0.9129 -3.885055584 0.9209 -3.408378962 0.9219 -3.13200249 0.7739 -8.726767166 0.7681 -8.66695597 0.7665 -8.511026475 0.7703 -8.165388579 0.7702 -7.886056648 0.7761 -7.588043762 0.7809 -7.283412422 0.7961 -6.995678626 0.8253 -6.691862621 0.8602 -6.392544977 0.8809 -6.067374056 0.8301 -6.684029655 0.8664 -6.378719832 0.8834 -6.065855188 0.8898 -5.752272167 0.8964 -5.132414673 0.8963 -4.811352704 0.9074 -4.098269308 0.9119 -3.66174277 0.9228 -3.2644011 b34sreturn; /$ input y x; /$ build x2 x3 x4 x5 x6 x7 x8 x9 x10; /$ gen x2=x*x; gen x3=x2*x; gen x4=x3*x; gen x5=x4*x; /$ gen x6=x5*x; gen x7=x6*x; gen x8=x7*x; gen x9=x8*x; /$ gen x10=x9*x; /$ We are reading from unit 4 where the data file is automatically /$ saved in character representation. Since the data is in real*16 /$ all series built are in real*16 and all math is in real*16. x16=r8tor16(array(164:)); call read(x16,4); call load(ntokin :staging); call load(getr16 :staging); call load(svd_ols :staging); call echooff; /$ repack as a matrix since two cols were loaded into array x16 xm=matrix(41,4:x16); call print(xm); y=array(:xm(,1),xm(,3)); x=array(:xm(,2),xm(,4)); x2 =x*x; x3=x2*x; x4=x3*x; x5=x4*x; x6 =x5*x; x7=x6*x; x8=x7*x; x9=x8*x; x10=x9*x; /$ Loading Answers into Character then reading in real*16 call character(cc,' -1467.48961422980 298.084530995537 -2772.17959193342 559.779865474950 -2316.37108160893 466.477572127796 -1127.97394098372 227.204274477751 -354.478233703349 71.6478660875927 -75.1242017393757 15.2897178747400 -10.8753180355343 2.23691159816033 -1.06221498588947 0.221624321934227 -0.670191154593408E-01 0.142363763154724E-01 -0.246781078275479E-02 0.535617408889821E-03 -0.402962525080404E-04 0.896632837373868E-05' ); call ntokin(cc,nfind,0,ibad); call print(nfind ); call getr16(cc,nfind,ans,ibad); ans=matrix(11,2: ans); ans=rollup(ans); testss=real16('0.795851382172941E-03'); r16coefe=r8tor16(array(3:)); r16se__e=r8tor16(array(3:)); r16rss_e=r8tor16(array(3:)); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*16 -- All calculations in real*16':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('OLSQ on Filippelli - Coef Using PDFAC':); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :savex); call lre(ans(,1),15,%coef,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using PDFAC':); call lre(ans(,2),15,%se, lrese ,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lrerss ,bits :print); call print(' ':); r16coefe(1)=mean(lrecoef); r16se__e(1)=mean(lrese); r16rss_e(1)=mean(lrerss); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :qr :savex ); call print('OLSQ on Filippelli - Coef Using QR':); call lre(ans(,1),15,%coef,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using QR':); call lre(ans(,2),15,%se, lrese ,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lrerss ,bits :print); call print(' ':); r16coefe(2)=mean(lrecoef); r16se__e(2)=mean(lrese); r16rss_e(2)=mean(lrerss); call print('Using Data loaded in Real*16 *****************':); call print('OLSQ on Filippelli - Coef Using SVD':); call print(' ':); call svd_ols(%y,%x,u,v,s,beta_svd,se_svd,pc_coef,%sigmasq,rss,ibad); call lre(ans(,1),15,beta_svd,lrecoef,bits :print); call print('OLSQ on Filippelli - SE Using SVD':); call lre(ans(,2),15,se_svd, lrese ,bits :print); call print('Residual sum of squares:':); call lre(testss,15,rss,lrerss ,bits :print); r16coefe(3)=mean(lrecoef); r16se__e(3)=mean(lrese); r16rss_e(3)=mean(lrerss); type=c8array(3:'R16_CHOL','R16_QR', 'R16_SVD'); call tabulate(type,r16coefe,r16se__e,r16rss_e :title 'Calculations when data was loaded as real*16'); b34srun; == ==REAL16ON_2 Effect on inverse /; /; Illustrates real*8 & Real*16 effect on inverse /; b34sexec matrix; call real16off; n=5; call real16info; xr8=rn(matrix(n,n:)); call print('should produce I matrix':); call print('Using real*8 matrix and default accuracy':); call print('Using Real16off ******************':); ixr8=inv(xr8); call print(ixr8*xr8); call real16on; call real16info; call print('Using Real16addon *******************':); call print('Using Real16off ******************':); ixr8=inv(xr8); call print(ixr8*xr8); call print('Using Real16on *******************':); ixr8=inv(xr8); call real16info; call print(ixr8*xr8); call real16off; call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8 Then converted to Real*16 ':); call print('All Calculations after conversion in real*16 ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); xr16 = r8tor16(xr8); ixr16 = inv(xr16); call real16info; call print(ixr16*xr16); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8 Then converted to Real*16 ':); call print('All Calculations after conversion in real*16 ':); call print('real32on ++++++++++++++++++++++++++++++++++++++++++++':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call real32on; call real16info; xr16 = r8tor16(xr8); ixr16 = inv(xr16); call real16info; call print(ixr16*xr16); call real16off; call print('bad matrix here +++++++++++++++++++++++++++++++++++++':); call real16info; fix=1.d+12; xr8(,1)=xr8(,1)*fix; call print(xr8); call print('should produce I matrix':); call print('Using real*8 matrix and default accuracy':); call print('Using Real16off ******************':); ixr8=inv(xr8); call print(ixr8*xr8); call real16on; call real16info; call print('Using Real16addon *******************':); call print('Using Real16off ******************':); ixr8=inv(xr8); call print(ixr8*xr8); call print('Using Real16on *******************':); ixr8=inv(xr8); call real16info; call print(ixr8*xr8); call real16off; call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8 Then converted to Real*16 ':); call print('All Calculations after conversion in real*16 ':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); xr16 = r8tor16(xr8); ixr16 = inv(xr16); call real16info; call print(ixr16*xr16); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*8 Then converted to Real*16 ':); call print('All Calculations after conversion in real*16 ':); call print('real32on ++++++++++++++++++++++++++++++++++++++++++++':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call real32on; call real16info; xr16 = r8tor16(xr8); ixr16 = inv(xr16); call real16info; call print(ixr16*xr16); b34srun; == ==REAL16ON_3 Tests of real16on and real32on /$ Illustrates Real*16 and Complex*32 Processing /$ real32on and real32vpa b34sexec matrix; n=4; x=rn(matrix(n,n:)); do ii=1,3; if(ii.eq.1)then; call real16off; call real16info; endif; if(ii.eq.2)then; call real16on; call real32on; call real16info; endif; if(ii.eq.3)then; call real16on; call real32on; call real32_vpa; call real16info; endif; r16x=r8tor16(x); c16x= complex(x, dsqrt(dabs(2.0*x))); c32x=c16toc32(c16x); call print('In real*16 real*8 complex*32 complex*16',r16x,x,c32x,c16x); ix=inv(x); ir16x=inv(r16x); ic16x=inv(c16x); ic32x=inv(c32x); call print('Inverse real*16 real*8 complex*32 complex*16', ir16x,ix,ic32x,ic16x); call print('errors of inverse' x*ix,r16x*ir16x,c16x*ic16x,c32x*ic32x); e_x=eig(x); e_e16=eig(r16x); e_c16x = eig(c16x); e_c32x = eig(c32x); call print(trace(x),sum(e_x),det(x),prod(e_x)); call print(trace(r16x),sum(e_e16),det(r16x),prod(e_e16)); call print(trace(c16x),sum(e_c16x),det(c16x),prod(e_c16x)); call print(trace(c32x),sum(e_c32x),det(c32x),prod(e_c32x)); enddo; b34srun; == ==REAL16ON_4 Simple Case to test functioning /; /; Illustrates Real*16 and Complex*32 Processing /; Problem too easy to see much differece /; b34sexec matrix; n=4; x=rn(matrix(n,n:)); x16=r8tor16(x); c16=complex(x,2.1*x); c32=c16toc32(c16); call real16off; call real32off; call real16info; call print('In real*16 real*8 complex*32 complex*16',x16,x,c32,c16); ix=inv(x); ix16=inv(x16); ic16=inv(c16); ic32=inv(c32); call print('Inverse real*16 real*8 complex*32 complex*16', ix16,ix,ic32,ic16); call print('errors of inverse' x*ix,x16*ix16,c16*ic16,c32*ic32); call real16on; call real32on; call real16info; call print('In real*16 real*8 complex*32 complex*16',x16,x,c32,c16); ix=inv(x); ix16=inv(x16); ic16=inv(c16); ic32=inv(c32); call print('Inverse real*16 real*8 complex*32 complex*16', ix16,ix,ic32,ic16); call print('errors of inverse' x*ix,x16*ix16,c16*ic16,c32*ic32); b34srun; == ==R8TOR16 Real*8 to Real*16 Examples /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); b34srun; == ==R16TOR8 Real*16 to Real*8 Examples /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix ; n=4; x=rn(matrix(n,n:)); r16x=r8tor16(x); r8now=r16tor8(r16x); call print(x,r16x,r8now); diff=x-r8now; call print('Difference',diff); b34srun; == ==RECODE Recode a variable /; /; real*8, real*4, real*16 integer*4 and character*8 shown /; b34sexec matrix; x =array(:1 2 3 0 6 0); cx =namelist(test1 test2 test3 test4 test5); xi =index(1 2 3 4 5 4 3); x16=r8tor16(x); x4 =r8tor4(x); newx =recode(x,0.0,missing()); newcx=recode(cx,'TEST2','new2'); newxi=recode(xi,4,99); newx16=recode(x16,r8tor16(0.0),real16('.123')); newx4 =recode(x4,r8tor4(0.0),r8tor4(.9876)); call tabulate(x,newx,cx,newcx,xi,newxi,x16,newx16,x4,newx4); b34srun; == ==RECODE2 More advanced recode examples /; recodes of missing to mean % median b34sexec matrix; x=array(:1. 2. 3. 4. 5.); x(2)=missing(); call print(x); newx=recode(x,missing(),888.); call tabulate(x,newx); x=recode(x,missing(),8.8); call print(x); /; we replace missing with median and mean xbad=array(:1.,2.,-999., 4., 50.); call print(x); medianx=median(goodrow( recode(xbad,-999.,missing()) ) ); x=recode(xbad,-999.,medianx); meanx=mean(goodrow( recode(xbad,-999.,missing()) ) ); x2=recode(xbad,-999.,meanx); call print(medianx,x,meanx,x2); b34srun; == ==RECURSIVE Illustrates Recursive Calls b34sexec matrix cbuffer=500000 showuse; * Shows slow times for recursive calls ; * Do loops faster!!!!; * Use of FORMULA and SOLVE statements are a still better way to go!!; call echooff; function test(i); i=i+1; j=i; call outinteger(3,3,i); if(i.gt.50)go to done; j=test(i); done continue; return(j); end; program testp; i=i+1; j=i; call outinteger(3,3,i); if(i.gt.50)go to done; call testp; done continue; return; end; call timer(base); i=1; k=test(i); call names(all); call print(k); call timer(base2); call print(' Function calls took',base2-base); call timer(base); i=1; call testp; call names(all); k=i; call print(k); call timer(base2); call print('Program calls took',base2-base); call timer(base); j=0; do i=1,50; j=j+1; call outinteger(3,3,j); enddo; call print(j); call timer(base2); call print('Do took',base2-base); b34srun; == ==RENAME Rename an object b34sexec matrix; test1=object(x,y); test2=object(x,y,1); call names; call print(test1,test2); x=10.; y=40.; call rename(x,test1); call rename(y,object(p,v,0)); call names; call print(xy,pv0); b34srun; == ==RESET Illustrates Ramsey (1969) Residual Reset Test b34sexec options ginclude('gas.b34'); b34srun; /; /; See Ramsey, J. 'Tests for Specification Errors in Classical /; Linear Least Squares Regression Analysis' /; Journal of the Royal Statistical Society, /; Series B: 350-371 /; b34sexec matrix; call echooff; call loaddata; call olsq(gasout gasin{1 to 6}:print); rr=%res; lower=2; do ik=2,6; do ip=lower,18; call reset(rr,tt,ip,ik,pp); j=ip-lower+1; test(j) =tt; prob(j) =pp; order(j)=ip; enddo; call print('Ramsey (1969) test for',ik); call tabulate(order,test,prob); enddo; /; alternate lower=2; do ik=2,6; do ip=lower,18; call reset(rr,tt,ip,ik :print); enddo; enddo; b34srun; /; /; Shows case where no problem /; b34sexec matrix; call echooff; n=1000; k=3; x = rn(matrix(n,k:)); beta= vector(k:) +1.; error=rn(vector(n:)); y=x*beta+error; call olsq(y x:print); rr=%res; lower=2; do ik=2,6; do ip=lower,18; call reset(rr,tt,ip,ik :print); enddo; enddo; b34srun; == ==RESET69 Illustrates Ramsey (1969) Reset Test b34sexec options ginclude('gas.b34'); b34srun; /; /; See Ramsey, J. 'Tests for Specification Errors in Classical /; Linear Least Squares Regression Analysis' /; Journal of the Royal Statistical Society, /; Series B: 350-371 /; b34sexec matrix; call echooff; call loaddata; call load(reset69); call olsq(gasout gasin{1 to 6} :print :savex); y=%y; xx=%x; yhat=%yhat; iorder=2; iprint=1; call reset69(y,yhat,xx,rtest,prob,iorder,iprint); b34srun; == ==RESET77 Illustrates Thursby - Schmidt RESET(77) Test b34sexec matrix ; /; /; Ref: "Some Properties of Tests for Specification Error in a /; Linear Regression Model" JASA September 1977 Vol 72 /; Number 359 pp 635-641 /; /; Set up to run big cases such as n=100000 ncases=100 /; By not having a loop => can call comress as "end" of loop /; call echooff ; call load(reset77); call print(reset77); /; Build an AR model n=10000 ; ncases=10; ar=0.25 ; call free(ma); const=0.0; start=.1; wnv=1.0; nout=200; i=0; /$ Loop using go to => can use a compress test continue; i=i+1; ar1yt =genarma(ar,ma,const,start,wnv,n,nout); call reset77(ar1yt,1,4,res77,pres77,1); call compress; if(i.lt.ncases)go to test; b34srun ; == ==RESTORE Call restore => Reload workspace /$ The file matrix.psv can be read by Speakeasy with /$ the command importall(matrix) b34sexec options ginclude('b34sdata.mac') macro(res72); b34srun; b34sexec matrix; call loaddata; call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); call names; call names(all); call save; call cleardat; call restore(:list); call names(all); call restore; call names(all); call tabulate(l k q lnl lnk lnq); call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); b34srun; == ==RESTORE2 Tests Restore & Save with further examples b34sexec matrix; * Math with matrix and vectors ; * For bigger problems, change n; n=3; right=integers(1,((n*n)-1))+10; call print('Right ',right); x=matrix(n,n:right,-7); x2=x*2.; v=vector(n:integers(1,n)); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)' ,x*2.) ; call print('Scaler times Matrix (3.*x)' ,3.*x) ; call print('Vector plus matrix (v+x)' ,v+x) ; call print('Matrix plus vector (x+v)' ,x+v) ; call print('Matrix plus matrix (x+x2)' ,x+x2) ; call print('Matrix plus scaler (x+2.)' ,x+2.) ; call print('Scaler plus matrix (3.+x)' ,3.+x) ; call print('Vector minus matrix (v-x)' ,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)' ,x-x2) ; call print('Matrix minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus matrix (3.-x)' ,3.-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=x*2.; call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*2.)' ,x*2.) ; call print('Scaler times Array(2) (3.*x)' ,3.*x) ; call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+2.)' ,x+2.) ; call print('Scaler plus Array(2) (3.+x)' ,3.+x) ; call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus Array(2) (3.-x)' ,3.-x) ; call print(' Complex Results ' '++++++++++++++++++++++++++++++++++++++++'); x=mfam(complex(x,x2)); v=vfam(complex(v,v+8.0)); x2=mfam(complex(x2)); call print('X, x2 v' ,x,x2,v) ; call print('Inverse of x (INV)' , (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)',x*complex(2.)) ; call print('Scaler times Matrix (3.*x)',complex(3.)*x) ; call print('Vector plus matrix (v+x)',v+x) ; call print('Matrix plus vector (x+v)',x+v) ; call print('Matrix plus matrix (x+x2)',x+x2) ; call print('Matrix plus scaler (x+2.)',x+complex(2.)) ; call print('Scaler plus matrix (3.+x)',complex(3.)+x) ; call print('Vector minus matrix (v-x)',,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)',x-x2) ; call print('Matrix minus scaler (x-2.)',x-complex(2.)) ; call print('Scaler minus matrix (3.-x)',complex(3.)-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=afam(x2); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)', (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*complex(2.))',x*complex(2.)); call print('Scaler times Array(2) (complex(3.)*x)',complex(3.)*x); call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+complex(2.))',x+complex(2.)); call print('Scaler plus Array(2) (complex(3.)+x)',complex(3.)+x); call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-complex(2.))',x-complex(2.)); call print('Scaler minus Array(2) (complex(3.)-x)',complex(3.)-x); call save(:file 'mathdata.psv'); call names; call cleardat; call restore(:file 'mathdata.psv'); call names; b34srun; == ==REVERSE Hinich-Rothman (1998) Reverse Test b34sexec options ginclude('b34sdata.mac') member(rothtr1); b34srun; b34sexec matrix; call loaddata; n=20000; x=rn(array(n:)); /$ rn data call reverse(x :print :rb 20. ); call reverse(nomgnp :print :rb 9.5 :norm divide ); call rothman(nomgnp :order 5 :test tr1 :ar 1 :tran dif :print); b34srun; b34sexec options ginclude('b34sdata.mac') member(rothtr2); b34srun; b34sexec matrix; call loaddata; call reverse(gnpdefl :print :rb 9.5 :norm divide ); call rothman(gnpdefl :order 5 :test tr2 :ar 1 :tran dif :print); b34srun; == ==REVERSE_2 Hinich-Rothman Tests of Barnett Nonlinearity Datsets b34sexec options ginclude('b34sdata.mac') member(barnett); b34srun; b34sexec matrix; call loaddata; rb=20.; call reverse(model1 :print :rb rb); call reverse(model2 :print :rb rb); call reverse(model3 :print :rb rb); call reverse(model4 :print :rb rb); call reverse(model5 :print :rb rb); b34srun; == ==RN Tests IMSL-10 Generators /$ Tests IMSL Version 10 REC and Randon Number Generators /$ Look at RANDOM1 and RANDOM2 test problems /$ b34sexec options recver(ggubs) rnver(ggnml); b34srun; b34sexec matrix showuse; n=20; x=array(n:); r1=rec(x); r2=rec(x:); rn1=rn(x); rn2=rn(x:drnnoa); rn3=rn(x:drnnor); call tabulate(r1,r2,rn1,rn2,rn3); b34srun; /$ Reset back to IMSL b34sexec options recver(imsl_1) rnver(drnnoa); b34srun; == ==RN2 Resetting Seed on the fly b34sexec matrix showuse; call i_rnget(i); call print('seed at start',i:); x=array(8:); call print(rn(x :drnnoa)); call i_rnget(j); call print('seed now is ',j:); call i_rnset(i); call print(rn(x:drnnoa)); b34srun; == ==RN3 Resetting Seed on the fly using calls b34sexec matrix; call i_rnget(i); call print('seed at start',i:); x=array(8:); call i_drnnoa(x); call print(x); call i_rnget(j); call print('seed now is ',j:); call i_rnset(i); call i_drnnoa(x); call print(x); b34srun; == ==ROLLDOWN Rolldown function => move matrix rows down b34sexec matrix; n=10; v=rn(vector(n:)); downv=rolldown(v); call tabulate(v downv); x=rn(matrix(5,5:)); call print('Illustrates Rolldown',x,rolldown(x)); x=rn(matrix(5,6:)); call print('Illustrates Rolldown',x,rolldown(x)); b34srun; == ==ROLLLEFT rollLeft function => move cols left b34sexec matrix; n=10; v=rn(vector(n:)); leftv=rollleft(v); call tabulate(v leftv); x=rn(matrix(5,5:)); call print('Illustrates Rollleft',x,rollleft(x)); x=rn(matrix(5,6:)); call print('Illustrates Rollleft',x,rollleft(x)); b34srun; == ==ROLLRIGHT Rollright function => move matrix cols right b34sexec matrix; n=10; v=rn(vector(n:)); rightv=rollright(v); call tabulate(v rightv); x=rn(matrix(5,5:)); call print('Illustrates Rollright',x,rollright(x)); x=rn(matrix(5,6:)); call print('Illustrates Rollright',x,rollright(x)); b34srun; == ==ROLLUP Rollup function => move matrix rows up b34sexec matrix; n=10; v=rn(vector(n:)); upv=rollup(v); call tabulate(v upv); x=rn(matrix(5,5:)); call print('Illustrates Rollup',x,rollup(x)); x=rn(matrix(5,6:)); call print('Illustrates Rollup',x,rollup(x)); b34srun; == ==ROLL_TESTS Test Of Rollleft, rollright, rolldown, rollup /; Tests rollup, rolldown, rollleft rollright b34sexec matrix; n=10; v=rn(vector(n:)); downv=rolldown(v); downv16 =rolldown(r8tor16(v)); downvvpa=rolldown(vpa(v)); call tabulate(v downv downv16 downvvpa); testch1='123456789a123456789b123456789c'; call print(testch1, rollup(testch1),rolldown(testch1), rollleft(testch1),rollright(testch1)); cc1='abcdefghijk'; cc2=rollright(cc1); cc3=rollright(cc2); testc(1,)=cc1; testc(2,)=cc2; testc(3,)=cc3; call print(testc, rollup(testc),rolldown(testc), rollright(testc),rollleft(testc)); x=rn(matrix(5,5:)); call print('Illustrates Rolldown', x, rolldown(x)); call print('Illustrates Rolldown',r8tor16(x),rolldown(r8tor16(x))); call print('Illustrates Rolldown',vpa(x), rolldown(vpa(x))); x=rn(matrix(5,6:)); call print('Illustrates Rolldown',x,rolldown(x)); call print('Illustrates Rolldown',r8tor16(x),rolldown(r8tor16(x))); call print('Illustrates Rolldown',vpa(x), rolldown(vpa(x))); b34srun; b34sexec matrix; n=10; v=rn(vector(n:)); leftv =rollleft(v); leftv16 =rollleft(r8tor16(v)); leftvvpa=rollleft(vpa(v)); call tabulate(v leftv,leftv16,leftvvpa); x=rn(matrix(5,5:)); call print('Illustrates Rollleft',x,rollleft(x)); call print('Illustrates Rollleft',r8tor16(x),rollleft(r8tor16(x))); call print('Illustrates Rollleft',vpa(x),rollleft(vpa(x))); x=rn(matrix(5,6:)); call print('Illustrates Rollleft',x,rollleft(x)); call print('Illustrates Rollleft',r8tor16(x),rollleft(r8tor16(x))); call print('Illustrates Rollleft',vpa(x),rollleft(vpa(x))); b34srun; b34sexec matrix; n=10; v=rn(vector(n:)); rightv =rollright(v); rightv16 =rollright(r8tor16(v)); rightvvpa =rollright(vpa(v)); call tabulate(v rightv rightv16 rightvvpa); x=rn(matrix(5,5:)); call print('Illustrates Rollright',x,rollright(x)); call print('Illustrates Rollright',r8tor16(x),rollright(r8tor16(x))); call print('Illustrates Rollright',vpa(x),rollright(vpa(x))); x=rn(matrix(5,6:)); call print('Illustrates Rollright',x,rollright(x)); call print('Illustrates Rollright',r8tor16(x),rollright(r8tor16(x))); call print('Illustrates Rollright',vpa(x),rollright(vpa(x))); b34srun; b34sexec matrix; n=10; v=rn(vector(n:)); upv=rollup(v); upv16 =rollup(r8tor16(v)); upvvpa=rollup(vpa(v)); call tabulate(v upv upv16 upvvpa); x=rn(matrix(5,5:)); call print('Illustrates Rollup',x,rollup(x)); call print('Illustrates Rollup',r8tor16(x),rollup(r8tor16(x))); call print('Illustrates Rollup',vpa(x),rollup(vpa(x))); x=rn(matrix(5,6:)); call print('Illustrates Rollup',x,rollup(x)); call print('Illustrates Rollup',r8tor16(x),rollup(r8tor16(x))); call print('Illustrates Rollup',vpa(x),rollup(vpa(x))); b34srun; == ==ROTHMAN Rothman Reversability Test b34sexec options ginclude('b34sdata.mac') member(rothtr1); b34srun; /$ /$ Tests setup to exactly replicate Rothman (1997) test output /$ Rothman code fixed to remove three bugs: /$ 1. backforecasts were overwritting code /$ 2. Backforecasts were not initialized. Now randon numbers used /$ 3. 100 observations dropped for simulations to stabilize model /$ b34sexec matrix; call loaddata; call rothman(nomgnp :maxit 100 :test tr1 :order 5 :ar 1 :tran dif :iseed 25443332 :print); call names(all); b34srun; b34sexec options ginclude('b34sdata.mac') member(rothtr2); b34srun; b34sexec matrix; call loaddata; call rothman(gnpdefl :maxit 100 :test tr2 :order 5 :ar 1 :tran dif :iseed 25443332 :print); call names(all); b34srun; == ==ROTHMAN2 Shows Tests using Random Numbers /$ /$ Tests setup for random numbers. Needs 9,000,000 space /$ As setup has 5000,000 data points /$ b34sexec matrix; n=500000; x=rn(array(n:)); call rothman(x :maxit 100 :test tr1 :order 5 :ar 1 :tran raw :iseed 25443332 :print); b34srun; b34sexec matrix; n=500000; x=rn(array(n:)); call rothman(x :maxit 100 :test tr2 :order 5 :ar 1 :tran raw :iseed 25443332 :print); b34srun; == ==ROTHMAN3 Random Numbers and Time and Freq Tests /$ /$ Depending on your computer, this jobs can take time /$ Since Random numbers => should not find reversal!! /$ b34sexec matrix; n=20000; x=rn(array(n:)); /$ rn data call reverse(x :print :rb 20. ); call rothman(x :order 20 :test tr1 :tran dif :print); call rothman(x :order 20 :test tr2 :tran dif :print); b34srun; == ==ROTHMAN4 Reversal Tests on Gasout b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call reverse(gasout :rb 10. :print ); call rothman(gasout :order 5 :test tr1 :tran dif :print); call rothman(gasout :order 5 :test tr2 :tran dif :print); b34srun; == ==RRPLOTS Plots of Recursive Residuals /$ /$ This job validates the rrplots routine and the /$ RR option on the OLSQ command /$ %b34slet dorr=0; b34sexec options ginclude('b34sdata.mac') macro(eeam88)$ b34seend$ %b34sif(&dorr.ne.0)%then; b34sexec rr ntest=2 irb=1 irrls=list ibcls=list icum=list icumsq=list iquant=list$ model lnq = lnk lnl $ b34seend$ %b34sendif; b34sexec matrix; call loaddata; call load(rrplots); call olsq( lnq lnk lnl :rr 1 :print); call tabulate(%rrobs,%ssr1,%ssr2,%rr,%rrstd,%res); call print('Sum of squares of std RR ',sumsq(goodrow(%rrstd)):); call print('Sum of squares of OLS RES ',sumsq(goodrow(%res)):); call print(%rrcoef,%rrcoeft); call rrplots(%rrstd,%rss,%nob,%k,%ssr1,%ssr2,1); call rrplots2(%rrcoef,%rrcoeft,%names,%lag,'c___',0,0); call rrplots2(%rrcoef,%rrcoeft,%names,%lag,'c___',0,1); b34srun; == ==RRPLOTS2 Plots RR coefficients b34sexec options ginclude('b34sdata.mac') macro(eeam88)$ b34seend$ b34sexec matrix; call loaddata; call load(rrplots); call olsq( lnq lnk lnl :rr 1 :print); call print(%rrcoef,%rrcoeft); list=0; grid=0; call rrplots(%rrstd,%rss,%nob,%k,%ssr1,%ssr2,list); call rrplots2(%rrcoef,%rrcoeft,%names,%lag, 'c___',list,grid); b34srun; == ==RTEST ACF and PACF of OLS Model /$ Illustrates incomplete and complete Model b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(rtest); call olsq(gasout gasin:print :diag); call rtest(%res,gasout,48); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); call rtest(%res,gasout,48); b34srun; == ==RTEST2 ACF and PACG of OLS Model no Y and Res Plot /$ Illustrates incomplete and complete Model b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(rtest2); call olsq(gasout gasin:print :diag); call rtest2(%res,gasout,48); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); call rtest2(%res,gasout,48); b34srun; == ==RTOCH Converts real*8 to Character*8 b34sexec matrix; x=array(5:1 2 3 4 5); call print(x); cx=rtoch(x); call names; newx=chtor(cx); call tabulate(x,newx); c=c8array(:'sue','diana','houston'); rc=chtor(c); call print(c,rc rtoch(rc)); b34srun; == ==RUNMATLAB Run Matlab Using RMATLAB /$ Running Matlab script under B34S Matrix /$ Tasks: 1. Do a graph /$ 2. Pass Data from B34S to Matlab /$ 3. Bring data back b34sexec matrix; /$ /$ Matlab Commands /$ pgmcards; x=rand(140); x=x'*x; % ' mesh(x) x=rand(6); makeb34s('junk.in',x); yyinmat=getb34s('ydat.m') x pause quit b34sreturn; * Illustrate b34s loading data in matlab; yy=rn(matrix(5,5:)); call print(yy); call makematlab(yy :file 'ydat.m'); call load(rmatlab); call rmatlab; call getmatlab(xxin :file 'junk.in'); call print(xxin); b34srun; == ==RUNMATLAB1 Run Matlab Using a Script /$ Running Matlab script under B34S Matrix b34sexec matrix; /$ /$ These are malab commands /$ datacards; % See Matlab Graph Manual page 2-26 t = 0:pi/20:2*pi; [x,y]=meshgrid(t); subplot(2,2,1) plot(sin(t),cos(t)) axis equal title('plot(sin(t),cos(t))') subplot(2,2,2) z=sin(x)+cos(y); plot(t,z) axis ([0 2*pi -2 2]) title('z=sin(x)+cos(y)') subplot(2,2,3) z=sin(x).*cos(y); plot(t,z) axis([0 2*pi -1 1]) title('z=sin(x).*cos(y)') subplot(2,2,4) z = (sin(x).^2)-(cos(y).^2); plot(t,z) axis([0 2*pi -1 1]) title('z = (sin(x).^2)-(cos(y).^2))') pause quit b34sreturn; call open(77,'test.m'); call rewind(77); call rewind(4); call copyf(4,77); call close(77); call dodos('matlab /r test /logfile test.out':); call dounix('matlab < test.m > test.out'); call dodos('pause'); call copyout('test.out'); b34srun; == ==RUNMATLAB2 Run Matlab Using a Script /$ Running Matlab script under B34S Matrix /$ First define matlab commands /$ b34sexec matrix; datacards; % The example runs a matlab problem under B34S Matrix % page 10-24 Graphics load earth sphere; h= findobj('TYPE','surface'); hem=[ones(257,125),X,ones(257,125)]; set(h,'CData',flipud(hem),'FaceColor','texturemap') colormap(map) axis equal view([90 0]) set(gca,'CameraViewAngleMode','manual') view([65 30]) pause quit b34sreturn; * Here load all commands ; call load(rmatlab); call rmatlab; b34srun; == ==SAVE Call SAVE & Restore commands => Manage workspace /$ The file matrix.psv can be read by Speakeasy with /$ the command importall(matrix) b34sexec options ginclude('b34sdata.mac') macro(res72); b34srun; b34sexec matrix; call loaddata; call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); call names; call names(all); call save; call cleardat; call restore(:list); call names(all); call restore; call names(all); call tabulate(l k q lnl lnk lnq); call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); b34srun; == ==SAVE_2 Illustrates Changing save format /$ Illustrates various saving options b34sexec matrix; x=rn(matrix(4,4:)); ix=inv(x); ixr16=inv(r8tor16(x)); call print(x,ix,ixr16); call checkpoint(:file 'test.psv' :ndigits16); call save( :file 'test2.psv' :ndigits32); b34srun; b34sexec matrix; call restore(:file 'test.psv'); call names(all); call print(x,ix,ixr16); call print('++++++++++++++++++++++++++++++++++++++':); call free(x,ix,ixr16); call restore(:file 'test2.psv'); call names(all); call print(x,ix,ixr16); b34srun; == ==SAVE_3 Various Precision Saves using defaults /$ Illustrates various saving options b34sexec matrix; i =integers(20); i8 =i4toi8(i); x =rn(matrix(4,4:)); ix =inv(x); ixr16=inv(r8tor16(x)); call print(i,i8,x,ix,ixr16); call names(all); /; /; saving using B34S form of checkpoint and speakeasy form /; call checkpoint( :file 'test.psv' ); call save ( :file 'test2.psv'); b34srun; b34sexec matrix; /; read Speakeasy save call restore(:file 'test.psv'); call names(all); call print(i,i8,x,ix,ixr16); /; Full save call print('++++++++++++++++++++++++++++++++++++++':); call free(i,i8,ix,ixr16); call restore(:file 'test2.psv'); call names(all); call print(i,i8,x,ix,ixr16); call free( i,i8,x,ix,ixr16); b34srun; == ==SC_TEST Serial Correlation Diagnostic tests 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_test); call load(acf_plot); call load(data_acf); call load(df_gls); 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_test(nacf,%res,%x,bg_order,lmorder); /; alternative ways to plot if that is desired /; Most people prefer the second way /; call acf_plot(%res,12,'GE Equation'); call data_acf(%res,'GE Equation',12); b34srun; == ==SCHUR Performs Schur decomposition b34sexec matrix; * Example from Matlab - General Matrix; a=matrix(3,3: 6., 12., 19., -9., -20., -33., 4., 9., 15.); call schur(a,s,u); call print(a,s,u); is_ident=u*transpose(u); is_a =u*s*transpose(u); * Look at eigenvalues of this degenerate matrix ; e=eigenval(a,evec:lapack); * no scaling ; e_noscal=eigenval(a,evec_ns:lapack); call print('Tests of the schur', is_ident,is_a, e,evec,e_noscal,evec_ns); * Positive Def. case ; aa=transpose(a)*a; call schur(aa,ss,uu); ee=eigenval(aa:lapack); call print(aa,ss,uu,ee); * Expanded calls; call schur(a,s,u,wr,wi); call print('Real and Imag eigenvalues'); call tabulate(wr,wi); * Testing Properties; call print(is_a,is_ident); * Random Problem ; n=10; a=rn(matrix(n,n:)); call schur(a,s,u); call print(a,s,u); is_ident=u*transpose(u); is_a =u*s*transpose(u); call schur(a,s,u,wr,wi); call print('Real and Imag eigenvalues'); call tabulate(wr,wi); call print(is_a,is_ident); * Complex case ; a=matrix(3,3: 6., 12., 19., -9., -20., -33., 4., 9., 15.); ca=complex(a,2.*a); call schur(ca,cs,cu,cw); call print(ca,cs,cu,'Eigenvalues Two Ways', cw,eigenval(ca)); is_ca=cu*cs*transpose(dconj(cu)); call print(is_ca); b34srun; == ==SCHUR_2 Illustrates real vs Complex Schur b34sexec matrix; * Complex Form of Schur has eigenvalues along diagonal ; a=rn(matrix(4,4:)); call schur(a,s,u); call print(eig(a),a,s,u); call schur(complex(a),cs,cu); call print(eig(complex(a)),a,cs,cu); * tests ; call print(a,u*s*transpose(u),cu*cs*transpose(dconj(cu))); b34srun; == ==SCREENOUT Illustrates SCREENOUTON / SCREENOUTOFF b34sexec matrix; /$ Illustrates SCREENOUTON /$ Note that OUTSTRING, OUTDOUBLE, OUTINTEGER will not /$ work if SCREENOUTON is in effect /$ /$ User can change the size of the last problem by setting N call screenouton; x=matrix(3,3:11 22 33 55 66 77 88 99 00); v=vector(3:1 2 3); call print(x,v); inv=(1./x); call print(inv); test=x*inv; call print(test); vx=v*x; call print(vx); xx=x*x; call print(xx); xv=x*v; call print(xv); * Big tests !! ; /$call cls; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); call outstring(3,3,'This is jj'); call outinteger(30,3,jj); call cls(4); call outstring(3,4,'This is 5'); call outinteger(30,4,5 ); call cls(5); call outstring(3,5,'This is 88.88!!'); call outdouble(40,5,88.8); call print('We have stopped!!!.',' ','Hit enter to proceed'); call stop(pause); n=100; x=matrix(n,n:); call timer(base); x=rn(x); /$call print(x); call timer(base2); call print('RN used ',base2-base); ff=(1./x); call timer(base); call print('Inverse used ',base-base2); test=x*ff; s=sum(test); call timer(base2); call print('Mult and test used ',base2-base); call print(s); b34srun; == ==SCREEN_1 Illustrate Screenclose b34sexec matrix; call screenclose; call open(70,'test.f'); call rewind(70); call character(test," write(6,*)'This is a test # 2'" " n=1000 " " write(6,*)n " " do i=1,n " " write(6,*) sin(float(i)) " " enddo " " stop " " end "); call write(test,70); call close(70); call dodos('lf95 test.f'); call dounix('lf95 test.f -otest'); call dodos('test > testout':); call dounix('./test > testout':); call open(71,'testout'); call character(test2,' '); call read(test2,71); call print(test2); testd=0.0; n=0; call read(n,71); testd=array(n:); call read(testd,71); call print(testd); call close(71); call dodos('erase testout'); call dodos('erase test.f'); call dounix('rm testout'); call dounix('rm test.f'); call screenopen; b34srun; == ==SCREEN_2 Illustrate Screenopen b34sexec matrix; call screenclose; call open(70,'test.f'); call rewind(70); call character(test," write(6,*)'This is a test # 2'" " n=1000 " " write(6,*)n " " do i=1,n " " write(6,*) sin(float(i)) " " enddo " " stop " " end "); call write(test,70); call close(70); call dodos('lf95 test.f'); call dounix('lf95 test.f -otest'); call dodos('test > testout':); call dounix('./test > testout':); call open(71,'testout'); call character(test2,' '); call read(test2,71); call print(test2); testd=0.0; n=0; call read(n,71); testd=array(n:); call read(testd,71); call print(testd); call close(71); call dodos('erase testout'); call dodos('erase test.f'); call dounix('rm testout'); call dounix('rm test.f'); call screenopen; b34srun; == ==SEIG Symmetric Eigenvalue Analysis b34sexec matrix; * Test case for Real symmetric Matrix from IMSL Math (10) pp 309-311; a=matrix(3,3:7.,-8.,-8.,-8.,-16.,-18.,-8.,-18.,13.); call print('A Matrix',a); e=seig(a); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of Symmetric Martix A',sum(e), 'Trace of Symmetric Matrix A',trace(a), 'Product of the eigenvalues of Symmetric Martix A',prod(e), 'Determinant of Symmetrix Matrix A',det(a)); ee=seig(a,evec); call print(ee,evec); call print('Test transpose(evec)*evec ', transpose(evec)*evec , ' ' 'Note: a*evec = evec*diagmat(ee)' a*evec,evec*diagmat(ee), 'Test evec*transpose(evec) ', evec*transpose(evec)) ; call print('Using EISPACK and LAPACK Test results':); e =eig(a,evec); e2=eig(a,evec2:lapack); call print('Eispack',evec, 'Test of eigenvalues note that diagonal matrix but not 1 on diag' transpose(evec)*evec 'Do we get a' evec*diagmat(e)*inv(evec) ' ' 'Test of LAPACK',evec2 'Do we get a' evec2*diagmat(e)*inv(evec2) evec2*transpose(evec2) transpose(evec2)*evec2); /$ Real*16 r16a=r8tor16(a); r16e=seig(r16a); call print('Eigenvalues of r16a', r16e, 'Sum of the eigenvalues of Symmetric Martix A',sum(r16e), 'Trace of Symmetric Matrix A',trace(r16a), 'Product of the eigenvalues of Symmetric Martix A',prod(r16e), 'Determinant of Symmetrix Matrix A',det(r16a)); r16ee= seig(r16a,r16evec); call print(r16ee,r16evec); call print('Test transpose(evec)*evec ', transpose(r16evec)*r16evec , ' ' 'Note: a*evec = evec*diagmat(ee)' r16a*r16evec,r16evec*diagmat(r16ee), 'Test evec*transpose(evec) ', r16evec* transpose(r16evec)) ; b34srun; == ==SET Illustrates set command b34sexec matrix; n=4; x=rn(matrix(n,n:)); call print(x); call set(x,3.0); call print('Here all of x is 3.0',x); call set(x,0.0); call setcol(x,3,5.0); call print('Here col 3 is 5.0' ,x); call set(x,0.0); call setrow(x,4,88.0); call print('Here row 4 is 88.0',x); b34srun; == ==SETCOL Illustrates setcol command b34sexec matrix; n=3; x=rn(matrix(n,n:)); call print(x); call setcol(x,1,3.0); call print(x); acol=array(n:); call setcol(acol,1,-55.); call print('Col 1 is -55.',acol); call print('Alternative'); acol(,1)=-88.; call print(acol); call print('While setcol checks for type.' 'x(,1)=88; ' 'Redefines as an integer '); x(,1)=88; call print(x); b34srun; == ==SETLABEL Illustrate SETLABEL b34sexec matrix; short=10.; long= 20; call names; call setlabel(short,'test'); call setlabel(long, 'This is a long label'); call names; call print('Label for long' ,label(long), 'Label for short',label(short)); b34srun; == ==SETLEVEL Illustrates setlevel b34sexec matrix; x=1.; call makeglobal(x); call setlevel(now); do i=1,20; xx=33.; call setlevel(up); call setlevel(now); call names(all); call setlevel(up); call setlevel(now); call setlevel(down); call setlevel(down); enddo; call setlevel(base); call names(all); b34srun; == ==SETNDIMV Sets Value in an N dimensional object b34sexec matrix; mm=index(4,5,6:); xx=rn(array(mm:)); idim =index(4,5,6); idim2=index(2,2,2); call setndimv(idim,idim2,xx,10.); vv= getndimv(idim,idim2 ,xx); call print(xx,vv); b34srun; == ==SETROW Illustrates setrow command b34sexec matrix; n=3; x=rn(matrix(n,n:)); call print(x); call setrow(x,2,3.0); call print('Here row 2 is 3.0',x); call print('Alternative'); x(2,)=-88.; call print(x); call print('While setrow checks for type.' 'x(2,)=88; ' 'Redefines as an integer '); x(2,)=88; call print(x); b34srun; == ==SETTIME Sets internal time data in a series b34sexec matrix; x=rn(array(120:)); call settime(x,1960,1,12.); call print(timebase(x),timestart(x),freq(x)); jdate=makejul(x); year=fyear(jdate); call graph(year,x :plottype xyplot); b34srun; == ==SEXTRACT Pull Data from a datatype b34sexec matrix; /; /; Define a structure with names of variables /; people=namelist(pname,ssn,age,race,income); /; /; load the elements of the structure /; pname =namelist(sue,joan,bob); ssn =array(:99,9821,22); age =idint(array(:35,45,58)); race =namelist(hisp,white,black); income=array(:40000,35000,50000); /; /; Test what has been loaded /; call tabulate(pname,ssn,age,race,income); /; /; Pull out data for age for all in people /; call print(sextract(people(3))); /; /; Get ss# and age fcor person 2 /; call print('Second person',sextract(people(1),2), sextract(people(3),2)); /; /; Update age array and place back in structure /; nage=age+1; call isextract(people(3),nage); call print(age); /; /; Make person # 1 77 /; call isextract(people(3),77,1); call print(age); b34srun; == ==SFAM Conversion of Scaler Klass b34sexec matrix; x=array(1,1:1); call print(klass(x),klass(sfam(x))); b34srun; == ==SIGD Sets print digits b34sexec matrix; r=pi(); do i=1,8; call print('sigd was ',i); call sigd(i); call print('pi was ',pi():line); call print('pi was ',pi()); enddo; /$ Illustrates OLS Capability under Matrix Command /$ # digits changed b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix sigd(4); call loaddata; call olsq(gasout gasin:print :diag); call sigd(10); call olsq(gasout gasin:print :diag); b34srun; == ==SIMULATE Dynamic Simulation of OLS Model /$ /$ Job illustrates use of SIMULATE in a bootstrap calculation /$ using the staging bootols subroutine /$ b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix$ call loaddata; call echooff; subroutine bootols(y,x,error,coef,nboot,bcoef,se,isave,lag); /$ /$ Bootstrap a model y = f(x) /$ We can assume no lags in tne model /$ /$ /$ Usually y = %y from olsq call /$ e = %x from olsq call with :savex option /$ error = %res from olsq call /$ coef = %coef from olsq call /$ hcoef = nboot by k matrix of estimated coefficients /$ hse = nboot by k matrix of estimated se scores /$ hrsq = nboot vector of r**2 /$ 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 /$ /$ Since lags already in the x matrix => works for cross section /$ or time series models /$ /$ Due to the recursive nature of the problem when lag > 0 the code /$ doe not run fast!! /$ /$ Command built 20 August 2003 /$ 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))$ 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; lagorder=integers(lag); 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); enddo$ endif; bcoef=vector(nocols(%hcoef):); se =vector(nocols(%hcoef):); /$ /$ This gets the SE /$ 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)se(j)=(upper-lower)/4.0; enddo; if(isave.eq.1)call makeglobal(%hcoef,%hse,%hrsq); return$ end$ call print(bootols)$ nlag=6$ call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print :savex)$ nboot=500; isave=1; lag=0; call bootols(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /$ call print(%hcoef,%hse,%hrsq)$ call print(bcoef,bse); lag=nlag; call bootols(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /$ call print(%hcoef,%hse,%hrsq)$ call print(bcoef,bse); b34srun$ == ==SIMULATE2 Plotting bootstrapped coefficients b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(bootplot :staging); nlag=6$ call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print :savex)$ coef=%coef; x=%x; error=%res; y=%y; nboot=800; nob=norows(x)$ %hcoef=matrix(nboot,nocols(x):)$ %hse =matrix(nboot,nocols(x):)$ %hrsq =vector(nboot:)$ ywork=vector(nob:)$ error=vfam(error)$ if(nlag.ne.0)then; lagorder=integers(nlag); do ii=1,nboot$ nerror=bootv(error); ny =bootv(y); call simulate(ywork,coef,x,nerror :lags nlag ny); call olsq(ywork x :noint); %hcoef(ii,)=%coef$ %hse(ii,) =%se$ %hrsq(ii) =%rsq$ call outstring(3,3,'Time Series Bootstrap #'); call outinteger(14,4,ii); enddo$ endif; call print(%hcoef,%hse,%hrsq); call bootplot(%hcoef(,1),'gasout{1} coef', 'Boot Values of gasout{1} Coef','lag1.wmf',1); if(nlag.gt.1)call bootplot(%hcoef(,2),'gasout{2} coef', 'Boot Values of gasout{2} Coef','lag2.wmf',1); if(nlag.gt.2)call bootplot(%hcoef(,3),'gasout{3} coef', 'Boot Values of gasout{3} Coef','lag3.wmf',1); if(nlag.gt.3)call bootplot(%hcoef(,4),'gasout{4} coef', 'Boot Values of gasout{4} Coef','lag4.wmf',1); if(nlag.gt.4)call bootplot(%hcoef(,5),'gasout{5} coef', 'Boot Values of gasout{5} Coef','lag5.wmf',1); if(nlag.gt.5)call bootplot(%hcoef(,6),'gasout{6} coef', 'Boot Values of gasout{6} Coef','lag6.wmf',1); call bootplot(%hrsq,'rsq values', 'Boot Values of R squared','rootrsq.wmf',1); b34srun; == ==SMOOTH Exponential Smoothing Methods /$ /$ Illustrates "Automatic Methods" on Gas Data /$ Results Graphed /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call smooth(gasout :method nce :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'No Change Extrapolation'); call graph(%error :heading 'No Change Extrapolation'); call smooth(gasout :method ncept :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'No Change Plus Trend'); call graph(%error :heading 'No Change Plus Trend'); call smooth(gasout :method avetd :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Average to Date'); call graph(%error :heading 'Average to Date'); call smooth(gasout :method mave :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Moving Average'); call graph(%error :heading 'Moving Average'); call smooth(gasout :method dmave :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Double Moving Average'); call graph(%error :heading 'Double Moving Average'); call smooth(gasout :method es :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Exponential Smoothing'); call graph(%error :heading 'Exponential Smoothing'); call smooth(gasout :method des :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Double Exponential Smoothing'); call graph(%error :heading 'Double Exponential Smoothing'); call smooth(gasout :method holt :print :alpha .4 :beta .1); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Holt Method'); call graph(%error :heading 'Hold Method'); call smooth(gasout :method winters :print :alpha .4 :beta .1); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Winters Method'); call graph(%error :heading 'Winters Method'); b34srun; == ==SMOOTH_2 Shows Gardner Advanced Smoothing %b34slet pass1=0; %b34slet pass2=1; %b34slet hanke=0; %b34slet gardner=1; %b34slet croston=1; /; /$ Illustrates Various Test Cases /$ /$ Due to initial S( ) Winters will not replicate /$ text book /$ %b34sif(&pass1.eq.1)%then; b34sexec options ginclude('class.mac') member(movie); b34srun; b34sexec matrix; call loaddata; * See Hanke & Reitsch page 145 ; call smooth(wsales :method mave :nma 3 :print); call tabulate(%xhatobs %actual %xhat %error); call print(%xhatmat); * See Hanke & Reitsch page 147 ; call smooth(wsales :method dmave :nma 3 :print); call tabulate(%xhatobs %actual %xhat %error); call print(%xhatmat); * See Hanke & Reitsch page 158 table 5.8 ; call smooth(wsales :method des :alpha .4 :print); call tabulate(%xhatobs %actual %xhat %error); call print(%xhatmat); b34srun; %b34sendif; %b34sif(&pass2.eq.1)%then; b34sexec options ginclude('class.mac') member(acme); b34srun; b34sexec matrix; call loaddata; %b34sif(&hanke.eq.1)%then; call smooth(sales :method nce :print); call print(%xhatmat,ccf(%actual,%xhat)); call tabulate(%xhatobs %actual %xhat %error); call smooth(sales :method ncept :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); call smooth(sales :method avetd :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); * Page 150 table 5.6 ; call smooth(sales :method es :alpha .1 :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); call smooth(sales :method es :alpha .6 :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); call smooth(sales :method des :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); * Page 163 table 5.9 ; call smooth(sales :method holt :alpha .3 :lag 4 :beta .1 :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); call print(%rss %mad %mse %mape %mpe %corr); * Page 167 table 5.10 ; call smooth(sales :method winters :alpha .4 :lag 4 :beta .1 :gamma .3 :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); call print(%rss %mad %mse %mape %mpe %corr); %b34sendif; %b34sif(&gardner.eq.1)%then; call smooth(sales :method ncept :print); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); call smooth(sales :method des :print :lag 3); call print(%xhatmat); call tabulate(%xhatobs %actual %xhat %error); call smooth(sales :method N_N :lag 3 :print :forecast index(5 26)); call print(%xhatmat); call tabulate(%sobs %actual %s %error); call tabulate(%foreobs,%fcast); call smooth(sales :method N_A :lag 3 :print :period 2 :forecast index(5 26)); call print(%xhatmat); call tabulate(%sobs %actual %s %error %I); call tabulate(%foreobs,%fcast); call smooth(sales :method N_M :lag 1 :print :period 1 :forecast index(5 26) :gamma .1 ); call print(%xhatmat); call tabulate(%sobs %actual %s %error %I); call tabulate(%foreobs,%fcast); /; /; make beta small here to damp adjustment /; call smooth(sales :method A_N :lag 1 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :tmax 1.0); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T); call tabulate(%foreobs,%fcast); call smooth(sales :method A_A :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :gamma .1 :beta .1 ); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %i); call tabulate(%foreobs,%fcast); call smooth(sales :method A_M :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :gamma .1 :beta .1 ); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %i); call tabulate(%foreobs,%fcast); call smooth(sales :method DA_N :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T); call tabulate(%foreobs,%fcast); call smooth(sales :method DA_A :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %I); call tabulate(%foreobs,%fcast); call smooth(sales :method DA_M :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %I); call tabulate(%foreobs,%fcast); call smooth(sales :method M_N :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %R ); call tabulate(%foreobs,%fcast); call smooth(sales :method M_A :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %R %I); call tabulate(%foreobs,%fcast); call smooth(sales :method M_M :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %R %I); call tabulate(%foreobs,%fcast); call smooth(sales :method DM_N :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %I); call tabulate(%foreobs,%fcast); call smooth(sales :method DM_A :lag 3 :print :period 1 :forecast index(5 26) :alpha .9 :tstart .1 :beta .1 :damp .1); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %I); call tabulate(%foreobs,%fcast); call smooth(sales :method DM_M :lag 3 :print :period 1 :forecast index(5 26) /; :alpha .9 /; :tstart .1 /; :beta .1 :damp .1 ); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %I); call tabulate(%foreobs,%fcast); call smooth(sales :method N_M :lag 6 :print :period 1 :forecast index(6 20) /; :alpha .9 /; :tstart .1 /; :beta .1 :damp .1 ); call print(%xhatmat); call tabulate(%sobs %actual %s %error %T %I); call tabulate(%foreobs,%fcast); %b34sendif; b34srun; %b34sendif; %b34sif(&croston.ne.0)%then; /; /; Croston Missing data methods /; b34sexec data heading('Smooth Data with 0.0'); input demand; label demand ='Demand Data with 0.0 '; datacards; 0 0 19 0 0 0 4 18 17 0 0 0 0 0 3 0 0 19 0 0 0 5 4 5 b34sreturn; b34srun; b34sexec matrix; call loaddata; call smooth(demand :method nce :print); call print(%xhatmat,%xhat); call tabulate(%actual %error %xhat); call smooth(demand :method es :print); call print(%xhatmat,%xhat); call tabulate(%actual %error %xhat); call smooth(demand :method croston :alpha .33 :print :pstart 2. :zstart 5.); call print(%xhatmat); call tabulate(%actual %error %s %P %z); call smooth(demand :method mcroston :alpha .33 :print :pstart 2. :zstart 5.); call print(%xhatmat); call tabulate(%actual %error %s %P %z); call smooth(demand :method vcroston :alpha .33 :print :pstart 2. :zstart 5. :lag 2); call print(%xhatmat); call tabulate(%actual %error %s %P %z); b34srun; %b34sendif; == ==SMOOTH_A Lag 1,...,4 Tests of SMOOTH Methods /$ /$ Illustrates "Automatic Methods" on Gas Data /$ Results Graphed /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; /; Tests for lag=1 forecasts iprintdt=0; lag=1; method=namelist(NCE NCEPT AVETD MAVE DMAVE ES DES HOLT WINTERS); call smooth(gasout :method nce :print :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'No Change Extrapolation' :nolabel :file 'nec_1.wmf'); call graph(%error :heading 'No Change Extrapolation' :nolabel :file 'nec_2.wmf'); i=1; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method ncept :print :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'No Change Plus Trend' :nolabel :file 'ncept_1.wmf'); call graph(%error :heading 'No Change Plus Trend' :nolabel :file 'ncept_2.wmf'); i=2; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method avetd :print :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Average to Date' :nolabel :file 'avetd_1.wmf'); call graph(%error :heading 'Average to Date' :nolabel :file 'avetd_2.wmf'); i=3; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method mave :print ); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Moving Average' :nolabel :file 'mave_1.wmf'); call graph(%error :heading 'Moving Average' :nolabel :file 'mave_2.wmf'); i=4; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method dmave :print :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Double Moving Average' :nolabel :file 'dmave_1.wmf'); call graph(%error :heading 'Double Moving Average' :nolabel :file 'dmave_2.wmf'); i=5; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method es :print :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Exponential Smoothing' :nolabel :file 'es_1.wmf'); call graph(%error :heading 'Exponential Smoothing' :nolabel :file 'es_2.wmf'); i=6; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method des :print :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Double Exponential Smoothing' :nolabel :file 'des_1.wmf'); call graph(%error :heading 'Double Exponential Smoothing' :nolabel :file 'des_2.wmf'); i=7; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method holt :print :alpha .4 :beta .1 :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Holt Method' :nolabel :file 'holt_1.wmf'); call graph(%error :heading 'Holt Method' :nolabel :file 'holt_2.wmf'); i=8; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call smooth(gasout :method winters :print :alpha .4 :beta .1 :lag lag); if(iprintdt.ne.0)call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Winters Method' :nolabel :file 'winters_1.wmf'); call graph(%error :heading 'Winters Method' :nolabel :file 'winters_2.wmf'); call names(all); i=9; rss(i) = %rss(1); mad(i) = %mad(1); mse(i) = %mse(1); mape(i) = %mape(1); mpe(i) = %mpe(1); corr(i) = %corr(1); call tabulate(method, RSS MAD MSE MAPE MPE CORR); /; Tests for lag > 1 call print(' ':); call free(rss,mad,mse,mape,mpe,corr); method=namelist(NCE NCEPT DMAVE DES HOLT WINTERS); do lag=1,4; call smooth(gasout :method nce :lag lag); i=1; rss(i) = %rss(lag); mad(i) = %mad(lag); mse(i) = %mse(lag); mape(i) = %mape(lag); mpe(i) = %mpe(lag); corr(i) = %corr(lag); call smooth(gasout :method ncept :lag lag); i=2; rss(i) = %rss(lag); mad(i) = %mad(lag); mse(i) = %mse(lag); mape(i) = %mape(lag); mpe(i) = %mpe(lag); corr(i) = %corr(lag); call smooth(gasout :method dmave :lag lag); i=3; rss(i) = %rss(lag); mad(i) = %mad(lag); mse(i) = %mse(lag); mape(i) = %mape(lag); mpe(i) = %mpe(lag); corr(i) = %corr(lag); call smooth(gasout :method des :lag lag); i=4; rss(i) = %rss(lag); mad(i) = %mad(lag); mse(i) = %mse(lag); mape(i) = %mape(lag); mpe(i) = %mpe(lag); corr(i) = %corr(lag); call smooth(gasout :method holt :alpha .4 :beta .1 :lag lag); i=5; rss(i) = %rss(lag); mad(i) = %mad(lag); mse(i) = %mse(lag); mape(i) = %mape(lag); mpe(i) = %mpe(lag); corr(i) = %corr(lag); call smooth(gasout :method winters :alpha .4 :beta .1 :lag lag); i=6; rss(i) = %rss(lag); mad(i) = %mad(lag); mse(i) = %mse(lag); mape(i) = %mape(lag); mpe(i) = %mpe(lag); corr(i) = %corr(lag); call print(' ':); call print('Summary Measures for Forecast lag ',lag:); call tabulate(method, RSS MAD MSE MAPE MPE CORR); enddo; b34srun; == ==SMOOTH_B Tests Cases on SMOOTH Methods /$ Illustrates Various Test Cases /$ /$ Due to initial S( ) Winters will not replicate /$ text book /$ b34sexec options ginclude('class.mac') member(movie); b34srun; b34sexec matrix; call loaddata; * See Hanke & Reitsch page 145 ; call smooth(wsales :method mave :nma 3 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); * See Hanke & Reitsch page 147 ; call smooth(wsales :method dmave :nma 3 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); * See Hanke & Reitsch page 158 table 5.8 ; call smooth(wsales :method des :alpha .4 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); b34srun; b34sexec options ginclude('class.mac') member(acme); b34srun; b34sexec matrix; call loaddata; call smooth(sales :method nce :print); call print(%xhatmat,ccf(%actual,%xhat)); call tabulate(%actual %xhat %error); call smooth(sales :method ncept :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call smooth(sales :method avetd :print); call print(%xhatmat); call tabulate(%actual %xhat %error); * Page 150 table 5.6 ; call smooth(sales :method es :alpha .1 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call smooth(sales :method es :alpha .6 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call smooth(sales :method des :print); call print(%xhatmat); call tabulate(%actual %xhat %error); * Page 163 table 5.9 ; call smooth(sales :method holt :alpha .3 :lag 4 :beta .1 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call print(%rss %mad %mse %mape %mpe %corr); * Page 167 table 5.10 ; call smooth(sales :method winters :alpha .4 :lag 4 :beta .1 :gamma .3 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call print(%rss %mad %mse %mape %mpe %corr); b34srun; == ==SMOOTH_C Uses CMAXF2 to get best Alpha b34sexec options ginclude('class.mac') member(movie); b34srun; b34sexec matrix; call loaddata; * See Hanke & Reitsch page 158 table 5.8 ; call smooth(wsales :method des :alpha .4 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); * Search using constrained maximize to get better alpha; * Search begins with alpha = .7 ; * We want to see if ~.4 is close to what is appropriate; * %rss(1) %mad(1) %corr(1) ; program test; call smooth(wsales :method des :alpha a); func=-1.*%rss(1); /; call print(a); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, a); return; end; rvec=array(1:.7); ll= array(1:.01); uu= array(1:.99); call echooff; call cmaxf2(func :name test :parms a :ivalue rvec :lower ll :upper uu :print); call print('Optimized Alpha',a:); call smooth(wsales :method des :alpha a :print); b34srun; == ==SNGL Converts real*8 to real*4 b34sexec matrix; x=dfloat(integers(20)); xreal4=sngl(x); call names(all); call tabulate(x,xreal4); call print('Range adjustments for real*4'); xlarge8=-1.e+64; xsmall8=.1e-50; xlarge4=sngl(xlarge8); xsmall4=sngl(xsmall8); call print(xlarge8,xsmall8,xlarge4,xsmall4); b34srun; == ==SOBJECT1 Tests / Illustrates Structured Objects b34sexec matrix; test=vector(:1 2 3 4); call print(test); n=4; v=vector(n:11. 22. 33. 44.); x=matrix(n,n:integers(1,n*n)); call print(x,v); v1=v(1); v3=v(3); call print(v,'This should be element 1 of v',v1); call print(v,'This should be element 3 of v',v3); i=idint(array(2:2 4)); call names; call names(all); call print('This is the structure index array - contains 2 4',i); v2=v(i); call print(v,'This should be elements 2 and 4 of v',v2); test1=x(,1); test2=x(2,); test3=x(2,2); call print('Test1 = col 1, test2 = row 2 test3 is element 2,2', test1 test2 test3); * Tests 2d structured call; kk=integers(1,3); digg=x(kk,kk); call print('Digg is the 3 by 3 part of x',digg); digg1=x(kk,1); call print('Digg1 is x col 1',digg1); digg2=x(2,kk); call print('Digg2 is x row 2',digg2); digg3=x(kk,); call print('Digg3 is x col 1',digg3); digg4=x(,kk); call print('Digg4 is x row 2',digg4); * ; nkk=integers(2,4); ndigg=x(nkk,nkk); call print(nkk,'Submatrix from x x(nkk,nkk)',ndigg); v=rn(vector(n:)); call print(v); newx=x;call print(newx);newx(2,)=v; call print('Random # row 2',newx); newx=x;call print(newx);newx(,2)=v; call print('Random # col 2',newx); * create a new variable ; notx(3,3)=digg; call print(digg,notx); i=idint(array(:1 3 4)); newx=x(i); call print('Contains rows 1 3 4 of x',newx); a=matrix(3,3:); call print(mean(x)); a(1,1)= mean(x); a(3,)=mean(x);call print(a); a=vector(2:); call free(a); call names; call names(all); call free(a);a(3 )= mean(x); call print(a); call free(a);a(3,)= mean(x); call print(a); call free(a);a(,3)= mean(x); call print(a); v=vector(3:1 2 3); a(2,)=v; call print(a); i=idint(array(2:1,3)); * place 1 3 in newv; call print(i); newv=v(i); call print('Term 1 and 3 of v in newv',newv); x=matrix(3,3:integers(1,9)); call print(x); * place 1 2 3 7 8 9 in newx; call free(newx); newx=x(i,); call print('Row1 and Row3 of x in newx',newx); call free(newx); newx=x(,i); call print('Col1 and Col3 of x in newx',newx); b34srun; == ==SOBJECT2 Further tests with structured objects b34sexec matrix; v=vector(:6 5 4 3 2 1); a=array(:1 2 3 4 5 6); call print(a,v); * note we trick program by passing an integer will use same size of v but zero it out; v2=v; a(2)=44.0; v(3)=-44; v2(3)=-44.; vnew(3)=-44.; * vnew will have only 3 elements. Elements 1 & 2 = 0; call print(a,v,v2,vnew); a(4)=110.; call print(a); a(7)=99.; * Here a expands one element; call print(a); * Here we change element 7 of a; a(7)=98.; call print(a); mat1=matrix(3,3:1 2 3 4 5 6 7 8 9); call print(mat1); arr2=array(3,3: 1 2 3 4 5 6 7 8 9); call print(arr2); mat1(2,2)=-999.; arr2(2,2)=-888.; call print(mat1,arr2); b34srun; == ==SOBJECT3 Further Structured Object Illustrations b34sexec matrix; x=rn(matrix(3,3:)); call print(x); * Place x(3,3) inside y. Note scaler subscripts; y(3,3)=x; call print('Note that the base of x is as 3,3',y); * Uses arrays i and j to put x in yy ; i=integers(3); j=i; yy=x(i,j); call print(yy); * Uses arrays i and j to put subset of x in yy ; i=integers(2,3); j=i; yyy=x(i,j); call print(yyy); * Illustrates use of scaler positioning in yyyy ; yyyy(2,3)=x(i,j); call print(yyyy); b34srun; == ==SOBJECT4 Advanced structured objects b34sexec matrix; * Program illustrates two cases; * # 1 Put data into a fixed location; * # 2 Put data into a structure ; x=vector(3:1 2 3); i=integers(3,1,-1); r=integers(3); call print(x,i); call print('Putting Data in a new variable.'); * test=vector(3:); test=x(i); call print('This is just a copy of x',test); test(i)=x(i); call print('This is just a copy of x',test); v(r)=x(i); call print('This reverses x',v); call print(i); xa=matrix(3,1:); xa(,1)=x(i); call print(xa); xabase(,1)=x; call print(xabase); xb=matrix(3,3:); xb1(i,1)=x(i); call print('X is now in col 1',xb1); xb2(i,2)=x(i); call print('X is now in col 2',xb2); xc1(1,i)=x(i); call print('X is now in row 1',xc1); xc2(2,i)=x(i); call print('X is now in row 2',xc2); j=integers(3); xb3(j,3)=x(i); call print('Uses i and j pointers',xb3); b34srun; /; == ==SOBJECT5 Using Structured Objects in Programs b34sexec matrix cbuffer=10000; * Shows subscript index working with programs; program prob4; call free(beta) ; beta(1)=-0.04866; beta(2)=1.03884 ; beta(3)=-0.73792; beta(4)=-0.51362; beta=vfam(beta) ; call rgex1; x=matrix(norows(y),3:); i=integers(norows(y)); xx=matrix(norows(y),3:); * Loading with an structured index ; x(i,1)=x1(i) ; x(i,2)=x2(i) ; x(i,3)=x3(i) ; * Loading with a base address. I. e. Copy into a col ; xx(,1)=x1; xx(,2)=x2; xx(,3)=x3; call print(x,xx); nx(i,1)=x1(i) ; nx(i,2)=x2(i) ; nx(i,3)=x3(i) ; nxx(,1)=x1; nxx(,2)=x2; nxx(,3)=x3; call print(nx,nxx); sx(i,1)=x1 ; sx(i,2)=x2 ; sx(i,3)=x3 ; sxx(,1)=x1; sxx(,2)=x2; sxx(,3)=x3; call print(sx,sxx); Call print('Row copy examples'); z=matrix(3,norows(y):); i=integers(norows(y)); zz=matrix(3,norows(y):); * Loading with an structured index ; z(1,i)=x1(i) ; z(2,i)=x2(i) ; z(3,i)=x3(i) ; * Loading with a base address. I. e. Copy into a row ; zz(1,)=x1; zz(2,)=x2; zz(3,)=x3; call print(z,zz); nz(1,i)=x1(i) ; nz(2,i)=x2(i) ; nz(3,i)=x3(i) ; nzz(1,)=x1; nzz(2,)=x2; nzz(3,)=x3; call print(nz,nzz); sz(1,i)=x1 ; sz(2,i)=x2 ; sz(3,i)=x3 ; szz(1,)=x1; szz(2,)=x2; szz(3,)=x3; call print(sz,szz); call print('Copy into a position'); cell(2,2)=x1(3); call print(cell); test=x1(3); call print(test); return; end; program uspopdat; /$ data from sas technical report page 9-2 year=dfloat(integers(179,197)); year=year*10. ; pop=array(:3.929 5.308 7.239 9.638 12.866 17.069 23.191 31.443 39.818 50.155 62.947 75.994 91.972 105.710 122.775 131.669 151.325 179.323 203.211 ); call tabulate(year pop); return; end; program rgex1; /$ loads data from gallant(1987) page 4 * Test comment; t=integers(1,30); y=array(:.98610 1.03848 .95482 1.04184 1.02324 .90475 .96263 1.05026 .98861 1.03437 .98982 1.01214 .66768 .55107 .96822 .98823 .59759 .99418 1.01962 .69163 1.04255 1.04343 .97526 1.04969 .80219 1.01046 .95196 .97658 .50811 .91840 ); x1=array(:1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0); x2=array(norows(x1):); x2=x2+1.; x3=array(:6.28 9.86 9.11 8.43 8.11 1.82 6.58 5.02 6.52 3.75 9.86 7.31 .47 .07 4.07 4.61 .17 6.99 4.39 .39 4.73 9.42 8.9 3.02 .7 3.31 4.51 2.65 .08 6.11); call tabulate(t y x1 x2 x3); return; end; call prob4; b34srun; == ==SOLVE Illustrates use of Formula + Solve b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix solvefree(50); * Shows use of formulas in simple case where ; * Here the analytic statement works same way as formula; * Formula allows resursive solutions ; * Formula solved one row at a time ; * DOUBLE case shows a recursive call ; call loaddata; test1=gasout*2.; formula simple = gasout(t)*2.; solve(test2=simple(t)*2. :range 1,norows(gasout): block simple); formula double = gasout(t)*2. +(.9*double(t-1)); solve(test3=double(t) :range 2, norows(gasout) :block double); call print('Test1 should equal test2/2.':); call print('simple = gasout*2.':); call print('test3 should equal double':); call tabulate(gasout,test1,test2,simple,test3,double); call print(mean(test1),mean(test2/2.)); call names(all); b34srun; == ==SOLVE1 Multiple calls to solve b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; * Formula allows resursive solutions ; * Formula solved one row at a time ; * DOUBLE case shows a recursive call ; * Note that formula set only once outside loop!!! ; call loaddata; formula double = gasout(t)*2. +(.9*double(t-1)); ntest=3; test1=array(ntest:); test2=array(ntest:); do jj=1,ntest; solve(test3=double(t) :range 2, norows(gasout) :block double); test1(jj)=mean(double); test2(jj)=mean(test3); enddo; call print('test1 should equal test2':); call tabulate(test1,test2); call names(all); call tabulate(gasout,double); b34srun; == ==SOLVE2 More complex use of SOLVE with 2 formulas b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; * Illustrates using FORMULA / SOLVE to solve true recursive system; call loaddata; call print(gasout); archvar = array(norows(gasout):); b1=.05; b2=.1 ; b3=.001; a0 = 1.; a1 = .001; formula archvar = a0 + a1*(archvar(t-1)*2.) +rn(1.); formula regresid= gasout(t) - b1 -b2*gasout(t-1) -b3*dsqrt( dabs(archvar(t)) ); call names(all); solve(archlogl = (-.5)*(dlog( dabs(regresid(t)) )+ ( (archvar(t)**2.) /regresid(t) ) ) :range 2, norows(gasout) :block archvar, regresid); call tabulate(gasout,archvar,regresid,archlogl); b34srun; == ==SOLVE3 Direct Recursive Call b34sexec matrix; /$ If N is too big this will blow up test=array(10:); test(1)=.1; b=1.1; formula test = b*test(t-1); solve(ar1=test(t) :range 2 norows(test) :block test); call print(ar1,test); b34srun; == ==SOLVE4 Use of Solve without Formulas b34sexec matrix; n=1000; v=1.0; ar1=array(n:)+missing(); ar1(1)=1.+rn(v); solve(ar1=.90*ar1(t-1)+rn(v):range 2 n); call graph(ar1); b34srun; == ==SOLVE5 Speed Differences SOLVE DO GENARMA - Simple cases b34sexec matrix solvefree(10); /$ If b is too big this will blow up /$ Shows speed differences between DO and solve /$ See solve8 for adjustments to do loop using cleantemp2 /$ solvefree(200) is slower!! /$ solvefree(50) is slower!! /$ Here DO faster than solve if solvefree too large /$ genarma is the correct way to proceed with this problem /$ /$ call compress is used to remove any workspace unused slots /$ so that do gets a fair test /$ n=10000; ar1=array(N:); ar2=ar1; ar1(1)=1.1; ar2(1)=ar1(1); b=.8; /$ call echooff; call timer(base1); /$ next Line tests array problems /$ solve(ar1=b*ar1(t-10)+ rn(b) :range 1, norows(ar1)); solve(ar1=b*ar1(t-1) + rn(b) :range 2, n); call timer(base2); call compress; call timer(base22); call echooff; do i=2,n; ar2(i)=b*ar2(i-1)+rn(b) ; enddo; call timer(base3); call compress; call timer(base33); ar=array(:b); ma=array(:-.5,-.25); start=array(:1.1); ar3=genarma(ar,ma,1.0,start,1.,n); call timer(base4); call print(' For n =',n,'Solve time',base2-base1, 'Do time',base3-base22, 'Genarma time',base4-base33); call graph(ar1,ar2,ar3); /$ call print(ar1); b34srun; == ==SOLVE6 Do vs SOLVE / FORMULA -- Complex Case b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix solvefree(50); * Illustrates using FORMULA / SOLVE to solve true recursive system; /$ Speed tests done /$ Problem validates accuracy call loaddata; call print(gasout); j=norows(gasout); /$ j=10; archvar = array(j:); regresid= array(j:); archlogl= array(j:); archvar2= array(j:); regresi2= array(j:); archlog2= array(j:); b1=.05; b2=.1 ; b3=.001; a0 = 1.; a1 = .001; i=2; call echooff; call timer(base1); formula archvar = a0 + a1*(archvar(t-1)*2.) ; formula regresid= gasout(t) - b1 -b2*gasout(t-1) -b3*dsqrt( dabs(archvar(t)) ); solve(archlogl = (-.5)*(dlog( dabs(regresid(t)) )+ ( (archvar(t)**2.) /regresid(t) ) ) /$ :range i norows(gasout) /$ :range i j :range i j /$ :range i , norows(gasout) :block archvar regresid); call timer(base2); call compress; /$ call names(all); /$ use of solvefree illustrated call timer(base22); do ii=i,j; call solvefree(:alttemp); archvar2(ii)= a0 + a1*(archvar2(ii-1)*2.) ; regresi2(ii)= gasout(ii) - b1 -b2*gasout(ii-1) -b3*dsqrt( dabs(archvar2(ii)) ); archlog2(ii)= (-.5)*(dlog( dabs(regresi2(ii)) )+ ( (archvar2(ii)**2.) /regresi2(ii) ) ) ; call solvefree(:cleantemp); enddo; call timer(base3); call print('SOLVE Time',(base2-base1),'Do time',(base3-base22) 'Gain of SOLVE ',((base3-base22)/(base2-base1)) ); call tabulate(gasout,archvar, regresid, archlogl, archvar2,regresi2, archlog2); call print('Tests Vectors Produced for Accuracy', mean(archvar), mean(regresid), mean(archlogl), mean(archvar2),mean(regresi2), mean(archlog2)); call names(all); b34srun; == ==SOLVE7 Generate AR(1) Model b34sexec matrix ; * Generate ar(1) model; g(1)=1.; theta= .97; vv = 10. ; formula jj=g(t-1)*theta+vv*rn(1.); solve(g=jj(t) :range 2 300 :block jj); call graph(g :heading 'AR(1) process'); call print(g); call autobj(g :print :nac 24 :npac 24 :nodif :autobuild ); b34srun; == ==SOLVE8 Illustrates cleantemp2 b34sexec matrix ; /$ If N is too big this will blow up /$ Tests speed of calculations. Set n for tests n=20000; ar1=array(N:); test=array(10:); test(1)=.1; test(2)=.99; b=1.1; call timer(base1); /$ solve(ar1=2.*test(t) :range 1, norows(test)); /$ solve(ar1=2.*test(t) :range norows(test)-9, norows(test)); /$ solve(ar1=2.*test(t-1) :range 2, 10); solve(ar1=2.*b :range 2, n); call timer(base2); call echooff; call compress; call timer(base22); do i=1,n; call solvefree(:alttemp); ar1(i)=2.*b; call solvefree(:cleantemp2); enddo; /$ /$ put back in ## mode since used cleantemp2 /$ call solvefree(:print); call solvefree(:cleantemp); call solvefree(:print); call timer(base3); call setcol(ar1,1,2.*b); call timer(base4); call print('Speed differences between SOLVE, Do Loop and Setcol', 'solve ',base2-base1,'do loop ',base3-base22,' Eq ', base4-base3); call names; b34srun; == ==SOLVEFREE Cases where SOLVEFREE does not seem to matter b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; * Shows use of formulas in simple case where ; * Here the analytic statement works same way as formula; * Formula allows resursive solutions ; * Formula solved one row at a time ; * DOUBLE case shows a recursive call ; call loaddata; call echooff; test3=gasout*2.; double=test3; call solvefree(:print); * simple case -- should not use the solve facility ; formula double = gasout(t); ii=1; call solvefree(ii); call timer(start); solve(test3=double(t) :range 2, norows(gasout) :block double); call timer(end); call print('Given solvefree = ',ii,' time was ',end-start); ii=1000; call solvefree(ii); call timer(start); solve(test3=double(t) :range 2, norows(gasout) :block double); call timer(end); call print('Given solvefree = ',ii,' time was ',end-start); * More complex case -- need solve facility ; formula double = gasout(t)*2. +(.9*double(t-1)); ii=1; call solvefree(ii); call timer(start); solve(test3=double(t) :range 2, norows(gasout) :block double); call timer(end); call print('Given solvefree = ',ii,' time was ',end-start); ii=1000; call solvefree(ii); call timer(start); solve(test3=double(t) :range 2, norows(gasout) :block double); call timer(end); call print('Given solvefree = ',ii,' time was ',end-start); b34srun; == ==SOLVEFREE1 Test cases using GARCH b34sexec options ginclude('b34sdata.mac') macro(bg_test1); b34srun; /$ Jobs in order %b34slet garcht=1 ; %b34slet dorats=1 ; %b34slet dotest=1 ; %b34slet solvet=1 ; %b34slet garchest=1; /$ /$ Speeds on Dell Laptop 1000 GH /$ /$ GARCHEST 6.040 /$ GARCH 6.639 /$ DO 2597.880 /$ SOLVE 1152.210 /$ /$ As N increases "cost" of Do and Solve /$ increase /$ /$ b34sexec options debugsubs(byplin); b34srun; /$ /$ Set dorats=1 to run RATS on the test problem /$ /$ Test problem discussed in "Benchmarks and Software Standards: a /$ Case study of GARCH procedures" McCullouch & Renfro /$ Journal of Economic and Social Measurement 25 (1998) 59-71 /$ /$ Benchmark values (coef & t) reported in Greene (2003) Page 245 /$ /$ mu a(0) a(1) delta /$ -.006190 .01076 .1531 .8060 /$ -.709 3.445 5.605 26.731 /$ /$ B34S Gets /$ /$ Constrained Maximum Likelihood Estimation using CMAXF2 Command /$ Final Functional Value 710.0988738779154 /$ # of parameters 4 /$ # of good digits in function 15 /$ # of iterations 33 /$ # of function evaluations 49 /$ # of gradiant evaluations 35 /$ Scaled Gradient Tolerance 6.055454452393343E-06 /$ Scaled Step Tolerance 3.666852862501036E-11 /$ Relative Function Tolerance 3.666852862501036E-11 /$ False Convergence Tolerance 2.220446049250313E-14 /$ Maximum allowable step size 2000.000000000000 /$ Size of Initial Trust region -1.000000000000000 /$ /$ # Name Coefficient Standard Error T Value /$ 1 MU -0.54028321E-02 0.78671320E-02 -0.68676007 /$ 2 A0 0.96955352E-02 0.19582736E-02 4.9510627 /$ 3 A1 0.14249617 0.20587446E-01 6.9215077 /$ 4 B1 0.82057943 0.23642897E-01 34.707228 /$ /$ Rats gets /$ /$ MAXIMIZE - Estimation by BHHH /$ Convergence in 23 Iterations. /$ Usable Observations 1973 /$ Function Value 710.20954834 /$ /$ Variable Coeff Std Error T-Stat Signif /$ ************************************************************** /$ 1. MU -0.005405453 0.008378648 -0.64515 0.51883241 /$ 2. A0 0.009737295 0.001209136 8.05310 0.00000000 /$ 3. A1 0.143009440 0.012892918 11.09209 0.00000000 /$ 4. B1 0.819965321 0.015312307 53.54943 0.00000000 /$ /$ /$ Has Do loop, GARCH implementation /$ Do loop runs very very slowly /$ solve look some what better /$ garchest is the fastest. /$ %b34sif(&garcht.ne.0)%then; b34sexec matrix ; call loaddata; count=0.0; j=norows(returns); arch = array(j:); res = array(j:); archlog= array(j:); * one and pfive are inplace constants. Make code run faster; one=1; pfive=.5; smu=mean(returns); svar=variance(returns-smu); /$ Set starting value for h(1) if ne 0.0 /$ arch= arch+1.; /$ arch= arch+ (sumsq(returns-smu)/dfloat(j)); call echooff; program test; func=0.0; count=count+1.0; res=returns-mu; call garch(res,arch,returns,func,1,n :gar array(:b1) idint(array(:1)) :gma array(:a1) idint(array(:1)) :constant array(:mu a0) ); /$ call print(func,count); call outstring(4,3,'F count mu a0 a1 b1'); call outdouble(34,3,func); call outdouble(54,3,count); call outdouble(4, 4, mu); call outdouble(24,4, a0); call outdouble(44,4, a1); call outdouble( 4,5, b1); * call print(func mu a0 a1 b1); return; end; call print(test); /$ /$ tests starting values /$ call timer(base1); call cmaxf2(func :name test :parms mu a0 a1 b1 /$ These are benchmark starting values. /$ :ivalue array(:-.016427, .221130, .35,.50) :ivalue array(:smu, svar .01 .5) :maxit 9000 /$ :gradtol .1d-07 /$ :steptol .1d-12 :lower array(:-10., .1d-2, .1d-2, .1d-2) :upper array(: 10. 10. 10. 10. ) :print); call timer(base2); tt=base2-base1; call print('Time for GARCH approach was ',tt:); call print(sumsq(goodrow(res))); * call tabulate(res,arch); * Two pass method ; fixedet=(returns-mean(returns))*(returns-mean(returns)); call arma(fixedet :maxit 2000 :relerr 0.0 :nar 1 :nma 1 :print); b34srun; %b34sendif; /$ /$ BHHH & BFGS methods used .. residuals set to 0 for beginning obs /$ %b34sif(&dorats.ne.0)%then; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = returns compute iter = 100,isiter=100 * * garch(1,1) * smpl(series=seriesn) set u11 = 0.0 set v11 = 0.0 nonlin mu a0 a1 b1 * frml regresid = seriesn-mu frml garchvar = a0+a1*u11{1}**2+b1*v11{1} frml regresid = seriesn-mu frml garchlogl = v11(t)=garchvar(t),u11(t)=regresid(t),$ -.5*(log(v11)+u11**2/v11) * bhhh method linreg seriesn # constant * Simplex can be used to start process compute mu=%beta(1), b1=.01, a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bhhh,recursive,iterations=iter) garchlogl 2 * * bfgs Method linreg seriesn # constant * Simplex can be used to start process compute mu=%beta(1), b1=.01, a0=%seesq,a1=.05 display %seesq compute beta1=0.0 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) garchlogl 2 * maximize(method=bfgs,recursive,iterations=iter) garchlogl 2 * b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ %b34sendif; /$ Do test Runs slowly %b34sif(&dotest.ne.0)%then; /$ /$ This approach runs very very slowly!! /$ b34sexec matrix ; call loaddata; count=0.0; j=norows(returns); arch = array(j:); res = array(j:); archlog= array(j:); * one and pfive are inplace constants. Make code run faster; one=1; pfive=.5; smu=mean(returns); svar=variance(returns-smu); /$ Set starting value for h(1) if ne 0.0 /$ arch= arch+1.; /$ arch= arch+ (sumsq(returns-smu)/dfloat(j)); call echooff; program test; func=0.0; count=count+1.0; /$ Uncomment do loop and comment call garch to switch /$ mode of running res=returns-mu; do i=2,j; arch(i)=a0+a1*(res(i-one)*res(i-one))+b1*arch(i-one); func=func-(pfive*mlsum(arch(i)))-(pfive*((res(i)*res(i))/arch(i))); enddo; /$ /$ adjusting h(1) /$ if(count.gt.1.)then; arch(1)=0.0; /$arch(1)=(sumsq(res)-(res(1)*res(1)))/dfloat(j-1); endif; /$ /$ Using built in garch subroutine results in faster code call outstring(4,3,'F count mu a0 a1 b1'); call outdouble(34,3,func); call outdouble(54,3,count); call outdouble(4, 4, mu); call outdouble(24,4, a0); call outdouble(44,4, a1); call outdouble( 4,5, b1); * call print(func mu a0 a1 b1); return; end; call print(test); /$ /$ tests starting values /$ call timer(base1); call cmaxf2(func :name test :parms mu a0 a1 b1 /$ These are benchmark starting values. /$ :ivalue array(:-.016427, .221130, .35,.50) :ivalue array(:smu, svar .01 .5) :maxit 9000 /$ :gradtol .1d-07 /$ :steptol .1d-12 :lower array(:-10., .1d-2, .1d-2, .1d-2) :upper array(: 10. 10. 10. 10. ) :print); call timer(base2); tt=base2-base1; call print('Time for DO approach was ',tt:); b34srun; %b34sendif; /$ Solve test %b34sif(&solvet.ne.0)%then; b34sexec matrix ; call solvefree(1); call loaddata; count=0.0; j=norows(returns); arch = array(j:); res = array(j:); archlog= array(j:); * one and mpfive are inplace constants. Make code run faster; one=1; mpfive=-.5; two=2.; smu=mean(returns); mu=smu; svar=variance(returns-smu); /$ Set starting value for h(1) if ne 0.0 /$ arch= arch+1.; /$ arch= arch+ (sumsq(returns-smu)/dfloat(j)); /$ call echooff; /$ Note we use formula only for recursive part regresid= returns-mu; formula archvar = a0 + a1*(regresid(t-one)**2.) + b1* archvar(t-one) ; call echooff; program test; regresid=returns-mu; solve(archlogl = mpfive*(dlog( dabs(archvar(t)) )+ ( (regresid(t)**two)/archvar(t) ) ) :range 2, norows(returns) :block archvar); func=0.0; count=count+1.0; func=sum(archlogl); /$ call print(func,count); call outstring(4,3,'F count mu a0 a1 b1'); call outdouble(34,3,func); call outdouble(54,3,count); call outdouble(4, 4, mu); call outdouble(24,4, a0); call outdouble(44,4, a1); call outdouble( 4,5, b1); * call print(func mu a0 a1 b1); return; end; /$ /$ tests starting values /$ call timer(base1); call cmaxf2(func :name test :parms mu a0 a1 b1 /$ These are benchmark starting values. /$ :ivalue array(:-.016427, .221130, .35,.50) :ivalue array(:smu, svar .01 .5) :maxit 9000 /$ :gradtol .1d-07 /$ :steptol .1d-12 :lower array(:-10., .1d-2, .1d-2, .1d-2) :upper array(: 10. 10. 10. 10. ) :print); call timer(base2); tt=base2-base1; call print('Time for SOLVE/FORMULA approach was ',tt:); b34srun; %b34sendif; %b34sif(&garchest.ne.0)%then; b34sexec matrix ; call loaddata; res=array(norows(returns):); arch=res; smu=mean(returns); svar=variance(returns-smu); call timer(base1); call garchest(res,arch,returns,func,1,nbad :ngar 1 :garparms array(:.5) :ngma 1 :gmaparms array(:.01) :lower array(:.1d-2, .1d-2, -10. .1d-2) :upper array(: 10. 10. 10. 10.) :simplex :print2 :maxit2 1000 :cparms array(2:smu svar) :print); call timer(base2); tt=base2-base1; call print('Time for GARCHEST approach was ',tt:); call tabulate(%resobs,res,arch); call graph(goodrow(res)); call graph(goodrow(arch)); b34srun; %b34sendif; == ==SOLVEFREE2 Advanced SOLVEFREE Options b34sexec matrix; /$ /$ illustrates advanced solvefree options /$ n=10; ar1=array(N:); ar2=ar1; ar1(1)=1.1; ar2(1)=ar1(1); b=.8; call timer(base1); solve(ar1=b*ar1(t-1) + rn(b) :range 2, n); call timer(base2); call solvefree(:print); do i=2,n; call solvefree(:alttemp); call print('after l'); call solvefree(:print); ar2(i)=b*ar2(i-1)+rn(b) ; call solvefree(:cleantemp); call solvefree(:print); call solvefree(i ); enddo; call timer(base3); ar=array(:b); ma=array(:-.5,-.25); start=array(:1.1); ar3=genarma(ar,ma,1.0,start,1.,n); call timer(base4); call print(' For n =',n,'Solve time',base2-base1, 'Do time',base3-base2, 'Genarma time',base4-base3); call graph(ar1,ar2,ar3); /$ call print(ar1); call solvefree(:gettemp ii); call print(ii); call solvefree(:alttemp); call solvefree(:gettemp ii); call print(ii); call solvefree(:basetemp); call solvefree(:gettemp ii); call print(ii); b34srun; == ==SORT SORT command on real*8 and Character Data b34sexec matrix; n=10; x=rn(array(n:)); sx=x; call sort(x); call tabulate(x,sx); n=namelist(:sue ann bobby houston); cn=n; call sort(cn); call tabulate(n,cn); call character(cc,'abcd12343210'); cc2=c1array(12,1:cc); call print(cc,cc2); call vocab(cb); ccb=cb; call sort(ccb); call print(cb,ccb); cfb=vocab(); ccfb=cfb; call sort(ccfb); call print(cfb,ccfb); b34srun; == ==SPACING Absolute spacing near a given Number b34sexec matrix; i=1; i8=i4toi8(i); x=1.; x16=r8tor16(x); y=sngl(x); call print('Largest integer*4 ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Largest real*16 ',huge(x16):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Smallest real*16 ',tiny(x16):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); call print('Epsilon real*16 ',epsilon(x16):); call print('Precision real*4 ',precision(y):); call print('Precision real*8 ',precision(x):); call print('Precision real*16 ',precision(x16):); x=.1d+00; x16=r8tor16(x); y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; x16=x16*r8tor16(dfloat(i)); spx(j) =spacing(x); spy(j) =spacing(y); spx16(j) =spacing(x16); nearpr8(j) =nearest(x, 1.); nearmr8(j) =nearest(x,-1.); nearpr16(j)=nearest(x16, r8tor16(1.)); nearmr16(j)=nearest(x16,r8tor16(-1.)); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8, Real*16 and Real*4'); call tabulate(testnum,spx,spy,spx16,nearpr8, nearmr8,nearpr4,nearmr4 nearpr16,nearmr16); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; == ==SPECFORE Forecast using Spectral Methods %b34slet domatlab = 0; %b34slet dorats = 0; %b34slet dob34s1 = 1; %b34slet file1="'_b34sdat.dat'"$ %b34slet file2="'b34sdata.m'"$ b34sexec options ginclude('b34sdata.mac') member(lydiapnm); b34srun; /$ user places RATS commands between /$ PGMCARDS$ /$ note: user RATS commands here /$ B34SRETURN$ /$ %b34sif(&dob34s1.ne.0)%then; b34sexec matrix; call echooff; call loaddata; call load(specfore); call print(' ':); call print('Forecast of sales and Advertising':); nfor=30; base=60; call specfore(sales, base,nfor,0,fsales1,obs,error1,actual1); call specfore(sales, base,nfor,2,fsales2,obs,error2,actual2); call specfore(advertis,base,nfor,0,fadd1,obs,error3,actual3); call specfore(advertis,base,nfor,2,fadd2,obs,error4,actual4); call print(' ':); call print('With out Trend Correction':); call tabulate(obs,actual1,fsales1,error1,actual3,fadd1,error3); call print('With Trend Correction':); call tabulate(obs,actual2,fsales2,error2,actual4,fadd2,error3); nn=integers(norows(actual1)); obs = obs(nn); fsales1=fsales1(nn); fsales2=fsales2(nn); nn=integers(norows(actual3)); fadd1 =fadd1(nn); fadd2 =fadd2(nn); call tabulate(obs actual1,fsales1 fsales2 ); call graph(obs actual1,fsales1 fsales2 :plottype xyplot :heading 'Sales Forecast out of sample # 2 with trend' :nolabel :nocontact :pgborder); call graph(obs actual3 fadd1 fadd2 :plottype xyplot :heading 'Advertis Forecast out of sample notrend # 2 with trend' :nolabel :nocontact :pgborder); cc1=ccf(fsales1,actual1); cc2=ccf(fsales2,actual2); cc3=ccf(fadd1,actual3); cc4=ccf(fadd2,actual4); ss1=sumsq(error1); ss2=sumsq(error2); ss3=sumsq(error3); ss4=sumsq(error4); call print(' ':); call print('Out of sample sales no trend sumsq ',ss1:); call print('Out of sample sales with trend sumsq ',ss2:); call print('Out of sample advertis no trend sumsq ',ss3:); call print('Out of sample sales with trend sumsq ',ss4:); call print('Out of sample sales forecast no trend correlation ',cc1:); call print('Out of sample sales forecast with trend correlation ',cc2:); call print('Out of sample adver forecast no trend correlation ',cc3:); call print('Out of sample adver forecast with trend correlation ',cc4:); b34srun; %b34sendif; %b34sif(&dorats.ne.0)%then; B34SEXEC OPTIONS OPEN('rats.dat') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * * see section 7.5 in RATS manual * Source(NOECHO) d:\R\specfore.src * SOURCE(ECHO) d:\R\specfore.src SET SERIES = sales COMPUTE istart = 60 COMPUTE iend = 90 * * @SPECFORE( options ) series start end forecasts * Computes forecasts using spectral techniques * * Parameters: * series : (input) Series to be forecast * start end : Range of entries to forecast * forecasts : (output) Series for computed forecasts * @SPECFORE(DIFFS=0,SDIFFS=0,TRANS=NONE,CONSTANT) SERIES ISTART IEND FORE SET ERROR = SERIES - FORE PRINT istart iend SERIES FORE ERROR B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(28)$ B34SRUN$ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ B34SEXEC OPTIONS /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; %b34sif(&domatlab.ne.0)%then; /$ /$ Builds a MATLAB input file for MATLAB version 6. /$ Changes made 2 February 2002 /$ /$ Since MATLAB is case sensitive, use lower case for all variable /$ references that are from b34s. MATLAB users upper case for a matrix /$ variable /$ /$ This job assumes user has already loaded data in B34S /$ The file name for file1 is hard coded in the matlab m file (file2) /$ /$ User changes this to default matlab file directory /$ /$ /$ Job runs on linux matlab and windows matlab /$ /$ When job ends, output will be seen in b34s.out file /$ /$ User loads data here if it has not occured already /$ b34sexec options open(%b34seval(&file1)) unit(28) disp=unknown$ b34seend$ b34sexec options clean(28)$ b34seend$ b34sexec options open(%b34seval(&file2)) unit(29) disp=unknown$ b34seend$ b34sexec options clean(29)$ b34seend$ b34sexec pgmcall$ matlab lowercase outfile(%b34seval(&file1))$ pgmcards$ % User MATLAB commands here such as plot(varname) % x1=test(sales,60,2,1,1); x1=specfore(sales,60,10,1,1); % quit is needed since have to get out of matlab automatically % Comment to stay in matlab and see plot b34sreturn$ b34seend$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dodos('matlab /r b34sdata /logfile matlab.out') dounix('matlab < b34sdata.m > matlab.out'); b34srun; b34sexec options dos('pause'); b34srun; b34sexec options writeout(' ', 'Output from Matlab ', ' '); b34srun; b34sexec options copyfout('matlab.out'); b34srun; b34sexec options dodos('erase matlab.out') dounix('rm matlab.out'); b34srun; %b34sendif; == ==SPECTRAL Call SPECTRAL Command => Advanced spectral Analysis b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call spectral(gasin,sinx,cosx,px,sx,freq); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call tabulate(freq freq2 period sinx cosx px sx); call spectral(gasin,sinx,cosx,px,sx,freq:1 2 3 2 1); call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of Gasin' :plottype xyplot); count=dfloat(integers(norows(gasin)))-1.; /; Test 100% recovery of actual value test=vector(norows(gasin):); do i=1,296; sum1=sinx*sin(count(i)*freq); sum2=cosx*cos(count(i)*freq); test(i)=sum1+sum2; enddo; adj=mean(gasin); call print('Constant ',adj:); adjtest=afam(test)+adj; call tabulate(gasin,test,adjtest); call olsq(gasin test :print); call olsq(gasin adjtest :print); ls_var=.5*(sumsq(sinx)+sumsq(cosx)); ss_var=ls_var *(dfloat(norows(gasin))/dfloat(norows(gasin)-1)); call print(' ':); call print('Large Sample Variance ',ls_var:); call print('Small Sample Variance ',ss_var:); b34srun; == ==SPECTRUM SPECTRUM Function => Spectral Analysis of 1 series b34sexec options ginclude('gas.b34'); b34srun; /$ /$ Job tests various options in calling spectrum function /$ b34sexec matrix; call loaddata; p1=spectrum(gasin); p =spectrum(gasin,freq); p2=spectrum(gasin,freq2:1 2 3 4 3 2 1); s =spectrum(gasin :1 2 3 4 3 2 1); call names(all); call tabulate(p1,p,freq,freq2,p2,s); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call tabulate(freq,freq2,period,p,s); call graph(freq2,p s:heading 'Periodogram and Spectrum of Gasin' :plottype xyplot); call graph(freq2,p:heading 'Periodogram of Gasin' :plottype xyplot); call graph(freq2,s:heading 'Spectrum of Gasin' :plottype xyplot); call graph(freq2,spectrum(gasin:1 4 1), spectrum(gasin:1 1 1) spectrum(gasin:1 1 1 1 1 1 1) :heading 'Effect of Weighting on Spectrum' :plottype xyplot); b34srun$ == ==STATAIO Read and write Stata *.dct files b34sexec data nohead noob=6$ input x y z$ label x = 'x variable'; label y = 'y variable'; label z = 'z variable'; datacards$ 11 33 55 22 99 99 33 23 14 01 44 88 01 33 77 22 24 25 b34sreturn$ b34srun$ b34sexec matrix; call loaddata; nomat=1; if(nomat.eq.0)call stataio(x y z :writefile 't.dct' :heading 'x y z test file'); if(nomat.ne.0)then; n=10; k=7; xmat=rn(matrix(n,k:)); call print(xmat); call stataio(xmat :writefile 't.dct' :heading 'Matrix file test'); endif; call stataio(:info 't.dct'); /; test read call stataio(:readfile 't.dct'); call names; call tabulate(x,y,z); b34srun; b34sexec stataio writestata file('mydata.dct'); /; var x y; b34srun; /; b34sexec options copyfout('mydata.mad'); b34srun; /; b34sexec options copyfout('mydata.dct'); b34srun; b34sexec stataio readstata file('mydata.dct'); b34srun; b34sexec options include('b34sdata.b34'); b34srun; b34sexec data $ input name number phone room start$ character name$ datacards$ Rebeccah 11 424 112 1 Carol 4 450 112 2 Louise 9 409 110 3 Gina 6 474 110 4 Mimi 10 410 109 5 Alice 1 411 106 6 Brenda 3 414 105 7 David 5 438 141 8 Betty 2 464 141 9 Holly 8 466 140 10 Gretel 7 465 140 11 b34sreturn$ b34srun$ b34sexec stataio writestata file('mydata.dct') heading('Character dsn'); b34srun; b34sexec options copyfout('mydata.dct'); b34srun; b34sexec stataio readstata file( 'mydata.dct') b34sfile('b34sdata2.b34'); b34srun; b34sexec options include('b34sdata2.b34'); b34srun; b34sexec list; b34srun; b34sexec matrix; call stataio(:info 'mydata.dct'); call stataio(:readfile 'mydata.dct'); call names; call tabulate(name number phone room start); b34srun; == ==STATA1_A Stata Probit Model using MAXF1 b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 1 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ b34sexec probit; model foreign = mpg weight; b34srun; b34sexec matrix; * This test run tests both command maxf1 ; * Uses mlsum to avoid problems ; call loaddata; theta=array(norows(foreign):); func=-10.d+32; mask1=array(norows(foreign):); mask2=mask1+1.; mask0=mask1; where(foreign.eq.1.0)mask1=mask2; where(foreign.eq.0.0)mask0=-1.0*mask2; program test; theta=(a+b1*mpg+b2*weight); add=probnorm(mask0*theta+mask1*theta); func=mlsum(add); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4, 5, b2); return; end; call print(test); call olsq(foreign mpg weight: print); call print(%coef); rvec=array(3:%coef(3),%coef(1),%coef(2)); /$ rvec=array(3:8.2,-.1,-.002) ; call echooff; call maxf1(func :name test :parms a b1 b2 :ivalue rvec :print); b34srun; == ==STATA1_B Stata Probit Model using maxf2 b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 1 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ b34sexec probit; model foreign = mpg weight; b34srun; b34sexec matrix; * This test run tests both command maxf2 ; * Uses mlsum to avoid problems ; call loaddata; theta=array(norows(foreign):); func=-10.d+32; mask1=array(norows(foreign):); mask2=mask1+1.; mask0=mask1; where(foreign.eq.1.0)mask1=mask2; where(foreign.eq.0.0)mask0=-1.0*mask2; program test; theta=(a+b1*mpg+b2*weight); add=probnorm(mask0*theta+mask1*theta); func=mlsum(add); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4, 5, b2); return; end; call print(test); call olsq(foreign mpg weight: print); call print(%coef); rvec=array(3:%coef(3),%coef(1),%coef(2)); /$ rvec=array(3:8.2,-.1,-.002) ; call echooff; call maxf2(func :name test :parms a b1 b2 :ivalue rvec :print); b34srun; == ==STATA1_C Testing of B34S / RATS b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 1 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ /$ /$ Look at Model with Rats /$ b34sexec probit; model foreign = weight mpg; b34srun; b34sexec loglin; model foreign = weight mpg; b34srun; B34SEXEC OPTIONS OPEN('RATS.DAT') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL inlist(mpg,weight,foreign)$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * smpl(series=mpg) * Rats Test of Logistic and Probit Models for Stata problem prbt foreign # constant weight mpg lgt foreign # constant weight mpg b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('Output from RATS',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ == ==STATA2_A Stata Two Equation Example Model using MAXF2 b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 25 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ b34sexec matrix; * This test run tests both command maxf1 ; * Uses mlsum to avoid problems ; call loaddata; theta=array(norows(foreign):); func=-10.d+32; program test; theta=normden((mpg-(a+b1*weight+b2*displ))/sigma); func=mlsum(theta)- mlsum(sigma); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4, 5, b2); call outdouble(36,5, sigma); return; end; call print(test); call olsq(mpg weight displ :print); call print(%coef); * We start from a long ways away. Sigma has been started as; * relatively large to help convergence ; rvec=array(4:.1 .1 .1 10.0); ll= array(4:-10000., -10000., -10000., .01 ); uu= array(4: 10000., 10000., 10000., 10000.); call echooff; call maxf2(func :name test :parms a b1 b2 sigma :ivalue rvec :maxsteps 10. :maxit 4000 :print); call print('Converting Sigma ',dlog(sigma)); b34srun; == ==STATA2_B Stata Two Equation Example Model using CMAXF2 b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 25 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ b34sexec matrix; * This test run tests both command maxf1 ; * Uses mlsum to avoid problems ; call loaddata; theta=array(norows(foreign):); func=-10.d+32; program test; theta=normden((mpg-(a+b1*weight+b2*displ))/sigma); func=mlsum(theta)- mlsum(sigma); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4, 5, b2); call outdouble(36,5, sigma); return; end; call print(test); call olsq(mpg weight displ :print); call print(%coef); rvec=array(4:.1 .1 .1 10.0); ll= array(4:-10000., -10000., -10000., .01 ); uu= array(4: 10000., 10000., 10000., 10000.); * We start from a long ways away. Sigma has been started as; * relatively large to help convergence ; call echooff; call cmaxf2(func :name test :parms a b1 b2 sigma :ivalue rvec :maxit 4000 :maxfun 4000 :maxg 4000 :maxsteps 10. :lower ll :upper uu :print); call print('Converting Sigma ',dlog(sigma)); b34srun; == ==STATA2_C Testing of B34S / RATS b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 25 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ /$ Test case illustrates danger of allowing RATS to /$ drop observations ****************************** /$ Do not get even OLS result!!!! /$ b34sexec matrix; * This test run tests both command maxf2; * Uses mlsum to avoid problems ; call loaddata; theta=array(norows(foreign):); func=-10.d+32; program test; theta=normden((mpg-(a + b1*weight + b2*displ)) / sigma); func=mlsum(theta,drop) - mlsum(sigma,drop2); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4, 5, b2); call outdouble(36,5, sigma); return; end; call print(test); call olsq(mpg weight displ :print); call print(%coef); * We start from a long ways away. Sigma has been started as; * relatively large to help convergence ; rvec=array(4:.1 .1 .1 10.); * These values need for RATS and not needed here ; * rvec=array(4:.1 .1 .1 100.0); call echooff; call maxf2(func :name test :parms a b1 b2 sigma :ivalue rvec :maxsteps 10. :maxit 4000 :print); call print(sigma,'log(sigma)', dlog(%coef(4))); call print(drop); b34srun; /$ Look at Model with Rats /$ B34SEXEC OPTIONS OPEN('RATS.DAT') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL inlist(mpg,weight,displ)$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * COMPUTE ITER = 10000,ISITER=1000 * smpl(series=mpg) nonlin b0 b1 b2 sigma frml theta = (mpg - b0 - b1*weight-b2*displ)/sigma frml archlogl = (log(%density(theta))-log(sigma)) linreg mpg # constant weight displ * If we set sigma to 10. we drop observations and these are never * put back. Results are NOT correct. B34s tries to put observations * back. So does stata * compute b0=.1,b1..1,b2-.1,sigma=10. compute b0=.1,b1=.1,b2=.1,sigma=100. nlpar(subiterations=isiter) maximize(method=bhhh,iterations=iter) archlogl 1 * b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('Output from RATS',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ b34srun$ == ==STEPWISE_1 BESTREG and STEPWISE Problem 1 b34sexec options ginclude('b34sdata.mac') member(draper_s_b); b34srun; b34sexec matrix; call loaddata; iprint2=0; call olsq(y x1 x2 x3 x4 :print); call stepwise(y x1 x2 x3 x4 :print :printsteps); if(iprint2.ne.0) call print( %means %nvar %cov %scale %hist %iend %aov %coef %swept ); call bestreg (y x1 x2 x3 x4 :print); if(iprint2.ne.0) call print(%cov, %nvar, %nsize, %nbest, %ngood, %means, %ivarx, %crit, %ivarx, %indvar, %icoefx, %ntbest, %coef ); call print('Using Criterion of Adjusted R^2 ':); call print('_______________________________ ':); call bestreg (y x1 x2 x3 x4 :crit 2 :print ); call print('Using Criterion of Mallows C(p) ':); call print('_______________________________ ':); call bestreg (y x1 x2 x3 x4 :crit 3 :print ); call print('Using Criterion of Adjusted R^2 but limited to 3':); call print('_______________________________ ':); /; Note: :crit -3 will attampt a math operation. The function sfam( ) /; forces generation of a temp call bestreg (y x1 x2 x3 x4 :crit sfam(-3) :print); /; /; Get different result depending on if :forward or :backward /; call stepwise(y x1 x2 x3 x4 :backward :printsteps :print); b34srun; == ==STEPWISE_2 BESTREG and STEPWISE Problem 2 /; Looks at a way too big problem b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; nlag=20; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call stepwise(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call bestreg(gasout gasout{1 to nlag} gasin{1 to nlag} :print); b34srun; == ==STEPWISE_3 Illustrates Various stepwise options /; Illustrates Various stepwise options b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; nlag=6; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call stepwise(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call stepwise(gasout gasout{1 to nlag} gasin{1 to nlag} :print :printsteps); call stepwise(gasout gasout{1 to nlag} gasin{1 to nlag} :backward :print); call stepwise(gasout gasout{1 to nlag} gasin{1 to nlag} :forward :print); call bestreg(gasout gasout{1 to nlag} gasin{1 to nlag} :print :iprint :iprint_cov); b34srun; == ==STEPWISE_4 BESTREG and STEPWISE Problem 2 /; Way too big a problem b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; nlag=20; call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call stepwise(gasout gasout{1 to nlag} gasin{1 to nlag} :print); call bestreg(gasout gasout{1 to nlag} gasin{1 to nlag} :print); b34srun; == ==STOP1 Call STOP => Program ends b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; p1=spectrum(gasin); p=spectrum(gasin,freq); call names(all); call tabulate(p1,p,freq); s=spectrum(gasin:1 2 3 4 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call tabulate(freq,freq2,period,p,s); call graph(freq2,p s:heading 'Periodogram and Spectrum of Gasin' :plottype xyplot); call stop; b34srun; == ==STOP2 Call STOP(PAUSE) => Program in a wait state b34sexec matrix; x=matrix(3,3:11 22 33 55 66 77 88 99 00); v=vector(3:1 2 3); call print(x,v); inv=(1./x); call print(inv); test=x*inv; call print(test); vx=v*x; call print(vx); xx=x*x; call print(xx); xv=x*v; call print(xv); call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); call outstring(3,3,'This is jj'); call outinteger(30,3,jj); call cls(4); call outstring(3,4,'This is 5'); call outinteger(30,4,5 ); call cls(5); call outstring(3,5,'This is 88.88!!'); call outdouble(40,5,88.8); call cls(6); call outstring(3,6,'We have paused!! Now hit enter.'); /$ This is a pause call stop(pause); b34srun; == ==STOP3 Call stop(RETURN); Program returns to base mode b34sexec matrix; x=array(:1 2 3 4 5 6 7 8); call print('At base level (root)'); subroutine one(x); call print('In one. X was ',x); call two(x); call print('In one. Should not see this'); return; end; subroutine two(x); call print('In two. X was ',x); call three(x); call print('In two. Should not see this'); return; end; subroutine three(x); call print('In three. X was ',x); call stop(return); call print('In three. Should not see this'); return; end; call print(one,two,three); call one(x); call print('Back at base level (root).'); b34srun; == ==ST_RES Structural Residual 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=6; nterms=10; x=catcol(gasin,gasout); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call tabulate(varx,varxhat,rsq); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); call print('VAR Residual and Structural Residual':); call st_res(residual,sigma,finv,sres); testres=transpose(finv*transpose(residual)); testres2=residual*transpose(finv); /; test calculatuion call print(residual,sigma,sres,testres,testres2); call print('Is the covariance matrix diagonal?':); call print(transpose(testres) *testres ); call print(transpose(testres2)*testres2); b34srun; == ==SUBMATRIX Extract a submatrix b34sexec matrix; x =rec(matrix(6,10:)); sx =submatrix(x,1,3,2,5); call print(x,sx); cx =complex(x,dsqrt(x)); csx =submatrix(cx,1,3,2,5); call print(cx,csx); /$ Character*1 example call character(cc,'1234567890abcdef'); c4by4=c1array(4,4:cc); s1=submatrix(c4by4,1,2,2,3); s2=submatrix(c4by4,3,4,3,4); call print(cc,c4by4,s1,s2); call names(all); b34srun; == ==SUBRENAME Subroutine rename /$ Tests SUBRENAME command /$ Command renames a routine in place b34sexec matrix; subroutine test(x); call print(x); return; end; x=rn(array(10:)); call test(x); newtest=test; call names(all); call free(test); call names(all); call print(newtest); call subrename(newtest); call print(newtest); call names(all); call newtest(x); b34srun; /$ Job Part # 2 b34sexec matrix ; * Shows use of formulas in simple case; function test(i); x=i*i; return(i); end; formula double = gasout*2.; call names; call print(double); call printall; call save; b34srun; b34sexec matrix; call restore; call names(all); call printall; y=double; call print('This has a bad copy ',y); tt=test; call printall; call subrename(y); call print('This is a good copy',y); b34srun; == ==SUBSET Subset of an object using subsert function b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call echooff; call loaddata; call load(subset); mask = (gasin .gt. 0.0); call olsq(gasout gasin :sample mask :print :diag :qr); call olsq(gasout gasin :sample mask :print :diag); call graph(%res :heading 'Residual'); call graph(%y %yhat :heading 'Fitted and Actual'); g2=subset(gasout,mask); g1=subset(gasin,mask); call olsq(g2,g1 :print); b34srun; == ==SUBSET_1 Subset a matrix b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call echooff; call loaddata; call load(subset); x=matrix(norows(gasout),3:); x(,1)=1.; x(,2)=vfam(gasin); x(,3)=vfam(gasout); mask = (gasin .gt. 0.0); newx=subset(x,mask); call print(x,newx); b34srun; == ==SUBSET_2 Speed tests b34sexec matrix; * Speed tests - each matrix 100,000 elements; * 30 problems => 3,000,000 data points!!; call echooff; call load(subset); x=rn(matrix(10000,10:)); do i=1,30; mask = (x(,1) .gt. 0.0); newx=subset(x,mask); call names(all); enddo; b34srun; == ==SUBTEST_1 Subroutine Call examples b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call print('Mean root program',mean(gasout)); subroutine means(x,xmean); call names(all); xmean=mean(x); call print('Mean in subroutine was',xmean); call names(all); call print('About to leave!!'); call print(x); x(1)=-99.; call print(x); return; end; call names; call names(all); call print(means); call means(gasout,testmean); * GASOUT will have changed for element # 1 ; call print(gasout); call names(all); call print('This was the mean that came out of the call',testmean); b34srun; == ==SUBTEST_2 Tests Subroutine Calls Under NL Options /$ This file tests the calling of subroutines from under a running /$ Nonlinear problems. The output is just a test. In this situation /$ the subroutine may not be useful b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; /$ Tests a subroutine call from a program under NLLS /$ Test problem used for code validation b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; subroutine funny(yhat,a,g1,k,r,l,v); * Slow way to go since another step; yhat=a*(g1*k**r+(1.0-g1)*l**r)**(v/r); return; end; program res72; call echooff; /$ Slow way to proceed call funny(yhat,a,g1,k,r,l,v); /$ yhat=a*(g1*k**r+(1.0-g1)*l**r)**(v/r); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 v r'); call outdouble(14,4,g1); call outdouble(34,4,v); call outdouble(50,4,r); return; end; call print(res72,funny); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.3053 1.0 1.85 .03) :print result residuals); call graph(%res); b34srun; b34sexec matrix; * Constrained Minimum tests both commands CMAXF1 and CMAXF2 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; subroutine funny(func,x1,x2); func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); return; end; program test; call funny(func,x1,x2); /$ func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test,funny); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf2(func :name test :parms x1 x2 :lower ll :upper UU :print); b34srun; /$ Tests if can call a subroutine fron inside routine /$ /$ Uses IMSL dn2onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; subroutine funny(func,x1,x2); func=(x1-2.)**2. + (x2-1.)**2. ; return; end; program test; call funny(func,x1,x2); /$ func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=((-1.)*(x1**2.)/4.) - (x2**2.) + 1. ; return; end; call print(test,funny); call echooff; call NLPMIN1(func g :name test :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; b34sexec options ginclude('gas.b34'); b34srun; /$ Using minimum to solve OLS problem /$ OLSQ used as a test /$ Uses IMSL dn2onf /$ Note that M and ME set = 0. G(1)=0.0d+00 is a dummy b34sexec matrix; call loaddata; subroutine funny(func,gasout,gasin,a,b); func=sumsq(gasout -(a+b*gasin)); return; end; program test; call funny(func,gasout,gasin,a,b); /$ func=sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); g(1)=0.0d+00; return; end; call print(test); call olsq(gasout gasin :print); call echooff; call NLPMIN1(func g :name test :parms a b :ivalue array(:2.,2.) :nconst 0 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /$ /$ Uses IMSL dn2ong /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; subroutine funny(func,x1,x2); func=(x1-2.)**2. + (x2-1.)**2. ; return; end; subroutine funny2(df,dg,a); call print(df,dg,a); return; end; program test; call funny(func,x1,x2); /$ func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; call funny2(df,dg,%active); return; end; call print(test,grad,funny,funny2); call echooff; call nlpmin2(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /$ /$ Uses IMSL dn0onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; subroutine funny(func,x1,x2); func=(x1-2.)**2. + (x2-1.)**2. ; return; end; subroutine funny2(df,dg,a); call print(df,dg,a); return; end; program test; call funny(func,x1,x2); /$ func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; call funny2(df,dg,%active); return; end; call print(test,grad,funny,funny2); call echooff; call nlpmin3(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; == ==SUM SUM function => sum elements b34sexec matrix; x=array(8,2:1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16); call print(x, sum(x), sumrows(x), sumcols(x)); call print(mfam(x),sum(mfam(x)),sumrows(mfam(x)),sumcols(mfam(x))); xhold=x; x=r8tor16(xhold); call print(x, sum(x), sumrows(x), sumcols(x)); call print(mfam(x),sum(mfam(x)),sumrows(mfam(x)),sumcols(mfam(x))); x=r8tor4(xhold); call print(x, sum(x), sumrows(x), sumcols(x)); call print(mfam(x),sum(mfam(x)),sumrows(mfam(x)),sumcols(mfam(x))); x=vpa(xhold); call print(x, sum(x), sumrows(x), sumcols(x)); call print(mfam(x),sum(mfam(x)),sumrows(mfam(x)),sumcols(mfam(x))); x=idint(xhold); call print(x, sum(x), sumrows(x), sumcols(x)); call print(mfam(x),sum(mfam(x)),sumrows(mfam(x)),sumcols(mfam(x))); b34srun; b34sexec matrix; a=array(5:1 2 3 4 5); s=sum(a); call print('Sum of 1 2 3 4 5',s); ia=idint(a); r16a=r8tor16(a); r16_s=sum(r16a); i_s=sum(ia); r4_s=sum(sngl(a)); vpa_a=vpa(a); vpa_s=sum(vpa_a); call print(i_s,r4_s,vpa_s,r16_s); b34srun$ == ==SUMCOLS SUM Elements in a col b34sexec matrix; x=array(8,2:1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16); call print(x,sumrows(x),sumcols(x)); call print(mfam(x),sumrows(mfam(x)),sumcols(mfam(x))); b34srun; == ==SUMROWS SUM Elements in a row b34sexec matrix; x=array(8,2:1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16); call print(x,sumrows(x),sumcols(x)); call print(mfam(x),sumrows(mfam(x)),sumcols(mfam(x))); b34srun; == ==SUMSQ SUMSQ function => Sum squared elements b34sexec matrix; a=array(5:1 2 3 4 5); s=sumsq(a);s2=sum(a*a); s3=ddot(a,a); call print(s,s2,s3); b34srun$ == ==SUSPEND Suspend execution of Program b34sexec matrix; call suspend(doit 'c:\b34slm\lib\matrix.mac',100); /; alternatives without a wait /; call load(doit ); /; call doit; /; -------------------------------------------------------- b34srun; == ==SVD SVD function => Singular Value Deconposition b34sexec matrix; * SVD uses LINPACK DSVDC and ZSVDC $ * SVD uses LINPACK QSVDC and CQSVDC $ * SVD( :LAPACK) uses LAPACK SGESVD, ZGESVD) * n sets rank for matrix tests; * noob sets # of observations for PC tests ; n=4; noob=20; x=rn(matrix(noob,n:)); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); sr4=svd(sngl(x),b,11,ur4,vr4); call print('Real*4 case Singular values',sr4,'Left Singular vectors', Ur4,'Right Singular vectors',vr4); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u)*x*v',transpose(u)*x*v, 'Is U orthagonal?','transpose(U)*U', transpose(U)*U, 'Is V orthagonal?','transpose(V)*V', transpose(V)*V, ' '); call print('LAPACK Case '); s2=svd(x,b,11,u2,v2:lapack); call print('X',x,'Singular values',s2,'Left Singular vectors',U2, 'Right Singular vectors',v2); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u2)*x*v2',transpose(u2)*x*v2, 'Is U orthagonal?','transpose(U2)*U2', transpose(U2)*U2, 'Is V orthagonal?','transpose(V)*V', transpose(V2)*V2, ' '); call print('Are these the same? ',s,s2); call print('Are these the same? ',u,u2); call print('Are these the same? ',v,v2); call print('Square Case using LINPACK'); n=4; noob=4; x=rn(matrix(noob,n:)); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u)*x*v',transpose(u)*x*v, 'Is U orthagonal?','transpose(U)*U', transpose(U)*U, 'Is V orthagonal?','transpose(V)*V', transpose(V)*V, ' ', 'LAPACK Case'); s2=svd(x,b,11,u2,v2:lapack); call print('X',x,'Singular values',s2,'Left Singular vectors',U2, 'Right Singular vectors',v2); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u2)*x*v2',transpose(u2)*x*v2, 'Is U orthagonal?','transpose(U2)*U2', transpose(U2)*U2, 'Is V orthagonal?','transpose(V2)*V2', transpose(V2)*V2, ' '); call print('Are these the same? ',s,s2); call print('Are these the same? ',u,u2); call print('Are these the same? ',v,v2); call print('Complex*16 cases':); x=afam(x);x=x*-1.;x=dsqrt(complex(x,0.0)) + complex(x,0.0); x=mfam(x); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'dconj(transpose(u))*x*v', dconj(transpose(u))*x*v, 'Is U orthagonal?','dconj(transpose(U))*U', dconj(transpose(U))*U, 'Is V orthagonal?','dconj(transpose(V))*V', dconj(transpose(V))*V, ' ' 'LAPACK Cases'); s2=svd(x,b,11,u2,v2:lapack); call print('X',x,'Singular values',s2,'Left Singular vectors',U2, 'Right Singular vectors',v2); call print('Test of Factorization. Is S along diagonal?', 'dconj(transpose(u))*x*v', dconj(transpose(u2))*x*v2, 'Is U orthagonal?','dconj(transpose(U))*U', dconj(transpose(U2))*U2, 'Is V orthagonal?','dconj(transpose(V))*V', dconj(transpose(V2))*V2,' '); call print('Are these the same? ',s,s2); call print('Are these the same? ',u,u2); call print('Are these the same? ',v,v2); cx16=x; * real*16 cases ; x=r8tor16(rn(matrix(noob,n:))); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u)*x*v',transpose(u)*x*v, 'Is U orthagonal?','transpose(U)*U', transpose(U)*U, 'Is V orthagonal?','transpose(V)*V', transpose(V)*V, ' ' 'Square Case'); n=4; noob=4; x=r8tor16(rn(matrix(noob,n:))); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u)*x*v',transpose(u)*x*v, 'Is U orthagonal?','transpose(U)*U', transpose(U)*U, 'Is V orthagonal?','transpose(V)*V', transpose(V)*V, ' ' 'Complex*32 Case'); x=c16toc32(cx16); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'dconj(transpose(u))*x*v',dconj(transpose(u))*x*v, 'Is U orthagonal?','dconj(transpose(U))*U', dconj(transpose(U))*U, 'Is V orthagonal?','dconj(transpose(V))*V', dconj(transpose(V))*V, ' '); call print('OLS Examples using SVD',' '); * ####################### ; x=rn(matrix(noob,n:)); call setcol(x,1,1.0); y=rn(vector(noob:)); call print(x,y,'OLS Results', '(1.0/(transpose(x)*x))*transpose(x)*mfam(y)', (1.0/(transpose(x)*x))*transpose(x)*mfam(y)); s=svd(x,b,21,u1,v); call names; call print('Singular values',s, 'X from SVD ', 'U1*diagmat(s)*transpose(v)', U1*diagmat(s)*transpose(v), 'Principle Component Coefficients', 'transpose(u1)*mfam(y)', transpose(u1)*mfam(y), ' ', 'Calculate OLS Coefficients using SVD values', '(V*(1./diagmat(s)))*(transpose(u1)*mfam(Y))', (V*(1./diagmat(s)))*(transpose(u1)*mfam(Y)) ); call print(diagmat(s)); A=transpose(u1)*mfam(y); B=V*(1./diagmat(s))*A; call print('A = PC Coefficients',A, 'B = OLS Coefficients',B); pred1=u1*a; pred2=x*b; call print('We compare two ways to get predicted values'); call tabulate(pred1,pred2); b34srun; b34sexec matrix; * shows that svd of PD matrix produces eigenvalues; x=rn(matrix(5,5:)); xpx=Transpose(x)*x; e=eig(xpx); ee=seig(xpx); s=svd(xpx); call print(e,ee,s); b34srun; == ==SVD2 Difficult SVD Problem b34sexec matrix display=col80high; * Example from Matlab Symbolic toolkit page 1-82; * Matrix is generated slowly; * Most of svd values close to pi; * Tests real*8 LINPACK & LAPACK and real*16 LINPACK; * Shows real*8 LAPACK more like real*16 LINPACK !!! ; call echooff; n=16; x=matrix(n,n:); do i=1,n; do j=1,n; x(i,j)=1./(dfloat(i)-dfloat(j)+.5); next j; next i; call print(x); call print('LINPACK real*8 SVD ',svd(x)); call print('LAPACK real*8 SVD ',svd(x:lapack)) xr16=r8tor16(x); call print('LINPACK real*16 SVD',svd(xr16)); b34srun; == ==SVD3 Speed Tests of LINPACK & LAPACK SVD b34sexec matrix; * Under 400 LINPACK is faster ; * Over 400 LAPACK is faster; * LAPACK shown to be more accurate ; subroutine testit(n,tt1,tt2); /; /; Tests SVD speed of system or order n /; tt1 is linpack speed /; tt2 is lapack speed /; x=rn(matrix(n,n:)); call timer(t1); s=svd(x,ibad,21,u,v); call timer(t2); tt1=t2-t1; call free(s,u,v); call compress; call timer(t1); s=svd(x,ibad,21,u,v :lapack); call timer(t2); tt2=t2-t1; call free(s,u,v); call compress; return; end; call echooff; istart=150; iend =400; jump =50; order =array((iend-istart)/jump:); linpack=array((iend-istart)/jump:); lapack =array((iend-istart)/jump:); icount=1; do n=150,600,25; call testit(n,t1,t2); order(icount)=dfloat(n); linpack(icount)=t1; lapack(icount) =t2; icount=icount+1; call compress; enddo; ratio=linpack/lapack; call tabulate(order linpack lapack ratio :title 'Relative Speed of Linpack/LAPACK SVD'); call graph(order,linpack,lapack :plottype xyplot :heading 'Relative Speed of Linpack/LAPACK SVD'); b34srun; == ==SWARTEST Stock-Watson VAR Test b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(swartest); call echooff; ibegin1=1; iend1=200; ibegin2=201; iend2=296; nlag=2; nterms=10; iprint=1; x=catcol(gasin,gasout); call print('Two variable test':); 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); /$ One variable test x=matrix(norows(gasout),1:gasout); call print('One Variable Test':); 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); /$ One variable test on random data n=2000; x=matrix(n,1:); x=rn(x); ibegin1 = 1; iend1 = n/2; ibegin2 = iend1+1; iend2 = n; nlag=12; nterms=20; call print('Test using Random Data':); 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); b34srun; == ==SWARTEST1A Illustrates Test for one series AR(1) Case b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); n=3000; ibegin1=1; iend1=n; ibegin2=n+1; iend2=2*n; nlag=1; nterms=10; iprint=1; ar=array(:.9); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ar=array(: .5); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Coefficient shift in AR Model'); call echooff; call print(' ':); call print('Shows a coef shift in AR Model':); 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 echoon; ar=array(:.9); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ar=array(: .9); testar1b=genarma(ar,ma,10.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Variance shift in AR model'); call echooff; 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 echoon; ar=array(:.9); start=array(:.1); testar1a=genarma(ar,ma,10.0,start,.1,n); ar=array(: .5); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Both Coef and Variance are shifting'); call echooff; call print(' ':); call print('Shows Both coef and var shift':); 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); b34srun; == ==SWARTEST1B Illustrates Test for one series MA(2) Case /$ /$ Shows estimation of a MA as an AR and then inverting model /$ Get out MA structure /$ b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); n=3000; ibegin1=1; iend1=n; ibegin2=n+1; iend2=2*n; nlag=8; nterms=10 ; iprint=1; ma=array(:.9,-.4); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ma=array(: .5,-.4); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Coef shift in MA Model'); call print(' ':); call print('Coef shift in MA Model':); call echooff; 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 echoon; ma=array(:.9,-.4); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ma=array(: .9,-.4); testar1b=genarma(ar,ma,6.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Var shift in MA Model'); call echooff; call print(' ':); call print('Var shift in MA Model':); 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 echoon; ma=array(:.9,-.4); start=array(:.1); testar1a=genarma(ar,ma,3.0,start,.1,n); ma=array(: .5,-.4); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Both Coef and Var Shift'); call echooff; call print(' ':); call print('Shows Both coef and var shift':); 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); b34srun; == ==SWARTEST2 Stock Watson Two Period Test b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(swartest); call echooff; /; Difference and align the series diffm=dif(m2dp,2,1); diffi=dif(fycp,1,1); i=norows(diffi); ix=integers(2,i); xin=diffm; yin=diffi(ix); n=norows(xin); ibegin1=1; iend1=200; ibegin2=201; iend2=370; nlag=19; nterms=30; iprint=-1; x=catcol(xin,yin); call print('Two variable test':); 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); /$ One variable test x=matrix(norows(yin),1:yin); call print('One Variable Test':); 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); b34srun; == ==SWARTEST3 Runs Stock Watson Test over a Range of Obs /$ /$ Runs Stock-Watson over a range of values /$ Uses Neuburger - Stokes /$ b34sexec options ginclude('b34sdata.mac') macro(res79)$ b34srun$ b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(swartest); call echooff; diffm=dif(m2dp,2,1); diffi=dif(fycp,1,1); i=norows(diffi); ix=integers(2,i); xin=diffm; yin=diffi(ix); n=norows(xin); istart=80; iend=n-istart; htest11=array(iend-istart+1:); htest12=array(iend-istart+1:); htest21=array(iend-istart+1:); htest22=array(iend-istart+1:); icount=1; x=catcol(xin,yin); do ii=istart,iend; ibegin1=1; iend1=ii; ibegin2=ii+1; iend2=n; nlag=19; nterms=30; iprint=0; 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(2)); call outdouble(22,4,test12(2)); call outdouble(2, 5,test21(2)); call outdouble(22,5,test22(2)); htest11(icount)=test11(2); htest12(icount)=test12(2); htest21(icount)=test21(2); htest22(icount)=test22(2); call compress; icount=icount+1; enddo; call tabulate(htest11,htest12,htest21,htest22); call print('Mean sigma11 ',mean(htest11)); call print('Mean sigma12 ',mean(htest12)); call print('Mean sigma21 ',mean(htest21)); call print('Mean sigma22 ',mean(htest22)); call graph(htest11 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest11.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(11)'); call graph(htest12 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest12.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(12)'); call graph(htest21 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest21.hp1' :hardcopyfmt HP_GL2 :heading 'sigma(21)'); call graph(htest22 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest22.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(22)'); call menu(cc :menutype inputtext :prompt ' Save File Name. blank => clipboard' ); call grreplay(:start :file cc ); 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); b34srun; == ==SWBOOTS Critical values for output from SWARTEST %b34slet kswboot =0; %b34slet kswboot2=0; %b34slet swboot =1; /$ Observation of Three Period /$ US Others Year /$ 1st Begin : 1 1 1890 1886 /$ 1st End : 25 29 1914 /$ 2nd Begin : 31 35 1920 /$ 2nd End : 50 54 1939 /$ 3rd Begin : 61 65 1950 /$ 3rd End : 112 116 2001 b34sexec options ginclude('b34sdata.mac') member(JML_GDP); b34srun; b34sexec matrix; call loaddata ; call load(buildlag); call load(varest); call load(swartest); call load(kswtest) ; call load(kswboots) ; call load(swboots) ; call echooff; nlag = 1 ; nterms = 10 ; iprint = 0 ; iprint2= -1 ; p=nlag ; printout=0 ; /; Note: Activate to 100 or more for actual runs!!! niter = 10 ; /; niter = 100; * method = 1 ; k = 30 ; call print('====================================') ; call print(' 3 Period Log differeced US GDP AR1 ') ; call print('====================================') ; call print(' x = us_gdp ') ; Call print('Without Interwar periods') ; call print('====================================') ; vbegin1 = index( 1 31 61) ; vend1 = index(25 50 112) ; x = us_gdp ; %b34sif(&kswboot.ne.0)%then; call print('Testing KSWTEST - KSWBOOTS one variable model':); call print('__________________________':); call print(' ':); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; call kswboots(x,p,k,printout,niter,1,vbegin1,vend1, nterms); /; call kswboots(x,p,k,printout,niter,2,vbegin1,vend1,nterms); /; call kswboots(x,p,k,printout,niter,3,vbegin1,vend1,nterms); %b34sendif; %b34sif(&kswboot2.ne.0)%then; call print('Testing KSWTEST - KSWBOOTS two variable model':); call print('__________________________':); call print(' ':); x=catcol(us_gdp uk_gdp); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; call kswboots(x,p,k,printout,niter,1,vbegin1,vend1,nterms); /; call kswboots(x,p,k,printout,niter,2,vbegin1,vend1,nterms); /; call kswboots(x,p,k,printout,niter,3,vbegin1,vend1,nterms); %b34sendif; %b34sif(&swboot.ne.0)%then; call print('Testing SWARTEST-SWBOOTS':); call print('________________________':); call print(' ':); bb=vbegin1; ar_p=p; ibegin1=1; iend1 =25; ibegin2=31; iend2 =50; iprint=1; printout=0; k=0; 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 print('Bootstrap Errors using Original Errors':); call swboots(X,ar_p,k,printout,niter,1,ibegin1,iend1,ibegin2,iend2, nterms); call print('Monte Carlo Critical value':) ; call swboots(X,ar_p,k,printout,niter,3,ibegin1,iend1,ibegin2,iend2, nterms); %b34sendif; b34srun ; == ==SWBOOTSM Statistics for Moving Stock Watson Test /$ /$ Runs Stock-Watson over a range of values /$ Uses Frankel Price Data studied in - Stokes(1997) to /$ test for breaks in VAR and to test if it was coef changes /$ or variance changes /$ /$ As setup the "focus variable" is series 2 /$ b34sexec options ginclude('b34sdata.mac') macro(frankel)$ b34srun$ b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(swartest); call load(swboots); call load(swbootsm); call echooff; /; subset model setup x=catcol(diffprce dpczu_1); istart=40; nlag=12; nterms=10; /; nterms=20; iprint=-1; /; iprint=0; printout=0; niter=6; /; niter=100; method=1; /; if set = 1 will get critical values using 95% /; if set = -1 will get critical values using 99% dist=1; kdrop=0; cc1='plot1.wmf'; cc2='plot2.wmf'; cc3='plot3.wmf'; fsvname='sw_data.fsv'; call swbootsm(x,istart,nlag,kdrop,iprint,printout,niter,method,nterms, dist,cc1,cc2,cc3,fsvname); b34srun; == ==SWB_PLOT Plotting Stock Watson Values from Extract file b34sexec matrix; call echooff; call load(swbootsm); dist=1; fsvname='c:\b34slm\macfiles\sw_move1.fsv'; cc1='test1.wmf'; cc2='test2.wmf'; cc3='test3.wmf'; call swb_plot(dist,fsvname,cc1,cc2,cc3); b34srun; == ==SWB2PLOT More complex version of swb_plot b34sexec matrix; call echooff; call load(swbootsm); dist=0; fsvname='c:\b34slm\macfiles\sw_move2.fsv'; cc1='test1_2.wmf'; cc2='test2_2.wmf'; cc3='test3_2.wmf'; smooth=1; iday = 1; imonth= 2; iyear = 1947; freq=12.; ioff=80; dist=1; call swb2plot(dist,fsvname,cc1,cc2,cc3,smooth,iday,imonth,iyear, freq,ioff); b34srun; == ==SYSTEM Call system => Call operating System b34sexec matrix; * Silent useage. Note Command has been turned off; call system('erase somename'); * Non silent usage if silent useage is a problem. Command off; call system('erase somename',:); b34srun; == ==SYSTEM_2 Multiple RATS calls from matrix /; /; Illustrates making a portable file and calling rats from /; matrix command a number of times in a row /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call makerats(gasin,gasout :file 'full.por'); call print(mean(gasin) mean(gasout)); call cleardat; call getrats('full.por'); call print(mean(gasin) mean(gasout)); call names; /$ call tabulate(obsnum,gasin,gasout); b34srun; b34sexec options open('rats.in') unit=77 disp=unknown; b34srun; b34sexec options clean(77); b34srun; b34sexec options copyf(4,77); pgmcards; allocate 2000 open data full.por data(format=portable) table linreg gasout # constant gasin{1 to 4} gasout{1 to 4} end b34sreturn; b34srun; b34sexec options rewind(77); b34srun; b34sexec options close(77); b34srun; b34sexec options open('full.por') unit=77 disp=unknown; b34srun; b34sexec options close(77); b34srun; /$ b34sexec options dodos('start /w /r rats32s rats.in /run') /$ dounix('rats rats.in rats.out')$ B34SRUN$ /$ b34sexec options npageout /$ WRITEOUT('OUTPUT FROM RATS',' ',' ') /$ COPYFOUT('rats.out') /$ dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') /$ dounix('rm rats.in','rm rats.out','rm rats.dat') /$ $ /$ B34SRUN$ b34sexec matrix; /$ /$ Note : /$ do i=1,5; call dodos('start /w /r rats32s rats.in /run' :); call dounix('rats rats.in rats.out':); call print('+++++++++++ copy ',i,' +++++++++++'); call print('+++++++++++++++++++++++++++++++++++':); if(i.eq.1)then; call copyout('rats.in'); endif; call copyout('rats.out'); enddo; b34srun; == ==TABULATE Tests Tabulate for Simple Case b34sexec matrix; subroutine fix(rad,ss,cc,title); call tabulate(rad,ss,cc :title title); return; end; n=12; rad=array(n:); ss=array(n:); cc=array(n:); call echooff; do i=1,n; rad(i)=dfloat(i)*pi()/6.; ss(i)=dsin(rad(i)); cc(i)=dcos(rad(i)); enddo; /$ Change format call tabulate(rad,ss,cc); call tabulate(rad,ss,cc :format '(f12.3)'); /$ Title call tabulate(rad,ss,cc :title 'Simple Title Example'); call character(title,'Calling a routine'); call fix(rad,ss,cc,title); b34srun; == ==TABULATE2 Tests Tabulate Writting to a file b34sexec matrix; n=12; rad=array(n:); ss=array(n:); cc=array(n:); call echooff; do i=1,n; rad(i)=dfloat(i)*pi()/6.; ss(i)=dsin(rad(i)); cc(i)=dcos(rad(i)); enddo; /$ Shows both uses of tabulate call open(71,'tab.txt'); call tabulate(rad,ss,cc:title 'Test of Tabulate'); call tabulate(rad,ss,cc:unit 71 :cdf); call close(71); b34srun; == ==TABULATE3 Formating Options b34sexec matrix; n=12; rad=array(n:); ss=array(n:); cc=array(n:); do i=1,n; rad(i)=dfloat(i)*pi()/6.; ss(i)=dsin(rad(i)); cc(i)=dcos(rad(i)); enddo; /$ Change format call tabulate(rad,ss,cc); call tabulate(rad,ss :title 'BIG title **************'); call tabulate(rad,ss :title 'little t'); /$ Note: Number must be within length of 12 /$ Checking not completely done call tabulate(rad,ss,cc :format "('A ',F8.3)"); call tabulate(rad,ss,cc :format '(f10.0)'); /$ place commas in Character*8 and print cc1=','; c=rtoch(array(12:)); c(,1)=cc1; call tabulate(rad,ss,cc,c); call tabulate(rad,ss,cc :ljname :title 'Left Just name'); call tabulate(rad,ss,cc :rjname :title 'Right Just name'); call tabulate(rad,ss,cc :cname :title 'Center name'); b34srun; == ==TARCH1A Tests Simple Arch Model b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ /$ Solving an ARCH model of form /$ res=gasout-(b0+b1*gasout{1} + b2*gasout{2} /$ vv= a0+a1*vv{1} /$ Max: (-.5)*(dlog(archvar)+((resid**2.)/archvar) ) /$ call loaddata; maxlag1=2; call olsq(gasout gasout{1 to maxlag1} :print); rvec=array(5:); rvec(1)=%coef(3); rvec(2)=%coef(1); rvec(3)=%coef(2); rvec(4)=dsqrt(%resvar); rvec(5)=.05; ylag1=afam(lag(gasout,1)); ylag2=afam(lag(gasout,2)); call echooff; program test; resid =gasout-b0-b1*ylag1-b2*ylag2; archvar=dabs(a0+(a1*(lag(resid,1)**2.))); func=sum(goodrow((-.5)*(dlog(archvar)+((resid**2.)/archvar)))); call outstring(3,3,'Function to be maximized'); call print(func); call outdouble(36,3,func); return; end; call print(test); call print(rvec); call maxf1(func :name test :parms b0 b1 b2 a0 a1 :nsig 6 :maxfun 5000 :ivalue rvec :print); b34srun; /$ bhhh method used .. residuals set to 0 for beginning obs /$ /$ user must replace gasout with user series name /$ b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec pgmcall$ rats passasts pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ') $ pgmcards$ * set seriesn = gasout compute iter = 100,isiter=100 * * Simple Arch Model using RATS * smpl(series=seriesn) set ram = 0.0 set vv = 1.0 nonlin b0 b1 b2 a0 a1 frml archvar = a0+a1*ram{1}**2 frml regresid = seriesn-b0-b1*seriesn{1}-b2*seriesn{2} frml archlogl = (vv(t)=archvar(t)),(ram(t)=regresid(t)), $ -.5*(log(vv)+ram**2/vv) linreg seriesn # constant seriesn{1} seriesn{2} compute b0=%beta(1), b1=%beta(2), b2=%beta(3), a0=%seesq,a1=.05 nlpar(subiterations=isiter) * maximize(method=simplex,recursive,iterations=iter) archlogl 3 * maximize(method=bhhh,recursive,iterations=iter) archlogl 3 * write 'hessian' %xx smpl(series=ram) statistics ram set rssam = ram(t)*ram(t) statistics rssam smpl(series=rssam) compute sumsqu = %sum(rssam) display 'sum of squares of u (ram) for arch-m' sumsqu * b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout writeout('output from rats',' ',' ') copyfout('rats.out') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in', 'rm rats.out', 'rm rats.dat') $ b34srun$ == ==TB_TO_JULIAN Convert tbase, tstart & freq to real*8 julian b34sexec matrix; call echooff; n=10; tbase=1972; tstart=3; freq1=12.; ioff=8; x=rn(array(n:)); call settime(x,tbase,tstart,freq1); y=rn(array(n-8:)); call up_date_tb(tbase,tstart,freq1,ntbase,ntstart,ioff); call settime(y,ntbase,ntstart,freq1); call describe(x :print); call describe(y :print); call tabulate(x); call tabulate(y); call print(tbase,tstart,freq1); call tb_to_julian(tbase,tstart, freq1,julian1); call tb_to_julian(ntbase,ntstart,freq1,julian2); date(1) =chardate(julian1); date(2) =chardate(julian2); date2(1) =chardatemy(julian1); date2(2) =chardatemy(julian2); fyear2(1) =fyear(julian1); fyear2(2) =fyear(julian2); day(1) =getday(julian1); day(2) =getday(julian2); month(1) =getmonth(julian1); month(2) =getmonth(julian2); year(1) =getyear(julian1); year(2) =getyear(julian2); quarter(1)=getqt(julian1); quarter(2)=getqt(julian2); call print(julian1,julian2,date,date2,fyear2,day,month,year,quarter); b34srun; == ==TBPF Tests Baxter - King Filter Program b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(BPF); highfreq=6.; lowfreq=32.; nterms=20; call print(gasout); call bpf(gasout,ngasout,highfreq,lowfreq,nterms); ngasout2=gasout-ngasout; call tabulate(gasout,ngasout,ngasout2); call graph(gasout,ngasout,ngasout2); b34srun; == ==TBPFM Tests Baxter - King Filter Program b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(bpfm); call print(bpfm); highfreq=6.; lowfreq=32.; nterms=20; call print(gasout); call bpfm(gasout,ngasout,highfreq,lowfreq,nterms); ngasout2=gasout-ngasout; call tabulate(gasout,ngasout,ngasout2); b34srun; == ==TDEN Student t density b34sexec matrix; t=grid(-4.0,4.0,.1); df=array(norows(t):)+10.; ttden =tden(t,df); ttprob =tprob(t,df); normden2 =normden(t); call print('DF was ',df:); call tabulate(t,ttden,ttprob,normden2); df=array(norows(t):)+1000.; ttden =tden(t,df); ttprob =tprob(t,df); normden2 =normden(t); call print('DF was ',df:); call tabulate(t,ttden,ttprob,normden2); df=array(norows(t):)+100000.; ttden =tden(t,df); ttprob =tprob(t,df); normden2 =normden(t); call print('DF was ',df:); call tabulate(t,ttden,ttprob,normden2); * Test interpolation ; * Rats gets .06115 .06104 .06094 .06084 .06075 .06065 ; * Matlab Truncates ; call print('tden(2.,10. )',tden(2.,10. ):); call print('tden(2.,10.2)',tden(2.,10.2):); call print('tden(2.,10.4)',tden(2.,10.4):); call print('tden(2.,10.6)',tden(2.,10.6):); call print('tden(2.,10.8)',tden(2.,10.8):); call print('tden(2.,11. )',tden(2.,11. ):); b34srun; == ==TESTARG Call testarg => Show variable Linkage b34sexec matrix; a=matrix(3,3:); a=rn(a);b=rn(vector(3:)); call testarg(a,b,c,a*b,'This is a comment'); b34srun; == ==TESTOLS1 Simple OLS Models using MATRIX b34sexec options ginclude('gas.b34'); b34srun; /$ /$ OLS is done three ways: 1. with reg /$ 2. with matrix /$ 3. with olsq /$ b34sexec reg; model gasout=gasin; b34srun; b34sexec matrix; call loaddata; x=matrix(norows(gasin),2:); x(,1)=vfam(gasin); call setcol(x,2,1.0); xpx=transpose(x)*x; call names; beta=vfam((1./xpx)*transpose(x)*mfam(gasout)); call print(xpx,beta); fgasout=vfam(x*mfam(beta)); resid=vfam(gasout)-vfam(fgasout); call names; ss=resid*resid; sigma=ss/dfloat(norows(resid)-2); se=dsqrt(diag(sigma*(1.0/xpx))); t=afam(beta)/afam(se); n=namelist(gasin,const); call print('Gasout = a + b*Gasin','RSS',ss); call tabulate(n,beta,se,t); call tabulate(gasout fgasout resid); call graph(resid:heading 'Residuals from Gas Data'); call olsq(gasout,gasin :print); call tabulate(%y,%yhat,%res); b34srun; == ==TESTS Tests LOADDATA Command b34sexec options ginclude('gas.b34')$ b34srun$ /$ /$ Here are saving as a vector /$ b34sexec matrix saveasvector$ call print('This Loads the gas data.', 'Simple graphs are next done.'); call loaddata; call print('This is GASIN',gasin); call print('This is GASOUT',gasout); call names; y=(8.); call print(y); yy=(8); call print(yy); z=8.; call print(z); zz=8.*8.; call print('This is zz should be 64',zz); is512=z*zz; call print('This is 512',is512); int=8; int64=int*int; call print('This is int64',int64); gasinp2=gasin+ 2.; gasoutm2=gasout- 2.; gasot2=gasout*2.; test=(gasout*2.0)/100.$ test2=gasout**2.$ test3=afam(gasout)**afam(gasout); call graph(gasout,test3); call names(all); call tabulate(gasin gasout gasinp2 gasoutm2 gasot2 test test2 test3); xmat=matrix(3,3:); xmat=rn(xmat); call print('X matrix',xmat); g=grid(0.0,10.0,.5); call print(g); b34srun$ == ==TFDIFINFO Tests FDIFIUNFO b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; d=1./3.; fdgas=fracdif(gasout,d,20); call tabulate(%fdacoef,%fdmcoef); call tabulate(fdgas,gasout); acf1=acf(gasout,12); acf2=acf(fdgas ,12); call tabulate(acf1,acf2); call graph(acf1,acf2 :Heading 'ACF of GASOUT and FD GASOUT'); * Testing with random numbers; n=10000; d=1./3.; x=rn(array(n:)); fx1=fracdif(x,d,100); call tabulate(%fdacoef,%fdmcoef); acffx1=acf(fx1,50); d=(-1.0)*d; fx2=fracdif(x,d,100); call tabulate(%fdacoef,%fdmcoef); acffx2=acf(fx2,50); call print('Table 2.3 in Cambell-Lo-MacKinlay', 'acffx1 has d=1/3. acffx2 has d=-1/3'); call tabulate(acffx1,acffx2); b34srun; b34sexec matrix; * See Cambell-Lo-MacKinley page 60-61 ; call load(fdifinfo); d1=1./3.; nterms=20; /$ Note that dgamma limits us in terms of number of terms call fdifinfo(d1,nterms,ar1,ma1,p1); call print('Results for d = 1/3 - See Page 61'); call tabulate(ar1,ma1,p1); d1=(-1.)/3.; call fdifinfo(d1,nterms,ar2,ma2,p2); call print('Results for d = -1/3 - See Page 61'); call tabulate(ar2,ma2,p2); b34srun; == ==TFILTER Effect of differencing, logs and HP Filter /; Effect of log and difference on the low frequency in a series /; Looks at HP Filter b34sexec matrix; call load(data3acf); call load(tfilter); n=600; nacf=min1(300,n/20); x=rn(array(n:)); unit_r=cusum(x); mm=min(unit_r); if(mm.lt.0.0)unit_r=unit_r+abs(mm)+.1e-16; lamda=14440; call tfilter(unit_r,'Unit_r Series',nacf,lamda,0); b34srun; == ==THP_BP_1 Tests H-P and B-P Filters /; Tests the H-P and B-K Filters when passed /; random normal data & ARMA data /; /; Spectrum of trend and dev data are calculated and /; displayed for HP and BK filter. /; /; Note that high and low freq are NOT in dev data for /; BK filter. /; b34sexec matrix; n=5000; s=1600; highfreq=8.; lowfreq=32.; nterms=20; * i=0 for random numbers, =1 for arma ; i=0; * random case ; if(i.eq.0)x=rn(array(n:)); * arma case ; if(i.eq.1)then; ar=array(:.6,-.3); * ma=array(:-.5,-.25); start=array(:.1,.1); x=genarma(ar,ma,1.0,start,.1,n); endif; acf1=acf(x,dmax1(norows(x)/50,2),se,pacf1); call graph(acf1,pacf1 :heading 'ACF & PACF '); 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 tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of x' :plottype xyplot); call hpfilter(x,xhpt,xhpdev,s); call graph(x,xhpt,xhpdev); call bpfilter(x,xbpt,xbpdev,highfreq,lowfreq,nterms:); xx=goodrow(catcol(x,xbpt,xbpdev)); newx =xx(,1); xbpt =xx(,2); xbpdev =xx(,3); call graph(newx,xbpt,xbpdev); call spectral(xhpdev,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xhpdev' :plottype xyplot); call spectral(xhpt,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xhpt' :plottype xyplot); call spectral(xbpdev,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xbpdev' :plottype xyplot); call spectral(xbpt,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xbpt' :plottype xyplot); b34srun; == ==TIMEBASE Illustrate Timebase b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call print(timebase(ct),timestart(ct),freq(ct)); b34srun; == ==TIMENOW Time now in form hh:mm:ss b34sexec matrix; call print('Date now is ',datenow():); call print('Time now is ',timenow():); b34srun; == ==TIMESTART Illustrate Timestart b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call print(timebase(ct),timestart(ct),freq(ct)); b34srun; == ==TINY Smallest Number of type b34sexec matrix; i=1; i8=i4toi8(i); x=1.; x16=r8tor16(x); y=sngl(x); call print('Largest integer*4 ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Largest real*16 ',huge(x16):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Smallest real*16 ',tiny(x16):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); call print('Epsilon real*16 ',epsilon(x16):); call print('Precision real*4 ',precision(y):); call print('Precision real*8 ',precision(x):); call print('Precision real*16 ',precision(x16):); x=.1d+00; x16=r8tor16(x); y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; x16=x16*r8tor16(dfloat(i)); spx(j) =spacing(x); spy(j) =spacing(y); spx16(j) =spacing(x16); nearpr8(j) =nearest(x, 1.); nearmr8(j) =nearest(x,-1.); nearpr16(j)=nearest(x16, r8tor16(1.)); nearmr16(j)=nearest(x16,r8tor16(-1.)); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8, Real*16 and Real*4'); call tabulate(testnum,spx,spy,spx16,nearpr8, nearmr8,nearpr4,nearmr4 nearpr16,nearmr16); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; == ==TNLLSQ_1 Test of NLLSQ Using Gallant (1987) Data /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Model taked from Gallant (1987) page 35 b34sexec options ginclude('b34sdata.mac') member(rgtab_1); b34srun; b34sexec matrix; call loaddata; call load(nlvarcov); * R. Gallant (1987) Page 35 --- Nonlinear Models ; * Parameters SE ; * -0.02588970 .01262384 ; * 1.01567967 .00993793 ; * -1.11569714 .16354199 ; * -0.50490286 .02565721 ; * Starting values suggested by Gallant ; program model1; call echooff; yhat=t1*x1 + t2*x2 + t4*dexp(t3*x3); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 t3 t4'); call outdouble(14,4,t1); call outdouble(34,4,t2); call outdouble(50,4,t3); call outdouble(14,5,t4); return; end; call print(model1); /$ Note: Without The Gallant starting values we go to a local /$ minimum /$ Can start with .0001 .0001 and -1. -1. to get to /$ answers. This is close to what Gallant suggests call nllsq(y,yhat :name model1 :parms t1 t2 t3 t4 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ :ivalue array(4:-.048866,1.03884,-.73792,-.51362) /$ If parameter # 3 is not set < 0 => problems /$ :ivalue array(4: .0001,.0001,-1.0,-1.0) :ivalue array(4:.1, 1., -.1, .1) :diff array(4: .1d-9 .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); call graph(%res); /$ callprint(nlvarcov); * See Gallant (1987) page 36 ; call nlvarcov(%resvar,%corrmat,%se,varcov); call print(varcov); b34srun; == ==TNLLSQ_2A Test of NLLSQ Restrictions Using Gallant (1987) /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Model taken from Gallant (1987) page 35 /$ Restrictions are tested b34sexec options ginclude('b34sdata.mac') member(rgtab_1); b34srun; b34sexec matrix; call loaddata; * R. Gallant (1987) Page 35 --- Nonlinear Models ; * Parameters SE ; * -0.02588970 .01262384 ; * 1.01567967 .00993793 ; * -1.11569714 .16354199 ; * -0.50490286 .02565721 ; * Starting values suggested by Gallant ; program model1; call echooff; yhat=t1*x1 + t2*x2 + t4*dexp(t3*x3); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 t3 t4'); call outdouble(14,4,t1); call outdouble(34,4,t2); call outdouble(50,4,t3); call outdouble(14,5,t4); return; end; call print(model1); /$ Note: Without The Gallant starting values we go to a local /$ minimum /$ Can start with .0001 .0001 and -1. -1. to get to /$ answers. This is close to what Gallant suggests call nllsq(y,yhat :name model1 :parms t1 t2 t3 t4 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ :ivalue array(4:-.048866,1.03884,-.73792,-.51362) /$ If parameter # 3 is not set < 0 => problems /$ :ivalue array(4: .0001,.0001,-1.0,-1.0) :ivalue array(4:.1, 1., -.1, .1) :diff array(4: .1d-9 .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); * Tests on coefficicient restrictions; fullss=%fss; fullcoef=%coef; * we assume t1=0; t1=0.0; call nllsq(y,yhat :name model1 :parms t2 t3 t4 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ :ivalue array(4:-.048866,1.03884,-.73792,-.51362) /$ If parameter # 2 is not set < 0 => problems /$ :ivalue array(3:.0001,.0001,-1.0,-1.0) :ivalue array(3: 1., -.1, .1) :diff array(3: .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); rss1=%fss; q=4; * See Galland page 60 ; lr=((rss1-fullss)/1.)/(fullss/(dfloat(%nob-q))); call print(lr,'Probility of F ',fprob(lr,1.0,dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,1.0,dfloat(%nob-q)) ); * Second set of restrictions ; * We test if t(3)*t(4)*dexp((3))=.2 ; * Same as asserting t(4)= 1./(5.*t(3)*dexp(t(3))); program model2; call echooff; t4=1./(5.*t3*dexp(t3)); yhat=t1*x1 + t2*x2 + t4*dexp(t3*x3); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 t3 t4'); call outdouble(14,4,t1); call outdouble(34,4,t2); call outdouble(50,4,t3); call outdouble(14,5,t4); return; end; t1=0.0; call nllsq(y,yhat :name model2 :parms t1 t2 t3 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ If parameter # 2 is not set < 0 => problems /$ :ivalue array(3:.0001,.0001,-1.0,-1.0) :ivalue array(3: fullcoef(1),fullcoef(2),fullcoef(3)) :diff array(3: .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); rss1=%fss; q=4; * See Galland page 62 ; lr=((rss1-fullss)/1.)/(fullss/(dfloat(%nob-q))); call print(lr,'Probility of F ',fprob(lr,1.0,dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,1.0,dfloat(%nob-q)) ); * Final Test where BOTH t(1) = 0 and t(3)*t(4)*dexp((3))=.2; T1=0.0; call nllsq(y,yhat :name model2 :parms t2 t3 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values :ivalue array(2: fullcoef(2),fullcoef(3)) :diff array(2: .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); rss1=%fss; q=4; * See Gallant page 64 ; lr=((rss1-fullss)/ dfloat(4-2)) / (fullss/(dfloat(%nob-q))); call print(lr,'Probility of F ',fprob(lr,2.0,dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,2.0,dfloat(%nob-q)) ); b34srun; == ==TNLLSQ_2B Runs TNLLSQ_2 using RATS /$ Illustrates Nonlinear Estimation using RATS Command under b34s /$ Model taken from Gallant (1987) page 35 /$ Restrictions are tested. Note that Rats appears NOT /$ to rerun the model with the restriction in place. /$ The resulting test is NOT EXACTLY is obtained when the /$ model is rerun as suggested by Gallant (1987) /$ b34sexec options ginclude('b34sdata.mac') member(rgtab_1); b34srun; /$ B34SEXEC OPTIONS OPEN('rats.dat') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * * Rats TEST command appears to NOT reestimate the coefficients * Rather the old values are used and the test is imposed * * Gallant (1987) suggests rerunning the model with the restriction * In this problem there are minor differences * * Gallant;s starting values * $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ * RATS and b34s are both influenced by the starting values nonlin t1 t2 t3 t4 frml yhat = t1*x1 + t2*x2 + t4*exp(t3*x3); input t1 t2 t3 t4 -.048866,1.03884,-.73792,-.51362 * If parameter # 3 is not set < 0 => problems nlls(frml=yhat,trace) y test # 1 # 0.0 * Tests with different starting values * Values Used by b34s * $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ nonlin t1 t2 t3 t4 frml yhat = t1*x1 + t2*x2 + t4*exp(t3*x3); input t1 t2 t3 t4 .0001,.0001,-1.0,-1.0 * -.048866,1.03884,-.73792,-.51362 * If parameter # 3 is not set < 0 => problems * .0001,.0001,-1.0,-1.0 nlls(frml=yhat,trace) y test # 1 # 0.0 * These starting values cause problems!!! * $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ nonlin t1 t2 t3 t4 frml yhat = t1*x1 + t2*x2 + t4*exp(t3*x3); input t1 t2 t3 t4 .0001,.0001,1.0,1.0 nlls(frml=yhat,trace) y test # 1 # 0.0 B34SRETURN$ B34SRUN $ B34SEXEC OPTIONS CLOSE(28)$ B34SRUN$ B34SEXEC OPTIONS CLOSE(29)$ B34SRUN$ b34sexec options /$ dodos('start /w /r rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run') dounix('rats rats.in rats.out')$ B34SRUN$ B34SEXEC OPTIONS NPAGEOUT WRITEOUT('Output from RATS',' ',' ') COPYFOUT('RATS.OUT') dodos('erase rats.in','erase rats.out','erase rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ == ==TNLLSQ_3 Further NLLSQ Test of Restrictions /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Model taken from Gallant (1987) page 66 /$ Restrictions are tested b34sexec options ginclude('b34sdata.mac') member(rgtab_2); b34srun; b34sexec matrix; call loaddata; * R. Gallant (1987) Page 66 --- Nonlinear Models ; * Parameters SE ; * 1.37396966 .04864622 ; * 0.40265518 .0132439 ; * Starting values suggested by Gallant ; program model; call echooff; yhat=t1*(dexp(-1.*t2*x1)-dexp(-1.*t1*x1))/(t1-t2); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 '); call outdouble(14,4,t1); call outdouble(34,4,t2); return; end; call print(model); /$ Note: Without The Gallant starting values we go to a local /$ minimum call nllsq(modelb, yhat :name model :parms t1 t2 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values :ivalue array(2:1.4,.4) :diff array(2: .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); * Tests on coefficicient restrictions; fullss=%fss; fullcoef=%coef; /$ Due to 'loop', this code runs slowly but corrrectly program model2; call echooff; t2=rho; z1=1.4; z2=0.0; c=t2-dlog(t2); loop continue; if(dabs(z1-z2).le.1.d-13)go to nextstep; z2=z1; z1=dlog(z1)+c; go to loop; nextstep continue; t1=z1; yhat=t1*(dexp(-1.*t2*x1)-dexp(-1.*t1*x1))/(t1-t2); call outstring(3,3,'Coefficients'); call outstring(3,4,'rho'); call outdouble(14,4,rho); return; end; call print(model2); call nllsq(modelb, yhat :name model2 :parms rho :eps2 .1d-13 :eps1 .1d-10 /$ These are Gallant's starting values :ivalue fullcoef(2) :diff .1d-9 /$ :flam 1.0 :flu 20. :print result residuals); q=2; newq=1;call loaddata; lr=((%fss-fullss)/dfloat(newq))/(fullss/dfloat(%nob-q)); call print(lr,'Probility of F ',fprob(lr,dfloat(newq),dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,dfloat(newq),dfloat(%nob-q))); * These results replicate Gallant (1987) page 69 ; * Rho and SE should be .47754289 with SE .03274044 ; * LR = 74.670 which indicates rejection ; b34srun; == ==TNONLIN_A Tests series using Hinich, Tsay, BDS b34sexec matrix; * Job takes time depending on n setting ; * TSAY, Hinich, Keenan and BDS tests illustrated ; * Note for low n (say 1000) get false positives in all but Hinich; call echooff; n=5000; call print('Random Data'); x=rn(array(n:)); call graph(acf(x) :heading 'Graph of acf of x'); call tsay(x,10,tsaytest,prob:); call hinich82(x,m,g,l:smoothspec); call print('Hinich Test on x'); call tabulate(m,g,l); call bds(x,.5 10:); do i=2,10; call keenan(x,tt,i,pp); j=i-1; test(j) =tt; prob(j) =pp; order(j) =i; enddo; call print('Keenan (1985) Test of X Series'); call tabulate(order,test,prob); call hinich96(x,0.0,V,H); call print('Mean Data for Hinich(96) Test on X',V,H); c=grid(.2 .45,.02); v=array(norows(c):); h=array(norows(c):); do i=1,norows(c); call hinich96(x,c(i),vv,hh); v(i)=vv; h(i)=hh; enddo; call print('Hinich(96) Test on X for various c values'); call tabulate(c,v,h); call print('Simple Nonlinear Data'); i=integers(norows(x)-1); xx=array(norows(i):); xx=x(i+1)*dexp(x(i))+rn(xx); call graph(acf(xx) :heading 'Graph of acf of xx'); call tsay(xx,10,tsaytest,prob:); call hinich82(xx,m,g,l:smoothspec); call print('Hinich Test on xx'); call tabulate(m,g,l); call bds(xx,.5,10:); do i=2,10; call keenan(xx,tt,i,pp); j=i-1; test(j) =tt; prob(j) =pp; order(j) =i; enddo; call print('Keenan (1985) Test of XX Series'); call tabulate(order,test,prob); call hinich96(xx,0.0,V,H); call print('Mean Data for Hinich(96) Test on XX',V,H); c=grid(.2 .45,.02); v=array(norows(c):); h=array(norows(c):); do i=1,norows(c); call hinich96(xx,c(i),vv,hh); v(i)=vv; h(i)=hh; enddo; call print('Hinich(96) Test on XX for various c values'); call tabulate(c,v,h); b34srun; == ==TPAD Test PAD Subroutine b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(pad); call print(pad); call pad(gasout,ngasout,10,20,missing()); call tabulate(gasout,ngasout); b34srun; == ==TO_RMATRIX Convert object to Row-Matrix b34sexec matrix; /; testm=vpa(matrix(2,2:1 2 3 4)); testm=(matrix(2,2:1 2 3 4)); testv=vector(:1 2 3 4 ); call print(testm,testv); call print(to_rmatrix(testm)); call print(to_rmatrix(testv)); call print(to_rmatrix(22.)); call print(to_cmatrix(testm)); call print(to_cmatrix(testv)); call print(to_cmatrix(22.)); call print(to_rarray(testm)); call print(to_rarray(testv)); call print(to_carray(testm)); call print(to_carray(testv)); call print(to_vector(testm)); call print(to_array(testm)); call print(to_vector(1.)); call print(to_array(2.)); b34srun; == ==TO_CMATRIX Convert object to Col-Matrix b34sexec matrix; /; testm=vpa(matrix(2,2:1 2 3 4)); testm=(matrix(2,2:1 2 3 4)); testv=vector(:1 2 3 4 ); call print(testm,testv); call print(to_rmatrix(testm)); call print(to_rmatrix(testv)); call print(to_rmatrix(22.)); call print(to_cmatrix(testm)); call print(to_cmatrix(testv)); call print(to_cmatrix(22.)); call print(to_rarray(testm)); call print(to_rarray(testv)); call print(to_carray(testm)); call print(to_carray(testv)); call print(to_vector(testm)); call print(to_array(testm)); call print(to_vector(1.)); call print(to_array(2.)); b34srun; == ==TO_RARRAY Convert object to Row-ARRAY b34sexec matrix; /; testm=vpa(matrix(2,2:1 2 3 4)); testm=(matrix(2,2:1 2 3 4)); testv=vector(:1 2 3 4 ); call print(testm,testv); call print(to_rmatrix(testm)); call print(to_rmatrix(testv)); call print(to_rmatrix(22.)); call print(to_cmatrix(testm)); call print(to_cmatrix(testv)); call print(to_cmatrix(22.)); call print(to_rarray(testm)); call print(to_rarray(testv)); call print(to_carray(testm)); call print(to_carray(testv)); call print(to_vector(testm)); call print(to_array(testm)); call print(to_vector(1.)); call print(to_array(2.)); b34srun; == ==TO_CARRAY Convert object to Col-Array b34sexec matrix; /; testm=vpa(matrix(2,2:1 2 3 4)); testm=(matrix(2,2:1 2 3 4)); testv=vector(:1 2 3 4 ); call print(testm,testv); call print(to_rmatrix(testm)); call print(to_rmatrix(testv)); call print(to_rmatrix(22.)); call print(to_cmatrix(testm)); call print(to_cmatrix(testv)); call print(to_cmatrix(22.)); call print(to_rarray(testm)); call print(to_rarray(testv)); call print(to_carray(testm)); call print(to_carray(testv)); call print(to_vector(testm)); call print(to_array(testm)); call print(to_vector(1.)); call print(to_array(2.)); b34srun; == ==TO_VECTOR Convert object to VECTOR b34sexec matrix; /; testm=vpa(matrix(2,2:1 2 3 4)); testm=(matrix(2,2:1 2 3 4)); testv=vector(:1 2 3 4 ); call print(testm,testv); call print(to_rmatrix(testm)); call print(to_rmatrix(testv)); call print(to_rmatrix(22.)); call print(to_cmatrix(testm)); call print(to_cmatrix(testv)); call print(to_cmatrix(22.)); call print(to_rarray(testm)); call print(to_rarray(testv)); call print(to_carray(testm)); call print(to_carray(testv)); call print(to_vector(testm)); call print(to_array(testm)); call print(to_vector(1.)); call print(to_array(2.)); b34srun; == ==TO_ARRAY Convert object to ARRAY b34sexec matrix; /; testm=vpa(matrix(2,2:1 2 3 4)); testm=(matrix(2,2:1 2 3 4)); testv=vector(:1 2 3 4 ); call print(testm,testv); call print(to_rmatrix(testm)); call print(to_rmatrix(testv)); call print(to_rmatrix(22.)); call print(to_cmatrix(testm)); call print(to_cmatrix(testv)); call print(to_cmatrix(22.)); call print(to_rarray(testm)); call print(to_rarray(testv)); call print(to_carray(testm)); call print(to_carray(testv)); call print(to_vector(testm)); call print(to_array(testm)); call print(to_vector(1.)); call print(to_array(2.)); b34srun; == ==TPROB Student t distribution b34sexec matrix; t=2.447; df=6.; p=tprob(t,df); call print('The prob: that a t(',df,') variate is GE abs(', t,') is ',p,'Note answer should be .9500'); b34srun; == ==TRACE TRACE function => Trace of a matrix b34sexec matrix; m=matrix(3,3:1 2 3 4 5 6 7 8 9); call names(all); t=trace(m); call print('Matrix M',m); call print('Trace of M',t); e=eigenval(m); call print('Sum of eigenvalues = trace',sum(e),trace(m)); b34srun; == ==TRANSPOSE Transpose function => Transpose of a matrix b34sexec matrix; real8=matrix(3,3:1 2 3 4 5 6 7 8 9); call print('Matrix and its transpose',real8,transpose(real8)); comp=complex(real8,real8); call print('Complex*16 Matrix and its transpose',comp,transpose(comp)); nn=namelist(a b c d e f g h i); nn2=array(3,3:nn); call print('Matrix and its transpose',nn2 ,transpose(nn2 )); call character(cc,'ABCDEFGHI'); ch1=c1array(3,3:cc); call print('Matrix and its transpose',ch1 ,transpose(ch1 )); int4=idint(real8);real4=sngl(real8); r16=r8tor16(real8); call print('Integer Matrix and its transpose',int4,transpose(int4)); call print('Real*4 Matrix and its transpose',real4,transpose(real4)); call print('Real*16 Matrix and its transpose',r16,transpose(r16)); c16=complex(real8,sqrt(real8)); c32=c16toc32(c16); call print('Complex*16 Matrix and its transpose',c16,transpose(c16)); call print('Complex*32 Matrix and its transpose',c32,transpose(c32)); b34srun; == ==TRATS_1 Rats running under Matrix Command /$ /$ Illustrates calling rats under b34s MATRIX /$ Missing data passed /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; newgaso(3)=missing(); call makerats(gasin,newgasi,gasout,newgaso :file 'full.por'); call print(mean(gasin)); call open(70,'rats.in'); call character(cc,'all 3000'); call write(cc,70); call character(cc,"open data 'full.por'"); call write(cc,70); call character(cc,'data(format=portable)'); call write(cc,70); call character(cc,'table'); call write(cc,70); call character(cc,'print'); call write(cc,70); call character(cc,'linreg gasout'); call write(cc,70); call character(cc,'# gasin{0 to 20} gasout{1 to 20}'); call write(cc,70); call rewind(70); call close(70); /$ note : call dodos('start /w /r rats32s rats.in /run',:); call dounix('rats rats.in rats.out',:); call copyout('rats.out'); b34srun; == ==TRATS_2 Passing a Matrix /$ /$ Illustrates calling rats under b34s MATRIX /$ b34sexec matrix; x=rn(matrix(700,6:)); call makerats(x :file 'full.por'); call open(70,'rats.in'); call rewind(70); call character(cc,'all 3000'); call write(cc,70); call character(cc,"open data 'full.por'"); call write(cc,70); call character(cc,'data(format=portable)'); call write(cc,70); call character(cc,'table'); call write(cc,70); call character(cc,'print'); call write(cc,70); call rewind(70); call close(70); /$ Note : call dodos('start /w /r rats32s rats.in /run',:); call dounix('rats rats.in rats.out',:); call copyout('c:\junk\rats.out'); b34srun; == ==TRATS_3 Passes 999 series from b34s to RATS /$ /$ Illustrates calling rats under b34s MATRIX /$ 999 series generated and passed to rats /$ b34sexec matrix; x=rn(matrix(10,999:)); call print(mean(x(,1)),mean(x(,6)),mean(x(,999))); call makerats(x :file 'full.por'); call open(70,'rats.in'); call rewind(70); call character(cc,'all 20'); call write(cc,70); call character(cc,"open data 'full.por'"); call write(cc,70); call character(cc,'data(format=portable)'); call write(cc,70); call character(cc,'table'); call write(cc,70); call rewind(70); call close(70); /$ Note : call dodos('start /w /r rats32s rats.in /run',:); call dounix('rats rats.in rats.out',:); call copyout('c:\junk\rats.out'); b34srun; == ==TRIPLES Triples Reversal Test b34sexec matrix ; * Program tests TRIPLES test using internal MATRIX Command; * Correct Answers should be: ; * eta =-.23333 ; * vareta = .01333 ; * Stat =-2.0207 ; n=6; x=vector(n: 2.373, 3.339, 1.980, 3.102, 0.000 3.335) ; call triples(x :print); n=100; x=rn(vector(n:)); call triples(x :print); b34srun ; == ==TRIPLES_2 Tests Triples using MATRIX Code b34sexec matrix ; * Program tests TRIPLES test using MATRIX Command; * Program written by Jin-Man Lee ; * Correct Answers should be: ; * eta =-.23333 ; * vareta = .01333 ; * Stat =-2.0207 ; call echooff ; * Program uses makeglobal to move x array around and save memory ; N = 6 ; * x=rn(vector(n:)) ; x=vector(n: 2.373, 3.339, 1.980, 3.102, 0.000 3.335) ; NN = dfloat(N) ; call makeglobal(x,n); /; *************************** function fstar(i,j,k) ; t1=x(i)+x(j)-2.0*x(k) ; t2=x(i)+x(k)-2.0*x(j) ; t3=x(k)+x(j)-2.0*x(i) ; t4=t1*t2*t3 ; if (t4 .eq. 0.0) then ; tmp = 0.0 ; endif ; if (t4 .ne. 0.0) then ; t1=t1/dabs(t1) ; t2=t2/dabs(t2) ; t3=t3/dabs(t3) ; tmp=(t1+t2+t3)/3.0 ; endif ; return(tmp) ; end ; /; *************************** function fx1i(i) ; t1=0.0 ; iia = i+1 ; if(i.lt.3) go to loop1 ; do j=1,i-2 ; do k=j+1,i-1 ; t1temp = fstar(j,k,i) ; t1=t1+t1temp ; enddo ; enddo ; loop1 continue ; if(i.lt.2) go to loop2 ; if(iia.gt.n) go to loop2 ; do j=1,i-1 ; do k=i+1,n ; t1temp = fstar(j,i,k) ; t1=t1+t1temp ; enddo ; enddo ; loop2 continue ; n_1 = n-1 ; if(iia.gt.n_1)go to loop3 ; do j=iia,n-1 ; do k=j+1,n ; t1temp = fstar(i,j,k) ; t1=t1+t1temp ; enddo ; enddo ; loop3 continue ; return(t1) ; end ; /; *************************** /; *************************** function fx2ij(i,j) ; ii=i ; jj=j ; if(i.gt.j)then ; ii=j ; jj=i ; endif ; iia = ii+1 ; jj_1 = jj-1 ; jja = jj+1 ; t1=0.0 ; if(ii.le.1)go to loop1 ; do k=1,ii-1 ; t1temp =fstar(k,ii,jj) ; t1=t1+ t1temp ; enddo ; loop1 continue ; if(jj.le.1)go to loop2 ; if(iia.gt.jj_1)go to loop2 ; do k=ii+1,jj-1 ; t1temp =fstar(ii,k,jj) ; t1=t1+ t1temp ; enddo ; loop2 continue ; if(jja.gt.n)go to loop3 ; do k=jj+1,n ; t1temp =fstar(ii,jj,k) ; t1=t1+ t1temp ; enddo ; loop3 continue; return(t1) ; end ; /; *************************** halfn=dint(nn/2.0) ; nnmin2=nn-2.0 ; nnchus3=(nn*(nn-1.0)*(nn-2.0))/6.0 ; nnchus2=(nn*(nn-1.0))/2.0 ; nnmin1c2=((nn-1.0)*(nn-2.0))/2.0 ; /; calculate eta eta = 0.0 ; do i=1, n-2 ; do j=i+1, n-1 ; do k=j+1, n ; eta1 = fstar(i,j,k) ; eta = eta + eta1 ; enddo ; enddo ; enddo ; eta=eta/nnchus3 ; /; calculate ksi1 ksi1=0.0 ; do i=1,n ; tempt1 = fx1i(i) ; temp=tempt1/nnmin1c2 ; temp2=(temp-eta)*(temp-eta) ; ksi1=ksi1+temp2 ; enddo ; ksi1=ksi1/nn ; /; call print('ksi1 : ',ksi1) ; /; calculate ksi2 ksi2=0.0 ; do i=1,n-1 ; do j=i+1,n ; tempt1=fx2ij(i,j) ; temp = tempt1/nnmin2 ; temp2=(temp-eta)*(temp-eta) ; ksi2=ksi2+temp2 ; enddo ; enddo ; ksi2=ksi2/nnchus2 ; /; call print('ksi2 : ',ksi2) ; /; calculate ksi3 ksi3=(1.0/9.0)-(eta*eta) ; /; call print('ksi3 : ',ksi3) ; /; calculate variance v=ksi1*3.0*(nn-3.0)*(nn-4.0)/2.0 ; v=v+(ksi2*3.0*(nn-3.0))+ksi3 ; v=v/nnchus3 ; /; calculate test statistic (which is std. n) if (v.gt.0.0)then ; stat3 = eta/dsqrt(v) ; endif ; if (v.le.0.0)then ; stat3 = 999999 ; endif ; call print('ETA : ',eta :); call print('VARIANCE : ',v :); call print('TRIPLES Test STAT : ',stat3 :); b34srun ; == ==TSASNL_1 Tests SAS NONLIN Test Problem # 1 /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Data from SAS NLIN b34sexec data Heading('Exponential Growth Curve') fileff=@@; input x y; datacards; 020 0.57 030 0.72 040 0.81 050 0.87 060 0.91 070 0.94 080 0.95 090 0.97 100 0.98 110 0.99 120 1.00 130 0.99 140 0.99 150 1.00 160 1.00 170 0.99 180 1.00 190 1.00 200 0.99 210 1.00 b34sreturn; b34srun; b34sexec matrix; call loaddata; * SAS NLIN Example # 1 ; * Coef SE ; * .99618857 0.00161380 ; * .04195389 0.00039823 ; call tabulate (x,y); program test; call echooff; yhat=b0*(1.0-dexp((-1.)*b1*x)); res=y-yhat; call outstring(3,3,'Coefficients'); call outstring(3,4,'b0 b1'); call outdouble(14,4,b0); call outdouble(34,4,b1); return; end; call print(test); call nllsq(y,yhat :name test :parms b0 b1 :ivalue array(2:.1 .1) :restrict idint(array(2:0 1)) :print result residuals); call graph(%res); call nl2sol(res :name test :parms b0 b1 :ivalue array(2:.1 .1) :print :maxit 5000 :maxfun 5000); b34srun; == ==TSASNL_2 Tests SAS NONLIN Test Problem # 2 /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Data from SAS NLIN b34sexec data Heading('CES Production Function') fileff=@@; input labor capital logq; datacards; .228 .802 -1.359 .258 .249 -1.695 .821 .771 .193 .767 .511 -0.649 .495 .758 -0.165 .487 .425 -0.270 .678 .452 -0.473 .748 .817 .031 .727 .845 -0.563 .695 .958 -0.125 .458 .084 -2.218 .981 .021 -3.633 .002 .295 -5.586 .429 .277 -0.773 .231 .546 -1.315 .664 .129 -1.678 .631 .017 -3.879 .059 .906 -2.301 .811 .223 -1.377 .758 .145 -2.270 .050 .161 -2.539 .823 .006 -5.150 .483 .836 -0.324 .682 .521 -0.253 .116 .930 -1.530 .440 .495 -0.614 .456 .185 -1.151 .342 .092 -2.089 .358 .485 -0.951 .162 .934 -1.275 b34sreturn; b34srun; b34sexec matrix; call loaddata; * SAS NLIN Example # 2 ; * CES Production Function ; * Coef SE ; * 0.12448510 0.07834296 ; * -0.33634124 0.27218006 ; * 0.33670746 0.13608506 ; * -3.01061741 2.32290326 ; call tabulate (labor,capital,logq); program test; call echooff; yhat=b0+a*dlog(d*(labor**r)+(1.0-d)*(capital**r)); res=logq-yhat; call outstring(3,3,'Coefficients'); call outstring( 3,4,'b0 a d r'); call outdouble(14,4,b0); call outdouble(34,4,a); call outdouble(14,5,d); call outdouble(34,5,r); return; end; call print(test); call nllsq(logq,yhat :name test :parms b0 a d r :ivalue array(4:1.,-1.,.5,-1.) :print result residuals); call graph(%res); call nl2sol(res :name test :parms b0 a d r :ivalue array(4:1.,-1.,.5,-1.) :print :maxit 5000 :maxfun 5000); b34srun; == ==TSASNL_3 Tests SAS NONLIN Test Problem # 3 /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Data from SAS NLIN b34sexec data Heading('Probit Model') fileff=@@; input year pop; build x; gen x=year-1790.; datacards; 1790 3.929 1800 5.308 1810 7.239 1820 9.638 1830 12.866 1840 17.069 1850 23.191 1860 31.443 1870 39.818 1880 50.155 1890 62.947 1900 75.994 1910 91.972 1920 105.710 1930 122.775 1940 131.669 1950 151.325 1960 179.323 1970 203.211 b34sreturn; b34srun; b34sexec matrix; call loaddata; x=year-1790.; * SAS NLIN Example # 3 ; * Sas Results from 1982 SAS Stat Guide; * Coef SE ; * -2.309281826 .03283271 ; * 0.01262851 .00095699 ; * 407.0826671 61.78489847 ; * ; * Residual Sum of squares 17.36980304 ; call tabulate (year,x,pop); program test; call echooff; yhat=c*probnorm(a+b*x); res=pop-yhat; call outstring(3,3,'Coefficients'); call outstring( 3,4,'a b c'); call outdouble(14,4,a); call outdouble(34,4,b); call outdouble(14,5,c); return; end; call print(test); call nllsq(pop,yhat :name test :parms a b c :diff array(3:.1d-9,.1d-9,.1d-9) :eps2 .1d-13 :eps1 .1d-10 :ivalue array(3:-2.4,.012,400.) :print result residuals); call graph(%res); call nl2sol(res :name test :parms a b c :ivalue array(3:-2.4,.012,400.) :print :maxit 5000 :maxfun 5000); b34srun; == ==T_ALIAS Tests Alias /; Test alias b34sexec matrix; x=2.5; y=3.5; xm=rn(matrix(3,3:)); xy=array(:x,y); r4x=sngl(x); call print(LOG(x), dlog(x)) ; call print(ln(x), dlog(x)) ; call print(log10(x), dlog10(x)) ; call print(exp(x), dexp(x)) ; call print(mod(x,2.), dmod(x,2.)); call print(max(xy), dmax(xy)) ; call print(max1(x,y), dmax1(x,y)); call print(min(xy), dmin(xy)) ; call print(inverse(xm), inv(xm)) ; call print(sin(x), dsin(x)) ; call print(cos(x), dcos(x)) ; call print(i4tor8(8), dfloat(8)) ; call print(i4tor4(8), float(8)) ; call print(sqrt(x), dsqrt(x)) ; call print(sinh(x), dsinh(x)) ; call print(gamma(x), dgamma(x)) ; call print(cosh(x), dcosh(x)) ; call print(conj(complex(x,y)), dconj(complex(x,y))); call print(atan(x), datan(x)) ; call print(atan2(x,y), datan2(x,y)); call print(arsin(.5), darsin(.5)); call print(arcos(.5), darcos(.5)); call print(abs(-3.6), dabs(-3.6)); call print(r8tor4(x), sngl(x)) ; call print(r4tor8(sngl(x)), dble(sngl(x))); b34srun; == ==TSAY Tsay (1986) Nonlinearity Test b34sexec options ginclude('gas.b34'); b34srun; b34sexec reg; model gasout=gasin{0 to 12} gasout{1 to 12}; bispec iauto iturno bds tsay tsayorder=10; b34srun; b34sexec options ginclude('b34sdata.mac') member(blake); b34srun; b34sexec matrix; * Both TSAY and BDS tests illustrated ; call loaddata; call bds(blake,.5,5:); call tsay(blake,20,tsaytest,prob:); call print('Random Data'); x=rn(array(5000:)); call tsay(x,20,tsaytest,prob:); b34srun; == ==TSCA_1 Runs SCA Under B34S and B34S MATRIX /$ /$ Test job shows SCA Under B34S and Under B34S MATRIX Command /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec options open('sca.dat') disp=unknown unit(28)$ b34srun$ b34sexec options open('sca.cmd') disp=unknown unit(29)$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec options dodos('erase scadata.fsv') dounix('rm scadata.fsv'); b34srun; b34sexec pgmcall$ sca scafname=mydata$ pgmcards$ /$#==myrun --- these commands are required to load the b34s data. --- assign file 18. attrib access(read). external 'sca.dat'. call procedure is mydata. file is 18. --- --- User can place any sca commands after here. A number --- of sample setups can be uncommented --- print age, ecg, chd, cat, wt --- crosstab cat, age. --- crosstab age, ecg, chd, cat. weight is wt. --- print gasin, gasout. --- acf gasin. --- regress variables are gasout gasin --- SCA Expert commands --- iarima gasout. hold residuals(res) --- estim utsmodel. method is exact. --- forecast utsmodel. --- VAR Identification --- ccm gasin, gasout. maxlag is 12. --- stepar gasin, gasout. arfits are 1 to 6. @ --- rccm are 1,2. output level(detailed). --- fsave series1. file is 'my.fsv'. dataset is test. --- --- iarima gasout. estim utsmodel. method is exact. hold residuals(testres). print testres. fsave testres. file is 'scadata.fsv'. dataset is test. stop. return /$#== b34sreturn$ b34srun$ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options dounix('sca sca.cmd > sca.out') dodos('scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out')$ b34srun$ b34sexec options npageout writeout('output from sca',' ',' ') copyfout('sca.out') dodos('erase sca.cmd','erase sca.out','erase sca.dat') dounix('rm sca.cmd', 'rm sca.out','rm sca.dat') $ /$ data back to b34s b34sexec matrix; call getsca('scadata.fsv', :member test); call print(testres); testres=goodrow(testres); call graph(testres); b34srun; /$ SCA Under B34S MATRIX Command b34sexec matrix; * calls SCA and gets the model; call echooff; do i=1,3; ar=array(:.7,-.5,.2 ); ma=array(:-.5,-.25); n=1000; start=array(:.1,.05,.0375); testdat=genarma(ar,ma,1.0,start,.1,n); /$ testdat=rn(array(1000:)); call print(mean(testdat)); call dodos('start /w /r erase full.fsv',:); call dounix( 'rm full.fsv',:); call dodos('start /w /r erase scadata.fsv',:); call dounix( 'rm scadata.fsv',:); call makesca(testdat :file 'full.fsv' :member test); call open(70,'sca.cmd'); call rewind(70); call character(cc,'==myrun'); call write(cc,70); call character(cc, "finput file is 'FULL.FSV'. dataset is test."); call write(cc,70); call character(cc,'iarima testdat.'); call write(cc,70); call character(cc, 'estim utsmodel. method is exact. hold residuals(testres).'); call write(cc,70); call character(cc,'print testres.'); call write(cc,70); call character(cc, "fsave testres. file is 'scadata.fsv'. dataset is test. rewind" ); call write(cc,70); call character(cc,'stop.'); call write(cc,70); call character(cc,'return'); call write(cc,70); call character(cc,'=='); call write(cc,70); call rewind(70); call close(70); call dounix('sca sca.cmd > sca.out') call dodos( 'start /w /r scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out',:); call getsca('scadata.fsv', :member test); call copyout('sca.out'); call print(testres); testres=goodrow(testres); call graph(testres); enddo; b34srun; == ==TSCA_2 SCA Called in Do Loop from B34S / MATRIX /$ /$ SCA Under B34S MATRIX Command /$ /$ 5000 observations done. ARMA commands tested in terms of SSR /$ Table at End of Job contrasts the programs /$ b34sexec matrix; * calls SCA and gets the model; * Tests Sum of squared residuals with both systems ; call echooff; n=10; b34ssr=array(n:); scassr=array(n:); do i=1,n; ar=array(:.7,-.5,.2 ); ma=array(:-.5); n=5000; start=array(:.1,.05,.0375); testdat=genarma(ar,ma,1.0,start,.1,n); /$ use b34s routines call arma(testdat :nar 5 nma 3 :print); call print('Mean of Test Data ',mean(testdat)); call print('B34s ARMA sumsq res ',sumsq(goodrow(%res))); b34sssr(i)=sumsq(goodrow(%res)); call dodos('start /w /r erase full.fsv',:); call dounix( 'rm full.fsv',:); call dodos('start /w /r erase scadata.fsv',:); call dounix( 'rm scadata.fsv',:); call makesca(testdat :file 'full.fsv' :member test); call open(70,'sca.cmd'); call rewind(70); call character(cc,'==myrun'); call write(cc,70); call character(cc, "finput file is 'FULL.FSV'. dataset is test."); call write(cc,70); call character(cc,'iarima testdat.'); call write(cc,70); call character(cc, 'estim utsmodel. method is exact. hold residuals(testres).'); call write(cc,70); /$ call character(cc,'print testres.'); /$ call write(cc,70); call character(cc, "fsave testres. file is 'scadata.fsv'. dataset is test. rewind" ); call write(cc,70); call character(cc,'stop.'); call write(cc,70); call character(cc,'return'); call write(cc,70); call character(cc,'=='); call write(cc,70); call rewind(70); call close(70); call dounix('sca sca.cmd > sca.out'); call dodos( 'start /w /r scaw32 10000 /f:sca.cmd /p:myrun /o:sca.out',:); call getsca('scadata.fsv', :member test); call copyout('sca.out'); /$ call print(testres); testres=goodrow(testres); call print('Mean of SCA Estimated Residual ',mean(testres)); call print('Sum of Squared SCA Residuals ',sumsq(testres)); scassr(i)=sumsq(testres); /$ call graph(testres); enddo; call tabulate(b34sssr,scassr); b34srun; == ==TSD TSD Data Base IO Examples b34sexec matrix; /; List what is in Libraries call tsd(:info :file 'c:\b34slm\examples\tsd1.tsd'); call tsd(:info :file 'c:\b34slm\examples\tsd2.tsd'); call tsd(:info :file 'c:\b34slm\examples\tsd3.tsd'); /; call tsd(:info :file '/usr/local/lib/b34slm/tsd1.tsd'); /; call tsd(:info :file '/usr/local/lib/b34slm/tsd2.tsd'); /; call tsd(:info :file '/usr/local/lib/b34slm/tsd3.tsd'); /; Load all series call tsd(:load :file 'c:\b34slm\examples\tsd1.tsd' :notime); call tsd(:load :file 'c:\b34slm\examples\tsd3.tsd' ); call tsd(:load :file 'c:\b34slm\examples\tsd2.tsd' :notime); /; call tsd(:load :file '/usr/local/lib/b34slm/tsd1.tsd' :notime); /; call tsd(:load :file '/usr/local/lib/b34slm/tsd3.tsd' ); /; call tsd(:load :file '/usr/local/lib/b34slm/tsd2.tsd' :notime); /; Use date from tsd3.tsd to get fyear year=fyear(%tsd_142); call tabulate(%tsd_142,year,%ser_142 :format '(f10.4)'); call names; /; Building and testing x=dfloat(integers(10)); y=x*x; call print(mean(x)); call tsd(:put x :file 'new.tsd' :new); call tsd(:put y :file 'new.tsd' :add :timeseries juldaydmy(1,1,1960) 4.); call tsd(:put ce :file 'new.tsd' :add); call free(x,ce); call tsd(:load :file 'new.tsd' :print); call clearall; call tsd(:get ce :file 'new.tsd' :print); call tsd(:get x :file 'new.tsd' :rename newx :print :datename newxdate); call names; b34srun; == ==TSD_BJ TSD Dataset to Automatic BJ Model Building b34sexec matrix; call load(rtest); call echooff; call tsd(:load :file 'c:\b34slm\examples\tsd3.tsd' :notime :nomessage); /; list names in workspace in %names% to further process automatically call names(:); /; Building and testing n=norows(%names%); call print('Number of Series Loaded ',n:); do i=1,n; if(kind(argument(%names%(i))).eq.8.and. freq(argument(%names%(i))).ne.0.0)then; call print('++++++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Automatic BJ Model for ',label(argument(%names%(i))):); call print('Timestart was ',timestart(argument(%names%(i))):); call print('Timebase was ',timebase(argument(%names%(i))):); call print('FREQ was ',freq(argument(%names%(i))):); call print('++++++++++++++++++++++++++++++++++++++++++++++++++++++++':); /; /; Estimate a BJ model using Automatic Procedure. /; call autobj(argument(%names%(i)) :print :nac 24 :npac 24 :seasonal idint(freq(argument(%names%(i)))) :autobuild ); /; /; Residual Analysis /; /; call rtest(%res,argument(%names%(i)),48); /; endif; enddo; b34srun; == ==TSD_1 Accessing TSD data and Processing /; /; Shows line up and purging time series data. /; Due to possible missing data inside the series the timestart /; and timebase have not been set. Howeber a date variable can /; added to preserve the date of each observation /; b34sexec matrix; call tsd(:get c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call tsd(:get c96c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call tsd(:get cd :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call names(:); /; do i=1,norows(%names%); /; call print(argument(%names%(i))); /; enddo; call names; call tabulate(c c96c cd); call tslineup(c c96c cd); call tabulate(c c96c cd); call align(c c96c cd); call tabulate(c c96c cd); call names; /; Using a date variable call clearall; call tsd(:get c :file 'c:\b34slm\tsd3.tsd' :print :nomessage :datename a1); call tsd(:get c96c :file 'c:\b34slm\tsd3.tsd' :print :nomessage :datename a2); call tsd(:get cd :file 'c:\b34slm\tsd3.tsd' :print :nomessage :datename a3); call names(:); /; do i=1,norows(%names%); /; call print(argument(%names%(i))); /; enddo; call names; call tabulate( c a1 c96c a2 cd a3); call tslineup( c a1 c96c a2 cd a3); call tabulate( c a1 c96c a2 cd a3); call align( c a1 c96c a2 cd a3); dates=chardate(a1); call tabulate(dates,c,a1,c96c,a2,cd,a3 :title 'Lined up data with dates'); call names; year=fyear(a1); call graph(year,c c96c cd :plottype xyplot :Heading 'TSD Data'); b34srun; == ==TSLINEUP Time Series Data Lined up /; /; Shows line up and purging time series data. /; Due to possible missing data inside the series the timestart /; and timebase have not been set. Howeber a date variable can /; added to preserve the date of each observation /; b34sexec matrix; call tsd(:get c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call tsd(:get c96c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call tsd(:get cd :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage); call names(:); /; do i=1,norows(%names%); /; call print(argument(%names%(i))); /; enddo; call names; call tabulate(c c96c cd); call tslineup(c c96c cd); call tabulate(c c96c cd); call align(c c96c cd); call tabulate(c c96c cd); call names; /; Using a date variable call clearall; call tsd(:get c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage :datename a1); call tsd(:get c96c :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage :datename a2); call tsd(:get cd :file 'c:\b34slm\examples\tsd3.tsd' :print :nomessage :datename a3); call names(:); /; do i=1,norows(%names%); /; call print(argument(%names%(i))); /; enddo; call names; call tabulate( c a1 c96c a2 cd a3); call tslineup( c a1 c96c a2 cd a3); call tabulate( c a1 c96c a2 cd a3); call align( c a1 c96c a2 cd a3); dates=chardate(a1); call tabulate(dates,c,a1,c96c,a2,cd,a3 :title 'Lined up data with dates'); call names; year=fyear(a1); call graph(year,c c96c cd :plottype xyplot :Heading 'TSD Data'); b34srun; == ==TSLINEUP2 All series loaded /; /; Shows line up and purging time series data. /; Due to possible missing data inside the series the timestart /; and timebase have not been set. However a date variable has been /; added to preserve the date of each observation as has been done /; here /; b34sexec matrix; call echooff; call tsd(:load :file 'c:\b34slm\examples\tsd3.tsd' /; :print :nodate :nomessage); call load(tsalign :staging); call tsalign; call tabulate(cdate,year,c,cd); call graph(year c :plottype xyplot); b34srun; == ==TSLINEUP3 Simple Example where one series loaded and one built /; b34sexec matrix; call echooff; call tsd(:get c :file 'c:\b34slm\examples\tsd3.tsd' /; :print :nodate :nomessage); logc =dlog(c); call settime(logc,timebase(c),timestart(c),freq(c)); /; get %julian% if had :nodate on call tslineup(logc c); year=fyear(%julian%); cdate=chardate(%julian%); call tabulate(year c logc ); call graph(year logc :plottype xyplot); b34srun; == ==TSLINEUP4 Time Series Align Example 1 /; /; Updates to variable time info /; b34sexec options ginclude('b34sdata.mac') member(c_s_house); b34srun; b34sexec matrix; call get(lspcs20r,lnffrate); call describe(lnffrate:); /; /; Save frequency and put in missing data prior to align /; ffhold=freq(lspcs20r); call tslineup(lspcs20r,lnffrate); call tabulate(%julian%,lspcs20r,lnffrate); /; /; /; Get dates set right /; /; call copytime(lspcs20r,%julian%); call align( %julian%,lspcs20r,lnffrate); call julian_to_tb(%julian%(1),ffhold,itbase,itstart); call settime(%julian%,itbase,itstart,ffhold); call copytime(%julian%, lspcs20r); call copytime(%julian%, lnffrate); /; /; see what we get /; call describe(lspcs20r:); call describe(lnffrate:); b34srun; == ==UP_DATE_TB Updates the info in tbase and tstart b34sexec matrix; call echooff; n=10; tbase=1972; tstart=3; freq1=12.; ioff=8; x=rn(array(n:)); call settime(x,tbase,tstart,freq1); y=rn(array(n-8:)); call up_date_tb(tbase,tstart,freq1,ntbase,ntstart,ioff); call settime(y,ntbase,ntstart,freq1); call describe(x :print); call describe(y :print); call tabulate(x); call tabulate(y); b34srun; == ==UPPERT Upper Triangle b34sexec matrix; x=rn(matrix(4,4:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); cx=complex(x,x*2.); x=r8tor16(x); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); cx=c16toc32(cx); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); b34srun; == ==UROOT_T /; Testing DF and PP using Hamilton as a reference %b34slet runsas = 0; b34sexec options ginclude('b34sdata.mac') member (hamilton1); b34srun; b34sexec matrix; call loaddata; call echooff; call load(df_pp :staging); call load(kpss); call load(df_gls); call load(uroot_t); n=5; call uroot_t(tbill, 'Tbill Rate Data From Hamilton',n,1,0); * call uroot_t(tbill, 'Tbill Rate Data From Hamilton',n,2,0); call print(' ':); * call uroot_t(ln_gnp,'Tbill Rate Data From Hamilton',n,1,1); call uroot_t(ln_gnp,'log(gnp) Data From Hamilton', n,1,0); call print(' ':); /; /; Generate random series to be tested /; randata =rn(array(100:)); nrandata=cusum(randata); n=6; call uroot_t(randata, 'Random Data ',n,1,0); call print(' ':); call uroot_t(nrandata,'Non Random Data',n,1,0); call print(' ':); call df_pp(tbill, 'Tbill Rate Data From Hamilton',n); call print(' ':); call df_pp(ln_gnp,'log(gnp) Data From Hamilton',n); b34srun; %b34sif(&runsas.ne.0)%then; b34sexec options open('testsas.sas') unit(29) disp=unknown$ b34srun$ b34sexec options clean(29) $ b34seend$ b34sexec pgmcall idata=29 icntrl=29$ sas $ * sas commands next ; pgmcards$ proc arima; identify var=tbill stationarity=(pp=4); run; proc arima; identify var=ln_gnp stationarity=(pp=4); run; proc arima; identify var=tbill stationarity=(dicky=4); run; proc arima; identify var=ln_gnp stationarity=(dicky=4); run; b34sreturn$ b34srun $ b34sexec options close(29)$ b34srun$ /$ the next card has to be modified to point to sas location /$ be sure and wait until sas gets done before letting b34s resume /$ *************************************************************** b34sexec options dodos('start /w /r sas testsas' ) dounix('sas testsas' ) $ b34srun$ b34sexec options npageout noheader writeout(' ','output from sas',' ',' ') writelog(' ','output from sas',' ',' ') copyfout('testsas.lst') copyflog('testsas.log') dodos('erase testsas.sas','erase testsas.lst','erase testsas.log') dounix('rm testsas.sas','rm testsas.lst','rm testsas.log') $ b34srun$ b34sexec options header$ b34srun$ %b34sendif; == ==VARRESDC Variance Decomposition b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ This validates with BTEST %b34slet testvc=0; /; This tests with RATS %b34slet runrats=1; 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); call varstab(beta,compmat,eigdata,modulus,1); pcgin1 =pcdecomp(,1); pcgin2 =pcdecomp(,3); pcgout1=pcdecomp(,2); pcgout2=pcdecomp(,4); gin1 =vardc(,1); gin2 =vardc(,3); gout1=vardc(,2); gout2=vardc(,4); call graph(pcgin1 pcgout1 :nocontact :pgborder :nolabel :grid :heading 'Variance decomposition for gasin model'); call graph(pcgin2,pcgout2 :nocontact :pgborder :nolabel :grid :heading 'Variance decomposition for gasout model'); call graph(gin1,gout1 :nocontact :pgborder :nolabel :heading 'Effect of a shock in gasin model'); call graph(gin2,gout2 :nocontact :pgborder :nolabel :heading 'Effect of a shock in gasout model'); b34srun; /; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ %b34sif(&testvc.ne.0)%then; /$ /$ Note slight differences in Coef since calculation done with /$ nonlinear procedure /$ b34sexec btest$ title=('Estimation run with gas data') $ seriesn var=gasin name=('b-j gas input data') $ seriesn var=gasout name=('b-j gas output data') $ ar(1,1,1)=.1 $ ar(1,1,2)=.1 $ ar(1,2,1)=.1 $ ar(1,2,2)=.1 $ ar(2,1,1)=.1 $ ar(2,1,2)=.1 $ ar(2,2,1)=.1 $ ar(2,2,2)=.1 $ output iprint lagrho=12 nfmat=12 $ constant=(yes,yes) $ forecast nt=(296,250) nf=(24,20) se actual $ b34seend$ /$ /$ Use BTIDEN to test lag 12 model /$ b34sexec btiden$ title=('Identification run with Gas Data and 20 lags') $ seriesn var=gasin name=('Exogenous Series') $ seriesn var=gasout name=('Endogenous Series') $ estvar p=2 output=normal numirf=10 granger ilarf$ bispec iauto iturno df pp$ b34seend$ %b34sendif; %b34sif(&runrats.ne.0)%then; /; /; See Rat2 User's guide version 8 page 230 /; Uses IMPLUSE command. Looks at the effect of a shock on all variables /; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec options copyf(4,29); b34sexec options noheader; b34srun; b34sexec pgmcall$ RATS PASSASTS pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * Rats run under B34S(r) system * * allocate 2000 * calendar(m) 1986:1 * grparm(patterns) * * From IMPULSES.PRG * Manual Example 10.3 * ************************************************************************ * * source d:\gasruns\varirf.src * compute neqn = 2 ;*<<<<<< compute nlags = 2 ;*<<<<<< compute nsteps = 12 ;*<<<<<< * system(model=gasmodel) variables gasin gasout ;*<<<<<<<< lags 1 to nlags det constant end(system) * see inquire * * To help create publication-quality graphs, this sets longer * labels for the series. These are used both in graph headers * and key labels. * compute [vect[strings]] implabel=|| $ ;* <<<<<< "Gasin ",$ "Gasout"|| * estimate(noprint) compute modelsize=%modelsize(gasmodel) ;*<<<<<< dec vect[int] depvar(modelsize) dec vect[labels] varlabels(modelsize) ewise varlabels(i)=%modellabel(gasmodel,i) ;*<<<<<< estimate(print,resids=resids) @structresids(factor=%decomp(%sigma)) resids / sresids * compute hstart = %regstart()+250 display %sigma compute hstart = 200 compute hend = %regend() * history section history(model=gasmodel,add,results=history,from=hstart,to=hend) do j=1,neqn spgraph(hfiend=1,vfields=neqn,$ header="Historical Decomposition of "+varlabels(j)) do i=1,neqn graph(header="Effect of "+varlabels(i),key=below) 3 # depvar(j) hstart-nlags hend # history(1,j) # history(1+i,j) end do i spgraph(done) end do j * ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * * The procedure VARIRF does the graphs shown below without * the extra programming. * You can choose the graphs to be organized BYSHOCKS, BYVARIABLES or both. * @VARIRF(model=gasmodel,steps=nsteps,varlabels=implabel,$ page=byshocks,errors) @VARIRF(model=gasmodel,steps=nsteps,varlabels=implabel,$ page=byvariables,errors) * * @VARIRF(model=gasmodel,steps=nsteps,varlabels=implabel,$ * page=one) * declare rect[series] impblk(neqn,neqn) declare vect[series] scaled(neqn) declare vect[strings] implabel(neqn) * * These apply to the GRAPH instructions which are coming up later * list ieqn = 1 to neqn smpl 1 nsteps * * This computes the full set of impulse responses, which are in * the series in * IMPBLK. IMPBLK(i,j) is the response of variable i to a shock in j. * impulse(model=gasmodel,result=impblk,noprint,steps=nsteps) errors( model=gasmodel,steps=nsteps,impulses) * * This loop plots the responses of all series to a single series. * The response of a series is normalized by dividing by its * innovation variance. This allows all the responses to a shock * to be plotted on a single scale. Note that these * graphs get a bit hard to read with more than five or six variables. * * As this program will generate a dozen graphs in a bunch, the * WINDOW option is used on the GRAPH instructions to give * them descriptive labels in the WINDOW menu. * do i=1,neqn compute header="Effect of a shock in series "+implabel(i) do j=1,neqn set scaled(j) = (impblk(j,i))/sqrt(%sigma(j,j)) end do j graph(header=header,key=below,klabels=implabel,number=0,$ window="to_"+implabel(i)) neqn cards scaled(ieqn) end do i * * And this loop graphs the responses of a variable to all shocks. * These don’t have to be normalized. * do i=1,neqn compute header="Effect of all shocks on variable "+implabel(i) graph(header=header,key=below,klabels=implabel,number=0,$ window="of_"+implabel(i)) neqn cards impblk(i,ieqn) end do i print b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run ') /; dodos('start /w /r rats32s rats.in ') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==VARRESDC2 Test of three Enders Series b34sexec options ginclude('b34sdata.mac') member(coint6); b34srun; %b34slet runrats=1; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call echooff; ibegin=1; iend=100; nlag=2; nterms=12; x=catcol(y,z,w); 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); call varstab(beta,compmat,eigdata,modulus,1); b34srun; /$ /$ Use BTIDEN to test lag 12 model /$ %b34sif(&runrats.ne.0)%then; /; /; See Rat2 User's guide version 8 page 230 /; Uses IMPLUSE command. Looks at the effect of a shock on all variables /; b34sexec options open('rats.dat') unit(28) disp=unknown$ b34srun$ b34sexec options open('rats.in') unit(29) disp=unknown$ b34srun$ b34sexec options clean(28)$ b34srun$ b34sexec options clean(29)$ b34srun$ b34sexec options copyf(4,29); b34sexec options noheader; b34srun; b34sexec pgmcall$ RATS PASSASTS pcomments('* ', '* Data passed from B34S(r) system to RATS', '* ', "display @1 %dateandtime() @33 ' Rats Version ' %ratsversion()" '* ') $ PGMCARDS$ * * Rats run under B34S(r) system * * allocate 2000 * calendar(m) 1986:1 * grparm(patterns) * * From IMPULSES.PRG * Manual Example 10.3 * ************************************************************************ * * source d:\gasruns\varirf.src * compute neqn = 3 ;*<<<<<< compute nlags = 2 ;*<<<<<< compute nsteps = 12 ;*<<<<<< * system(model=coint6) variables y z w ;*<<<<<<<< lags 1 to nlags det constant end(system) * see inquire * * To help create publication-quality graphs, this sets longer * labels for the series. These are used both in graph headers * and key labels. * compute [vect[strings]] implabel=|| $ ;* <<<<<< "y ",$ "z ",$ "w "|| * estimate(noprint) compute modelsize=%modelsize(coint6) ;*<<<<<< dec vect[int] depvar(modelsize) dec vect[labels] varlabels(modelsize) ewise varlabels(i)=%modellabel(coint6,i) ;*<<<<<< estimate(print,resids=resids) @structresids(factor=%decomp(%sigma)) resids / sresids * compute hstart = %regstart()+250 display %sigma compute hstart = 70 compute hend = %regend() * history section history(model=coint6,add,results=history,from=hstart,to=hend) do j=1,neqn spgraph(hfiend=1,vfields=neqn,$ header="Historical Decomposition of "+varlabels(j)) do i=1,neqn graph(header="Effect of "+varlabels(i),key=below) 3 # depvar(j) hstart-nlags hend # history(1,j) # history(1+i,j) end do i spgraph(done) end do j * ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * * The procedure VARIRF does the graphs shown below without * the extra programming. * You can choose the graphs to be organized BYSHOCKS, BYVARIABLES or both. * @VARIRF(model=coint6,steps=nsteps,varlabels=implabel,$ page=byshocks,errors) @VARIRF(model=coint6,steps=nsteps,varlabels=implabel,$ page=byvariables,errors) * * @VARIRF(model=coint6,steps=nsteps,varlabels=implabel,$ * page=one) * declare rect[series] impblk(neqn,neqn) declare vect[series] scaled(neqn) declare vect[strings] implabel(neqn) * * These apply to the GRAPH instructions which are coming up later * list ieqn = 1 to neqn smpl 1 nsteps * * This computes the full set of impulse responses, which are in * the series in * IMPBLK. IMPBLK(i,j) is the response of variable i to a shock in j. * impulse(model=coint6,result=impblk,noprint,steps=nsteps) errors( model=coint6,steps=nsteps,impulses) * * This loop plots the responses of all series to a single series. * The response of a series is normalized by dividing by its * innovation variance. This allows all the responses to a shock * to be plotted on a single scale. Note that these * graphs get a bit hard to read with more than five or six variables. * * As this program will generate a dozen graphs in a bunch, the * WINDOW option is used on the GRAPH instructions to give * them descriptive labels in the WINDOW menu. * do i=1,neqn compute header="Effect of a shock in series "+implabel(i) do j=1,neqn set scaled(j) = (impblk(j,i))/sqrt(%sigma(j,j)) end do j graph(header=header,key=below,klabels=implabel,number=0,$ window="to_"+implabel(i)) neqn cards scaled(ieqn) end do i * * And this loop graphs the responses of a variable to all shocks. * These don’t have to be normalized. * do i=1,neqn compute header="Effect of all shocks on variable "+implabel(i) graph(header=header,key=below,klabels=implabel,number=0,$ window="of_"+implabel(i)) neqn cards impblk(i,ieqn) end do i print b34sreturn$ b34srun $ b34sexec options close(28)$ b34srun$ b34sexec options close(29)$ b34srun$ b34sexec options /$ dodos(' rats386 rats.in rats.out ') dodos('start /w /r rats32s rats.in /run ') /; dodos('start /w /r rats32s rats.in ') dounix('rats rats.in rats.out')$ B34SRUN$ b34sexec options npageout WRITEOUT('Output from RATS',' ',' ') COPYFOUT('rats.out') dodos('ERASE rats.in','ERASE rats.out','ERASE rats.dat') dounix('rm rats.in','rm rats.out','rm rats.dat') $ B34SRUN$ %b34sendif; == ==VAREST VAR Modeling b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ This validates with BTEST %b34slet testvc=1; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call echooff; ibegin=1; iend=296; nlag=2; nterms=10; x=catcol(gasin,gasout); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call tabulate(varx,varxhat,rsq); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); call print('VAR Residual and Structural Residual':); call st_res(residual,sigma,finv,sres); call print(residual,sigma,sres); /$ /$ Much bigger problem here /$ nlag=20; call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call tabulate(varx,varxhat,rsq); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); b34srun; %b34sif(&testvc.ne.0)%then; /$ /$ Note slight differences in Coef since calculation done with /$ nonlinear procedure /$ b34sexec btest$ title=('Estimation run with gas data') $ seriesn var=gasin name=('b-j gas input data') $ seriesn var=gasout name=('b-j gas output data') $ ar(1,1,1)=.1 $ ar(1,1,2)=.1 $ ar(1,2,1)=.1 $ ar(1,2,2)=.1 $ ar(2,1,1)=.1 $ ar(2,1,2)=.1 $ ar(2,2,1)=.1 $ ar(2,2,2)=.1 $ output iprint lagrho=12 nfmat=12 $ constant=(yes,yes) $ forecast nt=(296,250) nf=(24,20) se actual $ b34seend$ /$ /$ Use BTIDEN to test lag 20 model /$ b34sexec btiden$ title=('Identification run with Gas Data and 20 lags') $ seriesn var=gasin name=('Exogenous Series') $ seriesn var=gasout name=('Endogenous Series') $ estvar p=20 output=normal numirf=10 granger ilarf$ bispec iauto iturno df pp$ b34seend$ %b34sendif; == ==VAREST_16 Illustrates real*8 and real*16 b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ This validates with BTEST %b34slet testvc=1; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call echooff; ibegin=1; iend=296; nlag=2; nterms=10; x=catcol(gasin,gasout); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call tabulate(varx,varxhat,rsq); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); call print('+++++++++++ real*16 +++++++++++++++++++':); x=r8tor16(x); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call tabulate(varx,varxhat,rsq); a =kindas(1.0,a); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); /$ /$ Much bigger problem here /$ nlag=20; call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call tabulate(varx,varxhat,rsq); a =kindas(1.0,a); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); b34srun; %b34sif(&testvc.ne.0)%then; /$ /$ Note slight differences in Coef since calculation done with /$ nonlinear procedure /$ b34sexec btest$ title=('Estimation run with gas data') $ seriesn var=gasin name=('b-j gas input data') $ seriesn var=gasout name=('b-j gas output data') $ ar(1,1,1)=.1 $ ar(1,1,2)=.1 $ ar(1,2,1)=.1 $ ar(1,2,2)=.1 $ ar(2,1,1)=.1 $ ar(2,1,2)=.1 $ ar(2,2,1)=.1 $ ar(2,2,2)=.1 $ output iprint lagrho=12 nfmat=12 $ constant=(yes,yes) $ forecast nt=(296,250) nf=(24,20) se actual $ b34seend$ /$ /$ Use BTIDEN to test lag 20 model /$ b34sexec btiden$ title=('Identification run with Gas Data and 20 lags') $ seriesn var=gasin name=('Exogenous Series') $ seriesn var=gasout name=('Endogenous Series') $ estvar p=20 output=normal numirf=10 granger ilarf$ bispec iauto iturno df pp$ b34seend$ %b34sendif; == ==VARIANCE Variance function => variance of an object b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; mgasin=mean(gasin); mgasout=mean(gasout); call print('Gasin Mean',mgasin); call print('Gasout Mean',mgasout); vgasin=variance(gasin); vgasout=variance(gasout); call print('Real*8 Gasin Variance ',vgasin); call print('Real*8 Gasout Variance',vgasout); call print('Real*16 Gasin Variance',variance(r8tor16(gasin ))); call print('Real*16 Gasout Variance',variance(r8tor16(gasout))); call print('VPA Gasin Variance ',variance(vpa(gasin ))); call print('VPA Gasout Variance ',variance(vpa(gasout))); b34srun$ /$ problem # 2 b34sexec matrix; /$ /$ Test variance with Wilkinson - Dallal (1977) data /$ Variance should be 1. /$ /$ "Accuracy of Sample Moments Calculations Among /$ Widely Used Statistical Programs," American /$ Statistican, 31:3, pp. 128-31. /$ x=array(3: 90000001., 90000002., 90000003.); v=variance(x); testv=v-1.0d+00; call print(v,testv); b34srun; == ==VECTOR VECTOR function => create a vector b34sexec matrix$ v=vector(4:1 2 3 4); call print(v); b34srun; == ==VERSION Version info in a Smooth example b34sexec data heading('Smooth Data with 0.0'); input demand; label demand ='Demand Data with 0.0 '; datacards; 0 0 19 0 0 0 4 18 17 0 0 0 0 0 3 0 0 19 0 0 0 5 4 5 b34sreturn; b34srun; b34sexec matrix; call loaddata; call version; call print('++++++++++++++++++++':); call version(full); call smooth(demand :method nce :print); call print(%xhatmat,%xhat); call tabulate(%actual %error %xhat); call smooth(demand :method es :print); call print(%xhatmat,%xhat); call tabulate(%actual %error %xhat); call smooth(demand :method croston :alpha .33 :print :pstart 2. :zstart 5.); call print(%xhatmat); call tabulate(%actual %error %xhat %P %z); call smooth(demand :method mcroston :alpha .33 :print :pstart 2. :zstart 5.); call print(%xhatmat); call tabulate(%actual %error %xhat %P %z); call smooth(demand :method vcroston :alpha .33 :print :pstart 2. :zstart 5. :lag 2); call print(%xhatmat); call tabulate(%actual %error %xhat %P %z); b34srun; == ==VFAM VFAM function => change array obj. to vector obj. b34sexec matrix$ x=array(3,3:); x=rn(x); call print(x); mx=vfam(x); call print(mx); xa=array(3:1 2 3); vxa=vfam(xa); call print(xa,vxa); b34srun; == ==VOCAB SORT command on real*8 and Character Data b34sexec matrix; call vocab(cb); ccb=cb; call sort(ccb); call print(cb,ccb); cfb=vocab(); ccfb=cfb; call sort(ccfb); call print(cfb,ccfb); b34srun; == ==VARSTAB Var Stability Test /; /; Illustrates call varstab that tests for Model stability /; 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=6; nterms=10; /; x=catcol(gasin,(gasin*gasin),gasout); x=catcol(gasin,gasout); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call varstab(beta,compmat,eigdata,modulus,1); call tabulate(varx,varxhat,rsq); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); call print('VAR Residual and Structural Residual':); call st_res(residual,sigma,finv,sres); call print(residual,sigma,sres); b34srun; == ==VOCAB_2 Lists Internal Command Numbers b34sexec matrix; call vocab(cb:); cfb=vocab(:); b34srun; == ==VPA1 Simple VPA test Case b34sexec matrix; call echooff; * Accuracy differences depending on data precision; call print(' 2.0/4.11 using different precisions':); call fprint(:clear :col 32 :string ' 10 20 30 40 50' :print :clear :col 32 :string '12345678901234567890123456789012345678901234567890' :print); call fprint(:clear :col 1 :string 'str => vpa' :col 30 :display vpa('2. ')/vpa('4.11') 'e70.52' :print :clear :col 30 :display vpa('2.00')/vpa('4.11') 'e50.32' :print); call fprint(:clear :col 1 :string 'real*8 => vpa' :col 30 :display vpa(2.00)/vpa(4.11) 'e50.32' :print); call fprint(:clear :col 1 :string 'real*8 => real*16' :col 18 :display r8tor16(2.)/r8tor16(4.11) '(e50.32)' :print); call fprint(:clear :col 1 :string 'str => real*16' :col 18 :display real16('2.00')/real16('4.11') '(e50.32)' :print); call fprint(:clear :col 1 :string 'real*8 => real*8' :col 18 :display array(:2.00/4.11) '(e50.32)' :print); call fprint(:clear :col 1 :string 'real*4 => real*4' :col 18 :display sngl(2.00)/sngl(4.11) '(e50.32)' :print); b34srun; == ==VPA2 More comprehensive VPA test case %b34slet runtests=0; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix /; display=col129high ; call loaddata; /$ /; call vpaset(:trace 1); %b34sif(&runtests.ne.0)%then; call vpaset(:info); call vpaset(:alltests); call vpaset(:jform1 1 ); call vpaset(:jform2 60); call vpaset(:ndigits 50); call vpaset(:alltests); %b34sendif; call vpaset(:ndigits 1750); call vpaset(:jform2 10); call vpaset(:info); call print(vpa(:pi)); hh=vpa(:pi); hh2=hh; call print(hh,hh2); x=10.; y=x; y(2)=x; call names; call names(all); call print(y); hh3(1)=hh; hh3(2)=vpa(:pi); call vpaset(:settings); call vpaset(hh,hht, 10 %ndig :convert); /; /; Illustrate "hiding" vpa data in a real*8 vector /; call vpaset(hh,r8 :saveasr8); call vpaset(r8,test :saveasvpa); call print(hh,test); call print(r8); call names(all); call names; call print(hh); call print(hh3); call print(afam(hh3)); call print(hh3(1)); call print(hh3(2)); hm =catcol(hh3,hh3); hm2=catrow(hh3,hh3); call names(all); call print(hm,hm2); call print(hm(1,1)); call print(hm(2,2)); call print(afam(hm)*afam(hm)); call print(afam(hm)*afam(hm)/afam(hm)); call print('fm1 is 2 fm2 is 4.11'); fm1=vpa(2); call names(all); call print('fm1',fm1); fm2=vpa(4.11); call print('fm2',fm2); fm3=vpa('4.110000000000000000000000000'); call print('fm3',fm3); call print('Using dp to m argument => fm2':); call print('+ - * /':); call print('Using string to m argument => fm3':); call print('+ - * /':); call print(fm1+fm2); call print(fm1+fm3); call print(fm1-fm2); call print(fm1-fm3); call print(fm1*fm2); call print(fm1*fm3); call print(fm1/fm2); call print(fm1/fm3); call print(fm1**fm2); call print(fm1**fm3); call print('Errors':); call print((fm1+fm2) -(fm1+fm3)); call print((fm1-fm2) -(fm1-fm3)); call print((fm1*fm2) -(fm1*fm3)); call print((fm1/fm2) -(fm1/fm3)); call print((fm1**fm2)-(fm1**fm3)); n=5; ar=rn(array(n,n:)); br=rn(array(n,n:)); aa=vpa(ar); bb=vpa(br); call names(all); call print('Looking at array math with real*8 and vpa' aa,bb, ' + ' aa+bb, ar+br, ' - ' aa-bb, ar-br, ' * ' aa*bb, ar*br, ' / ' aa/bb, ar/br, ' ** ' vpa(dabs(ar))**vpa(dabs(br)), dabs(ar) **dabs(br), 'Error + ', (aa+bb)-vpa(ar+br), 'Error - ', (aa-bb)-vpa(ar-br), 'Error * ', (aa*bb)-vpa(ar*br), 'Error / ', (aa/bb)-vpa(ar/br), 'Error ** ', ((vpa(dabs(ar))**vpa(dabs(br)))- (vpa(dabs(ar) ** dabs(br)))) ); call print(vpa(aa :to_dp)); call print(vpa(aa :to_int)); call names(all); zp=vpa(aa :pack); call names(all); st=vpa(aa(1,1) :to_str); call print(st); call vpaset(:jform2 10); st=vpa(aa(1,1) :to_str); call print(st); /; many blanks printed here call fprint(:clear :col 5 :string 'Default fmt' :col 15 :display aa(1,1) :print :clear :col 5 :string 'User 1 fmt' :col 15 :display aa(1,1) '(e12.4)' :print :clear :col 5 :string 'User 2 fmt' :col 15 :display aa(1,1) '(e80.60)' :print :cr 2); call print(aa,transpose(aa)); v1=aa(,1); call print(vpa(aa :to_dp)*transpose(vpa(aa :to_dp)), aa*transpose(aa)); call print(vpa(aa :to_dp)* vpa(v1 :to_dp), aa*v1); aa=mfam(aa); v1=vfam(v1); call print(vpa(aa :to_dp)*transpose(vpa(aa :to_dp)), aa*transpose(aa)); call print(vpa(aa :to_dp)*vpa(v1 :to_dp), aa*v1); /; Logical Operators /; Vector logical x=integers(1,8); y=x-4; x=0.0*dfloat(x)+1.0; y=dfloat(y); test1=vpa(x).eq.vpa(y); test2=vpa(x).gt.vpa(y); test3=vpa(x).ge.vpa(y); test4=vpa(x).lt.vpa(y); test5=vpa(x).le.vpa(y); test6=vpa(x).ne.vpa(y); call print('Test of vector test1=>eq test2=>gt test3=>ge test4=>lt test5=>le test6=>ne':); call tabulate(x,y,test1,test2,test3,test4,test5,test6); x=rn(array(15:)); fmx=vpa(x); call print(x,fmx); call tabulate(x,fmx); call print('*************************************************':); iaa=inv(aa); call print('%rcond was ',%rcond); call print('Inverse tests',aa,iaa,aa*iaa,diag(aa)); call print('real*8 inverse ',inv(vpa(aa :to_dp)) ); call print('real*8 test ',inv(vpa(aa :to_dp))*vpa(aa :to_dp) ); call print('*************************************************':); a1=matrix(3,3:1. 2. 3. 4. 5. 6. 7. 8. 9.); a2=-1.*dsqrt(a1); call print(complex(a1), complex(vpa(a1) )); call print(complex(a1,a2),complex(vpa(a1),vpa(a2))); call print('--------------------------------------':); call print('------------- Det tests --------------':); a1(1,1)=10.; detc16=det(complex(a1,a2)); rcondc16=rcond(complex(a1,a2)); jj=inv(complex(vpa(a1),vpa(a2))); detcvpa=%det; rcondvpa=%rcond; call print('Rcond two ways',rcondc16,rcondvpa); call print('Det calculated from complex*16 and vpa complex':); call print(detc16,detcvpa); call print('--------------------------------------':); cax=complex(aa,dsqrt(dabs(aa))); /; cax is vpa here call print('Testing taking out real part. Are these the same?':); call print(cax,vpa(real(cax):to_dp)); call print(real(cax)); call print(aa,complex(aa)); call print('+++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Inverse of real part as a test':); call print('complex*16 real case +++++++++++++':); call print(inv( vpa(real(cax) :to_dp))); call print(det( vpa(real(cax) :to_dp))); call print(rcond( vpa(real(cax):to_dp))); call print('VPA complex real case ++++++':); call print(inv( vpa(real(cax)))); call print('det and rcond',%det,%rcond); call print('++++++++ Full Complex Case +++++++':); call print('complex*16 cases +++++++++++++':); call print(inv( vpa(cax:to_z))); call print(det( vpa(cax:to_z))); call print(rcond( vpa(cax:to_z))); call print('VPA complex cases +++++++++++':); call print(inv(cax)); call print('det and rcond',%det,%rcond); call print('+++++++++++++++++++++++++++++++++':); call print('Inverting real part as if it was complex':); /; call print(aa,inv(aa), inv(complex(aa))); invaa=inv(aa); invcax=inv(cax); call print('++++++++++++++++ key test ++++':); call print(aa); call print(inv(aa)); call print(aa*invaa); call print('+++++++++++++++++++++++++++++++++':); call print('Inverse of real part as a test':); call print(inv( vpa(real(cax):to_dp))); call print(inv(real(cax))); call print(complex(aa)); call print(inv(complex(aa))); call print(invcax,cax*invcax); /;call vpaset(:ndigits 70); call vpaset(:jform2 10); call print('test mean- var sum, sumsq'); call print(mean(gasin)); call print(mean(vpa(gasin)) ); call print(variance(gasin)); call print(variance(vpa(gasin))); call print(sum(gasin), sum(vpa(gasin)) ); call print(sum(gasout), sum(vpa(gasout)) ); call print(sumsq(gasin), sumsq(vpa(gasin)) ); call print(trace( vpa(aa :to_dp)), trace(aa) ); call print(sumrows(vpa(aa :to_dp)), sumrows(aa) ); call print(sumcols(vpa(aa :to_dp)), sumcols(aa) ); * Complex Cases; rr=2.; ri=.7; z1=complex(rr,ri); zm1=vpa(z1); call print(zm1); rr=4.11; ri=006.1; z2=complex(rr,ri); zm2=vpa(z2); call print(zm2); call names(all); zm3=vpa(vpa('4.11'),vpa('6.1')); call print(zm3); zm1a=vpa(vpa('2.') vpa('.7')); call print(zm1*zm2,zm1*zm3, zm1a*zm3); call print('Note Accuracy differences due to string input':); nn=2; x=rn(matrix(nn,nn:)); x=vpa(x); x(2,2)=vpa('1.e+3999'); x(2,1)=vpa('1.e+94444'); call print(x(2,2)); call print(x); x=rn(array(10:)); call print(x,vpa(x)); cx=complex(x,dsqrt(dabs(x))); call print(cx); call print(vpa(cx)); nn=5; x=rn(array(nn,nn:)); call vpaset(:info); call print(x,vpa(x)); cx=complex(x,dsqrt(dabs(x))); call print(cx); call print(vpa(cx)); fm=vpa('3.44'); call print(vpa(fm :to_r16)); /; Write tests call vpaset(:info ); call vpaset(:jform2 80); xx =rn(array(10:)); fmxx =vpa(xx); /; Allocate blank objects to get results testvpa =vpa(array(10:)); test2vpa=vpa(vpa(array(10:)) :to_im); test3vpa=vpa(complex(matrix(nn,nn:),matrix(nn,nn:))); ixx=idint(xx); imxx=vpa(vpa(ixx) :to_im); call open(88,'vpa.dat'); call rewind(88); /; /; writes fm, im and zm data /; call write(fmxx,88); call write(imxx,88); call write(vpa(cx),88); call print(cx,vpa(cx)); call testarg(vpa(cx),88); call rewind(88); /; /; Test if can get data back /; call read(testvpa, 88); call read(test2vpa,88); call read(test3vpa,88); call rewind(88); call close(88); call tabulate(xx,fmxx,testvpa,ixx,test2vpa); call print(cx,vpa(cx),test3vpa); /; Function testing; x=rn(array(6:)); a_x=dabs(x); fm_x=vpa(x); a_fm_x=dabs(fm_x); call tabulate(x,a_x,fm_x,a_fm_x); /; Another way to get pi in an array fm_pi=pi(vpa(array(6:))); real_pi=pi(array(6:)); call tabulate(real_pi,fm_pi); call print(real_pi(1),fm_pi(1)); /; array and vector testing test=rn(array(5:)); vptest=vpa(test); test2d =rn(array(5,5:)); vptest2d=vpa(test2d); call print(test*2.0,vptest*vpa(2.0)); call print(vfam(test)*2.0,vfam(vptest)*vpa(2.0)); call print(2.0*test,vpa(2.0)*vptest); call print(2.0*vfam(test),vpa(2.0)*vfam(vptest)); call print(test*test,vptest*vptest); call print(test*test,vptest*vptest); call print(test2d*test,vptest2d*vptest); call print(vfam(test2d)*mfam(test),vfam(vptest2d)*mfam(vptest)); call print(test*test2d,vptest*vptest2d); call print(vfam(test)*mfam(test2d),vfam(vptest)*mfam(vptest2d)); call print(test2d*test2d,vptest2d*vptest2d); call print(mfam(test2d)*mfam(test2d),mfam(vptest2d)*mfam(vptest2d)); /; complex z=complex(.33,.44); z32=c16toc32(z); vpaz =vpa(z ); vpaz32=vpa(z32); call print(z,z32,vpaz,vpaz32); r32=real(vpaz32); i32=imag(vpaz32); call print(r32,i32); b34srun; == ==VPA3 Tests and Illustrates VPA Functions b34sexec matrix; ints=integers(20); ints=ints-10; reals=dfloat(ints); areals=dabs(reals); vpa_r=vpa(reals); aints=dabs(ints); avpa_r=dabs(vpa_r); call tabulate(ints,aints,reals,areals,vpa_r,avpa_r); n=10.; test=grid(0.0,pi()*n,.5); cc =dcos(test); ss =dsin(test); tt=dtan(test); cos_vpa=dcos(vpa(test)); sin_vpa=dsin(vpa(test)); tan_vpa=dtan(vpa(test)); call tabulate(test,cc,ss,tt,cos_vpa,sin_vpa,tan_vpa); x=dfloat(integers(-10,10)); dcosh2=dcosh(x); dsinh2=dsinh(x); dtanh2=dtanh(x); vdcosh2=vpa(dcosh(x)); vdsinh2=vpa(dsinh(x)); vdtanh2=vpa(dtanh(x)); call tabulate(x,dcosh2,dsinh2,dtanh2,vdcosh2,vdsinh2,vdtanh2); r8g=grid(.1,6.,.3) ; r8dint=dint(r8g) ; r8dnint=dnint(r8g) ; vr8g=vpa(r8g); vr8dint = dint(vr8g) ; vr8dnint=dnint(vr8g) ; call tabulate(r8g,r8dint,r8dnint,vr8g,vr8dint,vr8dnint); x=grid(0.0001 100. 1.); log10x=dlog10(x); lnx =dlog(x); testx1=10.**log10x; testx2=dexp(lnx); vx=vpa(x); vlog10x=dlog10(vx); vlnx =dlog(vx); vtestx1=vpa('10.')**vlog10x; vtestx2=dexp(vlnx); call tabulate(x,log10x,lnx,testx1,testx2 vx,vlog10x,vlnx,vtestx1,vtestx2); * Complex case; cx=complex(x,dsqrt(x)); lncx =dlog(cx); testcx =exp(lncx); vcx=vpa(cx); vlncx =dlog(vcx); vtestcx =exp(vlncx); call print('Complex cases':); call tabulate(cx,lncx,testcx,vlncx,vtestcx); n=20; reals1=rec(array(n:))*100.; reals2=rec(array(n:))*100.; maxreal=dmax1(reals1,reals2); minreal=dmin1(reals1,reals2); vmaxreal=dmax1(vpa(reals1),vpa(reals2)); vminreal=dmin1(vpa(reals1),vpa(reals2)); call tabulate(reals1,reals2,maxreal,minreal,vmaxreal,vminreal); ints =integers(20); reals =dfloat(ints); imods =dmod(ints,3); rmod =dmod(reals,3.0); vrmod =dmod(vpa(reals),vpa('3.0')); call tabulate(ints,imods,reals,rmod,vrmod); a=array(4:1,-2,3,-6); ac=complex(a,a*2.); ar=grid(1.,10.,1.); sqrtar=dsqrt(ar); test1=sqrtar*sqrtar; vsqrtar=dsqrt(vpa(ar)); vtest1=vsqrtar*vsqrtar; cc=complex(dfloat(integers(10)),dsqrt(dfloat(integers(10)))); vpa_cc=vpa(cc); call tabulate(cc,dconj(cc), vpa_cc, dconj(vpa_cc) :title 'Complex Case'); b34srun; == ==VPA4 Illustrates Inverse gains /; /; Shows gains in accuracy of the inverse with vpa /; b34sexec matrix; call echooff; n=6; x=rn(matrix(n,n:)); ix=inv(x,rcond8); r16x=r8tor16(x); ir16x=inv(r16x,rcond16); call print('Real*4 tests',sngl(x),inv(sngl(x)),sngl(x)*inv(sngl(x))); call print('Real*8 tests',x, ix, x*ix); call print('Real*16 tests',r16x,ir16x,r16x*ir16x); vpax=vpa(x); ivpax=inv(vpax,rcondvpa); detvpa=%det; call print(rcond8,rcond16,rcondvpa,det(x),det(r16x),detvpa); call print('Default accuracy'); call print('VPA Inverse ',vpax,ivpax,vpax*ivpax); /; call vpaset(:info); do i=100,1850,100; call vpaset(:ndigits i); call vpaset(:jform2 10); call print('*************************************************':); vpax=mfam(dsqrt(dabs(vpa(x)))); call vpaset(:jform2 i); call print('Looking at vpax(2,1) given ndigits was set as ',i:); call print(vpax(2,1)); ivpax=inv(vpax); call print('VPAX and Inverse VPAX at high accuracy ', vpax,ivpax,vpax*ivpax); call print('*************************************************':); enddo; b34srun; == ==VPA4B Illustrates Inverse gains For Complex Matrix /; /; Shows gains in accuracy of the inverse with vpa /; b34sexec matrix; call echooff; n=6; x=rn(matrix(n,n:)); x=complex(x,dsin(x)); ix=inv(x,rcond16); c32x=c16toc32(x); ic32x=inv(c32x,rcond32); call print('Complex*16',x, ix, x*ix); call print('Complex*32',c32x,ic32x,c32x*ic32x); vpax=vpa(x); ivpax=inv(vpax,rcondvpa); detvpa=%det; call print(rcond16,rcond32,rcondvpa,det(x),det(c32x),detvpa); call print('Default accuracy'); call print('VPA Inverse ',vpax,ivpax,vpax*ivpax); /; call vpaset(:info); do i=100,1850,100; call vpaset(:ndigits i); call vpaset(:jform2 10); call print('*************************************************':); x =rn(matrix(n,n:)); xi=rn(matrix(n,n:)); vpax=complex(dsqrt(dabs(vpa(x))),dsin(vpa(xi))); call vpaset(:jform2 i); call print('Looking at vpax(2,1) given ndigits was set as ',i:); call print(vpax(2,1)); ivpax=inv(vpax); call print('VPAX and Inverse VPAX at high accuracy ', vpax,ivpax,vpax*ivpax); call print('*************************************************':); enddo; b34srun; == ==VPA5 VPA Analysis of Fillippelli Data /; /; readvpa=1 => read vpa from character data. This is not needed here /; since read into real*16 preserves all accuracy %b34slet readvpa=0; %b34slet real32 =0; b34sexec matrix; /$ heading('Filippelli Data'); datacards; 0.8116 -6.860120914 0.9072 -4.324130045 0.9052 -4.358625055 0.9039 -4.358426747 0.8053 -6.955852379 0.8377 -6.661145254 0.8667 -6.355462942 0.8809 -6.118102026 0.7975 -7.115148017 0.8162 -6.815308569 0.8515 -6.519993057 0.8766 -6.204119983 0.8885 -5.853871964 0.8859 -6.109523091 0.8959 -5.79832982 0.8913 -5.482672118 0.8959 -5.171791386 0.8971 -4.851705903 0.9021 -4.517126416 0.909 -4.143573228 0.9139 -3.709075441 0.9199 -3.499489089 0.8692 -6.300769497 0.8872 -5.953504836 0.89 -5.642065153 0.891 -5.031376979 0.8977 -4.680685696 0.9035 -4.329846955 0.9078 -3.928486195 0.7675 -8.56735134 0.7705 -8.363211311 0.7713 -8.107682739 0.7736 -7.823908741 0.7775 -7.522878745 0.7841 -7.218819279 0.7971 -6.920818754 0.8329 -6.628932138 0.8641 -6.323946875 0.8804 -5.991399828 0.7668 -8.781464495 0.7633 -8.663140179 0.7678 -8.473531488 0.7697 -8.247337057 0.77 -7.971428747 0.7749 -7.676129393 0.7796 -7.352812702 0.7897 -7.072065318 0.8131 -6.774174009 0.8498 -6.478861916 0.8741 -6.159517513 0.8061 -6.835647144 0.846 -6.53165267 0.8751 -6.224098421 0.8856 -5.910094889 0.8919 -5.598599459 0.8934 -5.290645224 0.894 -4.974284616 0.8957 -4.64454848 0.9047 -4.290560426 0.9129 -3.885055584 0.9209 -3.408378962 0.9219 -3.13200249 0.7739 -8.726767166 0.7681 -8.66695597 0.7665 -8.511026475 0.7703 -8.165388579 0.7702 -7.886056648 0.7761 -7.588043762 0.7809 -7.283412422 0.7961 -6.995678626 0.8253 -6.691862621 0.8602 -6.392544977 0.8809 -6.067374056 0.8301 -6.684029655 0.8664 -6.378719832 0.8834 -6.065855188 0.8898 -5.752272167 0.8964 -5.132414673 0.8963 -4.811352704 0.9074 -4.098269308 0.9119 -3.66174277 0.9228 -3.2644011 b34sreturn; /$ input y x; /$ build x2 x3 x4 x5 x6 x7 x8 x9 x10; /$ gen x2=x*x; gen x3=x2*x; gen x4=x3*x; gen x5=x4*x; /$ gen x6=x5*x; gen x7=x6*x; gen x8=x7*x; gen x9=x8*x; /$ gen x10=x9*x; /$ We are reading from unit 4 where trhe data file is automatically /$ Saved call real16off; call real32off; call real16info; x16=r8tor16(array(164:)); call read(x16,4); call load(ntokin :staging); call load(getr16 :staging); call load(getvpa :staging); call load(getchar :staging); call echooff; vpx16=vpa(x16); /$ repack /; test reading into character then into vpa. This is not needed %b34sif(&readvpa.ne.0)%then; vpx16=vpx16*vpa('0.0'); call rewind(4); cc=c1array(10000:); call read(cc,4); call ntokin(cc,nfind,0,ibad); call print(nfind ); call getvpa(cc,nfind,vpx16,ibad); /; call print(vpx16,x16); call free(cc); %b34sendif; xm=matrix(41,4:x16); y=array(:xm(,1),xm(,3)); x=array(:xm(,2),xm(,4)); x2 =x*x; x3=x2*x; x4=x3*x; x5=x4*x; x6 =x5*x; x7=x6*x; x8=x7*x; x9=x8*x; x10=x9*x; vpxm=matrix(41,4:vpx16); vpy=array(:vpxm(,1),vpxm(,3)); vpx=array(:vpxm(,2),vpxm(,4)); vpx2 =vpx *vpx; vpx3 =vpx2*vpx; vpx4 =vpx3*vpx; vpx5 =vpx4*vpx; vpx6 =vpx5*vpx; vpx7 =vpx6*vpx; vpx8 =vpx7*vpx; vpx9 =vpx8*vpx; vpx10=vpx9*vpx; /; mcall tabulate(y vpy x vpx x10 vpx10); bigx=mfam(catcol(vpx vpx2 vpx3 vpx4 vpx5 vpx6 vpx7 vpx8 vpx9 vpx10)); bigx(,11)=vpa('1.0'); vpy=vfam(vpy); /;call print(bigx); /$ Loading Answers into Character then reading in real*16 call character(cc,' -1467.48961422980 298.084530995537 -2772.17959193342 559.779865474950 -2316.37108160893 466.477572127796 -1127.97394098372 227.204274477751 -354.478233703349 71.6478660875927 -75.1242017393757 15.2897178747400 -10.8753180355343 2.23691159816033 -1.06221498588947 0.221624321934227 -0.670191154593408E-01 0.142363763154724E-01 -0.246781078275479E-02 0.535617408889821E-03 -0.402962525080404E-04 0.896632837373868E-05' ); /; /; Detect # of tokens and load into real*16 and VPA /; call ntokin(cc,nfind,0,ibad); call print(nfind ); call getr16(cc,nfind,ans,ibad); call getchar(cc,nfind,cx,IBAD); /; call print(cx); ans=matrix(11,2: ans); ans=rollup(ans); cx =rollup(cx ); /; VPA OLS using VPA Versions of DGECO-DGEFA-DGEDI program testit; vp_beta=inv(transpose(bigx)*bigx)*transpose(bigx)*vpy; e =vpy-bigx*vp_beta; sigmasq=sumsq(e)/vpa(dfloat(norows(e)-nocols(bigx))); se =dsqrt(diag((sigmasq*inv(transpose(bigx)*bigx)))); dd=diag(( sigmasq*inv(transpose(bigx)*bigx))); call print(sigmasq,vp_beta,se); testss=real16('0.795851382172941E-03'); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('Data Loaded in Real*16 -- All calculations in real*16':); call print('+++++++++++++++++++++++++++++++++++++++++++++++++++++':); call print('OLSQ on Filippelli - Coef Using PDFAC':); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print ); call lre(ans(,1),15,%coef,lretest,bits :print); call print('OLSQ on Filippelli - SE Using PDFAC':); call lre(ans(,2),15,%se, lretest,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lretest,bits :print); call print(' ':); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 :print :qr); call print('OLSQ on Filippelli - Coef Using QR':); call lre(ans(,1),15,%coef,lretest,bits :print); call print('OLSQ on Filippelli - SE Using QR':); call lre(ans(,2),15,%se, lretest,bits :print); call print('Residual sum of squares:'); call lre(testss,15,%rss, lretest,bits :print); call print(' ':); call fprint( :clear :col 23 :string 'Alternative Estimates of Filippelli Model' :print :clear :col 23 :string ' 10 20 30 40 50' :print :clear :col 23 :string '12345678901234567890123456789012345678901234567890' :print :clear :col 23 :string '--------------------------------------------------' :print ); do i=1,norows(vp_beta); call fprint(:clear :col 3 :string 'VPA BETA' :col 12 :display i '(i3)' :col 21 :display vp_beta(i) '(e64.40)' :print :clear :col 3 :string 'Real*16 QR beta' :col 18 :display %coef(i) '(e49.40)' :print :clear :col 3 :string 'Answer for coef' :col 18 :display ans(i,1) '(e25.16)' :print :clear :col 3 :string 'VPA SE' :col 12 :display i '(i3)' :col 21 :display se(i) '(e64.40)' :print :clear :col 3 :string 'Real*16 QR SE' :col 18 :display %se(i) '(e49.40)' :print :clear :col 3 :string 'Answer for SE' :col 18 :display ans(i,2) '(e25.16)' :print :clear :string ' ' :print ); enddo; return; end; call print('Real16 off ********************************':); call real16off; call real16info; call testit; %b34sif(&real32.ne.0)%then; call print('Real16 & real32****************************':); call real16on; call real32on; call real16info; call testit; call print('Real16 on & real32_vpa*********************':); call real16on; call real32_vpa; call real16info; call testit; %b34sendif; b34srun; == ==VPA6 Random Numbers /; /; Uses IMSL real*8 and converts. Not ideal!! /; b34sexec matrix; n=50; vpax=vpa(array(n:)); /; call vpaset(:ndigits 300); vpax1=rec(vpax); vpax2=rn(vpax); call print(vpax1,vpax2); do i=1,10; call print(vpax1(i),vpax2(i)); enddo; b34srun; == ==VPA7 Extends the Filippelli Data to x**20 /; /; Extends the Filippelli Data to x**20 /; Runs with real*16 and VPA with success /; b34sexec matrix; /$ heading('Filippelli Data'); datacards; 0.8116 -6.860120914 0.9072 -4.324130045 0.9052 -4.358625055 0.9039 -4.358426747 0.8053 -6.955852379 0.8377 -6.661145254 0.8667 -6.355462942 0.8809 -6.118102026 0.7975 -7.115148017 0.8162 -6.815308569 0.8515 -6.519993057 0.8766 -6.204119983 0.8885 -5.853871964 0.8859 -6.109523091 0.8959 -5.79832982 0.8913 -5.482672118 0.8959 -5.171791386 0.8971 -4.851705903 0.9021 -4.517126416 0.909 -4.143573228 0.9139 -3.709075441 0.9199 -3.499489089 0.8692 -6.300769497 0.8872 -5.953504836 0.89 -5.642065153 0.891 -5.031376979 0.8977 -4.680685696 0.9035 -4.329846955 0.9078 -3.928486195 0.7675 -8.56735134 0.7705 -8.363211311 0.7713 -8.107682739 0.7736 -7.823908741 0.7775 -7.522878745 0.7841 -7.218819279 0.7971 -6.920818754 0.8329 -6.628932138 0.8641 -6.323946875 0.8804 -5.991399828 0.7668 -8.781464495 0.7633 -8.663140179 0.7678 -8.473531488 0.7697 -8.247337057 0.77 -7.971428747 0.7749 -7.676129393 0.7796 -7.352812702 0.7897 -7.072065318 0.8131 -6.774174009 0.8498 -6.478861916 0.8741 -6.159517513 0.8061 -6.835647144 0.846 -6.53165267 0.8751 -6.224098421 0.8856 -5.910094889 0.8919 -5.598599459 0.8934 -5.290645224 0.894 -4.974284616 0.8957 -4.64454848 0.9047 -4.290560426 0.9129 -3.885055584 0.9209 -3.408378962 0.9219 -3.13200249 0.7739 -8.726767166 0.7681 -8.66695597 0.7665 -8.511026475 0.7703 -8.165388579 0.7702 -7.886056648 0.7761 -7.588043762 0.7809 -7.283412422 0.7961 -6.995678626 0.8253 -6.691862621 0.8602 -6.392544977 0.8809 -6.067374056 0.8301 -6.684029655 0.8664 -6.378719832 0.8834 -6.065855188 0.8898 -5.752272167 0.8964 -5.132414673 0.8963 -4.811352704 0.9074 -4.098269308 0.9119 -3.66174277 0.9228 -3.2644011 b34sreturn; /$ We are reading from unit 4 where the data file is automatically /$ saved by the datacards statement into a character array. This array /; is then read into first real*16 and next into VPA!! call echooff; /; We know there are 164 obs so build array to read /; directly into real*16 and vpa x16=r8tor16(array(164:)); call read(x16,4); vpx16=vpa(x16); /$ repack xm=matrix(41,4:x16); y=array(:xm(,1),xm(,3)); x=array(:xm(,2),xm(,4)); x2 =x*x; x3 =x2*x; x4=x3*x; x5=x4*x; x6 =x5*x; x7 =x6*x; x8=x7*x; x9=x8*x; x10=x9*x; x11 =x10*x; x12=x11*x; x13=x12*x; x14=x13*x; x15 =x14*x; x16=x15*x; x17=x16*x; x18=x17*x; x19 =x18*x; x20=x19*x; call vpaset(:info); vpxm=matrix(41,4:vpx16); vpy=array(:vpxm(,1),vpxm(,3)); vpx=array(:vpxm(,2),vpxm(,4)); vpx2 =vpx *vpx; vpx3 =vpx2*vpx; vpx4 =vpx3*vpx; vpx5 =vpx4*vpx; vpx6 =vpx5*vpx; vpx7 =vpx6*vpx; vpx8 =vpx7*vpx; vpx9 =vpx8*vpx; vpx10=vpx9*vpx; vpx11=vpx10*vpx; vpx12=vpx11*vpx; vpx13=vpx12*vpx; vpx14=vpx13*vpx; vpx15=vpx14*vpx; vpx16=vpx15*vpx; vpx17=vpx16*vpx; vpx18=vpx17*vpx; vpx19=vpx18*vpx; vpx20=vpx19*vpx; bigx=mfam(catcol( vpx vpx2 vpx3 vpx4 vpx5 vpx6 vpx7 vpx8 vpx9 vpx10 vpx11 vpx12 vpx13 vpx14 vpx15 vpx16 vpx17 vpx18 vpx19 vpx20 )); bigx(,21)=vpa('1.0'); vpy=vfam(vpy); /; call print(bigx); /; VPA OLS using VPA Versions of DGECO-DGEFA-DGEDI vp_beta=inv(transpose(bigx)*bigx)*transpose(bigx)*vpy; e =vpy-bigx*vp_beta; sigmasq=sumsq(e)/vpa(dfloat(norows(e)-nocols(bigx))); se =dsqrt(diag((sigmasq*inv(transpose(bigx)*bigx)))); dd=diag(( sigmasq*inv(transpose(bigx)*bigx))); call print(sigmasq,vp_beta,se); call olsq(y x x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 :qr :print); b34srun; == ==VPA8 Very Hard OLS Data. /; /; Problem very very hard!!! /; Illustrates reading into real*8 and then into real*16 and VPA /; Reading from character into real*16 /; Reading from chapter into VPA /; b34sexec data heading('Bruce McCullough Test Case'); input y x; datacards; 10000000001 1000000000.000 10000000002 1000000000.000 10000000003 1000000000.900 10000000004 1000000001.100 10000000005 1000000001.010 10000000006 1000000000.990 10000000007 1000000001.100 10000000008 1000000000.999 10000000009 1000000000.000 10000000010 1000000000.001 b34sreturn; b34srun; b34sexec matrix; call loaddata; call echooff; /; /; Data reread into character to see what happens /; datacards; 10000000001 1000000000.000 10000000002 1000000000.000 10000000003 1000000000.900 10000000004 1000000001.100 10000000005 1000000001.010 10000000006 1000000000.990 10000000007 1000000001.100 10000000008 1000000000.999 10000000009 1000000000.000 10000000010 1000000000.001 b34sreturn; y16=r8tor16(y); x16=r8tor16(x); /; Cholesky on real*8 fails /; call olsq(y x :print); /; QR fails /; call olsq(y x :qr :print); /; real*16 Cholesky fails /; call olsq(y16 x16 :print); call olsq(y16 x16 :qr :print :savex); coef8_16=rollright(%coef); /; Go to vpa 64 digits and 20 digits to see if makes a difference y_vpa=vpa(%y); x_vpa=vpa(%x); beta_vpa=inv(transpose(x_vpa)*x_vpa)*transpose(x_vpa)*y_vpa; call print('Beta from VPA - default 64 digits accuracy ',beta_vpa); call print(beta_vpa(1)); call print(beta_vpa(2)); call vpaset(:ndigits 200); y_vpa=vpa(%y); x_vpa=vpa(%x); beta_vpa=inv(transpose(x_vpa)*x_vpa)*transpose(x_vpa)*y_vpa; call print('Beta from VPA - 200 digits accuracy ',beta_vpa); call print(beta_vpa(1)); call print(beta_vpa(2)); /; Reading data as character into VPA and real*16 /; Makes a difference !!!!!!!!!!!!!!!!!!!!!!!!!!! data16=r8tor16(array(20:)); call read(data16,4); call load(ntokin :staging); call load(getr16 :staging); call load(getvpa :staging); call load(getchar :staging); call vpaset(:ndigits 200); vpdata=vpa(data16); vpx=vpdata*vpa('0.0'); call rewind(4); cc=c1array(10000:); call read(cc,4); call ntokin(cc,nfind,0,ibad); call print(nfind ); call getvpa(cc,nfind,vpx,ibad); call free(cc); xm=matrix(10,2:data16); y16=array(:xm(,1)); x16=matrix(10,2:data16); x16(,1)=real16('1.'); /; This will not solve due to condition /; call olsq(y16 x16 :print :noint); /; call print('Here data read into real*16 directly - Note difference':); call olsq(y16 x16 :qr :print :noint); call print(' ':); call print('Display More digits to see what real*16 has':); call print(' ':); call fprint(:clear :display %coef(1) '(1pe48.32)' :print); call fprint(:clear :display %coef(2) '(1pe48.32)' :print); call print(' ':); call print('Compare with reading into real*8 then to real*16':); call print(' ':); call fprint(:clear :display coef8_16(1) '(1pe48.32)' :print); call fprint(:clear :display coef8_16(2) '(1pe48.32)' :print); call print(' ':); /; now run with vpa vpxm=matrix(10,2:vpx); vpy= vector(:vpxm(,1)); vpx=vpxm; vpx(,1)=vpa('1.0'); betavpa=inv(transpose(vpx)*vpx)*transpose(vpx)*vpy; call print(' ':); call print('Beta from VPA where character read into VPA':); call print('This is the right way to attack the problem':); call print('For gain compare with real*16 where character read':); call print(betavpa(1)); call print(betavpa(2)); call print(' ':); call print('Beta from VPA where vpa converted from real*8':); beta_vpa=rollright(beta_vpa);; call print(beta_vpa(1)); call print(beta_vpa(2)); call print(' ':); call print('Difference of coef # 1 and # 2':); call print('Shows effect of not reading in correct precision':); diffcoef=vpa(vector(2:)); diffcoef(1)=betavpa(1)-beta_vpa(1); diffcoef(2)=betavpa(2)-beta_vpa(2); call print(diffcoef(1)); call print(diffcoef(2)); b34srun; == ==WAVELET Calculate Wavelet b34sexec options ginclude('wavedata.mac') member(nino3); b34srun; /; /; Basic Wavelet test /; b34sexec matrix; call loaddata; call wavelet(nino :type morlet :settings :s0 .25 :dt .25 :lower 2. :upper 7.9 :jtot 44); /; call print(%wave,%scale,%period,%coi); /; call tabulate(nino,%recon_y); call graph(afam(nino)-afam(%recon_y)); call graph(%period,%w_power :plottype xyplot); rpart= real(%wave); ipart= imag(%wave); /; call graph(%period rpart ipart :plottype xyplot); call names(all); call tabulate(%scale,%period,%w_power,%w_phase, %w_ampl,%signif,%global,%g_sig); call print(%sa_df %sa_sig); call print('mean original data ',mean(nino):); call print('mean of reconstructed data ',mean(%recon_y):); call print('Variance of original Data ',variance(nino):); call print('Variance of reconstructed Data ',variance(%recon_y):); b34srun; == ==WAVELET2 Wavelet used to filter Series b34sexec options ginclude('wavedata.mac') member(nino3); b34srun; /; /; Illustrates filtering. Increasing so => tighter filter /; b34sexec matrix; call loaddata; /; This setting will closely filter series call wavelet(nino :type morlet :settings :s0 2.25 :dt .25 :jtot 44); filter1=%recon_y; call wavelet(nino :type morlet :settings :s0 3.5 :dt .25 :jtot 44); filter2=%recon_y; call wavelet(nino :type morlet :settings :s0 4.5 :dt .25 :jtot 44); filter3=%recon_y; call tabulate(nino,filter1,filter2,filter3); call graph(nino,filter1,filter2 filter3 :nolabel :heading 'Raw Nino and smoothed series'); b34srun; == ==WAVELET3 Filtering GASOUT with WAVELETS b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /; /; Illustrates filtering of wavelet data /; b34sexec matrix; call loaddata; gasout=gasout-mean(gasout); /; /; Select type of wavelet model /; /; type='morlet'; type='paul'; /; type='dog'; /; This setting will closely filter series call wavelet(gasout :type argument(type) :settings :s0 2.5 :dt .25 :jtot 44); filter1=%recon_y; call wavelet(gasout :type argument(type) :settings :s0 3.5 :dt .25 :jtot 44); filter2=%recon_y; call wavelet(gasout :type argument(type) :settings :s0 5.5 :dt .25 :jtot 44); filter3=%recon_y; call tabulate(gasout,filter1,filter2,filter3); call graph(gasout ,filter1,filter2 filter3 :nolabel :heading 'Raw gasout and smoothed series'); call olsq(gasout filter1{0 to 4} :print); call olsq(gasout filter2{0 to 4} :print); call olsq(gasout filter3{0 to 4} :print); call load(rtest); /$ /$ Default let program decide call autobj(gasout :print :nac 24 :npac 24 /$ :printsteps :spiketol 2.0 :autobuild ); /; call rtest(%res,gasout,48); res1=%res; call autobj(filter1 :print :nac 24 :npac 24 /$ :printsteps :spiketol 2.0 :autobuild ); res2=%res; /; call rtest(%res,filter1,48); call tabulate(gasout filter1 res1 res2); b34srun; == ==WAVELET4 Advanced Tests b34sexec options ginclude('wavedata.mac') member(nino3); b34srun; b34sexec matrix; call loaddata; call echooff; d3tests=1; /; base settings call wavelet(nino :type morlet :settings :s0 .25 :dt .25 :lag1 .72 :lower 2. :upper 7.9 :jtot 44); /; call print(%wave,%scale,%period,%coi); call tabulate(nino,%recon_y,%sa_wpow); call graph(%sa_wpow :heading 'Eq (24) Scale averaged wavelet power'); sa1=%sa_wpow; e1=afam(nino)-afam(%recon_y); call graph(e1 :heading 'wavelet error' ); call graph(%period,%w_power :plottype xyplot :heading 'Wave Power vs %period'); rpart= real(%wave); ipart= imag(%wave); call names(all); call tabulate(%scale,%period,%w_power,%w_phase, %w_ampl,%signif,%global,%g_sig); call print(%sa_df %sa_sig); call print('mean original data ',mean(nino):); call print('mean of reconstructed data ',mean(%recon_y):); call print('Variance of original Data ',variance(nino):); call print('Variance of reconstructed Data ',variance(%recon_y):); call wavelet(nino :type morlet :settings :s0 .25 :dt .25 :lag1 .72 :lower 2. :upper 30. :jtot 44); /; call print(%wave,%scale,%period,%coi); call tabulate(nino,%recon_y,%sa_wpow,sa1); call graph(%sa_wpow,sa1 :heading 'Eq (24) Sa wavelet power sa1 (2-7.9) %sa_wpow (2-30)'); rpart= real(%wave); ipart= imag(%wave); call tabulate(%scale,%period,%w_power,%w_phase, %w_ampl,%signif,%global,%g_sig); call print(%sa_df %sa_sig); call print('mean original data ',mean(nino):); call print('mean of reconstructed data ',mean(%recon_y):); call print('Variance of original Data ',variance(nino):); call print('Variance of reconstructed Data ',variance(%recon_y):); call wavelet(nino :type morlet :settings :s0 .25 :dt .25 :lag1 .72 :lower 2. :upper 30. :jtot 36); e2=afam(nino)-afam(%recon_y); call graph(e1,e2 :heading 'e1 jtot 44 e2 => jtot 36'); call tabulate(e1,e2); /; /; search across a band /; if(d3tests.ne.0)then; i1=1; i2=26; nn=i2-i1+1; s_power=array(norows(nino),nn:); icount=0; do i=i1,i2; call print('++++++++++++++++++++++++++++++++++++++++++':); icount=icount+1; /; rlower=dfloat(i); rlower=dfloat(i1); rupper=dfloat(i+4); call wavelet(nino :settings :type dog :s0 .25 :dt .25 :lag1 0.72 :lower rlower :upper rupper :jtot 60); s_power(1,icount)=%sa_wpow; enddo; /; call print(s_power); call graph(s_power :plottype meshc :d3axis :d3border :box 6 :heading 'SA _ Power ever wider span'); i1=1; i2=26; nn=i2-i1+1; s_power=array(norows(nino),nn:); icount=0; do i=i1,i2; call print('++++++++++++++++++++++++++++++++++++++++++':); icount=icount+1; rlower=dfloat(i); rupper=dfloat(i+4); call wavelet(nino :settings :type dog :s0 .25 :dt .25 :lag1 0.72 :lower rlower :upper rupper :jtot 60); s_power(1,icount)=%sa_wpow; enddo; /; call print(s_power); call graph(s_power :plottype meshc :d3axis :d3border :box 6 :heading 'SA _ Power - Constant Window'); endif; b34srun; == ==WHERE Where Command => Masking operation /; Here for the first where( ) the two objects /; across the equals sign are not the same structure. /; If the ( ) is false x2bad resolves to 0.0 whether or /; not it existed prior to the where( ) being found. /; /; The second where( ) has objects the same structure across /; the =. Both objects exist. Here the old x value is maintained. /; The logic here is test = x*(x.ne.y)+dummy*(x.eq.y) b34sexec matrix; x=array(:1,-2,3,-4,5,-6,7,-8,9,-10); y=array(:0,-2,1,-4,6,-6,2,-8,5,-10); x2bad=x; x2good=x; dummy=array(norows(x):)+ -9999.; where(x.eq.y)x2bad =-9999.; where(x.eq.y)x2good =dummy; test = (x*(x.ne.y))+ (dummy*(x.eq.y)); call tabulate(x,y,dummy,x2bad,x2good,test); b34srun; == ==WHERE_2 Further Example b34sexec matrix; x=array(:1,-2,3,-4,5,-6,7,-8,9,-10); y=array(:0,-2,1,-4,6,-6,2,-8,5,-10); yhold=array(norows(x):); call setcol(yhold,1,-99.); where(x.ne.y)yhold=y; where(x.eq.y)q=y; call print('We set yhold = -99 where x = y', 'We set yhold = y where x ne y', 'We set q = y where x = y', 'We set q = 0 where x ne y'); call tabulate(x,y,yhold,q); where(x.gt.0.0)isgtzero=1.; where(x.gt.0.0)isminus=missing(); call tabulate(x,isgtzero,isminus); b34srun; /$ /$ Illustrate resetting /$ b34sexec matrix; x=array(:1,-2,3,-4,5,-6,7,-8,9,-10); y=array(:0,-2,1,-4,6,-6,2,-8,5,-10); x2bad=x; x2good=x; dummy=array(norows(x):)+missing(); where(x.eq.y)x2bad =missing(); where(x.eq.y)x2good =dummy; call tabulate(x,y,x2bad,x2good); b34srun; == ==WRITE1 READ/WRITE/OPEN/REWIND/CLOSE b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; n=1000; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call open(71,'testdata'); test2=array(n:); call character(cc,'this is less '); call read(test2,71); i=i+100; call read(i,71); call print(i); call read(cc,71); call print(cc); a(1)='bob'; call read(a,71); call print(a); tmean2=mean(test2); call print(tmean2); call names(all); b34srun; == ==WRITE2 Illustrates WRITE/READ to build MATLAB I/O System b34sexec matrix ; /$ Shows Matrix subroutine implementation of built in /$ makematlab and getmatlab commands /$ /$ Job illustrates read / write i/o /$ subroutine gmatlab(c,xx); n=70; call open(n,c); call character(line,' '); call read(line,n); call print(line); xi=1.; xj=1.; call read(xi,n,'(20x,e16.8)'); call read(xj,n,'(20x,e16.8)'); xx=array(idint(xi),idint(xj):); call read(xx,n,'(5e16.8)'); call close(n); return; end; subroutine mmatlab(c,xx); n=70; call open(n,c); call character(ccc,'--File built by B34S(r) MATRIX Facility'); call write(ccc,n); i=norows(xx); j=nocols(xx); call write(dfloat(i),n,'(20x,e16.8)'); call write(dfloat(j),n,'(20x,e16.8)'); call write(xx,n,'(5e16.8)'); call close(n); return; end; xx=rn(array(100,50:)); call character(ccc,'c:\junk\test.mmm'); call mmatlab(ccc,xx); call gmatlab(ccc,crap); call print(crap); b34srun; == ==WRITE3 Character Writes b34sexec matrix; call open(99,'test'); call character(c,'Line one' 'Line 222222222222222222222' 'Line three '); call names(all); call print(c); call write(c,99); call close(99); b34srun; == ==ZDOTC Inner product and related commands b34sexec matrix; n=10; x=rn(vector(n:)); y=rn(x); call print(x,y); call print(x*y,ddot(x,y),afam(x)*afam(y),ddot(x,y:), sum(afam(x)*afam(y))); * Complex case ; cx=complex(x,y); cy=complex(y,x); call print(cx,cy); call print(cx*cy,dconj(cx)*cy,zdotu(cx,cy),zdotc(cx,cy), afam(cx)*afam(cy),dconj(afam(cx))*afam(cy), zdotu(cx,cy:),zdotc(cx,cy:), sum( afam(cx) *afam(cy)), sum(dconj(afam(cx))*afam(cy)) ); b34srun; == ==ZDOTU Inner product and related commands b34sexec matrix; n=10; x=rn(vector(n:)); y=rn(x); call print(x,y); call print(x*y,ddot(x,y),afam(x)*afam(y),ddot(x,y:), sum(afam(x)*afam(y))); * Complex case ; cx=complex(x,y); cy=complex(y,x); call print(cx,cy); call print(cx*cy,dconj(cx)*cy,zdotu(cx,cy),zdotc(cx,cy), afam(cx)*afam(cy),dconj(afam(cx))*afam(cy), zdotu(cx,cy:),zdotc(cx,cy:), sum( afam(cx) *afam(cy)), sum(dconj(afam(cx))*afam(cy)) ); b34srun; == ==ZEROL Zero out lower triangle b34sexec matrix; x=rn(matrix(4,4:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); cx=complex(x,x*2.); x=r8tor16(x); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); cx=c16toc32(cx); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); b34srun; == ==ZEROU Zero out upper triangle b34sexec matrix; x=rn(matrix(4,4:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); cx=complex(x,x*2.); x=r8tor16(x); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); cx=c16toc32(cx); call print(cx); call print(zerou(cx)); call print(zerou(cx :nodiag)); call print(zerol(cx)); call print(zerol(cx : :nodiag)); call print(uppert(cx)); call print(uppert(cx :nodiag)); call print(lowert(cx)); call print(lowert(cx :nodiag)); b34srun; ==