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 / PARTIAL.PZS / PARTIAL.ÐAS
Text File  |  2000-06-30  |  4KB  |  138 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. Const
  8.    N=30;
  9. Type
  10.    SUBS=1..N;
  11.    RVEC = Array [SUBS] Of Real;
  12.    NBYN = Array [SUBS] Of RVEC;
  13.    IVEC = Array [SUBS] Of Integer;
  14.    S8 = Array [SUBS] Of String[8];
  15. Var
  16.    dfile, ofile : Text;
  17.    sel : IVEC;
  18.    x, y, z: RVEC;
  19.    varn : S8;
  20.    cor, b, t : NBYN;
  21.    i, j, j1, k, l, nv, dv, cv, rv, ot: Integer;
  22.    det, nc: real;
  23.    error: boolean;
  24.  
  25. Procedure openfiles(Var dfile, ofile:Text; Var nv, dv, cv, ot:Integer);
  26. Var
  27.    dfl, ofl:String[12];
  28. Begin
  29.    ClrScr; Writeln(' *** PARTIAL: PARTIAL CORRELATION ***');
  30.    Writeln; Write('Name of the CORREL file? ');
  31.    Readln(dfl); Assign(dfile,dfl); Reset(dfile);
  32.    Write('Name of the output file? ');
  33.    Readln(ofl); Assign(ofile,ofl); Rewrite(ofile);
  34.    ot:= 0;
  35.    If (ofl='CON:') Or (ofl='con:') Then ot:=1;
  36.    If (ofl='LST:') Or (ofl='lst:') Then ot:=2;
  37.    If (ot=2) Then Begin
  38.       Writeln(ofile,'Multivariate Analysis Package (1.6) - ',
  39.          'Program: PARTIAL, Datafile: ',dfl); Writeln(ofile);
  40.       End;
  41.    Write('How many variables in CORREL matrix? '); Readln(nv);
  42.    Write('Number of variables to use in PARTIAL? '); Readln(dv);
  43.    Write('Number of these to control remaining correlations for? ');
  44.    Readln(cv);
  45.    End; (* Of openfiles *)
  46.  
  47. Procedure selectvar3(Var sel:IVEC; dv, cv:Integer);
  48. Var
  49.    i:Integer;
  50. Begin
  51.    Writeln;
  52.    For i:=1 To dv Do
  53.       Begin
  54.       If(i<=cv) Then Write('Column number for controlling variable ',i,'? ');
  55.       If(i>cv) Then Write('Column number for partialled variable ',i-cv,'? ');
  56.       Readln(sel[i]);
  57.       End;
  58.    End; (* Of selectvar *)
  59.  
  60. Procedure wait(ot:Integer);
  61. Begin
  62.   If ot=1 Then Begin
  63.     Write('- Press any key to continue -'); While Not KeyPressed Do; ClrScr;
  64.     End;
  65.   End; (* of wait *)
  66.  
  67. {$I GETCOR.LIB}
  68. {$I MATINV.LIB}
  69.  
  70. Begin (* main *)
  71.    openfiles(dfile, ofile, nv, dv, cv, ot);
  72.    selectvar3(sel, dv, cv);
  73.    (* read correlation matrix matrix *)
  74.    getcor(cor, x, y, varn, nc, sel, nv, dv, dfile);
  75.    (* invert left side*)
  76.    matinv(cor,cv,det,error);
  77.    (* multiply for coefficients *)
  78.    rv:=dv-cv;
  79.    For j:=1 To rv Do
  80.       Begin
  81.       j1:=j+cv;
  82.       For k:=1 To cv Do Begin
  83.          b[j,k]:=0.0;
  84.          For l:=1 To cv Do b[j,k]:=b[j,k]+(cor[j1,l]*cor[l,k]);
  85.          End;
  86.       End;
  87.    For j:=1 To rv Do
  88.      Begin 
  89.      ClrScr;
  90.      Writeln(ofile,'Regression Coefficients of ',varn[j+cv],' on Controls:');
  91.      Writeln(ofile);
  92.      For i:=1 To cv Do Writeln(ofile,'     ',varn[i],': ',b[j,i]:10:6);
  93.      Writeln(ofile);
  94.      wait(ot);
  95.     End;
  96.   For j:=1 To rv Do
  97.     For k:=1 To rv Do Begin
  98.       j1:=k+cv; t[j,k]:=0.0;
  99.       For l:=1 To cv Do t[j,k]:=t[j,k]+(b[j,l]*cor[l,j1]);
  100.       End;
  101.   For j:=1 To rv Do Begin
  102.     j1:=j+cv;
  103.     For k:=1 To rv Do Begin l:=k+cv; b[j,k]:=cor[j1,l]; End;
  104.     End;
  105.   For j:=1 To rv Do Begin
  106.     x[j]:=t[j,j]; y[j]:=Sqrt(x[j]);
  107.     z[j]:=(x[j]*(nc-cv-1.0))/((1.0-x[j])*cv);
  108.     End;
  109.   ClrScr;
  110.   Writeln(ofile,'Summary of Regression on Controls:');
  111.   Writeln(ofile);
  112.   Writeln(ofile,'Variable:     Mult. R    Mult. R-Sq.   F-Ratio');
  113.   For j:=1 To rv Do
  114.     Writeln(ofile,varn[j+cv]:8,'  ',y[j]:11:5,'  ',x[j]:11:5,'   ',z[j]:9:3);
  115.   Writeln(ofile); Writeln(ofile,'  degrees of freedom: ',cv:3,(nc-cv-1):5);
  116.   Writeln(ofile);
  117.   wait(ot);
  118.   For j:=1 To rv Do
  119.     For k:=1 To rv Do b[j,k]:=b[j,k]-t[j,k];
  120.   For j:=1 To rv Do x[j]:=Sqrt(b[j,j]);
  121.   For j:=1 To rv Do
  122.     For k:=1 To rv Do cor[j,k]:=b[j,k]/(x[j]*x[k]);
  123.   Writeln(ofile,'Residual Covariance and Partial Correlations:');
  124.   Writeln(ofile);
  125.   For j:= 1 To rv Do
  126.     Begin
  127.     For i := j+1 To rv Do
  128.       Begin
  129.       Writeln(ofile,varn[j+cv]:8,' with ',varn[i+cv]:8,'   Resid Covr: ',
  130.         b[j,i]:13,'  Partial Corr:',cor[j,i]:10:6);
  131.       End;
  132.     End;
  133.   Writeln(ofile);
  134.   Close(ofile); Close(dfile);
  135.   Assign(dfile,'MAPSTAT.COM'); Execute(dfile);
  136. End.
  137. x[j]);
  138.     z[j]:=(x[j]*(nc-cv-1.