lazarus-ccr/applications/lazstats/source_orig/CANONUNIT.PAS

unit CanonUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  MainUnit, OutPutUnit, FunctionsLib, GraphLib, Globals, DataProcs,
  MatrixLib, StdCtrls, Buttons, contexthelpunit;

type

  { TCannonFrm }

  TCannonFrm = class(TForm)
    HelpBtn: TButton;
    ResetBtn: TButton;
    CancelBtn: TButton;
    ComputeBtn: TButton;
    ReturnBtn: TButton;
    CorsChk: TCheckBox;
    InvChk: TCheckBox;
    EigenChk: TCheckBox;
    RedundChk: TCheckBox;
    GroupBox1: TGroupBox;
    LeftIn: TBitBtn;
    LeftOut: TBitBtn;
    RightIn: TBitBtn;
    RightOut: TBitBtn;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    LeftList: TListBox;
    RightList: TListBox;
    VarList: TListBox;
    procedure ComputeBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure HelpBtnClick(Sender: TObject);
    procedure LeftInClick(Sender: TObject);
    procedure LeftOutClick(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
    procedure RightInClick(Sender: TObject);
    procedure RightOutClick(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 

var
  CannonFrm: TCannonFrm;

implementation

{ TCannonFrm }

procedure TCannonFrm.ResetBtnClick(Sender: TObject);
VAR i : integer;
begin
     VarList.Clear;
     LeftList.Clear;
     RightList.Clear;
     LeftOut.Visible := false;
     LeftIn.Visible := true;
     RightOut.Visible := false;
     RightIn.Visible := true;
     for i := 1 to NoVariables do
         VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
end;

procedure TCannonFrm.RightInClick(Sender: TObject);
VAR i, index : integer;
begin
     index := VarList.Items.Count;
     i := 0;
     while i < index do
     begin
         if (VarList.Selected[i]) then
         begin
            RightList.Items.Add(VarList.Items.Strings[i]);
            VarList.Items.Delete(i);
            index := index - 1;
            i := 0;
         end
         else i := i + 1;
     end;
     RightOut.Visible := true;
end;

procedure TCannonFrm.RightOutClick(Sender: TObject);
VAR index : integer;
begin
     index := RightList.ItemIndex;
     if index < 0 then
     begin
          RightOut.Visible := false;
          exit;
     end;
     VarList.Items.Add(RightList.Items.Strings[index]);
     RightList.Items.Delete(index);
end;

procedure TCannonFrm.FormShow(Sender: TObject);
begin
     ResetBtnClick(self);
end;

procedure TCannonFrm.HelpBtnClick(Sender: TObject);
begin
  ContextHelpForm.HelpMessage((Sender as TButton).tag);
end;

procedure TCannonFrm.ComputeBtnClick(Sender: TObject);
label cleanup;
var
   i, j, k, count, a_size, b_size, no_factors, novars, prtopts, IER: integer;
   outline, cellstring, gridstring, SNo : string;
   s, m, n, df1, df2, q, w, pcnt_extracted, trace : double;
   minroot, critical_prob, Lambda, Pillia : double;
   chisqr, HLTrace, chiprob, ftestprob, Roys, f, Hroot : double;
   raa, rbb, rab, rba, bigmat, prod, first_prod, second_prod : DblDyneMat;
   char_equation, raainv, rbbinv, eigenvectors, norm_a, norm_b : DblDyneMat;
   raw_a, raw_b, a_cors, b_cors, eigentrans, theta, tempmat : DblDyneMat;
   mean, variance, stddev, roots, root_chi, chi_prob, pv_a, pv_b : DblDyneVec;
   rd_a, rd_b, pcnt_trace : DblDyneVec;
   root_df, a_vars, b_vars : IntDyneVec;
   selected : IntDyneVec;
   RowLabels, ColLabels : StrDyneVec;
   CanLabels : StrDyneVec;
   NCases : integer;
   title : string;
   errorcode : boolean;

begin
     k := 0;
     no_factors := 0;
     pcnt_extracted := 0.0;
     trace := 0.0;
     minroot := 0.0;
     critical_prob := 0.0;
     Pillia := 0.0;
     chisqr := 0.0;
     HLTrace := 0.0;
     chiprob := 0.0;

    // Get size of the Left and Right matrices (predictors and dependents)
    a_size := LeftList.Items.Count;
    b_size := RightList.Items.Count;
    novars := a_size + b_size;

    // allocate memory for matrices and vectors
    SetLength(raa,a_size,a_size);
    SetLength(rbb,b_size,b_size);
    SetLength(rab,a_size,b_size);
    SetLength(rba,b_size,a_size);
    SetLength(bigmat,novars+1,novars+1);
    SetLength(prod,novars,novars);
    SetLength(first_prod,novars,novars);
    SetLength(second_prod,novars,novars);
    SetLength(char_equation,novars,novars);
    SetLength(raainv,a_size,a_size);
    SetLength(rbbinv,b_size,b_size);
    SetLength(eigenvectors,novars,novars);
    SetLength(norm_a,novars,novars);
    SetLength(norm_b,novars,novars);
    SetLength(raw_a,novars,novars);
    SetLength(raw_b,novars,novars);
    SetLength(a_cors,novars,novars);
    SetLength(b_cors,novars,novars);
    SetLength(eigentrans,novars,novars);
    SetLength(theta,novars,novars);
    SetLength(tempmat,novars,novars);

    SetLength(mean,novars);
    SetLength(variance,novars);
    SetLength(stddev,novars);
    SetLength(roots,novars);
    SetLength(root_chi,novars);
    SetLength(chi_prob,novars);
    SetLength(pv_a,novars);
    SetLength(pv_b,novars);
    SetLength(rd_a,novars);
    SetLength(rd_b,novars);
    SetLength(pcnt_trace,novars);

    SetLength(root_df,novars);
    SetLength(a_vars,a_size);
    SetLength(b_vars,b_size);
    SetLength(CanLabels,novars);
    SetLength(RowLabels,novars);
    SetLength(ColLabels,novars);
    SetLength(Selected,novars);

     //------------ WORK STARTS HERE! -------------------------------------

     // Build labels for canonical functions 1 to novars
     for i := 1 to b_size do
         CanLabels[i-1]:='Var. ' + IntToStr(i);

     // identify variables selected for left and right variables
     for i := 0 to a_size - 1 do // identify left variables
     begin
         cellstring := LeftList.Items.Strings[i];
         for j := 1 to NoVariables do
         begin
             gridstring := OS3MainFrm.DataGrid.Cells[j,0];
             if (cellstring = gridstring) then
             begin
                 a_vars[i] := j;
                 RowLabels[i] := gridstring;
             end;
         end;
     end;
     for i := 0 to b_size - 1 do // identify left variables
     begin
         cellstring := RightList.Items.Strings[i];
         for j := 1 to NoVariables do
         begin
             gridstring := OS3MainFrm.DataGrid.Cells[j,0];
             if (cellstring = gridstring) then
             begin
                 b_vars[i] := j;
                 ColLabels[i] := gridstring;
             end;
         end;
     end;

     // build list of all variables selected
     for i := 1 to a_size do selected[i-1] := a_vars[i-1];
     for i := 1 to b_size do selected[i-1 + a_size] := b_vars[i-1];

     OutPutFrm.RichEdit.Clear;
     OutPutFrm.RichEdit.Lines.Add('CANONICAL CORRELATION ANALYSIS');
     OutPutFrm.RichEdit.Lines.Add('');
     // Get means, standard deviations, etc. for total matrix
     Correlations(novars,selected,bigmat,mean,variance,stddev,errorcode,Ncases);
     count := Ncases;
     if (IER = 1)then
     begin
          ShowMessage('Zero variance found for a variable-terminating');
          goto cleanup;
     end;

     //partition matrix into quadrants
     for i := 1 to a_size do
         for j := 1 to a_size do raa[i-1,j-1]:= bigmat[i-1,j-1];

     for i := a_size + 1 to novars do
         for j := a_size + 1 to novars do
              rbb[i-1-a_size,j-1-a_size] := bigmat[i-1,j-1];

     for i := 1 to a_size do
         for j := a_size + 1 to novars do
             rab[i-1,j-1-a_size] := bigmat[i-1,j-1];

     for i := a_size + 1 to novars do
         for j := 1 to a_size do
             rba[i-1-a_size,j-1] := bigmat[i-1,j-1];

     if CorsChk.Checked then
     begin
          title := 'Left Correlation Matrix';
          MAT_PRINT(raa,a_size,a_size,title,RowLabels,RowLabels,NCases);
          title := 'Right Correlation Matrix';
          MAT_PRINT(rbb,b_size,b_size,title,ColLabels,ColLabels,NCases);
          title := 'Left-Right Correlation Matrix';
          MAT_PRINT(rab,a_size,b_size,title,RowLabels,ColLabels,NCases);
          OutPutFrm.ShowModal;
          OutPutFrm.RichEdit.Clear;
     end;

     // get inverses of left and right hand matrices raa and rbb
     for i := 1 to a_size do
         for j := 1 to a_size do
             raainv[i-1,j-1] := raa[i-1,j-1];
     SVDinverse(raainv,a_size);
     if InvChk.Checked then
     begin
          title := 'Inverse of Left Matrix';
          MAT_PRINT(raainv,a_size,a_size,title,RowLabels,RowLabels,NCases);
     end;

     for i := 1 to b_size do
         for j := 1 to b_size do
             rbbinv[i-1,j-1] := rbb[i-1,j-1];
     SVDinverse(rbbinv,b_size);
     if InvChk.Checked then
     begin
          title := 'Inverse of Right Matrix';
          MAT_PRINT(rbbinv,b_size,b_size,title,ColLabels,ColLabels,NCases);
     end;

     // get products of raainv x rab and the rbbinv x rba matrix
     MatAxB(first_prod,rbbinv,rba,b_size,b_size,b_size,a_size,errorcode);
     MatAxB(second_prod,raainv,rab,a_size,a_size,a_size,b_size,errorcode);
     title := 'Right Inverse x Right-Left Matrix';
     MAT_PRINT(first_prod,b_size,a_size,title,ColLabels,RowLabels,NCases);
     title := 'Left Inverse x Left-Right Matrix';
     MAT_PRINT(second_prod,a_size,b_size,title,RowLabels,ColLabels,NCases);

     //get characteristic equations matrix (product of last two product matrices
     //The product should yeild rows and cols representing the smaller of the two sets
     MatAxB(char_equation,first_prod,second_prod,b_size,a_size, a_size,b_size,errorcode);
     title := 'Canonical Function';
     MAT_PRINT(char_equation,b_size,b_size,title,CanLabels,CanLabels,NCases);
     OutPutFrm.ShowModal;
     OutPutFrm.RichEdit.Clear;

     //  now get roots and vectors of the characteristic equation using
     // NonSymRoots routine
     minroot := 0.0;
     for i := 1 to b_size do
     begin
         roots[i-1] := 0.0;
         pcnt_trace[i-1] := 0.0;
         for j := 1 to b_size do eigenvectors[i-1,j-1] := 0.0;
     end;
     trace := 0.0;
     no_factors := b_size;
     nonsymroots(char_equation, b_size, no_factors, minroot, eigenvectors, roots,
                pcnt_trace, trace, pcnt_extracted);
     outline := format('Trace of the matrix:=%10.4f',[trace]);
     OutPutFrm.RichEdit.Lines.Add(outline);
     outline := format('Percent of trace extracted: %10.4f',[pcnt_extracted]);
     OutPutFrm.RichEdit.Lines.Add(outline);

     // Normalize smaller set weights and coumpute larger set weights
     MATTRN(eigentrans,eigenvectors,b_size,b_size);
     MatAxB(tempmat,eigentrans,rbb,b_size,b_size,b_size,b_size,errorcode);
     MatAxB(theta,tempmat,eigenvectors,b_size,b_size,b_size,b_size,errorcode);
     for j := 1 to b_size do
     begin
            q := 1.0 / sqrt(theta[j-1,j-1]);
            for i := 1 to b_size do
            begin
                norm_b[i-1,j-1] := eigenvectors[i-1,j-1] * q;
                raw_b[i-1,j-1] := norm_b[i-1,j-1] / stddev[a_size+i-1];
            end;
     end;
     MatAxB(norm_a,second_prod,norm_b,a_size,b_size,b_size,b_size,errorcode);
     for j := 1 to b_size do
     begin
            for i := 1 to a_size do
            begin
                norm_a[i-1,j-1] := norm_a[i-1,j-1] * (1.0 / sqrt(roots[j-1]));
                raw_a[i-1,j-1] := norm_a[i-1,j-1] / stddev[i-1];
            end;
     end;

     // Compute the correlations between variables and canonical variables
     MatAxB(a_cors,raa,norm_a,a_size,a_size,a_size,b_size,errorcode);
     for j := 1 to b_size do
     begin
         q := 0.0;
         for i := 1 to a_size do q := q + norm_a[i-1,j-1] * a_cors[i-1,j-1];
         q := 1.0 / sqrt(q);
         for i := 1 to a_size do a_cors[i-1,j-1] := a_cors[i-1,j-1] * q;
     end;
     MatAxB(b_cors,rbb,norm_b,b_size,b_size,b_size,b_size,errorcode);
     for j := 1 to b_size do
     begin
         q := 0.0;
         for i := 1 to b_size do q := q + norm_b[i-1,j-1] * b_cors[i-1,j-1];
         q := 1.0 / sqrt(q);
         for i := 1 to b_size do b_cors[i-1,j-1] := b_cors[i-1,j-1] * q;
     end;

     // Compute the Proportions of Variance (PVs) and Redundancy Coefficients
     for j := 1 to b_size do
     begin
         pv_a[j-1] := 0.0;
         for i := 1 to a_size do pv_a[j-1] := pv_a[j-1] + (a_cors[i-1,j-1] * a_cors[i-1,j-1]);
         pv_a[j-1] := pv_a[j-1] / a_size;
         rd_a[j-1] := pv_a[j-1] * roots[j-1];
     end;
     for j := 1 to b_size do
     begin
         pv_b[j-1] := 0.0;
         for i := 1 to b_size do pv_b[j-1] := pv_b[j-1] + (b_cors[i-1,j-1] * b_cors[i-1,j-1]);
         pv_b[j-1] := pv_b[j-1] / b_size;
         rd_b[j-1] := pv_b[j-1] * roots[j-1];
     end;

     // Compute tests of the roots
     q := a_size + b_size + 1;
     q := -(count - 1.0 - (q / 2.0));
     k := 0;
     for i := 1 to b_size do
     begin
         w := 1.0;
         for j := i to b_size do w := w * (1.0 - roots[j-1]);
         root_chi[i-1] := q * ln(w);
         root_df[i-1] := (a_size - i + 1) * (b_size - i + 1);
         chi_prob[i-1] := 1.0 - chisquaredprob(root_chi[i-1],root_df[i-1]);
         if (chi_prob[i-1] < critical_prob) then k := k + 1;
     end;
     Roys := roots[0] / (1.0 - roots[0]);
     Lambda := 1.0;
     for i := 1 to b_size do
     begin
         Hroot := roots[i-1] / (1.0 - roots[i-1]);
         Lambda := Lambda * (1.0 / (1.0 + Hroot));
         Pillia := Pillia + (Hroot / (1.0 + Hroot));
         HLTrace := HLTrace + Hroot;
     end;

     // Print remaining results
     OutPutFrm.RichEdit.Lines.Add('');
     OutPutFrm.RichEdit.Lines.Add('');
     outline := '   Canonical R   Root  % Trace   Chi-Sqr    D.F.    Prob.';
     OutPutFrm.RichEdit.Lines.Add(outline);
     for i := 1 to b_size do
     begin
         outline := format('%2d %10.6f %8.3f %7.3f %8.3f      %2d %8.3f',
          [i, sqrt(roots[i-1]), roots[i-1], pcnt_trace[i-1], root_chi[i-1], root_df[i-1], chi_prob[i-1]]);
         OutPutFrm.RichEdit.Lines.Add(outline);
     end;
     chisqr := -ln(Lambda) * (count - 1.0 - 0.5 * (a_size + b_size - 1.0));
     chiprob := 1.0 - chisquaredprob(chisqr,a_size * b_size);
     OutPutFrm.RichEdit.Lines.Add('');
     OutPutFrm.RichEdit.Lines.Add('Overall Tests of Significance:');
     OutPutFrm.RichEdit.Lines.Add('         Statistic      Approx. Stat.   Value   D.F.  Prob.>Value');
     outline := format('Wilk''s Lambda           Chi-Squared %10.4f  %3d   %6.4f',
                [chisqr,a_size * b_size,chiprob]);
     OutPutFrm.RichEdit.Lines.Add(outline);
     s := b_size;
     m := 0.5 * (a_size - b_size - 1);
     n := 0.5 * (count - b_size - a_size - 2);
     f := (HLTrace * 2.0 * (s * n + 1)) / (s * s * (2.0 * m + s + 1.0));
     df1 := s * (2.0 * m + s + 1.0);
     df2 := 2.0 * ( s * n  + 1.0);
     ftestprob := probf(f,df1,df2);
     outline := format('Hotelling-Lawley Trace  F-Test      %10.4f %2.0f %2.0f  %6.4f',
                [f, df1,df2, ftestprob]);
     OutPutFrm.RichEdit.Lines.Add(outline);
     df2 := s * (2.0 * n + s + 1.0);
     f := (Pillia / (s - Pillia)) * ( (2.0 * n + s +1.0) / (2.0 * m + s + 1.0) );
     ftestprob := probf(f,df1,df2);
     outline := format('Pillai Trace            F-Test      %10.4f %2.0f %2.0f  %6.4f',
                [f, df1,df2, ftestprob]);
     OutPutFrm.RichEdit.Lines.Add(outline);
     Roys := Roys * (count - 1 - a_size + b_size)/ a_size ;
     df1 := a_size;
     df2 := count - 1 - a_size + b_size;
     ftestprob := probf(Roys,df1,df2);
     outline := format('Roys Largest Root       F-Test      %10.4f %2.0f %2.0f  %6.4f',
                [Roys, df1, df2, ftestprob]);
     OutPutFrm.RichEdit.Lines.Add(outline);
     OutPutFrm.ShowModal;
     OutPutFrm.RichEdit.Clear;

     if EigenChk.Checked then
     begin
          title := 'Eigenvectors';
          MAT_PRINT(eigenvectors,b_size,b_size,title,CanLabels,CanLabels,NCases);
          OutPutFrm.ShowModal();
          OutPutFrm.RichEdit.Clear;
     end;

     title := 'Standardized Right Side Weights';
     MAT_PRINT(norm_a,a_size,b_size,title,RowLabels,CanLabels,NCases);
     title := 'Standardized Left Side Weights';
     MAT_PRINT(norm_b,b_size,b_size,title,ColLabels,CanLabels,NCases);
     OutPutFrm.ShowModal;
     OutPutFrm.RichEdit.Clear;
     title := 'Raw Right Side Weights';
     MAT_PRINT(raw_a,a_size,b_size,title,RowLabels,CanLabels,NCases);
     title := 'Raw Left Side Weights';
     MAT_PRINT(raw_b,b_size,b_size,title,ColLabels,CanLabels,NCases);
     OutPutFrm.ShowModal;
     OutPutFrm.RichEdit.Clear;
     title := 'Right Side Correlations with Function';
     MAT_PRINT(a_cors,a_size,b_size,title,RowLabels,CanLabels,NCases);
     title := 'Left Side Correlations with Function';
     MAT_PRINT(b_cors,b_size,b_size,title,ColLabels,CanLabels,NCases);
     OutPutFrm.ShowModal;
     OutPutFrm.RichEdit.Clear;

     if RedundChk.Checked then
     begin
          outline := 'Redundancy Analysis for Right Side Variables';
          OutPutFrm.RichEdit.Lines.Add(outline);
          OutPutFrm.RichEdit.Lines.Add('');
          outline := '            Variance Prop.    Redundancy';
          OutPutFrm.RichEdit.Lines.Add(outline);
          for i := 1 to b_size do
          begin
               outline := format('%10d %10.5f     %10.5f',[i,pv_a[i-1],rd_a[i-1]]);
               OutPutFrm.RichEdit.Lines.Add(outline);
          end;
          OutPutFrm.RichEdit.Lines.Add('');
          outline := 'Redundancy Analysis for Left Side Variables';
          OutPutFrm.RichEdit.Lines.Add(outline);
          outline := '            Variance Prop.    Redundancy';
          OutPutFrm.RichEdit.Lines.Add(outline);
          for i := 1 to b_size do
          begin
               outline := format('%10d %10.5f     %10.5f',[i,pv_b[i-1],rd_b[i-1]]);
               OutPutFrm.RichEdit.Lines.Add(outline);
               end;
          OutPutFrm.ShowModal;
          OutPutFrm.RichEdit.Clear;
     end;

     //------------- Now, clean up memory mess ----------------------------
cleanup:
    Selected := nil;
    ColLabels := nil;
    RowLabels := nil;
    CanLabels := nil;
    b_vars := nil;
    a_vars := nil;
    root_df := nil;
    pcnt_trace := nil;
    rd_b := nil;
    rd_a := nil;
    pv_b := nil;
    pv_a := nil;
    chi_prob := nil;
    root_chi := nil;
    roots := nil;
    stddev := nil;
    variance := nil;
    mean := nil;
    tempmat := nil;
    theta := nil;
    eigentrans := nil;
    b_cors := nil;
    a_cors := nil;
    raw_b := nil;
    raw_a := nil;
    norm_b := nil;
    norm_a := nil;
    eigenvectors := nil;
    rbbinv := nil;
    raainv := nil;
    char_equation := nil;
    second_prod := nil;
    first_prod := nil;
    prod := nil;
    rba := nil;
    rab := nil;
    rbb := nil;
    raa := nil;
end;

procedure TCannonFrm.LeftInClick(Sender: TObject);
VAR i, index : integer;
begin
     index := VarList.Items.Count;
     i := 0;
     while i < index do
     begin
         if (VarList.Selected[i]) then
         begin
            LeftList.Items.Add(VarList.Items.Strings[i]);
            VarList.Items.Delete(i);
            index := index - 1;
            i := 0;
         end
         else i := i + 1;
     end;
     LeftOut.Visible := true;
end;

procedure TCannonFrm.LeftOutClick(Sender: TObject);
VAR index : integer;
begin
     index := LeftList.ItemIndex;
     if index < 0 then
     begin
          LeftOut.Visible := false;
          exit;
     end;
     VarList.Items.Add(LeftList.Items.Strings[index]);
     LeftList.Items.Delete(index);
end;

initialization
  {$I canonunit.lrs}

end.