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

// Use file "taudata.laz" for testing.

unit KendallTauUnit;

{$mode objfpc}{$H+}

interface

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

type

  { TKendallTauForm }

  TKendallTauForm = class(TBasicStatsReportForm)
    RanksChk: TCheckBox;
    OptionsGroup: TGroupBox;
    XEdit: TEdit;
    YEdit: TEdit;
    ZEdit: TEdit;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    XIn: TBitBtn;
    XOut: TBitBtn;
    YIn: TBitBtn;
    YOut: TBitBtn;
    ZIn: TBitBtn;
    ZOut: TBitBtn;
    Label1: 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);
    procedure ZInClick(Sender: TObject);
    procedure ZOutClick(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
  KendallTauForm: TKendallTauForm;

implementation

{$R *.lfm}

uses
  Math,
  GridProcs, MatrixUnit;

{ TKendallTauForm }

procedure TKendallTauForm.AdjustConstraints;
begin
  inherited;

  ParamsPanel.Constraints.MinWidth := Max(
    4*CloseBtn.Width + 3*CloseBtn.BorderSpacing.Left,
    OptionsGroup.Width * 2 - XIn.Width);
  ParamsPanel.Constraints.MinHeight :=  OptionsGroup.Top + OptionsGroup.Height +
    ButtonBevel.Height + CloseBtn.BorderSpacing.Top + CloseBtn.Height;
end;


procedure TKendallTauForm.Compute;
var
  Ranks: DblDyneMat = nil;
  X: DblDyneMat = nil;
  Index: IntDyneMat = nil;
  ColLabels: StrDyneVec = nil;
  RowLabels: StrDyneVec = nil;
  ColNoSelected: IntdyneVec = nil;
  i, j, k, NoTies, NoSelected : integer;
  col1, col2, col3, NCases : integer;
  Probability, TieSum, Avg, SumT: double;
  z, denominator, stddev : double;
  TauXY, TauXZ, TauYZ : double;
  Tx, Ty, Tz : double;
  Term1, Term2 : double;
  PartialTau : double;
  title : string;
  lReport: TStrings;
begin
  // Allocate memory
  SetLength(index, NoCases, 3);
  SetLength(Ranks, NoCases, 3);
  SetLength(X, NoCases, 3);
  SetLength(ColLabels, 3);
  SetLength(RowLabels, NoCases);
  SetLength(ColNoSelected, NoVariables);

  Tx := 0.0;
  Ty := 0.0;
  Tz := 0.0;

  // Get column numbers and labels of variables selected
  NoSelected := 0;
  ColNoSelected[0] := GetVariableIndex(OS3MainFrm.DataGrid, XEdit.Text);
  if ColNoSelected[0] > -1 then inc(NoSelected);
  ColNoSelected[1] := GetVariableIndex(OS3MainFrm.DataGrid, YEdit.Text);
  if ColNoSelected[1] > -1 then inc(NoSelected);
  ColNoSelected[2] := GetVariableIndex(OS3MainFrm.DataGrid, ZEdit.Text);
  if ColNoSelected[2] > -1 then inc(NoSelected);
  SetLength(ColNoSelected, NoSelected);

  col1 := ColNoSelected[0];
  col2 := ColNoSelected[1];
  if NoSelected = 3 then col3 := ColNoSelected[2] else col3 := -1;

  // Get scores
  NCases := 0;
  for i := 1 to NoCases do
  begin
    if not GoodRecord(OS3MainFrm.DataGrid, i, ColNoSelected) then continue;
    NCases := NCases + 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];
    if NoSelected = 3 then
    begin
      X[NCases-1, 2] := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[col3, i]));
      Ranks[NCases-1, 2] := X[NCases-1, 2];
    end;
    index[NCases-1, 0] := NCases;
    index[NCases-1, 1] := NCases;
    if NoSelected = 3 then index[NCases-1, 2] := NCases;
  end;

  for i := 0 to NCases - 1 do
    RowLabels[i] := IntToStr(i+1);

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

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

  // Check for ties in each
  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;
      i := i + (NoTies-1);
      Tx := Tx + NoTies *(NoTies-1);
    end;
    i := i + 1;
  end;
    Tx := Tx / 2.0;

  // Repeat sort for second variable Y
  for i := 0 to NCases - 2 do
  begin
    for j := i + 1 to NCases-1 do
    begin
      if (Ranks[i,1] > Ranks[j,1]) then // swap
      begin
        Exchange(Ranks[i, 1], Ranks[j, 1]);
        Exchange(index[i, 1], Index[j, 1]);
      end;
    end;
  end;

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

  // Check for ties in each
  i := 1;
  while (i < NCases) do
  begin
    j := i+1;
    TieSum := 0.0;
    NoTies := 0;
    while (j <= NoCases) 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;
      i := i + (NoTies-1);
      Ty := Ty + NoTies * (NoTies - 1);
    end;
    i := i + 1;
  end;
  Ty := Ty / 2.0;

  // Repeat for z variable
  if NoSelected > 2 then // z was entered
  begin
    for i := 0 to NCases - 2 do
    begin
      for j := i + 1 to NCases-1 do
      begin
        if (Ranks[i,2] > Ranks[j,2]) then // swap
        begin
          Exchange(Ranks[i, 2], Ranks[j, 2]);
          Exchange(Index[i, 2], Index[j, 2]);
        end;
      end;
    end;

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

    // Check for ties in each
    i := 1;
    while (i < NCases) do
    begin
      j := i+1;
      TieSum := 0.0;
      NoTies := 0;
      while (j <= NoCases) do
      begin
        if (X[j-1,2] > X[i-1,2]) then
          Break;
        if (X[j-1,2] = X[i-1,2]) then
        begin
          TieSum := TieSum + Ranks[j-1,2];
          NoTies := NoTies + 1;
        end;
        j := j + 1;
      end;

      if (NoTies > 0) then // at least one tie found
      begin
        TieSum := TieSum + Ranks[i-1,2];
        NoTies := NoTies + 1;
        Avg := TieSum / NoTies;
        for j := i to i + NoTies - 1 do Ranks[j-1,2] := Avg;
        i := i + (NoTies-1);
        Tz := Tz + NoTies * (NoTies - 1);
      end;
      i := i + 1;
    end;
    Tz := Tz / 2.0;
  end;

  // Rearrange ranks into original score order
  for k := 1 to 3 do
  begin
    for i := 1 to NCases - 1 do
    begin
      for j := i + 1 to NCases do
      begin
        if (index[i-1,k-1] > index[j-1,k-1]) then // swap
        begin
          Exchange(Index[i-1, k-1], Index[j-1, k-1]);
          Exchange(Ranks[i-1, k-1], Ranks[j-1, k-1]);
        end;
      end;
    end;
  end;

  // compute Tau for X and Y
  // sort on X and obtain SumT for Y ranks
  SumT := 0.0;
  for i := 0 to NCases - 2 do
  begin
    for j := i + 1 to NCases-1 do
    begin
      if (Ranks[i,0] > Ranks[j,0]) then // swap
      begin
        Exchange(Ranks[i, 0], Ranks[j, 0]);
        Exchange(Ranks[i, 1], Ranks[j, 1]);
        if NoSelected = 3 then
          Exchange(Ranks[i, 2], Ranks[j, 2]);
        Exchange(Index[i, 0], Index[j, 0]);
      end;
    end;
  end;

  for i := 0 to NCases - 2 do
    for j := i + 1 to NCases - 1 do
      if Ranks[i,1] < Ranks[j,1] then
        SumT := SumT + 1.0
      else if Ranks[i,1] > Ranks[j,1] then
        SumT := SumT - 1.0;
  Term1 := sqrt((NCases * (NCases-1)) / 2.0 - Tx);
  Term2 := sqrt((NCases * (Ncases-1)) / 2.0 - Ty);
  denominator := Term1 * Term2;
  TauXY := SumT / denominator;

  if NoSelected > 2 then // get tau values for partial
  begin
    // Get TauXZ
    SumT := 0.0;
    for i := 0 to NCases - 2 do
      for j := i + 1 to NCases - 1 do
        if Ranks[i,2] < Ranks[j,2] then
          SumT := SumT + 1.0
        else if Ranks[i,2] > Ranks[j,2] then
          SumT := SumT - 1.0;
    Term1 := sqrt((NCases * (NCases-1)) / 2.0 - Tx);
    Term2 := sqrt((NCases * (Ncases-1)) / 2.0 - Tz);
    denominator := Term1 * Term2;
    TauXZ := SumT / denominator;

    // get back to original order then sort on Y
    for i := 0 to NCases - 2 do
    begin
      for j := i + 1 to NCases - 1 do
      begin
        if index[i,0] > index[j,0] then // swap
        begin
          Exchange(Ranks[i, 0], Ranks[j, 0]);
          Exchange(Ranks[i, 1], Ranks[j, 1]);
          Exchange(Ranks[i, 2], Ranks[j, 2]);
          Exchange(Index[i, 0], Index[j, 0]);
        end;
      end;
    end;

    // Get TauYZ
    for i := 0 to NCases - 2 do // sort on Y variable
    begin
      for j := i + 1 to NCases-1 do
      begin
        if (Ranks[i,1] > Ranks[j,1]) then // swap
        begin
          Exchange(Ranks[i, 1], Ranks[j, 1]);
          Exchange(Ranks[i, 2], Ranks[j, 2]);
          Exchange(Index[i, 1], Index[j, 1]);
        end;
      end;
    end;

    SumT := 0.0;
    for i := 0 to NCases - 2 do
      for j := i + 1 to NCases - 1 do
        if Ranks[i,2] < Ranks[j,2] then
          SumT := SumT + 1.0
        else if Ranks[i,2] > Ranks[j,2] then
          SumT := SumT - 1.0;
    Term1 := sqrt((NCases * (NCases-1)) / 2.0 - Ty);
    Term2 := sqrt((NCases * (Ncases-1)) / 2.0 - Tz);
    denominator := Term1 * Term2;
    TauYZ := SumT / denominator;
    PartialTau := (TauXY - TauXZ * TauYZ) / (sqrt(1.0 - sqr(TauXZ)) * sqrt(1.0 - sqr(TauYZ)));
  end;

  lReport := TStringList.Create;
  try
    lReport.Add('Kendall Tau for File ' + OS3MainFrm.FileNameEdit.Text);
    lReport.Add('');
    lReport.Add('Kendall Tau for Variables ' + ColLabels[0] + ' and ' + ColLabels[1]);

    // do significance tests
    stddev := sqrt( (2.0 * ( 2.0 * NCases + 5)) / (9.0 * NCases * (NCases - 1.0)));
    z := abs(TauXY / stddev);
    probability := 1.0 - probz(z);
    lReport.Add('Tau = %8.4f  z = %8.3f probability > |z| = %4.3f', [TauXY, z, probability]);
    if NoSelected > 2 then
    begin
      lReport.Add('');
      z := abs(TauXZ / stddev);
      probability := 1.0 - probz(z);
      lReport.Add('Kendall Tau for variables ' + ColLabels[0] + ' and ' + ColLabels[2]);
      lReport.Add('Tau = %8.4f  z = %8.3f probability > |z| = %4.3f', [TauXZ, z, probability]);
      z := abs(TauYZ / stddev);
      probability := 1.0 - probz(z);
      lReport.Add('');
      lReport.Add('Kendall Tau for variables ' + ColLabels[1] + ' and ' + ColLabels[2]);
      lReport.Add('Tau = %8.4f  z = %8.3f probability > |z| = %4.3f', [TauYZ, z, probability]);
      lReport.Add('');
      lReport.Add('Partial Tau = %8.4f', [PartialTau]);
    end;
    lReport.Add('');
    lReport.Add('NOTE: Probabilities are for large N (>10)');

    // print data matrix if option is elected
    if RanksChk.Checked then
    begin
      lReport.Add('');
      lReport.Add('-----------------------------------------------------------------');
      lReport.Add('');
      title := 'Ranks';
      if NoSelected = 2 then
        MatPrint(Ranks, NCases, 2, title, RowLabels, ColLabels, NCases, lReport)
      else
        MatPrint(Ranks, NCases, 3, title, RowLabels, ColLabels, NCases, lReport);
    end;

    FReportFrame.DisplayReport(lReport);
  finally
    lReport.Free;
  end;
end;


procedure TKendallTauForm.Reset;
var
  i: integer;
begin
  inherited;
  XEdit.Clear;
  YEdit.Clear;
  ZEdit.Clear;
  VarList.Items.Clear;
  for i := 1 to NoVariables do
    VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
  RanksChk.Checked := false;
  UpdateBtnStates;
end;


procedure TKendallTauForm.UpdateBtnStates;
var
  i: Integer;
  lSelected: Boolean;
begin
  inherited;
	
  lSelected := false;
  for i:=0 to VarList.Items.Count-1 do
    if VarList.Selected[i] then
    begin
      lSelected := true;
      break;
    end;
  XIn.Enabled := lSelected and (XEdit.Text = '');
  YIn.Enabled := lSelected and (YEdit.Text = '');
  ZIn.Enabled := lSelected and (ZEdit.Text = '');
  XOut.Enabled := (XEdit.Text <> '');
  YOut.Enabled := (YEdit.Text <> '');
  ZOut.Enabled := (ZEdit.Text <> '');
end;


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

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

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

  Result := true;
end;


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


procedure TKendallTauForm.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
    else
    if ZEdit.Text = '' then
      ZEdit.Text := s;
    Varlist.Items.Delete(index);
    UpdateBtnStates;
  end;
end;

procedure TKendallTauForm.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 TKendallTauForm.XOutClick(Sender: TObject);
begin
  if XEdit.Text <> '' then
  begin
    VarList.Items.Add(XEdit.Text);
    XEdit.Text := '';
  end;
  UpdateBtnStates;
end;


procedure TKendallTauForm.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 TKendallTauForm.YOutClick(Sender: TObject);
begin
  if YEdit.Text <> '' then
  begin
    VarList.Items.Add(YEdit.Text);
    YEdit.Text := '';
  end;
  UpdateBtnStates;
end;


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


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

end.