lazarus-ccr/applications/lazstats/source/forms/analysis/nonparametric/spearmanunit.pas

unit SpearmanUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
  StdCtrls, Buttons, ExtCtrls,
  MainUnit, Globals, DataProcs, BasicStatsReportFormUnit;

type

  { TSpearmanForm }

  TSpearmanForm = class(TBasicStatsReportForm)
    Bevel1: TBevel;
    XIn: TBitBtn;
    XOut: TBitBtn;
    YIn: TBitBtn;
    YOut: TBitBtn;
    XEdit: TEdit;
    YEdit: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    VarList: TListBox;
    procedure VarListDblClick(Sender: TObject);
    procedure VarListSelectionChange(Sender: TObject; {%H-}User: boolean);
    procedure XInClick(Sender: TObject);
    procedure XOutClick(Sender: TObject);
    procedure YInClick(Sender: TObject);
    procedure YOutClick(Sender: TObject);

  private
	
  protected
    procedure AdjustConstraints; override;
    procedure Compute; override;
    procedure UpdateBtnStates; override;
    function Validate(out AMsg: String; out AControl: TWinControl): boolean; override;

  public
    procedure Reset; override;
  end; 

var
  SpearmanForm: TSpearmanForm;


implementation

{$R *.lfm}

uses
  Math, MathUnit;

{ TSpearmanForm }

procedure TSpearmanForm.AdjustConstraints;
begin
  inherited;

  ParamsPanel.Constraints.MinWidth := 4*CloseBtn.Width + 3*CloseBtn.BorderSpacing.Left;
  ParamsPanel.Constraints.MinHeight := YOut.Top + YOut.Height +
    VarList.BorderSpacing.Bottom + ButtonBevel.Height +
    CloseBtn.BorderSpacing.Top + CloseBtn.Height;
end;


procedure TSpearmanForm.Compute;
var
  index: IntDyneMat = nil;
  Ranks: DblDyneMat = nil;
  X: DblDyneMat = nil;
  d: DblDyneVec = nil;
  ColNoSelected: IntDyneVec = nil;
  ColLabels: StrDyneVec = nil;
  i, j, itemp, NoTies, NoSelected: integer;
  col1, col2, NCases: integer;
  Probability, sumsqrx, sumsqry, Temp, TieSum, Avg, t, SumT, r: double;
  z, sumdsqr, df: double;
  cellstring: string;
  VarX, VarY, SDX, SDY, MeanX, MeanY, Rxy: double;
  lReport: TStrings;
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;

  lReport := TStringList.Create;
  try
    lReport.Add('SPEARMAN RANK CORRELATION BETWEEN %s AND %s', [ColLabels[0], ColLabels[1]]);;
    lReport.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
              Break;
            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;

        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;
    lReport.Add('Tied ranks correction for X = %8.2f for %d ties', [sumsqrx, NoTies]);

    // 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
              Break;
            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;

        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;
    lReport.Add('Tied ranks correction for Y = %8.2f for %d ties', [sumsqry, NoTies]);

    // 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
    lReport.Add('');
    lReport.Add('Observed scores, their ranks and differences between ranks');
    lReport.Add('CASE %10s    Ranks %10s     Ranks Rank Difference', [ColLabels[0], ColLabels[1]]);
    for i := 1 to NCases do
      lReport.Add('%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]]);
    lReport.Add('Spearman Rank Correlation: %6.3f',[r]);
    lReport.Add('');

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

    lReport.Add('');
    lReport.Add('Pearson r for original scores: %.3f', [Rxy]);
    lReport.Add('For the Original Scores:');
    lReport.Add('Mean X  Variance X  Std.Dev. X  Mean Y  Variance Y  Std.Dev. Y');
    lReport.Add('%8.2f  %8.2f  %8.2f  %8.2f  %8.2f  %8.2f', [MeanX, VarX, SDX, MeanY, VarY, SDY]);

    FReportFrame.DisplayReport(lReport);

  finally
    lReport.Free;
  end;
end;


procedure TSpearmanForm.Reset;
var
  i: integer;
begin
  inherited;

  XEdit.Text := '';
  YEdit.Text := '';
  VarList.Items.Clear;
  for i := 1 to NoVariables do
    VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);

  UpdateBtnStates;
end;


procedure TSpearmanForm.UpdateBtnStates;
begin
  inherited;
	
  XIn.Enabled := (VarList.Count > 0) and (XEdit.Text = '');
  YIn.Enabled := (Varlist.Count > 0) and (YEdit.Text = '');
  XOut.Enabled := XEdit.Text <> '';
  YOut.Enabled := YEdit.Text <> '';
end;


function TSpearmanForm.Validate(out AMsg: String; out AControl: TWinControl): boolean;
begin
  Result := false;

  if (XEdit.Text = '') then begin
     AMsg := 'X variable is not selected.';
     AControl := XEdit;
    exit;
  end;

  if (YEdit.Text = '') then begin
    AMsg := 'Y variable is not selected.';
    AControl := YEdit;
    exit;
  end;

  Result := true;
end;


procedure TSpearmanForm.VarListSelectionChange(Sender: TObject; User: boolean);
begin
  UpdateBtnStates;
end;


procedure TSpearmanForm.VarListDblClick(Sender: TObject);
var
  index: Integer;
  s: String;
begin
  index := VarList.ItemIndex;
  if index > -1 then
  begin
    s := VarList.Items[index];
    if XEdit.Text = '' then
      XEdit.Text := s
    else if YEdit.Text = '' then
      YEdit.Text := s;
    VarList.Items.Delete(index);
    UpdateBtnStates;
  end;
end;


procedure TSpearmanForm.XInClick(Sender: TObject);
var
  index: integer;
begin
  index := VarList.ItemIndex;
  if (index > -1) and (XEdit.Text = '') then
  begin
    XEdit.Text := VarList.Items[index];
    VarList.Items.Delete(index);
  end;
  UpdateBtnStates;
end;


procedure TSpearmanForm.XOutClick(Sender: TObject);
begin
  if XEdit.Text <> '' then
  begin
    VarList.Items.Add(XEdit.Text);
    XEdit.Text := '';
  end;
  UpdateBtnStates;
end;


procedure TSpearmanForm.YInClick(Sender: TObject);
var
  index: integer;
begin
  index := VarList.ItemIndex;
  if (index > -1) and (YEdit.Text = '') then
  begin
    YEdit.Text := VarList.Items[index];
    VarList.Items.Delete(index);
  end;
  UpdateBtnStates;
end;


procedure TSpearmanForm.YOutClick(Sender: TObject);
begin
  if YEdit.Text <> '' then
  begin
    VarList.Items.Add(YEdit.Text);
    YEdit.Text := '';
  end;
  UpdateBtnStates;
end;


end.