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 / CROSSTAB.PZS / CROSSTAB.ÐAS
Text File  |  2000-06-30  |  10KB  |  328 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 NSUBS variables and up to NCODES unique codes for each, so
  9.    long as the total number of cells is less than NCELLS.  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. Const
  14.    NSUBS=8;
  15.    NCODES=25;
  16.    NCELLS=3500;
  17. Type
  18.    SUBS=1..NSUBS;
  19.    CODS=1..NCODES;
  20.    TB = Array [1..NCELLS] Of Integer;
  21.    RC = Array [CODS] Of Real;
  22.    IX = Array [SUBS] Of RC;
  23.    MC = Array [CODS] Of RC;
  24.    I8 = Array [SUBS] Of Integer;
  25.    R8 = Array [SUBS] Of Real;
  26.    S8 = Array [SUBS] Of String[8];
  27. Var
  28.    dfile, ofile : Text;
  29.    sel, m, c : I8;
  30.    vars : R8;
  31.    varn : S8;
  32.    indx : IX;
  33.    tabl : TB;
  34.    i, j, k, nv, dv, ot : Integer;
  35.    nc : Real;
  36.  
  37. Procedure openfiles(Var dfile, ofile:Text; Var ot:Integer);
  38. Var
  39.    dfl, ofl:String[12];
  40. Begin
  41.    ClrScr; Writeln(' *** CROSSTAB: N-WAY TABLES AND ASSOCIATION TESTS ***');
  42.    Writeln; Write('Name of the data file? ');
  43.    Readln(dfl); Assign(dfile,dfl); Reset(dfile);
  44.    Write('Name of the output file? ');
  45.    Readln(ofl); Assign(ofile,ofl); Rewrite(ofile);
  46.    ot:= 0;
  47.    If (ofl='CON:') Or (ofl='con:') Then ot:=1;
  48.    If (ofl='LST:') Or (ofl='lst:') Then ot:=2;
  49.    If (ot=2) Then
  50.       Begin
  51.       Writeln(ofile,'Multivariate Analysis Package (1.6) - ',
  52.          'Program: CROSSTAB, Datafile: ',dfl); Writeln(ofile);
  53.       End;
  54.    End; (* Of openfiles *)
  55.  
  56. Procedure wait(ot:Integer);
  57. Begin
  58.   If ot=1 Then Begin
  59.     Write('- Press any key to continue -'); While Not KeyPressed Do; ClrScr;
  60.     End;
  61.   End; (* of wait *)
  62.  
  63. Procedure selectvar(Var sel, m:I8; Var varn:S8;Var nv, dv:Integer);
  64. Var
  65.    cfile:Text;
  66.    cfl:String[12];
  67.    i,j,f:Integer;
  68.    mis:Real;
  69.    van:String[8];
  70. Begin
  71.    Write('Name of the codebook file (or NONE)? '); Readln(cfl);
  72.    If (cfl<>'NONE') And (cfl<>'none') Then f:=1 Else f:=0;
  73.    If f=1 Then Begin Assign(cfile,cfl); Reset(cfile); End;
  74.    Writeln;
  75.    Write('How many variables in data file? '); Readln(nv);
  76.    Write('Number of variables to use in CROSSTAB? '); Readln(dv);
  77.    Write('Column number for COLUMN variable? '); Read(sel[1]);
  78.    Write('  Max. No. Categories? '); Readln(m[1]);
  79.    Write('Column number for ROW variable? '); Read(sel[2]);
  80.    Write('     Max. No. Categories? '); Readln(m[2]);
  81.    For i:=3 To dv Do
  82.       Begin
  83.       Write('Column number for BREAKDOWN variable ',i-2,'? ');
  84.       Read(sel[i]); Write('  Name? '); Readln(varn[i]);
  85.       Write('     Max. No. Categories? '); Readln(m[i]);
  86.       End;
  87.    If f=1 Then Begin
  88.      For j:=1 to nv Do Begin
  89.        Readln(cfile,f,van,mis);
  90.        For i:=1 to dv Do
  91.          If f=sel[i] Then Begin
  92.            varn[i]:=van; Writeln('Col: ',sel[i],'  Name: ',varn[i]);
  93.            End;     
  94.        End;
  95.      Close(cfile);
  96.      wait(1);
  97.      End;
  98.    End; (* Of selectvar *)
  99.  
  100. Procedure getcase(Var vars:R8;Var sel:I8;Var nv, dv:Integer; Var dfile:Text);
  101. Var
  102.    i, j:Integer;
  103.    x:Real;
  104. Begin
  105.    For i:=1 To nv Do
  106.       Begin
  107.       Read(dfile,x);
  108.       For j:=1 To dv Do If (sel[j]=i) Then vars[j]:=x;
  109.       End;
  110.    End; (* Of getcase *)
  111.  
  112. Procedure tables(Var vars:R8;Var dv:Integer; Var varn:S8; Var m, c:I8;
  113.                  Var indx:IX; Var tabl:TB);
  114. Var
  115.    i,j,k: Integer;
  116.    cell: I8;
  117. Begin
  118.    (* for each var search c[] codes stored in indx[] for match *)
  119.    For i:=1 To dv Do
  120.       Begin
  121.       cell[i]:=0;
  122.       For j:=c[i] downto 1 Do
  123.          If(vars[i]=indx[i,j]) Then cell[i]:=j;
  124.       (* no match found set up new code and identify cell *)
  125.       If cell[i]=0 Then
  126.          Begin
  127.          c[i]:=c[i]+1;
  128.          If c[i]>m[i] Then
  129.             Begin
  130.             ClrScr; gotoXY(5,10);
  131.             Writeln('** Error: Over',m[i]:3,' values for ',varn[i],' **');
  132.             Delay(2000); Bdos(0);
  133.             End;
  134.          indx[i,c[i]]:=vars[i]; cell[i]:=c[i];
  135.          End;
  136.       End;
  137.    (* add to table *)
  138.    j:=cell[1]; k:=1;
  139.    For i:=2 To dv Do
  140.      Begin
  141.      k:=k*m[i-1];
  142.      j:=j+cell[i]*k;
  143.      End;
  144.    tabl[j]:=tabl[j]+1;
  145.    End; (* Of tables *)
  146.  
  147. Procedure tabstats(Var gt:Real;Var snr, snc:Integer;Var srtot, sctot:RC;
  148.                    Var save:MC; ot:Integer; Var ofile:Text);
  149. Var
  150.    i, j, k, l: Integer;
  151.    sr, sc, ar, ac, ex, chi, temp: Real;
  152. Begin
  153.    (* association statistics *)
  154.    chi:=0.; temp:=0.; k:=0; l:=0;
  155.    For i:=1 To snr Do
  156.      Begin
  157.      If srtot[i]>0 Then k:=k+1;
  158.      For j:=1 To snc Do
  159.        Begin
  160.        If srtot[i]>0 Then l:=l+1;
  161.        If gt>0. Then ex:=srtot[i]*sctot[j]/gt Else ex:=0.;
  162.        If ex<>0. Then
  163.          Begin
  164.          chi:=chi+Sqr(save[i,j]-ex)/ex;
  165.          temp:=temp+Sqr(Abs(save[i,j]-ex)-0.5)/ex;
  166.          End;
  167.        End;
  168.      End;
  169.    Writeln(ofile); i:=(k-1)*(l-1);
  170.    Writeln(ofile,'Chi-Square:',chi:10:4,' Degrees of freedom:',i:4);
  171.    If i=1 Then Writeln(ofile,'Yale''s correction for continuity:',temp:9:4);
  172.    If(chi+gt)<>0. Then temp:=Sqrt(chi/(chi+gt)) Else temp:=0.;
  173.    Writeln(ofile,'Contingency Coefficient:',temp:9:4);
  174.    temp:=k; If k<l Then temp:=l;
  175.    If(gt*(temp-1.0))<>0. Then chi:=sqrt(chi/(gt*(temp-1.0))) Else chi:=0.;
  176.    Writeln(ofile,'Cramer''s V:',chi:7:4);
  177.    sc:=0.;
  178.    For i:=1 to snc Do
  179.      Begin
  180.      ar:=0.;
  181.      For j:=1 to snr Do
  182.        If save[i,j]>ar Then ar:=save[i,j];
  183.      sc:=sc+ar;
  184.      End;
  185.    ar:=0.;
  186.    For i:=1 to snr Do
  187.      If srtot[i]>ar Then ar:=srtot[i];
  188.    sr:=0.;
  189.    For i:=1 to snr Do
  190.      Begin
  191.      ac:=0.;
  192.      For j:=1 to snc Do
  193.        If save[i,j]>ac Then ac:=save[i,j];
  194.      sr:=sr+ac;
  195.      End;
  196.    ac:=0.;
  197.    For i:=1 to snc Do
  198.      If sctot[i]>ac Then ac:=sctot[i];
  199.    If(gt-ar)<>0. Then
  200.      Begin
  201.      temp:=(sc-ar)/(gt-ar);
  202.      Writeln(ofile,'Asymmetric Lambda with Row Dependent:',temp:9:4);
  203.      End;
  204.    If(gt-ac)<>0. Then
  205.      Begin
  206.      temp:=(sr-ac)/(gt-ac);
  207.      Writeln(ofile,'Asymmetric Lambda with Column Dependent:',temp:9:4);
  208.      End;
  209.    If((gt+gt)-ar-ac)<>0. Then
  210.      Begin
  211.      temp:=(sr+sc-ac-ar)/((gt+gt)-ar-ac);
  212.      Writeln(ofile,'Symmetric Lambda:',temp:9:4);
  213.      End;
  214.    Writeln(ofile);
  215.    wait(ot);
  216.    End; (* Of tabstats *)
  217.  
  218. Procedure tabout(dv:Integer;Var m, c:I8; Var varn:S8;
  219.                  Var indx:IX; Var tabl:TB; Var ofile:Text; ot:Integer);
  220. Var
  221.    i,j,k:Integer;
  222.    save: MC;
  223.    srtot, sctot: RC;
  224.    snr, snc: Integer;
  225.    gt: Real;
  226. Begin
  227.    (* save 2-way dimensions *)
  228.    snr:=c[2]; snc:=c[1];
  229.    If dv=2 Then c[3]:=1;
  230.    While c[3]>0 Do
  231.       Begin
  232.       (* write header *)
  233.       If dv>2 Then
  234.          Writeln(ofile,'Breakdown ',varn[3],' = ',indx[3,c[3]]:8:2);
  235.       Writeln(ofile,'Table rows:',varn[2],' by columns:',varn[1]);
  236.       Writeln(ofile); Write(ofile,'          ');
  237.       For i:=1 To snc Do
  238.         Write(ofile,indx[1,snc-i+1]:8:2);
  239.       FillChar(sctot,6*NCODES,0); FillChar(srtot,6*NCODES,0);
  240.       Writeln(ofile);
  241.       c[2]:=snr;
  242.       While c[2]>0 Do
  243.          Begin (* loop over rows *)
  244.          Write(ofile,indx[2,c[2]]:8:2,'  ');
  245.          c[1]:=snc;
  246.          While c[1]>0 Do
  247.             Begin (* loop over cols *)
  248.             j:=c[1]; k:=1;
  249.             For i:=2 To dv Do
  250.               Begin
  251.               k:=k*m[i-1];
  252.               j :=j+c[i]*k;
  253.               End;
  254.             Write(ofile,tabl[j]:8);
  255.             (* save 2-way table *)
  256.             save[c[2],c[1]]:=tabl[j];
  257.             srtot[c[2]]:=srtot[c[2]]+tabl[j];
  258.             sctot[c[1]]:=sctot[c[1]]+tabl[j];
  259.             c[1]:=c[1]-1;
  260.             End;
  261.          Writeln(ofile,srtot[c[2]]:8:0);
  262.          c[2]:=c[2]-1;
  263.          End;
  264.       (* write col totals and grand *)
  265.       Write(ofile,'          ');
  266.       gt:=0;
  267.       For i:=1 To snc Do
  268.          Begin
  269.          Write(ofile,sctot[snc-i+1]:8:0);
  270.          gt:=gt+sctot[i];
  271.          End;
  272.       Writeln(ofile,gt:8:0); Writeln(ofile);
  273.       wait(ot);
  274.       tabstats(gt, snr, snc, srtot, sctot, save, ot, ofile);
  275.       c[3]:=c[3]-1;
  276.       End;
  277.    End; (* Of tabout *)
  278.  
  279. Procedure tablop(dv,k:Integer;Var m, c:I8; Var varn:S8;
  280.                  Var indx:IX; Var tabl:TB; Var ofile:Text; ot:integer);
  281. Var
  282.    l: Integer;
  283. Begin
  284.    k:=k-1; l:=c[k];
  285.    If k < 4 Then l:=1;
  286.    While (l>0) And (k>1) Do
  287.       Begin
  288.       (* recursive loop to final 3 levels then write *)
  289.       If k>3 Then
  290.          Begin
  291.          Writeln(ofile,'Breakdown ',varn[k],' = ',indx[k,c[k]]:8:2);
  292.          tablop(dv,k,m,c,varn,indx,tabl,ofile,ot);
  293.          c[k]:=c[k]-1;
  294.          End;
  295.       If k < 4 Then tabout(dv,m,c,varn,indx,tabl,ofile,ot);
  296.       l:=l-1;
  297.       End;
  298.    k:=k+1;
  299.    End; (* Of tablop *)
  300.  
  301. Begin (* main *)
  302.    openfiles(dfile,ofile,ot);
  303.    (* intialize *)
  304.    nc:=0.;
  305.    FillChar(tabl,2*NCELLS,0); FillChar(c,2*NSUBS,0); FillChar(m,2*NSUBS,0);
  306.    selectvar(sel,m,varn,nv,dv);
  307.    (* accumulate tables, c=#codes in indx for var *)
  308.    Writeln;
  309.    k:=0;
  310.    While Not EOF(dfile) Do
  311.       Begin
  312.       k:=k+1;
  313.       getcase(vars, sel, nv, dv, dfile);
  314.       If Frac(k/10)=0.0 Then Write('+');
  315.       If Not EOF(dfile) Then
  316.          Begin
  317.          nc:=nc+1;
  318.          tables(vars,dv,varn,m,c,indx,tabl);
  319.          End;
  320.       End;
  321.    (* compute for 2-ways And Output *)
  322.    k:=dv+1;
  323.    ClrScr;
  324.    tablop(dv,k,m,c,varn,indx,tabl,ofile,ot);
  325.    Close(dfile); Close(ofile);
  326.    Assign(dfile,'MAPSTAT.COM'); Execute(dfile);
  327. End.
  328. riteln(ofile,