unit SpearmanUnit;

{$mode objfpc}{$H+}

interface

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

type

  { TSpearmanFrm }

  TSpearmanFrm = class(TForm)
    XIn: TBitBtn;
    XOut: TBitBtn;
    YIn: TBitBtn;
    YOut: TBitBtn;
    ResetBtn: TButton;
    CancelBtn: TButton;
    ComputeBtn: TButton;
    ReturnBtn: TButton;
    XEdit: TEdit;
    YEdit: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    VarList: TListBox;
    procedure ComputeBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
    procedure XInClick(Sender: TObject);
    procedure XOutClick(Sender: TObject);
    procedure YInClick(Sender: TObject);
    procedure YOutClick(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 

var
  SpearmanFrm: TSpearmanFrm;

implementation

{ TSpearmanFrm }

procedure TSpearmanFrm.ResetBtnClick(Sender: TObject);
VAR i : integer;
begin
     XEdit.Text := '';
     YEdit.Text := '';
     Xin.Visible := true;
     Xout.Visible := false;
     Yin.Visible := true;
     Yout.Visible := false;
     VarList.Items.Clear;
     for i := 1 to NoVariables do
         VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
end;

procedure TSpearmanFrm.XInClick(Sender: TObject);
VAR index : integer;
begin
     index := VarList.ItemIndex;
     XEdit.Text := VarList.Items.Strings[index];
     VarList.Items.Delete(index);
     Xin.Visible := false;
     Xout.Visible := true;
end;

procedure TSpearmanFrm.XOutClick(Sender: TObject);
begin
     VarList.Items.Add(XEdit.Text);
     XEdit.Text := '';
     Xin.Visible := true;
     Xout.Visible := false;
end;

procedure TSpearmanFrm.YInClick(Sender: TObject);
VAR index : integer;
begin
     index := VarList.ItemIndex;
     YEdit.Text := VarList.Items.Strings[index];
     VarList.Items.Delete(index);
     Yin.Visible := false;
     Yout.Visible := true;
end;

procedure TSpearmanFrm.YOutClick(Sender: TObject);
begin
     VarList.Items.Add(YEdit.Text);
     YEdit.Text := '';
     Yin.Visible := true;
     Yout.Visible := false;
end;

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

procedure TSpearmanFrm.ComputeBtnClick(Sender: TObject);
label Check1, Check2;
var
   i, j, k, itemp, NoTies, NoTieGroups, NoSelected : integer;
   col1, col2, NCases : integer;
   index : IntDyneMat;
   Probability, sumsqrx, sumsqry, Temp, TieSum, Avg, t, SumT, r : double;
   z, sumdsqr, df : double;
   Ranks, X : DblDyneMat;
   d : DblDyneVec;
   cellstring, outline : string;
   ColNoSelected : IntDyneVec;
   ColLabels : StrDyneVec;
   VarX, VarY, SDX, SDY, MeanX, MeanY, Rxy : double;
begin
    // Allocate memory
    SetLength(ColNoSelected,NoVariables);
    SetLength(index,NoCases,2);
    SetLength(Ranks,NoCases,2);
    SetLength(X,NoCases,2);
    SetLength(d,NoCases);
    SetLength(ColLabels,NoVariables);

    // Get column numbers and labels of variables selected
    for j := 1 to NoVariables do
    begin
         cellstring := OS3MainFrm.DataGrid.Cells[j,0];
         if cellstring = Xedit.Text then
         begin
              ColNoSelected[0] := j;
              ColLabels[0] := cellstring;
         end;
         if cellstring = Yedit.Text then
         begin
              ColNoSelected[1] := j;
              ColLabels[1] := cellstring;
         end;
    end;
    NoSelected := 2;

    OutPutFrm.RichEdit.Clear;
    outline := 'Spearman Rank Correlation Between ';
    outline := outline + ColLabels[0];
    outline := outline +' & ';
    outline := outline + ColLabels[1];
    OutPutFrm.RichEdit.Lines.Add(outline);
    OutPutFrm.RichEdit.Lines.Add('');

    // Get scores
    NCases := 0;
    MeanX := 0.0;
    MeanY := 0.0;
    VarX := 0.0;
    VarY := 0.0;
    Rxy := 0.0;
    NoTies := 0;

    for i := 1 to NoCases do
    begin
        if ( not GoodRecord(i,NoSelected,ColNoSelected)) then continue;
        NCases := NCases + 1;
        col1 := ColNoSelected[0];
        col2 := ColNoSelected[1];
        X[NCases-1,0] := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[col1,i]));
        Ranks[NCases-1,0] := X[NCases-1,0];
        X[NCases-1,1] := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[col2,i]));
        Ranks[NCases-1,1] := X[NCases-1,1];
        index[NCases-1,0] := NCases;
        index[NCases-1,1] := NCases;
        VarX := VarX + X[NCases-1,0] * X[NCases-1,0];
        VarY := VarY + X[NCases-1,1] * X[NCases-1,1];
        MeanX := MeanX + X[NCases-1,0];
        MeanY := MeanY + X[NCases-1,1];
        Rxy := Rxy + X[NCases-1,0] * X[NCases-1,1];
    end;

    // Rank the first variable
    for i := 1 to NCases - 1 do
    begin
         for j := i + 1 to NCases do
         begin
            if (Ranks[i-1,0] > Ranks[j-1,0]) then // swap
            begin
                Temp := Ranks[i-1,0];
                Ranks[i-1,0] := Ranks[j-1,0];
                Ranks[j-1,0] := Temp;
                itemp := index[i-1,0];
                index[i-1,0] := index[j-1,0];
                index[j-1,0] := itemp;
                Temp := X[i-1,0];
                X[i-1,0] := X[j-1,0];
                X[j-1,0] := Temp;
            end;
        end;
    end;

    // Assign ranks
    for i := 1 to NCases do Ranks[i-1,0] := i;

    // Check for ties in each
//    NoTieGroups := 0;
    SumT := 0.0;
    i := 1;
    while (i < NCases) do
    begin
        j := i+1;
        TieSum := 0.0;
        NoTies := 0;
        while (j <= NCases) do
        begin
            if (X[j-1,0] > X[i-1,0]) then  goto Check1;
            if (X[j-1,0] = X[i-1,0]) then
            begin
                TieSum := TieSum + Ranks[j-1,0];
                NoTies := NoTies + 1;
            end;
            j := j + 1;
        end;
Check1:
        if (NoTies > 0) then // at least one tie found
        begin
            TieSum := TieSum + Ranks[i-1,0];
            NoTies := NoTies + 1;
            Avg := TieSum / NoTies;
            for j := i to i + NoTies - 1 do Ranks[j-1,0] := Avg;
            t := ( Power(NoTies,3) - NoTies) / 12.0;
            SumT := SumT + t;
//            NoTieGroups := NoTieGroups + 1;
            i := i + (NoTies-1);
        end;
        i := i + 1;
    end;
    sumsqrx := ( (Power(NCases,3) - NCases) / 12.0) - SumT;
    outline := format('Tied ranks correction for X = %8.2f for %d ties',[sumsqrx,NoTies]);
    OutPutFrm.RichEdit.Lines.Add(outline);

    // Repeat sort for second variable
    for i := 1 to NCases - 1 do
    begin
        for j := i + 1 to NCases do
        begin
            if (Ranks[i-1,1] > Ranks[j-1,1]) then // swap
            begin
                Temp := Ranks[i-1,1];
                Ranks[i-1,1] := Ranks[j-1,1];
                Ranks[j-1,1] := Temp;
                itemp := index[i-1,1];
                index[i-1,1] := index[j-1,1];
                index[j-1,1] := itemp;
                Temp := X[i-1,1];
                X[i-1,1] := X[j-1,1];
                X[j-1,1] := Temp;
            end;
        end;
    end;

    // Assign ranks
    for i := 1 to NCases do Ranks[i-1,1] := i;

    // Check for ties in each
    SumT := 0.0;
//    NoTieGroups := 0;
    i := 1;
    while (i < NCases) do
    begin
        j := i+1;
        TieSum := 0.0;
        NoTies := 0;
        while (j <= NCases) do
        begin
            if (X[j-1,1] > X[i-1,1]) then goto Check2;
            if (X[j-1,1] = X[i-1,1]) then
            begin
                TieSum := TieSum + Ranks[j-1,1];
                NoTies := NoTies + 1;
            end;
            j := j + 1;
        end;
Check2:
        if (NoTies > 0) then // at least one tie found
        begin
            TieSum := TieSum + Ranks[i-1,1];
            NoTies := NoTies + 1;
            Avg := TieSum / NoTies;
            for j := i to i + NoTies - 1 do Ranks[j-1,1] := Avg;
            t := ( Power(NoTies,3) - NoTies) / 12.0;
            SumT := SumT + t;
//            NoTieGroups := NoTieGroups + 1;
            i := i + (NoTies-1);
        end;
        i := i + 1;
    end;
    sumsqry := ( (Power(NCases,3) - NCases) / 12.0) - SumT;
    outline := format('Tied ranks correction for Y = %8.2f for %d ties',[sumsqry,NoTies]);
    OutPutFrm.RichEdit.Lines.Add(outline);

    // arrange scores in order of first variable
    for i := 1 to Ncases - 1 do
    begin
         for j := i + 1 to Ncases do
         begin
              if (index[i-1,0] > index[j-1,0]) then // swap all
              begin
                   itemp := index[i-1,0];
                   index[i-1,0] := index[j-1,0];
                   index[j-1,0] := itemp;
                   Temp := X[i-1,0];
                   X[i-1,0] := X[j-1,0];
                   X[j-1,0] := Temp;
                   Temp := Ranks[i-1,0];
                   Ranks[i-1,0] := Ranks[j-1,0];
                   Ranks[j-1,0] := Temp;
              end; // end swap
         end; // next j
    end; // next i

    // arrange scores of the second variable
    for i := 1 to Ncases - 1 do
    begin
         for j := i + 1 to Ncases do
         begin
              if (index[i-1,1] > index[j-1,1]) then // swap all
              begin
                   itemp := index[i-1,1];
                   index[i-1,1] := index[j-1,1];
                   index[j-1,1] := itemp;
                   Temp := X[i-1,1];
                   X[i-1,1] := X[j-1,1];
                   X[j-1,1] := Temp;
                   Temp := Ranks[i-1,1];
                   Ranks[i-1,1] := Ranks[j-1,1];
                   Ranks[j-1,1] := Temp;
              end; // end swap
         end; // next j
    end; // next i

    // Calculate difference scores
    sumdsqr := 0.0;
    for i := 1 to NCases do
    begin
        d[i-1] := Ranks[i-1,0] - Ranks[i-1,1];
        sumdsqr := sumdsqr + (d[i-1] * d[i-1]);
    end;

    // Calculate corrected spearman rank correlation
    r := (sumsqrx + sumsqry - sumdsqr) / (2.0 * sqrt(sumsqrx * sumsqry));

    // Calculate Pearson correlation
    VarX := VarX - (MeanX * MeanX) / NCases;
    VarX := VarX / (NCases-1);
    VarY := VarY - (MeanY * MeanY) / NCases;
    VarY := VarY / (NCases - 1);
    SDX := sqrt(VarX);
    SDY := sqrt(VarY);
    Rxy := Rxy - (MeanX * MeanY) / NCases;
    Rxy := Rxy / (NCases - 1);
    Rxy := Rxy / (SDX * SDY);
    MeanX := MeanX / NCases;
    MeanY := MeanY / NCases;

    // Output the results
    OutPutFrm.RichEdit.Lines.Add('');
    OutPutFrm.RichEdit.Lines.Add('Observed scores, their ranks and differences between ranks');
    outline := format('CASE %10s    Ranks %10s     Ranks Rank Difference',
            [ColLabels[0], ColLabels[1]]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    for i := 1 to NCases do
    begin
        outline := format('%4d %10.2f%10.2f%10.2f%10.2f%10.2f',
                [i, X[i-1,0], Ranks[i-1,0], X[i-1,1], Ranks[i-1,1], d[i-1]]);
        OutPutFrm.RichEdit.Lines.Add(outline);
    end;
    outline := format('Spearman Rank Correlation = %6.3f',[r]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    OutPutFrm.RichEdit.Lines.Add('');

    if (NCases > 10) then// Use normal distribution approximation
    begin
        z := r * sqrt((NCases - 2) / (1.0 - (r * r)));
        outline := format('t-test value for hypothesis r = 0 is %5.3f',[z]);
        OutPutFrm.RichEdit.Lines.Add(outline);
        df := NCases - 2;
        Probability := probt(z,df);
        outline := format('Probability > t = %6.4f',[Probability]);
        OutPutFrm.RichEdit.Lines.Add(outline);
    end
    else
    begin
        outline := 'Use table P, page 284 in Siegel for testing significance of r.';
        OutPutFrm.RichEdit.Lines.Add(outline);
    end;

    OutPutFrm.RichEdit.Lines.Add('');
    outline := format('Pearson r for original scores := %6.3f',[Rxy]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    OutPutFrm.RichEdit.Lines.Add('For the Original Scores:');
    OutPutFrm.RichEdit.Lines.Add('Mean X  Variance X  Std.Dev. X  Mean Y  Variance Y  Std.Dev. Y');
    outline := format('%8.2f  %8.2f  %8.2f  %8.2f  %8.2f  %8.2f',[MeanX,VarX,SDX,MeanY,VarY,SDY]);
    OutPutFrm.RichEdit.Lines.Add(outline);

    OutPutFrm.ShowModal;
    OutPutFrm.RichEdit.Clear;

    // clean up the heap
    ColLabels := nil;
    d := nil;
    X := nil;
    Ranks := nil;
    index := nil;
    ColNoSelected := nil;
end;

initialization
  {$I spearmanunit.lrs}

end.