home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / MAPSTATF.LBR / PLOT.PZS / PLOT.ÐAS
Text File  |  2000-06-30  |  7KB  |  211 lines
  1. (* Multivariate Analysis Package - Bivariate Plotting Module
  2.    Copyright 1985 Douglas L. Anderton.  This program may be freely
  3.    circulated so long as it is not sold for profit and any charge does
  4.    not exceed costs of reproduction. *)
  5.  
  6. {  set printer control codes in procedure openfiles }
  7.  
  8. Program Plot(Input,Output);
  9. Const
  10.   N=20;
  11. Type
  12.   SUBS = 1..N;
  13.   RVEC = Array [SUBS] Of Real;
  14.   SVEC = Array [1..21] Of String[1];
  15.   IVEC = Array [SUBS] Of Integer;
  16.   S8 = Array [SUBS] Of String[8];
  17.   PLT = Array [1..60] Of String[120];
  18. Var
  19.   dfile, ofile : Text;
  20.   sel : IVEC;
  21.   miss, vars : RVEC;
  22.   title : String[80];
  23.   varn : S8;
  24.   nc, i, j, k, l, nv, ix, dv, ot : Integer;
  25.   xmin, xmax, xscl, ymin, ymax, yscl : Real;
  26.   sym : SVEC;
  27.   g : PLT;
  28.  
  29. Function Rmin(value1, value2: Real): Real;
  30. Begin If value1<value2 Then Rmin:=value1 Else Rmin:=value2 End;
  31.  
  32. Function Rmax(value1, value2: Real): Real;
  33. Begin If value1>value2 Then Rmax:=value1 Else Rmax:=value2 End;
  34.  
  35. Procedure openfiles(Var dfile, ofile:Text; Var ot:Integer);
  36. Var
  37.   dfl, ofl:String[12];
  38. Begin
  39.   ClrScr; Writeln(' *** PLOT: 2-DIMENSIONAL DATA PLOTTING ***');
  40.   Writeln; Writeln('Output is to LST: - Turn Your Printer On.');
  41.   ofl:='LST:'; Assign(ofile,ofl); Rewrite(ofile); ot:=2;
  42.   Write('Name of the data file? ');
  43.   Readln(dfl); Assign(dfile,dfl); Reset(dfile);
  44.   (* EPSON MX/FX set to 1/8 line spacing and compressed print *)
  45.   Writeln(ofile,#$12);
  46.   Writeln(ofile,'Multivariate Analysis Package (1.6) - ',
  47.     'Program: PLOT, Datafile: ',dfl);
  48.   Writeln(ofile,#$1B#$30#$0F); Writeln(ofile);
  49.   End; (* Of openfiles *)
  50.  
  51. Procedure symbols(varn:S8; dv, j:Integer; Var sym:SVEC);
  52. Var
  53.   i:Integer;
  54. Begin
  55.   Writeln;
  56.   For i:=1 To dv-j Do
  57.     Begin
  58.     Write('Plotting Symbol to use for ',varn[i],'? ');Readln(sym[i]);
  59.     End;
  60.   Write('Plotting Symbol to use for collision? ');Readln(sym[21]);
  61.   End; (* Of symbols *)
  62.  
  63. Procedure selcvar(Var sel:IVEC; Var varn:S8; Var miss:RVEC;
  64.                   Var ij, nv, dv:Integer);
  65. Var
  66.   cfile:Text;
  67.   cfl:String[12];
  68.   i,j,f:Integer;
  69.   mis:Real;
  70.   van:String[8];
  71. Begin
  72.   Write('Name of the codebook file (or NONE)? '); Readln(cfl);
  73.   If (cfl<>'NONE') And (cfl<>'none') Then f:=1 Else f:=0;
  74.   If f=1 Then Begin Assign(cfile,cfl); Reset(cfile); End;
  75.   Writeln;
  76.   Write('How many variables in data file? '); Readln(nv);
  77.   Write('Number of variables to use in PLOT? '); Readln(dv);
  78.   ij:=0;
  79.   Write('Column number for X variable (0=case number)? ');Readln(sel[dv]);
  80.   If sel[dv]>0 Then
  81.     Begin
  82.     Str(sel[dv]:3,varn[dv]); miss[dv]:=-1E37;
  83.     ij:=1;
  84.     End;
  85.   Writeln;
  86.   For i:=1 To dv-ij Do
  87.     Begin
  88.     Write('Column number for Y variable ',i,'? '); Readln(sel[i]);
  89.     Str(sel[i]:3,varn[i]); miss[i]:=-1E37;
  90.     End;
  91.   If f=1 Then Begin
  92.     For j:=1 to nv Do Begin
  93.       mis:=-1E37;
  94.       Readln(cfile,f,van,mis);
  95.       For i:=1 to dv Do
  96.         If f=sel[i] Then Begin
  97.           varn[i]:=van; miss[i]:=mis;
  98.           Writeln('Col: ',sel[i],'  Name: ',varn[i],' Missing: ',miss[i]:6);
  99.           End;     
  100.       End;
  101.     Close(cfile);
  102.     End;
  103.   End; (* Of selcvar *)
  104.  
  105. Procedure getcase(Var vars:RVEC; sel:IVEC; nv, dv:Integer; Var dfile:Text);
  106. Var
  107.   i, j:Integer;
  108.   x:Real;
  109. Begin
  110.   For i:=1 To nv Do
  111.     Begin
  112.     Read(dfile,x);
  113.     For j:=1 To dv Do If (sel[j]=i) Then vars[j]:=x;
  114.     End;
  115.   End; (* Of getcase *)
  116.  
  117. Begin (* main *)
  118.   openfiles(dfile, ofile, ot);
  119.   selcvar(sel, varn, miss, ix, nv, dv);
  120.   symbols(varn, dv, ix, sym);
  121.   (* initialize *)
  122.   FillChar(g,60*120,' ');
  123.   nc:=0; xmin:=1E30; xmax:=-1E30; ymin:=1E30; ymax:=-1E30;
  124.   If ix=0 Then xmin:=1;
  125.   (* Read for max and min *)
  126.   Writeln; Writeln('1st Pass:');
  127.   While Not EOF(dfile) Do Begin
  128.     getcase(vars, sel, nv, dv, dfile);
  129.     j:=0;
  130.     If Not EOF(dfile) Then Begin
  131.       For i:=1 to dv Do If vars[i]=miss[i] Then j:=1;
  132.       If j=0 Then Begin
  133.         nc:=nc+1;
  134.         If Frac(nc/10)=0.0 Then Write('+');
  135.         If ix=0 Then xmax:=nc
  136.         Else Begin
  137.           xmin:=Rmin(vars[dv],xmin); xmax:=Rmax(vars[dv],xmax); End;
  138.         For i:=1 To dv-ix Do Begin
  139.           ymin:=Rmin(vars[i],ymin); ymax:=Rmax(vars[i],ymax); End;
  140.         End;
  141.       End;
  142.     End;
  143.   (* scale graph *)
  144.   ClrScr; Writeln;
  145.   Write('Minimum for X Axis (',xmin:8,'=default)? ');Readln(xmin);
  146.   Write('Maximum for X Axis (',xmax:8,'=default)? ');Readln(xmax);
  147.   Write('Minimum for Y Axis (',ymin:8,'=default)? ');Readln(ymin);
  148.   Write('Maximum for Y Axis (',ymax:8,'=default)? ');Readln(ymax);
  149.   xscl:=119.0/(xmax-xmin); yscl:=59.0/(ymax-ymin);
  150.   (* fill it *)
  151.   Reset(dfile); Writeln('2nd Pass:'); nc:=0;
  152.   While Not EOF(dfile) Do Begin
  153.     getcase(vars, sel, nv, dv, dfile);
  154.     j:=0;
  155.     If Not EOF(dfile) Then Begin
  156.       For i:=1 to dv Do If vars[i]=miss[i] Then j:=1;
  157.       If j=0 Then Begin
  158.         nc:=nc+1;
  159.         If Frac(nc/10)=0.0 Then Write('+');
  160.         If ix=0 Then k:=Trunc((nc-xmin)*xscl)+1
  161.         Else k:=Trunc((vars[dv]-xmin)*xscl)+1;
  162.         For i:=1 To dv-ix Do Begin
  163.           l:=Trunc((vars[i]-ymin)*yscl)+1;
  164.           If ((l>0) And (l<60)) And ((k>0) And (k<120)) Then
  165.             If (Copy(g[l],k,1)=' ') Then
  166.               Begin Delete(g[l],k,1); Insert(sym[i],g[l],k); End
  167.           Else Begin Delete(g[l],k,1); Insert(sym[21],g[l],k); End;
  168.           End;
  169.         End;
  170.       End;
  171.     End;
  172.   (* Output Plot *)
  173.   ClrScr;
  174.   Writeln('Title (up to 80 chars)? '); Readln(title);
  175.   Writeln(ofile,title);
  176.   Writeln(ofile);
  177.   Write(ofile,'         |-');
  178.   For i:=1 To 12 Do Write(ofile,'---------|');
  179.   Writeln(ofile);
  180.   For i:=1 To 60 Do Begin
  181.     j:=61-i;
  182.     If (Frac(j/10)=0.0) Then Begin
  183.       yscl:=((ymax-ymin)/60)*j+ymin;
  184.       Writeln(ofile,yscl:8,'-|',g[j]:120,'|');
  185.       End
  186.     Else Writeln(ofile,'        -|',g[j]:120,'|');
  187.     End;
  188.   Write(ofile,ymin:8,'-+|');
  189.   For i:=1 To 12 Do Write(ofile,'---------|');
  190.   Writeln(ofile); Write(ofile,'   ');
  191.   For i:=0 To 12 Do Begin
  192.     xscl:=((xmax-xmin)/120)*(i*10)+xmin;
  193.     Write(ofile,xscl:8);
  194.     If i<12 Then Write(ofile,'  ');
  195.     End;
  196.   Writeln(ofile); Writeln(ofile,'Legend:');
  197.   For i:=1 To dv-ix Do Begin
  198.     Write(ofile,' ',varn[i]:8,'=',sym[i]:1,' ');
  199.     If (i=13) And (dv>13) Then Writeln(ofile);
  200.     End;
  201.   If ix=0 Then varn[dv]:='Case Num ';
  202.   Writeln(ofile,' by ',varn[dv]:8);
  203.   Writeln(ofile,#$12); Writeln(ofile);
  204.   Close(dfile);  Close(ofile);
  205.   Assign(dfile,'MAPSTAT.COM'); Execute(dfile);
  206. End.
  207. 
  208.   Writeln(ofile,title);
  209.   Writeln(ofile);
  210.   Write(ofile,'         |-');
  211.   For i:=1 To 12 Do Write(ofile,'------