home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / lambda / soundpot / f / map12.lbr / PARTIAL.PZS / PARTIAL.PAS
Encoding:
Pascal/Delphi Source File  |  1993-10-26  |  6.1 KB  |  212 lines
  1. (* Multivariate Analysis Package - Partial Correlation 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. Program Partial(Input,Output);
  7. Type
  8.    R30 = Array [1..30] Of Real;
  9.    M30 = Array [1..30,1..30] Of Real;
  10.    I30 = Array [1..30] Of Integer;
  11.    S8 = Array [1..30] Of String[8];
  12. Var
  13.    dfile, ofile : Text;
  14.    sel : I30;
  15.    x, y, z: R30;
  16.    varn : S8;
  17.    cor, b, t : M30;
  18.    i, j, j1, k, l, nv, dv, cv, rv, ot, nc: Integer;
  19.    det: real;
  20.  
  21. Procedure openfiles(Var dfile, ofile:Text; Var nv, dv, cv, ot:Integer);
  22. Var
  23.    dfl, ofl:String[12];
  24. Begin
  25.    ClrScr; Writeln(' *** PARTIAL: PARTIAL CORRELATION ***');
  26.    Writeln; Write('Name of the CORREL file? ');
  27.    Readln(dfl); Assign(dfile,dfl); Reset(dfile);
  28.    Write('Name of the output file? ');
  29.    Readln(ofl); Assign(ofile,ofl); Rewrite(ofile);
  30.    ot:= 0;
  31.    If (ofl='CON:') Or (ofl='con:') Then ot:=1;
  32.    If (ofl='LST:') Or (ofl='lst:') Then ot:=2;
  33.    If (ot=2) Then
  34.       Begin
  35.       Writeln(ofile,'Multivariate Analysis Package (1.2) - ',
  36.          'Program: PARTIAL, Datafile: ',dfl); Writeln(ofile);
  37.       End;
  38.    Write('How many variables in CORREL matrix? ');
  39.    Readln(nv);
  40.    Write('Number of variables to use in PARTIAL? ');
  41.    Readln(dv);
  42.    Write('Number of these to control remaining correlations for? ');
  43.    Readln(cv);
  44.    End; (* Of openfiles *)
  45.  
  46. Procedure selectvar(Var sel:I30; Var varn:S8; dv, cv:Integer);
  47. Var
  48.    i:Integer;
  49. Begin
  50.    Writeln;
  51.    For i:=1 To dv Do
  52.       Begin
  53.       If(i<=cv) Then Write('Column number for controlling variable ',i,'? ');
  54.       If(i>cv) Then Write('Column number for partialled variable ',i-cv,'? ');
  55.       Read(sel[i]); Write('  Name? '); Readln(varn[i]);
  56.       End;
  57.    End; (* Of selectvar *)
  58.  
  59. Procedure getcor(Var cor:M30; Var mean, stdev:R30; Var nc:Integer;
  60.                   sel:I30; nv, dv:Integer; Var dfile:Text);
  61. Var
  62.    i,j,k,l,z:Integer;
  63.    x,y:Real;
  64.    dum15:String[15];
  65.    dum21:String[21];
  66.    dum8:String[8];
  67.    dum36:String[36];
  68. Begin
  69.    Readln(dfile); Readln(dfile);
  70.    For i := 1 To nv Do
  71.       Begin
  72.       Readln(dfile,dum15,x,dum21,y,dum8,z);
  73.       If (i=1) Then nc:=z;
  74.       If (nc>z) Then nc:=z;
  75.       For j := 1 To dv Do
  76.          Begin
  77.          If (sel[j]=i) Then
  78.             Begin
  79.             mean[j] := x; stdev[j] := y;
  80.             End;
  81.          End;
  82.       End;
  83.       For i :=1 to 3 Do Readln(dfile);
  84.       For i := 1 To nv-1 Do
  85.          For k := i+1 To nv Do
  86.             Begin
  87.             Readln(dfile,dum36,x,dum15,y);
  88.             For j := 1 To dv Do
  89.                Begin
  90.                cor[j,j] := 1.0;
  91.                If (sel[j]=i) Then
  92.                   For l := 1 To dv Do
  93.                      If (sel[l]=k) Then
  94.                      Begin
  95.                      cor[j,l] := y; cor[l,j] := y;
  96.                      End;
  97.                End;
  98.             End;
  99.    End; (* Of getcor *)
  100.  
  101. Procedure minv(Var a:M30; Var d:Real; m:Integer);
  102. (* matrix inversion in pascal: gauss - reduction method
  103.    inverse returned in a and determinant in d, m is dimension *)
  104. Var
  105.    j,k,l:Integer;
  106.    pvt,t:Real;
  107. Begin
  108.    d := 1.0;
  109.    For j:=1 To m Do
  110.       Begin
  111.       pvt := a[j,j]; d := d*pvt; a[j,j] := 1.0;
  112.       If (pvt=0) Then 
  113.          Begin
  114.          Writeln; Writeln('  *** Multicollinear Matrix ***'); Writeln;
  115.          End;
  116.       For k:=1 To m Do a[j,k] := a[j,k]/pvt;
  117.       For k:=1 To m Do
  118.          If ((k-j) <> 0) Then
  119.             Begin
  120.             t := a[k,j]; a[k,j] := 0.0;
  121.             For l:=1 To m Do a[k,l] := a[k,l] - (a[j,l]*t);
  122.             End;
  123.       End;
  124.    End; (* of minv *)
  125.  
  126. Begin (* main *)
  127.    openfiles(dfile, ofile, nv, dv, cv, ot);
  128.    selectvar(sel, varn, dv, cv);
  129.    (* read correlation matrix matrix *)
  130.    getcor(cor, x, y, nc, sel, nv, dv, dfile);
  131.    (* invert left side*)
  132.    minv(cor,det,cv);
  133.    (* multiply for coefficients *)
  134.    rv:=dv-cv;
  135.    For j:=1 To rv Do
  136.       Begin
  137.       j1:=j+cv;
  138.       For k:=1 To cv Do
  139.          Begin
  140.          b[j,k]:=0.0;
  141.          For l:=1 To cv Do b[j,k]:=b[j,k]+(cor[j1,l]*cor[l,k]);
  142.          End;
  143.       End;
  144.    For j:=1 To rv Do
  145.      Begin 
  146.      ClrScr;
  147.      Writeln(ofile,'Regression Coefficients of ',varn[j+cv],' on Controls:');
  148.      Writeln(ofile);
  149.      For i:=1 To cv Do Writeln(ofile,'     ',varn[i],': ',b[j,i]:10:6);
  150.      Writeln(ofile);
  151.      If ot=1 Then
  152.        Begin
  153.        Write('- Press any key to continue -'); While Not KeyPressed Do;
  154.        ClrScr;
  155.        End;
  156.     End;
  157.   For j:=1 To rv Do
  158.     For k:=1 To rv Do
  159.       Begin
  160.       j1:=k+cv;
  161.       t[j,k]:=0.0;
  162.       For l:=1 To cv Do t[j,k]:=t[j,k]+(b[j,l]*cor[l,j1]);
  163.       End;
  164.   For j:=1 To rv Do
  165.     Begin
  166.     j1:=j+cv;
  167.     For k:=1 To rv Do
  168.       Begin
  169.       l:=k+cv;
  170.       b[j,k]:=cor[j1,l];
  171.       End;
  172.     End;
  173.   For j:=1 To rv Do
  174.     Begin
  175.     x[j]:=t[j,j];
  176.     y[j]:=Sqrt(x[j]);
  177.     z[j]:=(x[j]*(nc-cv-1.0))/((1.0-x[j])*cv);
  178.     End;
  179.   ClrScr;
  180.   Writeln(ofile,'Summary of Regression on Controls:');
  181.   Writeln(ofile);
  182.   Writeln(ofile,'Variable:     Mult. R    Mult. R-Sq.   F-Ratio');
  183.   For j:=1 To rv Do
  184.     Writeln(ofile,varn[j+cv]:8,'  ',y[j]:11:5,'  ',x[j]:11:5,'   ',z[j]:9:3);
  185.   Writeln(ofile); Writeln(ofile,'  degrees of freedom: ',cv:3,(nc-cv-1):5);
  186.   Writeln(ofile);
  187.   If ot=1 Then
  188.     Begin
  189.     Write('- Press any key to continue -'); While Not KeyPressed Do;
  190.     ClrScr;
  191.     End;
  192.   For j:=1 To rv Do
  193.     For k:=1 To rv Do b[j,k]:=b[j,k]-t[j,k];
  194.   For j:=1 To rv Do x[j]:=Sqrt(b[j,j]);
  195.   For j:=1 To rv Do
  196.     For k:=1 To rv Do cor[j,k]:=b[j,k]/(x[j]*x[k]);
  197.   Writeln(ofile,'Residual Covariance and Partial Correlations:');
  198.   Writeln(ofile);
  199.   For j:= 1 To rv Do
  200.     Begin
  201.     For i := j+1 To rv Do
  202.       Begin
  203.       Writeln(ofile,varn[j+cv]:8,' with ',varn[i+cv]:8,'   Resid Covr: ',
  204.         b[j,i]:13,'  Partial Corr:',cor[j,i]:10:6);
  205.       End;
  206.     End;
  207.   Writeln(ofile);
  208.   Close(ofile); Close(dfile);
  209. End.
  210. test: ',tt:11:5);
  211.       tt:=SQR((vr[1]/nc[1])/((vr[1]/nc[1])+(vr[2]/nc[2])))/(nc[1]-1);
  212.       tt:=tt+SQR((vr[1]/nc[2])/((vr[2