You've already forked lazarus-ccr
457 lines
14 KiB
Plaintext
457 lines
14 KiB
Plaintext
|
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.
|
||
|
|
|