(* Multivariate Analysis Package - Descriptive Statistics Module Copyright 1985 Douglas L. Anderton. This program may be freely circulated so long as it is not sold for profit and any charge does not exceed costs of reproduction *) Program Descrpt(Input,Output); Label initer, ngroup; Const N=100; Type SUBS = 1..N; RVEC = Array [SUBS] Of Real; IVEC = Array [SUBS] Of Integer; S8 = Array [SUBS] Of String[8]; S = String[8]; Var dfile, ofile: Text; sel : IVEC; t1, t2, t3, vr, gold, wht, mu, stdv, ster, vrnc, skw, krt, rng: Real; nc, miss, vars, mm1, mm2, mm3, mm4, vmin, vmax : RVEC; varn : S8; grp, fg, i, j, k, nv, dv, ot, gp, wt, wgt : Integer; ngp : Boolean; yn : S; Procedure openfiles(Var dfile, ofile:Text; Var ot:Integer); Var dfl, ofl:String[12]; Begin ClrScr; Writeln(' *** DESCRPT: DESCRIPTIVE STATISTICS ***'); Writeln; Write('Name of the data file? '); Readln(dfl); Assign(dfile,dfl); Reset(dfile); Write('Name of the output file? '); Readln(ofl); Assign(ofile,ofl); Rewrite(ofile); ot:=0; If(ofl='CON:') Or (ofl='con:') Then ot:=1; If(ofl='LST:') Or (ofl='lst:') Then ot:=2; If(ot=2) Then Begin Writeln(ofile,'Multivariate Analysis Package (1.6) - ', 'Program: DESCRPT, Datafile: ',dfl); Writeln(ofile); End; End; (* Of openfiles *) Procedure wait(ot:Integer); Begin If ot=1 Then Begin Write('- Press any key to continue -'); While Not KeyPressed Do; ClrScr; End; End; (* of wait *) Procedure selvar(Var sel:IVEC; Var varn:S8; Var miss:RVEC; Var gp, wt, dv, nv:Integer); Var cfile:Text; cfl:String[12]; i,j,f:Integer; mis:Real; van:String[8]; Begin Write('Name of the codebook file (or NONE)? '); Readln(cfl); If (cfl<>'NONE') And (cfl<>'none') Then f:=1 Else f:=0; If f=1 Then Begin Assign(cfile,cfl); Reset(cfile); End; Writeln; Write('How many variables in data file? '); Readln(nv); Write('Number of variables to use in DESCRPT? '); Readln(dv); For i:=1 To dv Do Begin Write('Column number for variable ',i,'? '); Readln(sel[i]); Str(sel[i]:3,varn[i]); miss[i]:=-1E37; End; Write('Of these Column numbers which is weight (0=none)? '); Readln(wt); Write('Of these Column numbers which is grouping (0=none)? '); Readln(gp); If gp<>0 Then Begin Writeln('Note: data assumed sorted on grouping variable'); Writeln(' histograms not allowed with grouped data'); End; If f=1 Then Begin For j:=1 to nv Do Begin mis:=-1E37; Readln(cfile,f,van,mis); For i:=1 to dv Do If f=sel[i] Then Begin varn[i]:=van; miss[i]:=mis; Writeln('Col: ',sel[i],' Name: ',varn[i],' Missing: ',miss[i]:6); End; End; Close(cfile); wait(1); End; End; (* Of selvar *) Procedure getcase(Var vars:RVEC; sel:IVEC; nv, dv:Integer; Var dfile:Text); Var i, j:Integer; x:Real; Begin For i:=1 To nv Do Begin Read(dfile,x); For j:=1 To dv Do If(sel[j]=i) Then vars[j]:=x; End; End; (* Of getcase *) Procedure histogram(mx, mn, iv:Real; vnum:Integer; varn:S; miss:Real; Var dfile, ofile:Text); Var l, k, tot:Integer; x, p, c:Real; s:String[1]; freq:Array [1..200] Of Integer; Begin (* reread data For frequencies *) Reset(dfile); tot:=0; FillChar(freq,2*200,0); While Not Eof(dfile) Do Begin For l:=1 To vnum Do Read(dfile,x); Readln(dfile); If(x <> miss) Then Begin l:=Trunc(((x-mn)/((mx-mn)/iv))+1); If l>Trunc(iv) Then l:=Trunc(iv); freq[l]:=freq[l]+1; tot:=tot+1; End; End; (* now print graphics *) s:='#'; c:=0.0; ClrScr; Writeln(ofile); Writeln(ofile, 'Histogram for ', varn,' with ',Round(iv),' intervals'); Writeln(ofile); Writeln(ofile,'From To Freq Pct Cum --10--20--30--40--50', '--60--70--80--90-100'); mx:=(mx-mn)/iv; For l:=1 To Trunc(iv) Do Begin p:=(freq[l]/tot)*100.0; c:=c+p; Write(ofile,mn+((l-1)*mx):9:3,mn+(l*mx):9:3, freq[l]:4,p:7:2,c:7:2,'|'); For k:=1 To Round(0.4*p) Do Write(ofile,s); Writeln(ofile); End; Writeln(ofile,' --10--20--30--40--50', '--60--70--80--90-100'); End; (* Of histogram *) Begin (* main *) openfiles(dfile, ofile, ot); selvar(sel, varn, miss, gp, wt, dv, nv); (* intialize *) fg:=0; wgt:=0; grp:=0; For i:=1 To dv Do Begin If wt=sel[i] Then wgt:=i; If gp=sel[i] Then grp:=i; End; initer: FillChar(nc,6*N,0); FillChar(mm1,6*N,0); FillChar(mm2,6*N,0); FillChar(mm3,6*N,0); FillChar(mm4,6*N,0); (* accumulate *) Writeln; k:=0; While Not EOF(dfile) Do Begin k:=k+1; If fg=0 Then getcase(vars, sel, nv, dv, dfile); fg:=0; If Frac(k/10)=0.0 Then Write('+'); ngp:=False; If Not EOF(dfile) Then Begin If((grp<>0) And (k>1)) Then ngp:=Not(vars[grp]=gold); gold:=vars[grp]; If ngp Then Goto ngroup; If(((wgt<>0) And (vars[wgt]<>miss[wgt])) Or (wgt=0)) Then For j:=1 To dv Do Begin If vars[j]<>miss[j] Then Begin wht:=1; If(wgt<>0) And (j<>wgt) Then wht:=vars[wgt]; If nc[j]=0.0 Then Begin vmax[j]:=vars[j]; vmin[j]:=vars[j]; End; If vars[j]>vmax[j] Then vmax[j]:=vars[j]; If vars[j] 1 Then Begin mu:=mm1[j]; vrnc:=mm2[j]/(nc[j]-1.0); stdv:=Sqrt(vrnc); ster:=stdv/Sqrt(nc[j]); rng:=vmax[j]-vmin[j]; If((stdv<>0.0) and (nc[j]>2.0)) Then skw:=nc[j]*mm3[j]/((nc[j]-1.0)*(nc[j]-2.0)*vrnc*stdv) Else skw:=0.0; If((vrnc<>0.0) And (nc[j]>3.0)) Then krt:=(nc[j]*(nc[j]+1.0)* mm4[j]-Sqr(mm2[j])*(nc[j]-1)*3.0)/((nc[j]-1.0)*(nc[j]-2.0)* (nc[j]-3.0)*Sqr(vrnc)) Else krt:=0.0; Writeln(ofile,'Mean: ',mu:13:5,' Std. Error:',ster:13:5); Writeln(ofile,'Variance:',vrnc:13:5,' Std. Dev: ',stdv:13:5); Writeln(ofile,'Skewness:',skw:13:5,' Kurtosis: ',krt:13:5); Writeln(ofile,'Max: ',vmax[j]:13:5,' Min: ',vmin[j]:13:5); Writeln(ofile,'Range: ',rng:13:5,' Cases: ',nc[j]:13:5); Writeln(ofile); (* construct frequency histogram *) If(gp<>0) Then Begin Write('- Press any key to continue -'); While Not KeyPressed Do; End; If(gp=0) Then Begin Writeln('Histograms take another pass at the data, do you want'); Write('one for variable ',varn[j],'? '); Readln(yn); If((Copy(yn,1,1)='Y') Or (Copy(yn,1,1)='y')) Then Begin rng:=ot*20.0; If rng>nc[j] Then rng:=nc[j]; Write('Intervals in histogram (recommend',Trunc(rng):3,')? '); Readln(rng); Writeln; histogram(vmax[j],vmin[j],rng,sel[j],varn[j],miss[j], dfile,ofile); wait(ot); End; End; End; ClrScr; End; If Not EOF(dfile) Then Begin fg:=1; Goto initer; End; Close(dfile); Close(ofile); Assign(dfile,'MAPSTAT.COM'); Execute(dfile); End.