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

unit FriedmanUnit;

{$mode objfpc}{$H+}

interface

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

type

  { TFriedmanFrm }

  TFriedmanFrm = class(TForm)
    HelpBtn: TButton;
    ResetBtn: TButton;
    CancelBtn: TButton;
    ComputeBtn: TButton;
    ReturnBtn: TButton;
    GrpVar: TEdit;
    GrpIn: TBitBtn;
    GrpOut: TBitBtn;
    Label2: TLabel;
    Label3: TLabel;
    TreatVars: TListBox;
    TrtIn: TBitBtn;
    TrtOut: TBitBtn;
    Label1: TLabel;
    VarList: TListBox;
    procedure ComputeBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure GrpInClick(Sender: TObject);
    procedure GrpOutClick(Sender: TObject);
    procedure HelpBtnClick(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
    procedure TrtInClick(Sender: TObject);
    procedure TrtOutClick(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 

var
  FriedmanFrm: TFriedmanFrm;

implementation

{ TFriedmanFrm }

procedure TFriedmanFrm.ResetBtnClick(Sender: TObject);
VAR i : integer;
begin
     VarList.Items.Clear;
     TreatVars.Items.Clear;
     GrpVar.Text := '';
     for i := 1 to NoVariables do
     begin
          VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
     end;
     GrpIn.Visible := true;
     GrpOut.Visible := false;
     TrtIn.Visible := true;
     TrtOut.Visible := false;
end;

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

procedure TFriedmanFrm.TrtOutClick(Sender: TObject);
VAR index : integer;
begin
   index := TreatVars.ItemIndex;
   if index < 0 then
   begin
        TrtOut.Visible := false;
        TrtIn.Visible := true;
        exit;
   end;
   VarList.Items.Add(TreatVars.Items.Strings[index]);
   TreatVars.Items.Delete(index);
   TrtIn.Visible := true;
end;

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

procedure TFriedmanFrm.ComputeBtnClick(Sender: TObject);
Var
   i, j, k, L, col, itemp, GrpCol, CondVar, mingrp, maxgrp : integer;
   tiestart, tieend, NoSelected, NCases, group, nogrps : integer;
   s, t, TotRanks, chisqr, probchi, score : double;
   X, ColRanks : DblDyneVec;
   Ranks, means : DblDyneMat;
   RowLabels, ColLabels : StrDyneVec;
   index : IntDyneVec;
   GrpNo : IntdyneMat;
   cellstring, outline: string;
   title : string;
   ties : boolean;
   ColNoSelected : IntDyneVec;
begin
     k := TreatVars.Items.Count;
     NoSelected := k + 1;
     SetLength(ColNoSelected,NoVariables);
     SetLength(ColLabels,NoVariables);

     // get group variable and treatment variables
     GrpCol := 0;
     for i := 1 to NoVariables do
     begin
          cellstring := OS3MainFrm.DataGrid.Cells[i,0];
          if cellstring = GrpVar.Text then
          begin
               ColNoSelected[0] := i;
               GrpCol := i;
          end;
          for j := 1 to k do
          begin
               if cellstring = TreatVars.Items.Strings[j-1] then
               begin
                    ColNoSelected[j] := i;
                    ColLabels[j-1] := cellstring;
               end;
          end;
     end;

     // get minimum and maximum group codes
     NCases := 0;
     mingrp := 10000;
     maxgrp := -10000;
     for i := 1 to NoCases do
     begin
          if not GoodRecord(i,NoSelected,ColNoSelected) then continue;
          NCases := NCases + 1;
          group := round(StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[GrpCol,i])));
          if group > maxgrp then maxgrp := group;
          if group < mingrp then mingrp := group;
     end;
     nogrps := maxgrp - mingrp + 1;

    // Initialize arrays
     SetLength(RowLabels,nogrps);
     SetLength(index,k);
     SetLength(GrpNo,nogrps,k);
     SetLength(Ranks,nogrps,k);
     SetLength(means,nogrps,k);
     SetLength(X,k);
     SetLength(ColRanks,k);
    for j := 0 to k-1 do
    begin
        for i := 0 to nogrps-1 do
        begin
            means[i,j] := 0.0;
            Ranks[i,j] := 0.0;
            GrpNo[i,j] := 0;
        end;
        ColRanks[j] := 0.0;
        X[j] := 0.0;
        index[j] := j+1;
    end;

    // Initialize labels
    for i := 1 to nogrps do
    begin
        cellstring := format('Group %d',[mingrp + i - 1]);
        RowLabels[i-1] := cellstring;
    end;

    // Setup for printing results
    OutPutFrm.RichEdit.Clear;
    OutPutFrm.RichEdit.Lines.Add('FRIEDMAN TWO-WAY ANOVA ON RANKS');
    OutPutFrm.RichEdit.Lines.Add('See pages 166-173 in S. Siegel''s Nonparametric Statistics');
    OutPutFrm.RichEdit.Lines.Add('for the Behavioral Sciences, McGraw-Hill Book Co., New York, 1956');
    OutPutFrm.RichEdit.Lines.Add('');

    // Obtain mean score for each cell
    for i := 1 to NoCases do
    begin
        if ( not GoodRecord(i,NoSelected,ColNoSelected)) then continue;
        group := round(StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[GrpCol,i])));
        group := group - mingrp + 1;
        for j := 1 to k do // treatment values
        begin
             col := ColNoSelected[j];
             score := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[col,i]));
             means[group-1,j-1] := means[group-1,j-1]  + score;
             GrpNo[group-1,j-1]  := GrpNo[group-1,j-1] + 1;
        end;
    end;
    for i := 1 to nogrps do
        for j := 1 to k do
            means[i-1,j-1] := means[i-1,j-1] / GrpNo[i-1,j-1];

    // Print means and group size arrays
    title := 'Treatment means - values to be ranked.';
    MAT_PRINT(means,nogrps,k,title,RowLabels,ColLabels,NCases);
    title := 'Number in each group''s treatment.';
    IntArrayPrint(GrpNo,nogrps,k,'GROUP',RowLabels,ColLabels,title);

    // Gather row data in X array and rank within rows
    for i := 0 to nogrps-1 do
    begin
        for j := 0 to k-1 do
        begin
            X[j] := means[i,j];
            index[j] := j+1;
        end;

        //rank scores in this row i
        for j := 1 to k - 1 do
        begin
            for L := j + 1 to k do
            begin
                if (X[j-1] > X[L-1]) then
                begin
                    t := X[j-1];
                    X[j-1] := X[L-1];
                    X[L-1] := t;
                    itemp := index[j-1];
                    index[j-1] := index[L-1];
                    index[L-1] := itemp;
                end;
            end;
        end;
        for j := 1 to k do
        begin
            Ranks[i,index[j-1]-1] := j;
        end;

        //Check for tied ranks and use average if desired here
        tiestart := 0;
        tieend := 0;
        ties := false;
        j := 1;
        while j < k do
        begin
            for L := j + 1 to k do
            begin
                if (means[i,j-1] = means[i,L-1]) then
                begin
                    ties := true;
                    tiestart := j;
                    tieend := L;
                end;
            end;
            if (ties = true) then
            begin
                s := 0.0;
                for L := tiestart to tieend do s := s + Ranks[i,L-1];
                for L := tiestart to tieend do
                     Ranks[i,L-1] := s / (tieend - tiestart + 1);
                j := tieend;
                ties := false;
            end;
            j := j + 1;
        end; // next j
    end; // next group i

    //Get sum of ranks in columns
    for i := 1 to nogrps do
        for j := 1 to k do
            ColRanks[j-1] := ColRanks[j-1] + Ranks[i-1,j-1];

    //Calculate Statistics
    TotRanks := 0;
    for j := 1 to k do TotRanks := TotRanks + (ColRanks[j-1] * ColRanks[j-1]);
    chisqr := TotRanks * 12.0 / (nogrps * k * (k + 1));
    chisqr := chisqr - (3 * nogrps * (k + 1));
    probchi := 1.0 - chisquaredprob(chisqr, k - 1);

    //Now, show results
    title := 'Score Rankings Within Groups';
    MAT_PRINT(Ranks,nogrps,k,title,RowLabels,ColLabels,NCases);
    title := 'TOTAL RANKS';
    DynVectorPrint(ColRanks,k,title,ColLabels,NCases);
    OutPutFrm.RichEdit.Lines.Add('');
    outline := format('Chi-square with %d D.F. := %8.3f with probability := %6.4f',
        [k-1, chisqr, probchi]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    if ((k < 5) and (nogrps < 10)) then
    begin
        OutPutFrm.RichEdit.Lines.Add('Chi-square too approximate-use exact table (TABLE N)');
        OutPutFrm.RichEdit.Lines.Add('page 280-281 in Siegel');
    end;
    OutPutFrm.ShowModal;
    OutPutFrm.RichEdit.Clear;

    // clean up the heap
     ColRanks := nil;
     X := nil;
     means := nil;
     Ranks := nil;
     GrpNo := nil;
     index := nil;
     RowLabels := nil;
     ColLabels := nil;
     ColNoSelected := nil;
end;

procedure TFriedmanFrm.GrpInClick(Sender: TObject);
VAR index : integer;
begin
     index := VarList.ItemIndex;
     GrpVar.Text := VarList.Items.Strings[index];
     VarList.Items.Delete(index);
     GrpIn.Visible := false;
     GrpOut.Visible := true;
end;

procedure TFriedmanFrm.GrpOutClick(Sender: TObject);
begin
     VarList.Items.Add(GrpVar.Text);
     GrpVar.Text := '';
     GrpIn.Visible := true;
     GrpOut.Visible := false;
end;

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

initialization
  {$I friedmanunit.lrs}

end.