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 / TRANSFRM.PZS / TRANSFRM.ÐAS
Text File  |  2000-06-30  |  12KB  |  340 lines
  1. (* Multivariate Analysis Package - Data Transformation Module
  2.    Copyright 1985 Douglas L. Anderton.  This program may be
  3.    freely circulated so long as it is not sold for profit
  4.    and any charge does not exceed costs of reproduction *)
  5.  
  6. Program Transfrm(Input,Output);
  7. Const
  8.    N=100;
  9. Type
  10.    SUBS=1..N;
  11.    RVEC = Array [SUBS] Of Real;
  12.    RVE2 = Array [1..200] Of Real;
  13.    IVEC = Array [SUBS] Of Integer;
  14.    IVE2 = Array [1..200] Of SUBS;
  15.    ST12 = String[12];
  16.    TR = String[79];
  17.    TS = Array [SUBS] of TR;
  18. Var
  19.    dfile, ofile, tfile : Text;
  20.    sel : IVEC;
  21.    sub : IVE2;
  22.    miss, vars, ho : RVEC;
  23.    cns : RVE2;
  24.    dv, fo, t : SUBS;
  25.    i, k, l, nv, nt : Integer;
  26.    trans: TS;
  27.  
  28. {$I TRANSBUF.LIB}
  29.  
  30. Procedure openfiles(Var dfile, ofile, tfile:Text; Var fo:SUBS);
  31. Var
  32.    dfl, ofl:String[12];
  33. Begin
  34.    ClrScr; Writeln(' *** TRANSFRM: DATA TRANSFORMATION ***');
  35.    Writeln; Write('Name of the input data file? ');
  36.    Readln(dfl); Assign(dfile,dfl); Reset(dfile);
  37.    Write('Name of output data file (con:/lst: not allowed)? ');
  38.    Readln(ofl);
  39.    If (ofl='CON:') Or (ofl='con:') Then ofl:='CONSOLE.TMP';
  40.    If (ofl='LST:') Or (ofl='lst:') Then ofl:='LIST.TMP';
  41.    initwrite(ofl);
  42.    Write('Name of the transformation file (or con:)? ');
  43.    Readln(dfl); Assign(tfile,dfl); Reset(tfile);
  44.    If (dfl='CON:') Or (dfl='con:') Then fo:=1 Else fo:=0;
  45.    End; (* Of openfiles *)
  46.  
  47. Procedure selectvar(Var sel:IVEC; Var miss:RVEC; Var nv:Integer; Var dv:SUBS);
  48. Var
  49.   cfile:Text;
  50.   cfl:String[12];
  51.   i,j,f:Integer;
  52.   mis:Real;
  53.   van:String[8];
  54. Begin
  55.    Write('Name of the codebook file (or NONE)? '); Readln(cfl);
  56.    If (cfl<>'NONE') And (cfl<>'none') Then f:=1 Else f:=0;
  57.    If f=1 Then Begin Assign(cfile,cfl); Reset(cfile); End;
  58.    Writeln;
  59.    Write('How many variables in data file? '); Readln(nv);
  60.    Write('Number of variables to use in TRANSFRM? '); Readln(dv);
  61.    For i := 1 To dv Do
  62.      Begin
  63.      Write('Column number for variable ',i,'? '); Readln(sel[i]);
  64.      miss[i]:=-1E37;
  65.      End;
  66.   If f=1 Then Begin
  67.     For j:=1 to nv Do Begin
  68.       mis:=-1E37;
  69.       Readln(cfile,f,van,mis);
  70.       For i:=1 to dv Do
  71.         If f=sel[i] Then Begin
  72.           miss[i]:=mis;
  73.           Writeln('Col: ',sel[i],' Name: ',van,' Missing: ',miss[i]:6);
  74.           End;
  75.       End;
  76.     Close(cfile);
  77.     End;
  78.   End; (* Of selectvar *)
  79.  
  80. Procedure prmenu2;
  81. Begin
  82.    ClrScr; Writeln(' *** TRANSFRM: DATA TRANSFORMATION ***'); Writeln;
  83.    Writeln('Valid Arithmetic Operators:');
  84.    Writeln('     +         -        *       /       =');
  85.    Writeln('Turbo Pascal Functions Supported:');
  86.    Writeln('     ABS     ARCTAN    COS      EXP     FRAC     INT');
  87.    Writeln('     LN      SIN       SQR      SQRT    ROUND    TRUNC');
  88.    Writeln('     RANDOM');
  89.    Writeln('Nonstandard MAP functions supported:');
  90.    Writeln('     IF      IFS       LAG      NORMAL  POW      REC');
  91.    Writeln('Number Entry:');
  92.    Writeln('     Leading minus allowed (not plus) number must be less than');
  93.    Writeln('     or equal to 11 digits, e.g. .001  12   -.0000005  etc.');
  94.    Writeln;
  95.    Writeln('Note: no check of statements is provided until runtime. [n]');
  96.    Writeln('      refers to the nth variable read, not the nth column.');
  97.    Writeln('      Comments may follow transformations on the same line');
  98.    Writeln('      except END statement.  Functions must be UPPERCASE.');
  99.    Writeln;
  100.    End; (* of prmenu2 *)
  101.  
  102. Procedure prmenu;
  103. Begin
  104.    ClrScr; Writeln(' *** TRANSFRM: DATA TRANSFORMATION ***'); Writeln;
  105.    Write('Data transformation statements are entered in RPN (reverse');
  106.    Writeln(' polish notation)');
  107.    Write('with blanks separating each operator, constant, or variable.');
  108.    Writeln(' Statements are');
  109.    Write('terminated by ''='' to end  the statement and the variable');
  110.    Writeln(' number  to receive');
  111.    Write('the value.  Variables are referred  to by column number');
  112.    Writeln(' in  brackets ''[n]''.');
  113.    Write('New variables created by  transformations are  added to');
  114.    Writeln(' the data file.  Use');
  115.    Write('successive numbers for new variables (if you read  four');
  116.    Writeln(' variables the first');
  117.    Write('you create should be ''[5]'' etc.)  ''END'' in the first');
  118.    Writeln(' three columns will end');
  119.    Writeln('input of transformations.');
  120.    Writeln;
  121.    Writeln('Examples:');
  122.    Write('   To put the square root of 3.2 times the first variable into');
  123.    Writeln(' the first -');
  124.    Writeln('     ->3.2 [1] * SQRT = [1]');
  125.    Write('   To create a new sixth variable as the natural logarithm of');
  126.    Writeln(' the second');
  127.    Writeln('   divided by the fifth -');
  128.    Writeln('     ->[5] [2] LN / = [6]');
  129.    Writeln('   To recode second variable if between 10 and 50 to value 3 -');
  130.    Writeln('     ->[2] 10 50 3 REC = [2]'); Writeln;
  131.    Writeln('A summary of available operators is displayed during entry.');
  132.    Writeln;
  133.    Write('- Press any key to continue -'); While Not KeyPressed Do;
  134.    ClrScr; prmenu2;
  135.    End; (* Of prmenu *)
  136.  
  137. Procedure getcase(Var vars:RVEC; sel:IVEC; nv, dv:SUBS; Var dfile:Text);
  138. Var
  139.    i, j:SUBS;
  140.    x:Real;
  141. Begin
  142.    For i := 1 To nv Do
  143.       Begin
  144.       Read(dfile,x);
  145.       For j := 1 To dv Do If (sel[j]=i) Then vars[j] := x;
  146.       End;
  147.    End; (* Of getcase *)
  148.  
  149. Procedure nextop(temp:TR; Var tstr: ST12; Var sgp:Integer);
  150. Var k,l: SUBS;
  151. Begin
  152.    k:=Pos(' ',Copy(temp,sgp,11));
  153.    tstr:=Copy(temp,sgp,k);
  154.    sgp:=sgp+k;
  155.    End; (* Of nextop *)
  156.  
  157. Function Tnum(Var t:Char): Boolean;
  158. Begin Tnum:=false;
  159.  If(((t>='0') and (t<='9')) or (t='.')) Then Tnum:=True; End;
  160.  
  161. Procedure ParseNums(Var trans:TS; Var cns:RVE2; Var sub:IVE2);
  162. Var
  163.    opr: Real;
  164.    i, t, f, cntp, subp: SUBS;
  165.    j, sgp, varn: Integer;
  166.    tstr: ST12;
  167.    temp: TR;
  168.    tstr1: Char;
  169. Begin
  170.    FillChar(cns,6*200,0); FillChar(sub,200,0); cntp:=0; subp:=0;
  171.    i:=1; t:=0;
  172.    While (t=0) Do
  173.      Begin
  174.      sgp:=1; temp:=trans[i]; f:=0;
  175.      While (f<2) Do
  176.        Begin
  177.        nextop(temp,tstr,sgp);
  178.        tstr1:=tstr[1];
  179.        case tstr1 of
  180.          '-':If(Tnum(tstr[2])) Then Begin
  181.                Val(Copy(tstr,2,(Pos(' ',tstr)-1)),opr,j);
  182.                cntp:=cntp+1; cns[cntp]:=-opr; End;
  183.          '[':Begin Val(Copy(tstr,2,(Pos(']',tstr)-2)),varn,j);
  184.                subp:=subp+1; sub[subp]:=varn;
  185.                If(f>0) then f:=2; End;
  186.          'E':If(tstr[2]='N') Then Begin t:=1; f:=2; End;
  187.          '=':f:=1;
  188.          Else {of case check to see if it is a constant}
  189.            If(Tnum(tstr1)) Then Begin
  190.                 Val(Copy(tstr,2,(Pos(' ',tstr)-1)),opr,j);
  191.                 cntp:=cntp+1; cns[cntp]:=-opr; End;
  192.          End; (* of case *)
  193.        End; (* of this transform *)
  194.      i:=i+1;
  195.      End;
  196.   End; (* Of ParseNums *)
  197.  
  198. Procedure transform(Var vars, hold, miss:RVEC; cns:RVE2; sub:IVE2;
  199.                     Var dv, t:SUBS; trans:TS);
  200. Var
  201.    op1, op2, op3, op4: Real;
  202.    st: RVEC;
  203.    i, sp, tag, flg: SUBS;
  204.    j, sgp, varn, cntp, subp: Integer;
  205.    tstr: ST12;
  206.    temp: TR;
  207.    tstr1: Char;
  208.  
  209. Procedure push(ac: Real; Var st:RVEC; Var sp:SUBS);
  210. Begin sp:=sp+1; st[sp]:=ac; End; (* Of push *)
  211.  
  212. Function pop(Var st:RVEC; Var sp:SUBS): Real;
  213. Begin pop:=st[sp]; sp:=sp-1; End; (* Of pop *)
  214.  
  215. Procedure nextcnt(Var cntp:Integer; Var cns:RVE2; Var x:Real);
  216. Begin cntp:=cntp+1; x:=cns[cntp]; End;
  217.  
  218. Procedure nextint(Var subp:Integer; Var sub:IVE2; Var x:Integer);
  219. Begin subp:=subp+1; x:=sub[subp]; End;
  220.  
  221. Begin (* Of Transform *)
  222.    i:=1; t:=0; flg:=0; tstr:='?'; cntp:=0; subp:=0;
  223.    While ((tstr[1]<>'E') or (tstr[2]<>'N')) and (t=0) Do
  224.       Begin
  225.       FillChar(st,6*N,0);
  226.       sp:=0; sgp:=1; tag:=0; temp:=trans[i];
  227.       While (tag=0) Do
  228.        Begin
  229.        nextop(temp,tstr,sgp);
  230.        tstr1:=tstr[1];
  231.        case tstr1 of
  232.          '=': tag:=4;
  233.          '+': push((pop(st,sp)+pop(st,sp)),st,sp);
  234.          '*': push((pop(st,sp)*pop(st,sp)),st,sp);
  235.          '/': push((pop(st,sp)/pop(st,sp)),st,sp);
  236.          '-': If(Tnum(tstr[2])) Then Begin nextcnt(cntp,cns,op1);
  237.                 op1:=-op1; push(op1,st,sp); End
  238.               Else push((pop(st,sp)-pop(st,sp)),st,sp);
  239.          '[':Begin nextint(subp,sub,varn); push(vars[varn],st,sp);
  240.               If(vars[varn]=miss[varn]) Then Begin
  241.                 While (tstr[1]<>'=') Do nextop(temp,tstr,sgp); tag:=3; End;
  242.              End;
  243.          'I':If (tstr[3]='S') Then {ifs, if and int}
  244.                 If(pop(st,sp)<0.0) Then tag:=2
  245.                 Else tag:=5 (* keep record but stop loop *)
  246.               Else If(tstr[3]='T') Then push(Int(pop(st,sp)),st,sp)
  247.               Else If(pop(st,sp) < 0.0) Then tag:=1;
  248.          'E':If(tstr[2]='N') Then tag:=4 {exp and end}
  249.              Else push(Exp(pop(st,sp)),st,sp);
  250.          'L':If(tstr[2]='N') Then push(Ln(pop(st,sp)),st,sp) {ln and lag}
  251.              Else Begin op1:=pop(st,sp); push(hold[varn],st,sp);
  252.                   hold[varn]:=op1; End;
  253.          'P':push(exp(pop(st,sp)*ln(pop(st,sp))),st,sp); {pow}
  254.          'S':If(tstr[2]='Q') Then {sqrt sqr and sin}
  255.                If(tstr[4]='T') Then push(Sqrt(pop(st,sp)),st,sp)
  256.                Else push(Sqr(pop(st,sp)),st,sp)
  257.              Else push(Sin(pop(st,sp)),st,sp);
  258.          'C':push(Cos(pop(st,sp)),st,sp); {cos}
  259.          'A':If(tstr[2]='B') Then push(abs(pop(st,sp)),st,sp) {abs and arctan}
  260.              Else push(ArcTan(pop(st,sp)),st,sp);
  261.          'T':push(Trunc(pop(st,sp)),st,sp); {trunc}
  262.          'F':push(Frac(pop(st,sp)),st,sp); {frac}
  263.          'R':If(tstr[2]='A') Then push(Random,st,sp) {random round and rec}
  264.              Else If(tstr[2]='O') Then push(Round(pop(st,sp)),st,sp)
  265.                   Else Begin
  266.                   op1:=pop(st,sp);op2:=pop(st,sp);
  267.                   op3:=pop(st,sp);op4:=pop(st,sp);
  268.                   If((op3<=op4) and (op4<=op2)) Then push(op1,st,sp)
  269.                     Else push(op4,st,sp); End;
  270.          'N':Begin push(0.0,st,sp); {normal}
  271.             For j:=1 To 12 Do push((pop(st,sp)+Random),st,sp);
  272.             push((pop(st,sp)-6.0),st,sp); End;
  273.          Else {of case check to see if it is a constant}
  274.            If(Tnum(tstr1)) Then Begin nextcnt(cntp,cns,op1);
  275.              push(op1,st,sp); End;
  276.          End; (* of case *)
  277.        End; (* of this transform *)
  278.      If(tstr1='=') Then nextop(temp,tstr,sgp);
  279.      If(tstr[1]='[') Then
  280.         Begin
  281.         nextint(subp,sub,varn);
  282.         If(varn>dv) Then dv:=varn;
  283.         vars[varn]:=pop(st,sp);
  284.         If(tag=3) Then vars[varn]:=-1E37;
  285.         End;
  286.      If(tag=2) Then t:=1;
  287.      i:=i+1;
  288.      End;
  289.   End; (* Of transform *)
  290.  
  291. Begin (* main *)
  292.    openfiles(dfile,ofile,tfile,fo);
  293.    selectvar(sel,miss,nv,dv);
  294.    (* intialize *)
  295.    nt:=0; Randomize;
  296.    (* build transformations *)
  297.    If (fo=1) Then prmenu;
  298.    Writeln;
  299.    i:=1;
  300.    While i>0 Do
  301.      Begin
  302.      If(fo=1) Then
  303.        Begin
  304.        Writeln; Write(' ->');
  305.        Read(tfile,trans[i]);
  306.        End;
  307.      If(fo<>1) Then
  308.        Begin
  309.        Readln(tfile,trans[i]);
  310.        Writeln(' -> ',trans[i]);
  311.        End;
  312.      trans[i]:=Concat(trans[i],' ');
  313.      If (trans[i][1]='E') Then i:=0 Else i:=i+1;
  314.      End;
  315.    ParseNums(trans,cns,sub);
  316.    (* read and transform *)
  317.    k:=0;
  318.    For i:=1 To dv Do ho[i]:=-1E37;
  319.    While Not EOF(dfile) Do
  320.      Begin
  321.      k:=k+1;
  322.      getcase(vars,sel,nv,dv,dfile);
  323.      If (Frac(k/10)=0.0) Then Write('+');
  324.      If Not EOF(dfile) Then
  325.        Begin
  326.        transform(vars,ho,miss,cns,sub,dv,t,trans);
  327.        (* Output *)
  328.        If (t=0) Then Begin
  329.          For i:=1 To dv Do Write(usr,vars[i]:11,' '); Writeln(usr);
  330.          End;
  331.        End;
  332.      End;
  333.    Close(dfile); endwrite;
  334.    Assign(dfile,'MAPSTAT.COM'); Execute(dfile);
  335. End.
  336.  
  337. 0; Randomize;
  338.    (* build transformations *)
  339.    If (fo=1) Then prmenu;
  340.