unit ExactUnit;

{$mode objfpc}{$H+}

interface

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

type

  { TFisherFrm }

  TFisherFrm = class(TForm)
    ResetBtn: TButton;
    CancelBtn: TButton;
    ComputeBtn: TButton;
    ReturnBtn: TButton;
    RC11Edit: TEdit;
    RC12Edit: TEdit;
    RC21Edit: TEdit;
    RC22Edit: TEdit;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    NCasesEdit: TEdit;
    NCasesLabel: TLabel;
    Panel2: TPanel;
    RowIn: TBitBtn;
    RowOut: TBitBtn;
    ColIn: TBitBtn;
    ColOut: TBitBtn;
    DepIn: TBitBtn;
    DepOut: TBitBtn;
    ColEdit: TEdit;
    DepEdit: TEdit;
    RowEdit: TEdit;
    InputGrp: TRadioGroup;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    VarList: TListBox;
    Panel1: TPanel;
    procedure ColInClick(Sender: TObject);
    procedure ColOutClick(Sender: TObject);
    procedure ComputeBtnClick(Sender: TObject);
    procedure DepInClick(Sender: TObject);
    procedure DepOutClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure InputGrpClick(Sender: TObject);
    procedure RC11EditKeyPress(Sender: TObject; var Key: char);
    procedure RC12EditKeyPress(Sender: TObject; var Key: char);
    procedure RC21EditKeyPress(Sender: TObject; var Key: char);
    procedure RC22EditKeyPress(Sender: TObject; var Key: char);
    procedure ResetBtnClick(Sender: TObject);
    procedure RowInClick(Sender: TObject);
    procedure RowOutClick(Sender: TObject);
  private
    { private declarations }
    procedure FisherTable(A, b, C, d : integer; p, SumP : double);
  public
    { public declarations }
  end; 

var
  FisherFrm: TFisherFrm;

implementation

{ TFisherFrm }

procedure TFisherFrm.ResetBtnClick(Sender: TObject);
VAR i : integer;
begin
     VarList.Clear;
     RowEdit.Text := '';
     ColEdit.Text := '';
     DepEdit.Text := '';
     DepEdit.Visible := false;
     RowIn.Visible := true;
     RowOut.Visible := false;
     ColIn.Visible := false;
     ColOut.Visible := false;
     DepIn.Visible := false;
     DepOut.Visible := false;
     NCasesLabel.Visible := false;
     Label4.Visible := false;
     NCasesEdit.Text := '';
     NCasesEdit.Visible := false;
     for i := 1 to NoVariables do
         VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
     Panel1.Visible := false;
     Panel2.Visible := false;
     RC11Edit.Text := '';
     RC12Edit.Text := '';
     RC21Edit.Text := '';
     RC22Edit.Text := '';
end;

procedure TFisherFrm.RowInClick(Sender: TObject);
VAR index : integer;
begin
     index := VarList.ItemIndex;
     RowEdit.Text := VarList.Items.Strings[index];
     VarList.Items.Delete(index);
     RowIn.Visible := false;
     RowOut.Visible := true;
end;

procedure TFisherFrm.RowOutClick(Sender: TObject);
begin
     VarList.Items.Add(RowEdit.Text);
     RowEdit.Text := '';
     RowIn.Visible := true;
     RowOut.Visible := false;
end;

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

procedure TFisherFrm.ColInClick(Sender: TObject);
VAR index : integer;
begin
     index := VarList.ItemIndex;
     ColEdit.Text := VarList.Items.Strings[index];
     VarList.Items.Delete(index);
     ColIn.Visible := false;
     ColOut.Visible := true;
end;

procedure TFisherFrm.ColOutClick(Sender: TObject);
begin
     VarList.Items.Add(ColEdit.Text);
     ColEdit.Text := '';
     ColIn.Visible := true;
     ColOut.Visible := false;
end;

procedure TFisherFrm.ComputeBtnClick(Sender: TObject);
var
   i, j, row, col, caserow, casecol, A, b, C, d, Largest : integer;
   N, APlusB, APlusC, BPlusD, CPlusD, NoSelected, dep : integer;
   FirstP, p, SumProb, Tocher, Alpha, X : double;
   obs : array[1..2,1..2] of integer;
   ColNoSelected : IntDyneVec;
   done : boolean;
   cellstring, outline, response : string;
begin
    Randomize; // initialize random number generator
    row := 0;
    col := 0;
    dep := 0;

    // get column no.s of row and col variables
    if InputGrp.ItemIndex <> 3 then
    begin
         for i := 1 to NoVariables do
         begin
              cellstring := RowEdit.Text;
              if cellstring = OS3MainFrm.DataGrid.Cells[i,0] then row := i;
              cellstring := ColEdit.Text;
              if cellstring = OS3MainFrm.DataGrid.Cells[i,0] then col := i;
              if InputGrp.ItemIndex = 2 then
              begin
                   cellstring := DepEdit.Text;
                   if cellstring = OS3MainFrm.DataGrid.Cells[i,0] then dep := i;
              end;
         end;
    end;
    SetLength(ColNoSelected,3);
    ColNoSelected[0] := row;
    ColNoSelected[1] := col;
    if InputGrp.ItemIndex = 2 then
    begin
         ColNoSelected[2] := dep;
         NoSelected := 3;
    end
    else NoSelected := 2;

    //initialize observed matrix
    for i := 1 to 2 do
        for j := 1 to 2 do obs[i,j] := 0;

    if InputGrp.ItemIndex = 3 then // get freq. from form
    begin
         obs[1,1] := StrToInt(RC11Edit.Text);
         obs[1,2] := StrToInt(RC12Edit.Text);
         obs[2,1] := StrToInt(RC21Edit.Text);
         obs[2,2] := StrToInt(RC22Edit.Text);
    end;

    if InputGrp.ItemIndex = 0 then // count no. in row/col combinations
    begin
         for j := 1 to NoCases do
         begin
              if (not GoodRecord(j,NoSelected,ColNoSelected)) then continue;
              caserow := round(StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[row,j])));
              casecol := round(StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[col,j])));
              if (caserow > 2) or (caserow < 1) then
              begin
                   ShowMessage('ERROR! Row < 1 or > 2 found. Case ignored.');
                   continue;
              end;
              if (casecol > 2) or (casecol < 1) then
              begin
                   ShowMessage('ERROR! Column < 1 or > 2 found. Case ignored.');
                   continue;
              end;
              obs[caserow,casecol] := obs[caserow,casecol] + 1;
         end;
    end;

    if (InputGrp.ItemIndex = 1) or (InputGrp.ItemIndex = 2) then // Grid has frequencies for row/col
    begin
         for j := 1 to NoCases do
         begin
              if (not GoodRecord(j,NoSelected,ColNoSelected)) then continue;
              caserow := round(StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[row,j])));
              casecol := round(StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[col,j])));
              if (caserow > 2) or (caserow < 1) then
              begin
                   ShowMessage('ERROR! Row < 1 or > 2 found. Case ignored.');
                   continue;
              end;
              if (casecol > 2) or (casecol < 1) then
              begin
                   ShowMessage('ERROR! Column < 1 or > 2 found. Case ignored.');
                   continue;
              end;
              obs[caserow,casecol] := round(StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[dep,j])));
              if InputGrp.ItemIndex = 2 then
                 obs[caserow,casecol] := obs[caserow,casecol] *
                     StrToInt(NCasesEdit.Text);
         end;
    end;

    //Find smallest value
    A := obs[1,1];
    b := obs[1,2];
    C := obs[2,1];
    d := obs[2,2];
    APlusB := A + b;
    CPlusD := C + d;
    BPlusD := b + d;
    APlusC := A + C;
    N := A + b + C + d;
    Largest := 1;
    if (b > A) then largest := 2;
    if ((b > A) and (b > C) and (b > d)) then Largest := 2;
    if ((C > A) and (C > b) and (C > d)) then Largest := 3;
    if ((d > A) and (d > b) and (d > C)) then Largest := 4;

    //Ready output
    OutPutFrm.RichEdit.Clear;
    SumProb := 0.0;
    OutPutFrm.RichEdit.Lines.Add('Fisher Exact Probability Test');
    OutPutFrm.RichEdit.Lines.Add('');

    //Get first probability
    FirstP := combos(A, APlusC) * combos(b, BPlusD) / combos(APlusB, N);
    SumProb := SumProb + FirstP;
    FisherTable(A, b, C, d, FirstP, SumProb);

    //Get more extreme probabilities
    done := false;
    while (not done) do
    begin
        case Largest of
        1: begin// top row, first col
                if (A = APlusB) then done := true
                else begin
                     A := A + 1;
                     b := b - 1;
                     C := C - 1;
                     d := d + 1;
                end;
           end;
        2: begin// top row, second column
                if (b = APlusB) then done := true
                else begin
                     A := A - 1;
                     b := b + 1;
                     C := C + 1;
                     d := d - 1;
                end;
           end;
        3: begin // second row, first column
                if (C = CPlusD) then done := true
                else begin
                     A := A - 1;
                     b := b + 1;
                     C := C + 1;
                     d := d - 1;
                end;
           end;
        4: begin // second row, second column
                if (d = CPlusD) then done := true
                else begin
                     A := A + 1;
                     b := b - 1;
                     C := C - 1;
                     d := d + 1;
                end;
           end;
        end; // end case
        if (not done) then
        begin
            p := combos(A, APlusC) * combos(b, BPlusD) / combos(APlusB, N);
            SumProb := SumProb + p;
            FisherTable(A, b, C, d, p, SumProb);
        end;
    end;

    //Tocher's modification
    response :=
        InputBox( 'ALPHA','Enter your Alpha (Type I Error rate) : ', '0.05');
    Alpha := StrToFloat(response);
    if ((SumProb - FirstP) > Alpha) then //Extreme values > alpha - accept null hypothesis
        OutPutFrm.RichEdit.Lines.Add('Null hypothesis accepted.')
    else begin//Extreme values significant - is total probability significant?
        if (SumProb >= Alpha) then//No, so apply Tocher's rule
        begin
            Tocher := ( Alpha - (SumProb - FirstP)) / FirstP;
            X := random(1000) / 1000.0; //Select a random value between 0 and num - 1
            outline := format('Tocher ratio computed: %5.3f',[Tocher]);
            OutPutFrm.RichEdit.Lines.Add(outline);
            if (X < Tocher) then //Call it significant
            begin
                outline := format('A random value of %5.3f selected was less than the Tocher value.',[X]);
                OutPutFrm.RichEdit.Lines.Add(outline);
                OutPutFrm.RichEdit.Lines.Add('Conclusion: Reject the null Hypothesis');
            end
            else begin //Call it non-significant
                outline := format('A random value of %5.3f selected was greater than the Tocher value.',[X]);
                OutPutFrm.RichEdit.Lines.Add(outline);
                OutPutFrm.RichEdit.Lines.Add('Conclusion: Accept the null Hypothesis');
            end;
        end
        else begin //Total probability < alpha - reject null
            OutPutFrm.RichEdit.Lines.Add('Probability less than alpha - reject null hypothesis.');
        end; // end if-else
    end; // end if-else
    OutPutFrm.ShowModal;
end;

procedure TFisherFrm.DepInClick(Sender: TObject);
VAR index : integer;
begin
     index := VarList.ItemIndex;
     DepEdit.Text := VarList.Items.Strings[index];
     VarList.Items.Delete(index);
     DepIn.Visible := false;
     DepOut.Visible := true;
end;

procedure TFisherFrm.DepOutClick(Sender: TObject);
begin
     VarList.Items.Add(DepEdit.Text);
     DepEdit.Text := '';
     DepIn.Visible := true;
     DepOut.Visible := false;
end;

procedure TFisherFrm.InputGrpClick(Sender: TObject);
begin
     if InputGrp.ItemIndex = 3 then
     begin
          Panel2.Visible := true;
          Panel1.Visible := false;
          RC11Edit.SetFocus;
          Label4.Visible := false;
          ColIn.Visible := false;
          DepIn.Visible := false;
          DepOut.Visible := false;
     end
     else
     begin
          Panel1.Visible := true;
          Panel2.Visible := false;
          ColIn.Visible := true;
          ColOut.Visible := false;
          if InputGrp.ItemIndex = 2 then
          begin
               NCasesLabel.Visible := true;
               NCasesEdit.Visible := true;
          end
          else begin
               NCasesLabel.Visible := false;
               NCasesEdit.Visible := false;
          end;
          if InputGrp.ItemIndex = 0 then
          begin
               Label4.Visible := false;
               DepEdit.Visible := false;
               DepIn.Visible := false;
               DepOut.Visible := false;
          end
          else begin  // InputGrp = 1
               Label4.Visible := true;
               DepEdit.Visible := true;
               DepIn.Visible := true;
               DepOut.Visible := true;
          end;
     end;
end;

procedure TFisherFrm.RC11EditKeyPress(Sender: TObject; var Key: char);
begin
     if Ord(Key) = 13 then RC12Edit.SetFocus;
end;

procedure TFisherFrm.RC12EditKeyPress(Sender: TObject; var Key: char);
begin
     if Ord(Key) = 13 then RC21Edit.SetFocus;
end;

procedure TFisherFrm.RC21EditKeyPress(Sender: TObject; var Key: char);
begin
     if Ord(Key) = 13 then RC22Edit.SetFocus;
end;

procedure TFisherFrm.RC22EditKeyPress(Sender: TObject; var Key: char);
begin
     if Ord(Key) = 13 then ComputeBtn.SetFocus;
end;

procedure TFisherFrm.FisherTable(A, b, C, d : integer; p, SumP : double);
var
   outline : string;
begin
    OutPutFrm.RichEdit.Lines.Add('');
    OutPutFrm.RichEdit.Lines.Add('Contingency Table for Fisher Exact Test');
    OutPutFrm.RichEdit.Lines.Add('                 Column');
    OutPutFrm.RichEdit.Lines.Add('Row             1          2');
    outline := format(' 1     %10d %10d',[A, b]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    outline := format(' 2     %10d %10d',[C, d]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    outline := format('Probability := %6.4f',[p]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    OutPutFrm.RichEdit.Lines.Add('');
    outline := format('Cumulative Probability := %6.4f',[SumP]);
    OutPutFrm.RichEdit.Lines.Add(outline);
    OutPutFrm.RichEdit.Lines.Add('');
end;
initialization
  {$I exactunit.lrs}

end.