pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

LazStats: Refactor KWAnovaUnit

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7824 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2020-10-28 23:39:08 +00:00
parent a5b4c307a0
commit 3f1dd4c7cb
2 changed files with 278 additions and 196 deletions
Download Patch File Download Diff File Expand all files Collapse all files

48
applications/lazstats/source/forms/analysis/nonparametric/kwanovaunit.lfm
View File

@ -1,36 +1,36 @@
inherited KWAnovaForm: TKWAnovaForm
Left = 518
Height = 265
Height = 390
Top = 283
Width = 565
Width = 748
HelpType = htKeyword
HelpKeyword = 'html/Kruskal-WallisOne-WayANOVA.htm'
Caption = 'Kruskal-Wallis One Way ANOVA on Ranks'
ClientHeight = 265
ClientWidth = 565
ClientHeight = 390
ClientWidth = 748
inherited ParamsPanel: TPanel
Height = 249
Height = 374
Width = 363
ClientHeight = 249
ClientHeight = 374
ClientWidth = 363
inherited CloseBtn: TButton
Left = 308
Top = 224
Top = 349
end
inherited ComputeBtn: TButton
Left = 224
Top = 224
Top = 349
end
inherited ResetBtn: TButton
Left = 162
Top = 224
Top = 349
end
inherited HelpBtn: TButton
Left = 103
Top = 224
Top = 349
end
inherited ButtonBevel: TBevel
Top = 208
Top = 333
Width = 363
end
object Label1: TLabel[5]
@ -74,7 +74,7 @@ inherited KWAnovaForm: TKWAnovaForm
AnchorSideRight.Control = GrpIn
AnchorSideBottom.Control = OptionsGroup
Left = 0
Height = 130
Height = 255
Top = 17
Width = 160
Anchors = [akTop, akLeft, akRight, akBottom]
@ -218,7 +218,7 @@ inherited KWAnovaForm: TKWAnovaForm
AnchorSideBottom.Control = ButtonBevel
Left = 0
Height = 49
Top = 159
Top = 284
Width = 180
Anchors = [akLeft, akBottom]
AutoSize = True
@ -246,6 +246,26 @@ inherited KWAnovaForm: TKWAnovaForm
end
inherited ParamsSplitter: TSplitter
Left = 375
Height = 265
Height = 390
end
object PageControl: TPageControl[2]
Left = 384
Height = 374
Top = 8
Width = 356
ActivePage = KWAnovaPage
Align = alClient
BorderSpacing.Left = 4
BorderSpacing.Top = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
TabIndex = 0
TabOrder = 2
object KWAnovaPage: TTabSheet
Caption = 'Kruskal-Wallis One-Way ANOVA'
end
object MWUPage: TTabSheet
Caption = 'Mann-Whitney U Tests'
end
end
end

426
applications/lazstats/source/forms/analysis/nonparametric/kwanovaunit.pas
View File

@ -8,8 +8,8 @@ interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
StdCtrls, Buttons, ExtCtrls,
MainUnit, FunctionsLib, Globals, DataProcs, BasicStatsReportFormUnit;
StdCtrls, Buttons, ExtCtrls, ComCtrls,
MainUnit, FunctionsLib, Globals, ReportFrameUnit, BasicStatsReportFormUnit;
type
@ -29,6 +29,9 @@ type
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
PageControl: TPageControl;
KWAnovaPage: TTabSheet;
MWUPage: TTabSheet;
VarList: TListBox;
procedure DepInClick(Sender: TObject);
procedure DepOutClick(Sender: TObject);
@ -37,7 +40,11 @@ type
procedure VarListDblClick(Sender: TObject);
procedure VarListSelectionChange(Sender: TObject; {%H-}User: boolean);
private
MWUReportFrame: TReportFrame;
procedure Process_MannWhitney(const ColNoSelected: IntDyneVec;
ANumGroups: Integer);
protected
procedure AdjustConstraints; override;
procedure Compute; override;
@ -45,7 +52,8 @@ type
function Validate(out AMsg: String; out AControl: TWinControl): Boolean; override;
public
procedure Reset; override;
constructor Create(AOwner: TComponent); override;
procedure Reset; override;
end;
var
@ -63,6 +71,28 @@ uses
{ TKWAnovaForm }
constructor TKWAnovaForm.Create(AOwner: TComponent);
begin
inherited;
FReportFrame.Parent := KWAnovaPage;
FReportFrame.BorderSpacing.Left := 0;
FReportFrame.BorderSpacing.Top := 0;
FReportFrame.BorderSpacing.Bottom := 0;
FReportFrame.BorderSpacing.Right := 0;
MWUReportFrame := TReportFrame.Create(self);
MWUReportFrame.Name := '';
MWUReportFrame.Parent := MWUPage;
MWUReportFrame.Align := alClient;
MWUReportFrame.BorderSpacing.Left := 0;
MWUReportFrame.BorderSpacing.Top := 0;
MWUReportFrame.BorderSpacing.Bottom := 0;
MWUReportFrame.BorderSpacing.Right := 0;
InitToolbar(MWUReportFrame.ReportToolbar, tpRight);
PageControl.ActivePageIndex := 0;
end;
procedure TKWAnovaForm.AdjustConstraints;
begin
inherited;
@ -78,20 +108,16 @@ end;
procedure TKWAnovaForm.Compute;
var
i, j, k, m, ind_var, dep_var, min_grp, max_grp, group, total_n : integer;
NoTies, NoTieGroups, nogroups, NoSelected, npairs, n1, n2 : integer;
largestN : integer;
NoTies, NoTieGroups, nogroups: integer;
ColNoSelected : IntdyneVec = nil;
group_count : IntDyneVec = nil;
Ranks: DblDyneMat = nil;
X : DblDyneMat = nil;
RankSums: DblDyneVec = nil;
score, t, SumT, Avg, Probchi, H, CorrectedH, value : double;
Correction, Temp, TieSum, alpha, U, U2, SD, z, prob : double;
cellstring, outline: string;
Correction, TieSum: double;
lReport: TStrings;
begin
alpha := StrToFloat(AlphaEdit.Text);
// Allocate array memory
SetLength(Ranks, NoCases, 2);
SetLength(X, NoCases, 2);
@ -99,7 +125,6 @@ begin
// Get column numbers of the independent and dependent variables
ind_var := GetVariableIndex(OS3MainFrm.DataGrid, GrpEdit.Text);
dep_var := GetVariableIndex(OS3MainFrm.DataGrid, DepEdit.Text);
NoSelected := 2;
SetLength(ColNoSelected, 2);
ColNoSelected[0] := ind_var;
ColNoSelected[1] := dep_var;
@ -243,178 +268,14 @@ begin
lReport.Add('Statistic H corrected for ties: %8.4f', [CorrectedH]);
lReport.Add('Corrected H is approx. chi-square with %d degrees of freedom and probability %.4f', [k, ProbChi]);
if MWUChk.Checked then
begin
lReport.Add('');
lReport.Add('------------------------------------------------------------------------');
lReport.Add('');
FReportFrame.DisplayReport(lReport);
// Do Mann-Whitney U tests on group pairs
alpha := StrToFloat(AlphaEdit.Text);
npairs := nogroups * (nogroups - 1) div 2;
alpha := alpha / npairs;
lReport.Add('New alpha for %d paired comparisons: %.3f', [npairs, alpha]);
for i := 1 to nogroups - 1 do
begin
for j := i + 1 to nogroups do
begin
// Setup for printer output
lReport.Add('');
lReport.Add('');
lReport.Add('MANN-WHITNEY U TEST');
lReport.Add('See pages 116-127 in S. Siegel: Nonparametric Statistics for the Behavioral Sciences');
lReport.Add('');
lReport.Add('Comparison of group %d with group %d', [i, j]);
group_count[0] := 0;
group_count[1] := 0;
RankSums[0] := 0;
RankSums[1] := 0;
total_n := 0;
for k := 1 to NoCases do
begin
if (not GoodRecord(OS3MainFrm.DataGrid, k, ColNoSelected)) then continue;
score := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[dep_var, k]));
value := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[ind_var, k]));
if round(value) = i then
begin
X[total_n,0] := score;
X[total_n,1] := value;
group_count[0] := group_count[0] + 1;
total_n := total_n + 1;
end;
if round(value) = j then
begin
X[total_n,0] := score;
X[total_n,1] := value;
group_count[1] := group_count[1] + 1;
total_n := total_n + 1;
end;
end; // next case k
//Sort all scores in ascending order
for k := 1 to total_n - 1 do
begin
for m := k + 1 to total_n do
begin
if (X[k-1,0] > X[m-1,0]) then
begin
Temp := X[k-1,0];
X[k-1,0] := X[m-1,0];
X[m-1,0] := Temp;
Temp := X[k-1,1];
X[k-1,1] := X[m-1,1];
X[m-1,1] := Temp;
end;
end;
end;
// get ranks for these two groups
for k := 0 to total_n-1 do
begin
Ranks[k,0] := k+1;
Ranks[k,1] := X[k,1];
end;
//Check for ties in ranks - replace with average rank and calculate
//T for each tie and sum of the T's
NoTieGroups := 0;
k := 1;
while k < total_n do
begin
m := k + 1;
TieSum := 0;
NoTies := 0;
while (m < total_n) do
begin
if (X[m-1,0] > X[k-1,0]) then
Break;
if (X[m-1,0] = X[k-1,0]) then // match
begin
TieSum := TieSum + round(Ranks[m-1,0]);
NoTies := NoTies + 1;
end;
m := m + 1;
end;
if (NoTies > 0) then //At least one tie found
begin
TieSum := TieSum + Ranks[k-1,0];
NoTies := NoTies + 1;
Avg := TieSum / NoTies;
for m := k to k + NoTies - 1 do Ranks[m-1,0] := Avg;
t := Power(NoTies,3) - NoTies;
SumT := SumT + t;
NoTieGroups := NoTieGroups + 1;
k := k + (NoTies - 1);
end;
k := k + 1;
end; // next k
// Calculate sum of ranks in each group
for k := 1 to total_n do
begin
group := round(Ranks[k-1,1]);
RankSums[group-1] := RankSums[group-1] + Ranks[k-1,0];
end;
//Calculate U for larger and smaller groups
n1 := group_count[0];
n2 := group_count[1];
if (n1 > n2) then
begin
group := i-1;
U := (n1 * n2) + ((n1 * (n1 + 1)) / 2.0) - RankSums[group];
end
else
begin
group := j - 1;
U := (n1 * n2) + ((n2 * (n2 + 1)) / 2.0) - RankSums[group];
end;
U2 := (n1 * n2) - U;
SD := (n1 * n2 * (n1 + n2 + 1)) / 12.0;
SD := sqrt(SD);
if (U2 > U) then z := (U2 - (n1 * n2 / 2)) / SD
else z := (U - (n1 * n2 / 2)) / SD;
prob := 1.0 - probz(z);
// Report results
lReport.Add(' Score Rank Group');
lReport.Add('');
for k := 1 to total_n do
lReport.Add('%10.2f %10.2f %10.0f', [X[k-1,0], Ranks[k-1,0], Ranks[k-1,1]]);
lReport.Add('');
lReport.Add('Sum of Ranks in each Group');
lReport.Add('Group Sum No. in Group');
group := i - 1;
lReport.Add('%3d %10.3f %5d', [i, RankSums[group], group_count[0]]);
group := j - 1;
lReport.Add('%3d %10.3f %5d', [j, RankSums[group], group_count[1]]);
lReport.Add('');
lReport.Add( 'No. of tied rank groups: %8d', [NoTieGroups]);
if (n1 > n2) then largestN := n1 else largestN := n2;
if (largestN < 20) then
outline := Format( 'Statistic U: %8.4f',[U])
else
begin
if (U > U2) then
outline := Format('Statistic U: %8.4f',[U])
else
outline := Format('Statistic U: %8.4f',[U2]);
end;
lReport.Add(outline);
lReport.Add( 'z Statistic (corrected for ties): %8.4f', [z]);
lReport.Add( 'Prob. > z: %8.4f', [prob]);
if (n2 < 20) then
begin
lReport.Add('z test is approximate. Use tables of exact probabilities in Siegel.');
lReport.Add('(Table J or K, pages 271-277)');
end;
end; // next group j
end; // next group i
end;
if lReport.Count > 0 then
FReportFrame.DisplayReport(lReport);
if MWUChk.Checked then
begin
MWUPage.TabVisible := true;
Process_MannWhitney(ColNoSelected, NoGroups);
end else
MWUPage.TabVisible := false;
finally
lReport.Free;
@ -472,19 +333,220 @@ begin
end;
// Do Mann-Whitney U tests on group pairs
procedure TKWAnovaForm.Process_MannWhitney(const ColNoSelected: IntDyneVec;
ANumGroups: Integer);
var
alpha, score, value, tieSum, avg, T, sumT, U, U2, SD, z, prob: Double;
nPairs: Integer;
i, j, k, m: Integer;
totalN, depVar, IndVar, numTies, numTieGroups, group, n1, n2, largestN: Integer;
outline: String;
lReport: TStrings;
group_count: IntDyneVec = nil;
RankSums: DblDyneVec = nil;
X: DblDyneMat = nil;
Ranks: DblDyneMat = nil;
begin
SetLength(X, NoCases, 2);
SetLength(Ranks, NoCases, 2);
SetLength(group_count, 2);
SetLength(RankSums, ANumGroups);
numTieGroups := 0;
sumT := 0.0;
alpha := StrToFloat(AlphaEdit.Text);
nPairs := ANumGroups * (ANumGroups - 1) div 2;
alpha := alpha / nPairs;
indVar := ColNoSelected[0];
depVar := ColNoSelected[1];
lReport := TStringList.Create;
try
lReport.Add('New alpha for %d paired comparisons: %.3f', [nPairs, alpha]);
for i := 1 to ANumGroups - 1 do
begin
for j := i + 1 to ANumGroups do
begin
lReport.Add('');
lReport.Add('');
lReport.Add('MANN-WHITNEY U TEST');
lReport.Add('See pages 116-127 in S. Siegel: Nonparametric Statistics for the Behavioral Sciences');
lReport.Add('');
lReport.Add('Comparison of group %d with group %d', [i, j]);
group_count[0] := 0;
group_count[1] := 0;
RankSums[0] := 0;
RankSums[1] := 0;
totalN := 0;
for k := 1 to NoCases do
begin
if (not GoodRecord(OS3MainFrm.DataGrid, k, ColNoSelected)) then continue;
score := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[depVar, k]));
value := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[indVar, k]));
if round(value) = i then
begin
X[totalN, 0] := score;
X[totalN, 1] := value;
inc(group_count[0]);
inc(totalN);
end;
if round(value) = j then
begin
X[totalN, 0] := score;
X[totalN, 1] := value;
inc(group_count[1]);
inc(totalN);
end;
end; // next case k
// Sort all scores in ascending order
for k := 1 to totalN - 1 do
begin
for m := k + 1 to totalN do
begin
if (X[k-1, 0] > X[m-1, 0]) then
begin
Exchange(X[k-1, 0], X[m-1, 0]);
Exchange(X[k-1, 1], X[m-1, 1]);
end;
end;
end;
// Get ranks for these two groups
for k := 0 to totalN-1 do
begin
Ranks[k, 0] := k + 1;
Ranks[k, 1] := X[k, 1];
end;
// Check for ties in ranks - replace with average rank and calculate
// T for each tie and sum of the T's
numTieGroups := 0;
k := 1;
while k < totalN do
begin
m := k + 1;
tieSum := 0;
numTies := 0;
while (m < totalN) do
begin
if (X[m-1, 0] > X[k-1, 0]) then
Break;
if (X[m-1, 0] = X[k-1, 0]) then // match
begin
tieSum := tieSum + round(Ranks[m-1, 0]);
inc(numTies);
end;
inc(m);
end;
if (numTies > 0) then //At least one tie found
begin
tieSum := tieSum + Ranks[k-1, 0];
inc(numTies);
avg := tieSum / numTies;
for m := k to k + numTies - 1 do
Ranks[m-1,0] := avg;
T := numTies * numTies * numTies - numTies;
sumT := sumT + T;
inc(numTieGroups);
k := k + (numTies - 1);
end;
inc(k);
end; // next k
// Calculate sum of ranks in each group
for k := 0 to totalN-1 do
begin
group := round(Ranks[k, 1]);
RankSums[group-1] := RankSums[group-1] + Ranks[k, 0];
end;
// Calculate U for larger and smaller groups
n1 := group_count[0];
n2 := group_count[1];
if (n1 > n2) then
begin
group := i - 1;
U := (n1 * n2) + ((n1 * (n1 + 1)) / 2.0) - RankSums[group];
end else
begin
group := j - 1;
U := (n1 * n2) + ((n2 * (n2 + 1)) / 2.0) - RankSums[group];
end;
U2 := (n1 * n2) - U;
SD := (n1 * n2 * (n1 + n2 + 1)) / 12.0;
SD := sqrt(SD);
if (U2 > U) then
z := (U2 - (n1 * n2 / 2)) / SD
else
z := (U - (n1 * n2 / 2)) / SD;
prob := 1.0 - probz(z);
// Report results
lReport.Add(' Score Rank Group');
lReport.Add('');
for k := 1 to totalN do
lReport.Add('%10.2f %10.2f %10.0f', [X[k-1,0], Ranks[k-1,0], Ranks[k-1,1]]);
lReport.Add('');
lReport.Add('Sum of Ranks in each Group');
lReport.Add('Group Sum No. in Group');
group := i - 1;
lReport.Add('%3d %10.3f %5d', [i, RankSums[group], group_count[0]]);
group := j - 1;
lReport.Add('%3d %10.3f %5d', [j, RankSums[group], group_count[1]]);
lReport.Add('');
lReport.Add( 'No. of tied rank groups: %8d', [numTieGroups]);
if (n1 > n2) then
largestN := n1
else
largestN := n2;
if (largestN < 20) then
outline := Format( 'Statistic U: %8.4f',[U])
else
begin
if (U > U2) then
outline := Format('Statistic U: %8.4f',[U])
else
outline := Format('Statistic U: %8.4f',[U2]);
end;
lReport.Add(outline);
lReport.Add( 'z Statistic (corrected for ties): %8.4f', [z]);
lReport.Add( 'Prob. > z: %8.4f', [prob]);
if (n2 < 20) then
begin
lReport.Add('z test is approximate. Use tables of exact probabilities in Siegel.');
lReport.Add('(Table J or K, pages 271-277)');
end;
end; // next group j
end; // next group i
MWUReportFrame.DisplayReport(lReport);
finally
lReport.Free;
end;
end;
procedure TKWAnovaForm.Reset;
var
i: integer;
begin
inherited;
MWUPage.TabVisible := false;
GrpEdit.Clear;
DepEdit.Clear;
AlphaEdit.Text := FormatFloat('0.00', DEFAULT_ALPHA_LEVEL);
MWUChk.Checked := false;
VarList.Items.Clear;
for i := 1 to NoVariables do
VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i, 0]);
UpdateBtnStates;
end;