You've already forked lazarus-ccr
f000670847
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7822 8e941d3f-bd1b-0410-a28a-d453659cc2b4
575 lines
14 KiB
ObjectPascal
575 lines
14 KiB
ObjectPascal
unit ExactUnit;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
|
|
ExtCtrls, StdCtrls, Buttons,
|
|
MainUnit, FunctionsLib, Globals, BasicStatsReportFormUnit;
|
|
|
|
type
|
|
|
|
{ TFisherForm }
|
|
|
|
TFisherForm = class(TBasicStatsReportForm)
|
|
AlphaEdit: TEdit;
|
|
Label2: TLabel;
|
|
Label5: TLabel;
|
|
Notebook: TNotebook;
|
|
GridDataPage: TPage;
|
|
TableDataPage: TPage;
|
|
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;
|
|
RowLabel: TLabel;
|
|
ColLabel: TLabel;
|
|
DepLabel: TLabel;
|
|
VarList: TListBox;
|
|
procedure ColInClick(Sender: TObject);
|
|
procedure ColOutClick(Sender: TObject);
|
|
procedure DepInClick(Sender: TObject);
|
|
procedure DepOutClick(Sender: TObject);
|
|
procedure InputGrpClick(Sender: TObject);
|
|
procedure RowInClick(Sender: TObject);
|
|
procedure RowOutClick(Sender: TObject);
|
|
procedure VarListDblClick(Sender: TObject);
|
|
procedure VarListSelectionChange(Sender: TObject; {%H-}User: boolean);
|
|
|
|
private
|
|
procedure PrintFisherTable(AList: TStrings; A, B, C, D: integer; P, SumP: double);
|
|
|
|
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
|
|
FisherForm: TFisherForm;
|
|
|
|
|
|
implementation
|
|
|
|
{$R *.lfm}
|
|
|
|
uses
|
|
Utils, GridProcs;
|
|
|
|
|
|
{ TFisherForm }
|
|
|
|
procedure TFisherForm.AdjustConstraints;
|
|
begin
|
|
inherited;
|
|
ParamsPanel.Constraints.MinWidth := InputGrp.Width;
|
|
ParamsPanel.Constraints.MinHeight := InputGrp.Top + InputGrp.Height +
|
|
NCasesEdit.Top + NCasesEdit.Height +
|
|
Notebook.BorderSpacing.Bottom + AlphaEdit.Height +
|
|
ButtonBevel.Height + CloseBtn.BorderSpacing.Top + CloseBtn.Height;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.ColInClick(Sender: TObject);
|
|
var
|
|
index: integer;
|
|
begin
|
|
index := VarList.ItemIndex;
|
|
if (index > -1) and (ColEdit.Text = '') then
|
|
begin
|
|
ColEdit.Text := VarList.Items[index];
|
|
VarList.Items.Delete(index);
|
|
end;
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.ColOutClick(Sender: TObject);
|
|
begin
|
|
if ColEdit.Text <> '' then
|
|
begin
|
|
VarList.Items.Add(ColEdit.Text);
|
|
ColEdit.Text := '';
|
|
end;
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.Compute;
|
|
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 = nil;
|
|
done: boolean;
|
|
lReport: TStrings;
|
|
begin
|
|
Randomize; // initialize random number generator
|
|
|
|
// get column no.s of row and col variables
|
|
if InputGrp.ItemIndex <> 3 then
|
|
begin
|
|
row := GetVariableIndex(OS3MainFrm.DataGrid, RowEdit.Text);
|
|
col := GetVariableIndex(OS3MainFrm.DataGrid, ColEdit.Text);
|
|
if InputGrp.ItemIndex = 2 then
|
|
dep := GetVariableIndex(OS3MainFrm.DataGrid, DepEdit.Text);
|
|
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;
|
|
SetLength(ColNoSelected, noSelected);
|
|
|
|
// Initialize observed matrix
|
|
for i := 1 to 2 do
|
|
for j := 1 to 2 do obs[i, j] := 0;
|
|
|
|
// Count no. in row/col combinations
|
|
if InputGrp.ItemIndex = 0 then
|
|
begin
|
|
for j := 1 to NoCases do
|
|
begin
|
|
if (not GoodRecord(OS3MainFrm.DataGrid, j, 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
|
|
ErrorMsg('Row < 1 or > 2 found. Case ignored.');
|
|
continue;
|
|
end;
|
|
if (caseCol > 2) or (caseCol < 1) then
|
|
begin
|
|
ErrorMsg('Column < 1 or > 2 found. Case ignored.');
|
|
continue;
|
|
end;
|
|
obs[caseRow, caseCol] := obs[caseRow, caseCol] + 1;
|
|
end;
|
|
end;
|
|
|
|
// Grid has frequencies for row/col
|
|
if (InputGrp.ItemIndex = 1) or (InputGrp.ItemIndex = 2) then
|
|
begin
|
|
for j := 1 to NoCases do
|
|
begin
|
|
if (not GoodRecord(OS3MainFrm.DataGrid, j, 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
|
|
ErrorMsg('Row < 1 or > 2 found. Case ignored.');
|
|
continue;
|
|
end;
|
|
if (caseCol > 2) or (caseCol < 1) then
|
|
begin
|
|
ErrorMsg('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;
|
|
|
|
// Get freq. from form
|
|
if InputGrp.ItemIndex = 3 then
|
|
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;
|
|
|
|
//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 for output
|
|
lReport := TStringList.Create;
|
|
try
|
|
lReport.Add('FISHER EXACT PROBABILITY TEST');
|
|
lReport.Add('');
|
|
|
|
//Get first probability
|
|
FirstP := combos(A, APlusC) * combos(B, BPlusD) / combos(APlusB, N);
|
|
SumProb := FirstP;
|
|
PrintFisherTable(lReport, A, B, C, D, FirstP, SumProb);
|
|
lReport.Add('');
|
|
|
|
//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
|
|
inc(A);
|
|
dec(B);
|
|
dec(C);
|
|
inc(D);
|
|
end;
|
|
end;
|
|
2: begin// top row, second column
|
|
if (B = APlusB) then
|
|
done := true
|
|
else
|
|
begin
|
|
dec(A);
|
|
inc(B);
|
|
inc(C);
|
|
dec(D);
|
|
end;
|
|
end;
|
|
3: begin // second row, first column
|
|
if (C = CPlusD) then
|
|
done := true
|
|
else
|
|
begin
|
|
dec(A);
|
|
inc(B);
|
|
inc(C);
|
|
dec(D);
|
|
end;
|
|
end;
|
|
4: begin // second row, second column
|
|
if (D = CPlusD) then
|
|
done := true
|
|
else
|
|
begin
|
|
inc(A);
|
|
dec(B);
|
|
dec(C);
|
|
inc(D);
|
|
end;
|
|
end;
|
|
end; // end case
|
|
|
|
if (not done) then
|
|
begin
|
|
p := combos(A, APlusC) * combos(b, BPlusD) / combos(APlusB, N);
|
|
SumProb := SumProb + p;
|
|
PrintFisherTable(lReport, A, B, C, D, p, SumProb);
|
|
lReport.Add('');
|
|
end;
|
|
end;
|
|
|
|
//Tocher's modification
|
|
alpha := StrToFloat(AlphaEdit.Text);
|
|
|
|
// Extreme values > alpha - accept null hypothesis
|
|
if ((sumProb - FirstP) > alpha) then
|
|
lReport.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 // wp: why not simply X := random()
|
|
lReport.Add('Tocher ratio computed: %5.3f', [Tocher]);
|
|
if (X < Tocher) then //Call it significant
|
|
begin
|
|
lReport.Add('A random value of %5.3f selected was less than the Tocher value.', [X]);
|
|
lReport.Add('');
|
|
lReport.Add('Conclusion: Reject the null Hypothesis');
|
|
end else
|
|
begin //Call it non-significant
|
|
lReport.Add('A random value of %5.3f selected was greater than the Tocher value.', [X]);
|
|
lReport.Add('');
|
|
lReport.Add('Conclusion: Accept the null Hypothesis');
|
|
end;
|
|
end else
|
|
begin //Total probability < alpha - reject null
|
|
lReport.Add('Probability less than alpha - reject null hypothesis.');
|
|
end; // end if-else
|
|
end; // end if-else
|
|
|
|
FReportFrame.DisplayReport(lReport);
|
|
|
|
finally
|
|
lReport.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.DepInClick(Sender: TObject);
|
|
var
|
|
index: integer;
|
|
begin
|
|
index := VarList.ItemIndex;
|
|
if (index > -1) and (DepEdit.Text = '') then
|
|
begin
|
|
DepEdit.Text := VarList.Items[index];
|
|
VarList.Items.Delete(index);
|
|
end;
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.DepOutClick(Sender: TObject);
|
|
begin
|
|
if DepEdit.Text <> '' then
|
|
begin
|
|
VarList.Items.Add(DepEdit.Text);
|
|
DepEdit.Text := '';
|
|
end;
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.InputGrpClick(Sender: TObject);
|
|
begin
|
|
if InputGrp.ItemIndex = 3 then
|
|
begin
|
|
Notebook.PageIndex := 1;
|
|
// Panel2.Visible := true;
|
|
// Panel1.Visible := false;
|
|
//RC11Edit.SetFocus; // <!!!!!!!!!!!!!!!!!!!!!!!!!!!! Fix me
|
|
end else
|
|
begin
|
|
Notebook.PageIndex := 0;
|
|
// Panel1.Visible := true;
|
|
// Panel2.Visible := false;
|
|
ColIn.Enabled := true;
|
|
ColOut.Enabled := 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
|
|
DepLabel.Visible := false;
|
|
DepEdit.Visible := false;
|
|
DepIn.Visible := false;
|
|
DepOut.Visible := false;
|
|
end
|
|
else begin // InputGrp = 1
|
|
DepLabel.Visible := true;
|
|
DepEdit.Visible := true;
|
|
DepIn.Visible := true;
|
|
DepOut.Visible := true;
|
|
DepIn.Enabled := true;
|
|
DepOut.Enabled := false;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.PrintFisherTable(AList: TStrings;
|
|
A, B, C, D: integer; P, SumP: double);
|
|
begin
|
|
AList.Add('Contingency Table for Fisher Exact Test');
|
|
AList.Add(' Column');
|
|
AList.Add('Row 1 2');
|
|
AList.Add(' 1 %10d %10d', [A, B]);
|
|
AList.Add(' 2 %10d %10d', [C, D]);
|
|
AList.Add('');
|
|
AList.Add('Probability: %8.4f', [P]);
|
|
AList.Add('Cumulative Probability: %8.4f', [SumP]);
|
|
AList.Add('');
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.Reset;
|
|
var
|
|
i: integer;
|
|
begin
|
|
inherited;
|
|
|
|
Notebook.PageIndex := -1;
|
|
VarList.Clear;
|
|
for i := 1 to NoVariables do
|
|
VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
|
|
|
|
RowEdit.Clear;
|
|
ColEdit.Clear;
|
|
DepEdit.Clear;
|
|
DepEdit.Visible := false;
|
|
DepIn.Visible := false;
|
|
DepOut.Visible := false;
|
|
DepLabel.Visible := false;
|
|
NCasesLabel.Visible := false;
|
|
NCasesEdit.Clear;
|
|
NCasesEdit.Visible := false;
|
|
RC11Edit.Clear;
|
|
RC12Edit.Clear;
|
|
RC21Edit.Clear;
|
|
RC22Edit.Clear;
|
|
|
|
AlphaEdit.Text := FormatFloat('0.00', DEFAULT_ALPHA_LEVEL);
|
|
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.RowInClick(Sender: TObject);
|
|
var
|
|
index: integer;
|
|
begin
|
|
index := VarList.ItemIndex;
|
|
if (index > -1) and (RowEdit.Text = '') then
|
|
begin
|
|
RowEdit.Text := VarList.Items[index];
|
|
VarList.Items.Delete(index);
|
|
end;
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.RowOutClick(Sender: TObject);
|
|
begin
|
|
if RowEdit.Text <> '' then
|
|
begin
|
|
VarList.Items.Add(RowEdit.Text);
|
|
RowEdit.Text := '';
|
|
end;
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
function TFisherForm.Validate(out AMsg: String; out AControl: TWinControl): boolean;
|
|
var
|
|
x: Double;
|
|
n: Integer;
|
|
begin
|
|
Result := false;
|
|
|
|
if InputGrp.ItemIndex = 3 then
|
|
begin
|
|
if (RC11Edit.Text = '') or not TryStrToInt(RC11Edit.Text, n) then
|
|
begin
|
|
AControl := RC11Edit;
|
|
AMsg := 'No valid input.';
|
|
exit;
|
|
end;
|
|
if (RC12Edit.Text = '') or not TryStrToInt(RC12Edit.Text, n) then
|
|
begin
|
|
AControl := RC12Edit;
|
|
AMsg := 'No valid input';
|
|
exit;
|
|
end;
|
|
if (RC21Edit.Text = '') or not TryStrToInt(RC21Edit.Text, n) then
|
|
begin
|
|
AControl := RC21Edit;
|
|
AMsg := 'No valid input.';
|
|
exit;
|
|
end;
|
|
if (RC22Edit.Text = '') or not TryStrToInt(RC22Edit.Text, n) then
|
|
begin
|
|
AControl := RC22Edit;
|
|
AMsg := 'No valid input';
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
if AlphaEdit.Text = '' then
|
|
begin
|
|
AMsg := 'Input required.';
|
|
AControl := AlphaEdit;
|
|
exit;
|
|
end;
|
|
|
|
if not TryStrToFloat(AlphaEdit.Text, x) or (x < 0) or (x > 1) then
|
|
begin
|
|
AMsg := 'Numerical value between 0 and 1 required.';
|
|
AControl := AlphaEdit;
|
|
exit;
|
|
end;
|
|
|
|
Result := true;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.VarListDblClick(Sender: TObject);
|
|
var
|
|
index: Integer;
|
|
s: String;
|
|
begin
|
|
index := VarList.ItemIndex;
|
|
if index > -1 then
|
|
begin
|
|
s := VarList.Items[index];
|
|
if RowEdit.Text = '' then
|
|
RowEdit.Text := s
|
|
else if ColEdit.Text = '' then
|
|
ColEdit.Text := s
|
|
else if (DepEdit.Text = '') and (InputGrp.ItemIndex in [1, 2]) then
|
|
DepEdit.Text := s;
|
|
VarList.Items.Delete(index);
|
|
UpdateBtnStates;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.VarListSelectionChange(Sender: TObject; User: boolean);
|
|
begin
|
|
UpdateBtnStates;
|
|
end;
|
|
|
|
|
|
procedure TFisherForm.UpdateBtnStates;
|
|
begin
|
|
inherited;
|
|
|
|
RowIn.Enabled := VarList.ItemIndex > -1;
|
|
ColIn.Enabled := VarList.ItemIndex > -1;
|
|
DepIn.Enabled := VarList.ItemIndex > -1;
|
|
RowOut.Enabled := RowEdit.Text <> '';
|
|
ColOut.Enabled := ColEdit.Text <> '';
|
|
DepOut.Enabled := DepEdit.Text <> '';
|
|
end;
|
|
|
|
|
|
end.
|
|
|