home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / lambda / soundpot / f / map12.lbr / CROSSTAB.PZS / CROSSTAB.PAS
Encoding:
Pascal/Delphi Source File  |  1993-10-26  |  9.3 KB  |  320 lines
  1. (* Multivariate Analysis Package - N-Way Crosstabulation Module
  2.    A copyrighted program by Douglas L. Anderton 1985.  This
  3.    program may be freely circulated so long as it is not sold for
  4.    profit and any charge does not exceed costs of reproduction *)
  5.  
  6. {$A-}
  7. Program Crosstab(Input,Output);
  8. (* Up to eight variables and up to 25 unique codes for each, so
  9.    long as the total number of cells is less than 3500.  You
  10.    should use a variable with less than 8 unique codes for the
  11.    column variable for the most attractive printout on a 80col.
  12.    printer. *)
  13. Type
  14.    TB = Array [1..3500] Of Integer;
  15.    IX = Array [1..8,1..25] Of Real;
  16.    I8 = Array [1..8] Of Integer;
  17.    R8 = Array [1..8] Of Real;
  18.    S8 = Array [1..8] Of String[8];
  19.    R25 = Array [1..25] Of Real;
  20.    M25 = Array [1..25,1..25] Of Real;
  21. Var
  22.    dfile, ofile : Text;
  23.    sel, m, c : I8;
  24.    vars : R8;
  25.    varn : S8;
  26.    indx : IX;
  27.    tabl : TB;
  28.    i, j, k, nv, dv, ot : Integer;
  29.    nc : Real;
  30.  
  31. Procedure openfiles(Var dfile, ofile:Text; Var nv, dv, ot:Integer);
  32. Var
  33.    dfl, ofl:String[12];
  34. Begin
  35.    ClrScr; Writeln(' *** CROSSTAB: N-WAY TABLES AND ASSOCIATION TESTS ***');
  36.    Writeln; Write('Name of the data file? ');
  37.    Readln(dfl); Assign(dfile,dfl); Reset(dfile);
  38.    Write('Name of the output file? ');
  39.    Readln(ofl); Assign(ofile,ofl); Rewrite(ofile);
  40.    ot:= 0;
  41.    If (ofl='CON:') Or (ofl='con:') Then ot:=1;
  42.    If (ofl='LST:') Or (ofl='lst:') Then ot:=2;
  43.    If (ot=2) Then
  44.       Begin
  45.       Writeln(ofile,'Multivariate Analysis Package (1.2) - ',
  46.          'Program: CROSSTAB, Datafile: ',dfl); Writeln(ofile);
  47.       End;
  48.    Write('How many variables in data file? ');
  49.    Readln(nv);
  50.    Write('Number of variables to use in CROSSTAB? ');
  51.    Readln(dv);
  52.    End; (* Of openfiles *)
  53.  
  54. Procedure selectvar(Var sel, m:I8; Var varn:S8; dv:Integer);
  55. Var
  56.    i:Integer;
  57. Begin
  58.    Writeln; Write('Column number for COLUMN variable? ');
  59.    Read(sel[1]); Write('  Name? '); Readln(varn[1]);
  60.    Write('     Max. No. Categories? '); Readln(m[1]);
  61.    Write('Column number for ROW variable? ');
  62.    Read(sel[2]); Write('  Name? '); Readln(varn[2]);
  63.    Write('     Max. No. Categories? '); Readln(m[2]);
  64.    For i := 3 To dv Do
  65.       Begin
  66.       Write('Column number for BREAKDOWN variable ',i-2,'? ');
  67.       Read(sel[i]); Write('  Name? '); Readln(varn[i]);
  68.       Write('     Max. No. Categories? '); Readln(m[i]);
  69.       End;
  70.    End; (* Of selectvar *)
  71.  
  72. Procedure getcase(Var vars:R8; sel:I8; nv, dv:Integer; Var dfile:Text);
  73. Var
  74.    i, j:Integer;
  75.    x:Real;
  76. Begin
  77.    For i := 1 To nv Do
  78.       Begin
  79.       Read(dfile,x);
  80.       For j := 1 To dv Do
  81.          Begin
  82.          If (sel[j]=i) Then vars[j] := x;
  83.          End;
  84.       End;
  85.    End; (* Of getcase *)
  86.  
  87. Procedure tables(vars:R8; dv:Integer; Var varn:S8; Var m, c:I8;
  88.                  Var indx:IX; Var tabl:TB);
  89. Var
  90.    i,j,k: Integer;
  91.    cell: I8;
  92. Begin
  93.    (* for each var search c[] codes stored in indx[] for match *)
  94.    For i:= 1 To dv Do
  95.       Begin
  96.       j := c[i]; cell[i]:=0;
  97.       While j > 0 Do
  98.          Begin
  99.          If (vars[i] = indx[i,j]) Then cell[i] := j;
  100.          j := j - 1;
  101.          End;
  102.       (* no match found set up new code and identify cell *)
  103.       If cell[i] = 0 Then
  104.          Begin
  105.          c[i] := c[i] + 1;
  106.          If c[i] > m[i] Then
  107.             Begin
  108.             ClrScr; gotoXY(5,10);
  109.             Writeln('** Error: Over',m[i]:3,' values for ',varn[i],' **');
  110.             Delay(2000); Bdos(0);
  111.             End;
  112.          indx[i,c[i]] := vars[i]; cell[i] := c[i];
  113.          End;
  114.       End;
  115.    (* add to table *)
  116.    j:=cell[1]; k:=1;
  117.    For i:=2 To dv Do
  118.      Begin
  119.      k:=k*m[i-1];
  120.      j :=j+cell[i]*k;
  121.      End;
  122.    tabl[j] := tabl[j] + 1;
  123.    End; (* Of tables *)
  124.  
  125. Procedure tabstats(gt:Real; snr, snc:Integer; srtot, sctot:R25;
  126.                    save:M25; ot:Integer; Var ofile:Text);
  127. Var
  128.    i, j, k, l: Integer;
  129.    sr, sc, ar, ac, ex, chi, temp: Real;
  130. Begin
  131.    (* association statistics *)
  132.    chi:=0.; temp:=0.; k:=0; l:=0;
  133.    For i:=1 To snr Do
  134.      Begin
  135.      If srtot[i] > 0 Then k:=k+1;
  136.      For j:=1 To snc Do
  137.        Begin
  138.        If srtot[i] > 0 Then l:=l+1;
  139.        ex := srtot[i]*sctot[j]/gt;
  140.        If ex > 0. Then
  141.          Begin
  142.          chi := chi+Sqr(save[i,j]-ex)/ex;
  143.          temp := temp+Sqr(Abs(save[i,j]-ex)-0.5)/ex;
  144.          End;
  145.        End;
  146.      End;
  147.    Writeln(ofile); i:=(k-1)*(l-1);
  148.    Writeln(ofile,'Chi-Square:',chi:10:4,' Degrees of freedom:',i:4);
  149.    If i=1 Then Writeln(ofile,'Yale''s correction for continuity:',temp:9:4);
  150.    temp := Sqrt(chi/(chi+gt));
  151.    Writeln(ofile,'Contingency Coefficient:',temp:9:4);
  152.    temp := k; If k<l Then temp:=l;
  153.    chi := sqrt(chi/(gt*(temp-1)));
  154.    Writeln(ofile,'Cramer''s V:',chi:7:4);
  155.    sc:=0.;
  156.    For i:= 1 to snc Do
  157.      Begin
  158.      ar:=0.;
  159.      For j:= 1 to snr Do
  160.        If save[i,j] > ar Then ar:=save[i,j];
  161.      sc:=sc+ar;
  162.      End;
  163.    ar:=0;
  164.    For i:=1 to snr Do
  165.      If srtot[i] > ar Then ar:=srtot[i];
  166.    sr:=0.;
  167.    For i:= 1 to snr Do
  168.      Begin
  169.      ac:=0.;
  170.      For j:= 1 to snc Do
  171.        If save[i,j] > ac Then ac:=save[i,j];
  172.      sr:=sr+ac;
  173.      End;
  174.    ac:=0;
  175.    For i:=1 to snc Do
  176.      If sctot[i] > ac Then ac:=sctot[i];
  177.    If (gt-ar) > 0 Then
  178.      Begin
  179.      temp:=(sc-ar)/(gt-ar);
  180.      Writeln(ofile,'Asymmetric Lambda with Row Dependent:',temp:9:4);
  181.      End;
  182.    If (gt-ac) > 0 Then
  183.      Begin
  184.      temp:=(sr-ac)/(gt-ac);
  185.      Writeln(ofile,'Asymmetric Lambda with Column Dependent:',temp:9:4);
  186.      End;
  187.    If ((2*gt)-ar-ac) > 0 Then
  188.      Begin
  189.      temp:=(sr+sc-ac-ar)/((2*gt)-ar-ac);
  190.      Writeln(ofile,'Symmetric Lambda:',temp:9:4);
  191.      End;
  192.    Writeln(ofile);
  193.    If ot=1 Then
  194.      Begin
  195.      Write('- Press any key to continue -'); While Not KeyPressed Do;
  196.      ClrScr;
  197.      End;
  198.    End; (* Of tabstats *)
  199.  
  200. Procedure tabout(dv:Integer; m, c:I8; Var varn:S8;
  201.                  Var indx:IX; Var tabl:TB; Var ofile:Text; ot:Integer);
  202. Var
  203.    i,j,k:Integer;
  204.    save: M25;
  205.    srtot, sctot: R25;
  206.    snr, snc: Integer;
  207.    gt: Real;
  208. Begin
  209.    (* save 2-way dimensions *)
  210.    snr:=c[2]; snc:=c[1];
  211.    If dv=2 Then c[3]:=1;
  212.    While c[3] > 0 Do
  213.       Begin
  214.       (* write header *)
  215.       If dv > 2 Then
  216.          Writeln(ofile,'Breakdown ',varn[3],' = ',indx[3,c[3]]:8:2);
  217.       Writeln(ofile,'Table rows:',varn[2],' by columns:',varn[1]);
  218.       Writeln(ofile); Write(ofile,'          ');
  219.       For i:=1 To snc Do
  220.         Begin
  221.         Write(ofile,indx[1,snc-i+1]:8:2);
  222.         sctot[i]:=0.0;
  223.         End;
  224.       Writeln(ofile);
  225.       For i:=1 To snr Do srtot[i]:=0.0;
  226.       c[2]:=snr;
  227.       While c[2] > 0 Do
  228.          Begin (* loop over rows *)
  229.          Write(ofile,indx[2,c[2]]:8:2,'  ');
  230.          c[1]:=snc;
  231.          While c[1] > 0 Do
  232.             Begin (* loop over cols *)
  233.             j:=c[1]; k:=1;
  234.             For i:=2 To dv Do
  235.               Begin
  236.               k:=k*m[i-1];
  237.               j :=j+c[i]*k;
  238.               End;
  239.             Write(ofile,tabl[j]:8);
  240.             (* save 2-way table *)
  241.             save[c[2],c[1]]:=tabl[j];
  242.             srtot[c[2]]:=srtot[c[2]]+tabl[j];
  243.             sctot[c[1]]:=sctot[c[1]]+tabl[j];
  244.             c[1] := c[1] - 1;
  245.             End;
  246.          Writeln(ofile,srtot[c[2]]:8:0);
  247.          c[2] := c[2] - 1;
  248.          End;
  249.       (* write col totals and grand *)
  250.       Write(ofile,'          ');
  251.       For i:=1 To snc Do
  252.          Begin
  253.          Write(ofile,sctot[snc-i+1]:8:0);
  254.          gt:=gt+sctot[i];
  255.          End;
  256.       Writeln(ofile,gt:8:0); Writeln(ofile);
  257.       If ot=1 Then
  258.          Begin
  259.          Write('- Press any key to continue -'); While Not KeyPressed Do;
  260.          ClrScr;
  261.          End;
  262.       tabstats(gt, snr, snc, srtot, sctot, save, ot, ofile);
  263.       c[3] := c[3] - 1;
  264.       End;
  265.    End; (* Of tabout *)
  266.  
  267. Procedure tablop(dv,k:Integer;Var m, c:I8; Var varn:S8;
  268.                  Var indx:IX; Var tabl:TB; Var ofile:Text; ot:integer);
  269. Var
  270.    l: Integer;
  271. Begin
  272.    k := k - 1; l:=c[k];
  273.    If k < 4 Then l := 1;
  274.    While (l > 0) And (k > 1) Do
  275.       Begin
  276.       (* recursive loop to final 3 levels then write *)
  277.       If k > 3 Then
  278.          Begin
  279.          Writeln(ofile,'Breakdown ',varn[k],' = ',indx[k,c[k]]:8:2);
  280.          tablop(dv,k,m,c,varn,indx,tabl,ofile,ot);
  281.          c[k] := c[k] - 1;
  282.          End;
  283.       If k < 4 Then tabout(dv,m,c,varn,indx,tabl,ofile,ot);
  284.       l := l - 1;
  285.       End;
  286.    k := k + 1;
  287.    End; (* Of tablop *)
  288.  
  289. Begin (* main *)
  290.    openfiles(dfile,ofile,nv,dv,ot);
  291.    (* intialize *)
  292.    nc := 0.;
  293.    For i:=1 To 3000 Do tabl[i] := 0;
  294.    For i:=1 To 8 Do
  295.       Begin
  296.       c[i] := 0; m[i] := 0;
  297.       End;
  298.    selectvar(sel,m,varn,dv);
  299.    (* accumulate tables, c=#codes in indx for var *)
  300.    Writeln;
  301.    k:=0;
  302.    While Not EOF(dfile) Do
  303.       Begin
  304.       k:=k+1;
  305.       getcase(vars, sel, nv, dv, dfile);
  306.       If Frac(k/10)=0.0 Then Write('+');
  307.       If Not EOF(dfile) Then
  308.          Begin
  309.          nc := nc + 1;
  310.          tables(vars,dv,varn,m,c,indx,tabl);
  311.          End;
  312.       End;
  313.    (* compute for 2-ways And Output *)
  314.    k := dv + 1;
  315.    ClrScr;
  316.    tablop(dv,k,m,c,varn,indx,tabl,ofile,ot);
  317.    Close(dfile); Close(ofile);
  318. End.
  319. ┼╒σ!î█⌡┼╒σσ≡!Yφ░╤:jO:lé╒═╙╤:kO:mâ═╙!≡═Ñ*n═ß╤┴±╔!≡    δ!i45(╔!+/ û0ⁿå⌡y■0(±φ╔
  320. d!9├-!I├-