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

LazStats: Refactor KMeansUnit.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7371 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2020-04-11 15:08:50 +00:00
parent 3f97dee397
commit 29bfc99530
3 changed files with 496 additions and 507 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
applications/lazstats/docs/HelpNDoc/LazStats.hnd
View File

Binary file not shown.

95
applications/lazstats/source/forms/analysis/multivariate/kmeansunit.lfm
View File

@ -2,21 +2,21 @@ object KMeansFrm: TKMeansFrm
Left = 664 Left = 664
Height = 349 Height = 349
Top = 318 Top = 318
Width = 407 Width = 422
AutoSize = True AutoSize = True
Caption = 'k Means Clustering ' Caption = 'k Means Clustering '
ClientHeight = 349 ClientHeight = 349
ClientWidth = 407 ClientWidth = 422
OnActivate = FormActivate OnActivate = FormActivate
OnCreate = FormCreate OnCreate = FormCreate
OnShow = FormShow OnShow = FormShow
Position = poMainFormCenter Position = poMainFormCenter
LCLVersion = '2.1.0.0' LCLVersion = '2.1.0.0'
object ResetBtn: TButton object ResetBtn: TButton
AnchorSideRight.Control = CancelBtn AnchorSideRight.Control = ComputeBtn
AnchorSideBottom.Control = Owner AnchorSideBottom.Control = Owner
AnchorSideBottom.Side = asrBottom AnchorSideBottom.Side = asrBottom
Left = 106 Left = 201
Height = 25 Height = 25
Top = 316 Top = 316
Width = 54 Width = 54
@ -30,29 +30,11 @@ object KMeansFrm: TKMeansFrm
OnClick = ResetBtnClick OnClick = ResetBtnClick
TabOrder = 3 TabOrder = 3
end end
object CancelBtn: TButton
AnchorSideRight.Control = ComputeBtn
AnchorSideBottom.Control = Owner
AnchorSideBottom.Side = asrBottom
Left = 172
Height = 25
Top = 316
Width = 62
Anchors = [akRight, akBottom]
AutoSize = True
BorderSpacing.Left = 12
BorderSpacing.Top = 8
BorderSpacing.Right = 12
BorderSpacing.Bottom = 8
Caption = 'Cancel'
ModalResult = 2
TabOrder = 4
end
object ComputeBtn: TButton object ComputeBtn: TButton
AnchorSideRight.Control = ReturnBtn AnchorSideRight.Control = CloseBtn
AnchorSideBottom.Control = Owner AnchorSideBottom.Control = Owner
AnchorSideBottom.Side = asrBottom AnchorSideBottom.Side = asrBottom
Left = 246 Left = 267
Height = 25 Height = 25
Top = 316 Top = 316
Width = 76 Width = 76
@ -64,33 +46,33 @@ object KMeansFrm: TKMeansFrm
BorderSpacing.Bottom = 8 BorderSpacing.Bottom = 8
Caption = 'Compute' Caption = 'Compute'
OnClick = ComputeBtnClick OnClick = ComputeBtnClick
TabOrder = 5 TabOrder = 4
end end
object ReturnBtn: TButton object CloseBtn: TButton
AnchorSideRight.Control = Owner AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = Owner AnchorSideBottom.Control = Owner
AnchorSideBottom.Side = asrBottom AnchorSideBottom.Side = asrBottom
Left = 334 Left = 355
Height = 25 Height = 25
Top = 316 Top = 316
Width = 61 Width = 55
Anchors = [akRight, akBottom] Anchors = [akRight, akBottom]
AutoSize = True AutoSize = True
BorderSpacing.Left = 12 BorderSpacing.Left = 12
BorderSpacing.Top = 8 BorderSpacing.Top = 8
BorderSpacing.Right = 12 BorderSpacing.Right = 12
BorderSpacing.Bottom = 8 BorderSpacing.Bottom = 8
Caption = 'Return' Caption = 'Close'
ModalResult = 1 ModalResult = 11
TabOrder = 6 TabOrder = 5
end end
object HelpBtn: TButton object HelpBtn: TButton
Tag = 129 Tag = 129
AnchorSideRight.Control = ResetBtn AnchorSideRight.Control = ResetBtn
AnchorSideBottom.Control = Owner AnchorSideBottom.Control = Owner
AnchorSideBottom.Side = asrBottom AnchorSideBottom.Side = asrBottom
Left = 43 Left = 138
Height = 25 Height = 25
Top = 316 Top = 316
Width = 51 Width = 51
@ -108,11 +90,11 @@ object KMeansFrm: TKMeansFrm
AnchorSideLeft.Control = Owner AnchorSideLeft.Control = Owner
AnchorSideRight.Control = Owner AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = ReturnBtn AnchorSideBottom.Control = CloseBtn
Left = 0 Left = 0
Height = 8 Height = 8
Top = 300 Top = 300
Width = 407 Width = 422
Anchors = [akLeft, akRight, akBottom] Anchors = [akLeft, akRight, akBottom]
Shape = bsBottomLine Shape = bsBottomLine
end end
@ -121,16 +103,17 @@ object KMeansFrm: TKMeansFrm
AnchorSideTop.Control = Owner AnchorSideTop.Control = Owner
AnchorSideRight.Control = Owner AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = Bevel1
Left = 0 Left = 0
Height = 101 Height = 101
Top = 0 Top = 199
Width = 407 Width = 422
Anchors = [akTop, akLeft, akRight] Anchors = [akLeft, akRight, akBottom]
AutoSize = True AutoSize = True
BevelOuter = bvNone BevelOuter = bvNone
ClientHeight = 101 ClientHeight = 101
ClientWidth = 407 ClientWidth = 422
TabOrder = 0 TabOrder = 1
object Label1: TLabel object Label1: TLabel
AnchorSideLeft.Control = Panel1 AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = NoClustersEdit AnchorSideTop.Control = NoClustersEdit
@ -235,22 +218,21 @@ object KMeansFrm: TKMeansFrm
end end
object Panel2: TPanel object Panel2: TPanel
AnchorSideLeft.Control = Owner AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Panel1 AnchorSideTop.Control = Owner
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = Bevel1 AnchorSideBottom.Control = Panel1
Left = 0 Left = 0
Height = 191 Height = 191
Top = 109 Top = 8
Width = 407 Width = 422
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
AutoSize = True AutoSize = True
BorderSpacing.Top = 8 BorderSpacing.Top = 8
BevelOuter = bvNone BevelOuter = bvNone
ClientHeight = 191 ClientHeight = 191
ClientWidth = 407 ClientWidth = 422
TabOrder = 1 TabOrder = 0
object Label3: TLabel object Label3: TLabel
AnchorSideLeft.Control = Panel2 AnchorSideLeft.Control = Panel2
AnchorSideTop.Control = Panel2 AnchorSideTop.Control = Panel2
@ -272,20 +254,21 @@ object KMeansFrm: TKMeansFrm
Left = 8 Left = 8
Height = 173 Height = 173
Top = 18 Top = 18
Width = 164 Width = 172
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Left = 8 BorderSpacing.Left = 8
BorderSpacing.Top = 3 BorderSpacing.Top = 3
BorderSpacing.Right = 8 BorderSpacing.Right = 8
ItemHeight = 0 ItemHeight = 0
MultiSelect = True MultiSelect = True
OnSelectionChange = VarListSelectionChange
TabOrder = 0 TabOrder = 0
end end
object VarInBtn: TBitBtn object VarInBtn: TBitBtn
AnchorSideLeft.Control = Panel2 AnchorSideLeft.Control = Panel2
AnchorSideLeft.Side = asrCenter AnchorSideLeft.Side = asrCenter
AnchorSideTop.Control = VarList AnchorSideTop.Control = VarList
Left = 189 Left = 197
Height = 28 Height = 28
Top = 18 Top = 18
Width = 28 Width = 28
@ -334,7 +317,7 @@ object KMeansFrm: TKMeansFrm
AnchorSideLeft.Side = asrCenter AnchorSideLeft.Side = asrCenter
AnchorSideTop.Control = VarInBtn AnchorSideTop.Control = VarInBtn
AnchorSideTop.Side = asrBottom AnchorSideTop.Side = asrBottom
Left = 189 Left = 197
Height = 28 Height = 28
Top = 50 Top = 50
Width = 28 Width = 28
@ -384,7 +367,7 @@ object KMeansFrm: TKMeansFrm
AnchorSideLeft.Side = asrCenter AnchorSideLeft.Side = asrCenter
AnchorSideTop.Control = VarOutBtn AnchorSideTop.Control = VarOutBtn
AnchorSideTop.Side = asrBottom AnchorSideTop.Side = asrBottom
Left = 180 Left = 188
Height = 25 Height = 25
Top = 102 Top = 102
Width = 46 Width = 46
@ -395,7 +378,7 @@ object KMeansFrm: TKMeansFrm
Spacing = 0 Spacing = 0
TabOrder = 3 TabOrder = 3
end end
object ListBox1: TListBox object SelList: TListBox
AnchorSideLeft.Control = AllBtn AnchorSideLeft.Control = AllBtn
AnchorSideLeft.Side = asrBottom AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Label4 AnchorSideTop.Control = Label4
@ -404,21 +387,23 @@ object KMeansFrm: TKMeansFrm
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = Panel2 AnchorSideBottom.Control = Panel2
AnchorSideBottom.Side = asrBottom AnchorSideBottom.Side = asrBottom
Left = 234 Left = 242
Height = 173 Height = 173
Top = 18 Top = 18
Width = 165 Width = 172
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Left = 8 BorderSpacing.Left = 8
BorderSpacing.Top = 3 BorderSpacing.Top = 3
BorderSpacing.Right = 8 BorderSpacing.Right = 8
ItemHeight = 0 ItemHeight = 0
MultiSelect = True
OnSelectionChange = VarListSelectionChange
TabOrder = 4 TabOrder = 4
end end
object Label4: TLabel object Label4: TLabel
AnchorSideLeft.Control = ListBox1 AnchorSideLeft.Control = SelList
AnchorSideTop.Control = Panel2 AnchorSideTop.Control = Panel2
Left = 234 Left = 242
Height = 15 Height = 15
Top = 0 Top = 0
Width = 93 Width = 93

298
applications/lazstats/source/forms/analysis/multivariate/kmeansunit.pas
View File

@ -1,3 +1,6 @@
// File for testing: cansas.laz, all variables
// In the help file example No of Desired Clusters is 4
unit KMeansUnit; unit KMeansUnit;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
@ -23,9 +26,8 @@ type
VarOutBtn: TBitBtn; VarOutBtn: TBitBtn;
AllBtn: TBitBtn; AllBtn: TBitBtn;
ResetBtn: TButton; ResetBtn: TButton;
CancelBtn: TButton;
ComputeBtn: TButton; ComputeBtn: TButton;
ReturnBtn: TButton; CloseBtn: TButton;
StdChkBox: TCheckBox; StdChkBox: TCheckBox;
RepChkBox: TCheckBox; RepChkBox: TCheckBox;
GroupBox1: TGroupBox; GroupBox1: TGroupBox;
@ -33,7 +35,7 @@ type
Label2: TLabel; Label2: TLabel;
Label3: TLabel; Label3: TLabel;
Label4: TLabel; Label4: TLabel;
ListBox1: TListBox; SelList: TListBox;
VarList: TListBox; VarList: TListBox;
NoClustersEdit: TEdit; NoClustersEdit: TEdit;
Label1: TLabel; Label1: TLabel;
@ -45,6 +47,7 @@ type
procedure HelpBtnClick(Sender: TObject); procedure HelpBtnClick(Sender: TObject);
procedure ResetBtnClick(Sender: TObject); procedure ResetBtnClick(Sender: TObject);
procedure VarInBtnClick(Sender: TObject); procedure VarInBtnClick(Sender: TObject);
procedure VarListSelectionChange(Sender: TObject; User: boolean);
procedure VarOutBtnClick(Sender: TObject); procedure VarOutBtnClick(Sender: TObject);
private private
{ private declarations } { private declarations }
@ -70,6 +73,7 @@ type
VAR AN2 : DblDyneVec; VAR NCP : IntDyneVec; VAR AN2 : DblDyneVec; VAR NCP : IntDyneVec;
VAR D : DblDyneVec; VAR ITRAN : IntDyneVec; VAR D : DblDyneVec; VAR ITRAN : IntDyneVec;
INDX : integer); INDX : integer);
procedure UpdateBtnStates;
public public
{ public declarations } { public declarations }
@ -81,68 +85,65 @@ var
implementation implementation
uses uses
Math; Math, Utils;
{ TKMeansFrm } { TKMeansFrm }
procedure TKMeansFrm.ResetBtnClick(Sender: TObject); procedure TKMeansFrm.ResetBtnClick(Sender: TObject);
VAR cellstring : string; var
i: integer; i: integer;
begin begin
VarList.Clear; VarList.Clear;
ListBox1.Clear; SelList.Clear;
for i := 1 to NoVariables do for i := 1 to NoVariables do
begin VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
cellstring := OS3MainFrm.DataGrid.Cells[i,0];
VarList.Items.Add(cellstring);
end;
RepChkBox.Checked := false; RepChkBox.Checked := false;
StdChkBox.Checked := true; StdChkBox.Checked := true;
VarOutBtn.Enabled := false;
DescChkBox.Checked := false; DescChkBox.Checked := false;
NoClustersEdit.Text := ''; NoClustersEdit.Text := '';
ItersEdit.Text := '100'; ItersEdit.Text := '100';
UpdateBtnStates;
end; end;
procedure TKMeansFrm.VarInBtnClick(Sender: TObject); procedure TKMeansFrm.VarInBtnClick(Sender: TObject);
VAR var
index, count, i : integer; i: integer;
cellstring : string;
begin begin
count := 0; i := 0;
index := ListBox1.Items.Count; while i < VarList.Items.Count do
for i := 0 to index - 1 do
begin begin
if (VarList.Selected[i]) then if VarList.Selected[i] then
begin begin
cellstring := VarList.Items.strings[i]; SelList.Items.Add(VarList.Items[i]);
ListBox1.Items.Add(cellstring); VarList.Items.Delete(i);
count := count + 1; i := 0;
end else
i := i + 1;
end; end;
UpdateBtnStates;
end; end;
while (count > 0) do procedure TKMeansFrm.VarListSelectionChange(Sender: TObject; User: boolean);
begin begin
for i := 0 to VarList.Items.Count - 1 do UpdateBtnStates;
begin
if (VarList.Selected[i]) then
begin
VarList.Items.Delete(i);
count := count - 1;
end;
end;
end;
VarOutBtn.Enabled := true;
end; end;
procedure TKMeansFrm.VarOutBtnClick(Sender: TObject); procedure TKMeansFrm.VarOutBtnClick(Sender: TObject);
VAR index : integer; var
cellstring : string; i: integer;
begin begin
index := ListBox1.ItemIndex; i := 0;
cellstring := ListBox1.Items.Strings[index]; while i < SelList.Items.Count do
VarList.Items.Add(cellstring); begin
ListBox1.Items.Delete(index); if SelList.Selected[i] then
begin
VarList.Items.Add(SelList.Items[i]);
SelList.Items.Delete(i);
i := 0;
end else
i := i + 1;
end;
UpdateBtnStates;
end; end;
procedure TKMeansFrm.FormActivate(Sender: TObject); procedure TKMeansFrm.FormActivate(Sender: TObject);
@ -152,12 +153,11 @@ begin
if FAutoSized then if FAutoSized then
exit; exit;
w := MaxValue([HelpBtn.Width, ResetBtn.Width, CancelBtn.Width, ComputeBtn.Width, ReturnBtn.Width]); w := MaxValue([HelpBtn.Width, ResetBtn.Width, ComputeBtn.Width, CloseBtn.Width]);
HelpBtn.Constraints.MinWidth := w; HelpBtn.Constraints.MinWidth := w;
ResetBtn.Constraints.MinWidth := w; ResetBtn.Constraints.MinWidth := w;
CancelBtn.Constraints.MinWidth := w;
ComputeBtn.Constraints.MinWidth := w; ComputeBtn.Constraints.MinWidth := w;
ReturnBtn.Constraints.MinWidth := w; CloseBtn.Constraints.MinWidth := w;
Constraints.MinWidth := Width; Constraints.MinWidth := Width;
Constraints.MinHeight := Height; Constraints.MinHeight := Height;
@ -168,8 +168,6 @@ end;
procedure TKMeansFrm.FormCreate(Sender: TObject); procedure TKMeansFrm.FormCreate(Sender: TObject);
begin begin
Assert(OS3MainFrm <> nil); Assert(OS3MainFrm <> nil);
if OutputFrm = nil then
Application.CreateForm(TOutputFrm, OutputFrm);
end; end;
procedure TKMeansFrm.FormShow(Sender: TObject); procedure TKMeansFrm.FormShow(Sender: TObject);
@ -185,47 +183,68 @@ begin
end; end;
procedure TKMeansFrm.AllBtnClick(Sender: TObject); procedure TKMeansFrm.AllBtnClick(Sender: TObject);
VAR var
index, noitems : integer; index: integer;
cellstring: string; cellstring: string;
begin begin
noitems := VarList.Items.Count; for index := 0 to VarList.Items.Count - 1 do
for index := 0 to noitems - 1 do
begin begin
cellstring := VarList.Items.Strings[index]; cellstring := VarList.Items[index];
ListBox1.Items.Add(cellstring); SelList.Items.Add(cellstring);
end; end;
VarList.Clear; VarList.Clear;
VarOutBtn.Enabled := true; UpdateBtnStates;
end; end;
procedure TKMeansFrm.ComputeBtnClick(Sender: TObject); procedure TKMeansFrm.ComputeBtnClick(Sender: TObject);
VAR VAR
i, j, L, Ncols, N, M, K,IFAULT, ITER, col : integer; i, j, L, Ncols, N, M, K,IFAULT, ITER, col : integer;
center, itemp : integer; center: integer;
IC1, IC2, NC, NCP, ITRAN, LIVE, ColSelected : IntDyneVec; IC1, IC2, NC, NCP, ITRAN, LIVE, ColSelected : IntDyneVec;
A, C : DblDyneMat; A, C : DblDyneMat;
D, AN1, AN2, WSS, DT : DblDyneVec; D, AN1, AN2, WSS: DblDyneVec;
cellstring: string; cellstring: string;
outline : string; outline : string;
strval : string;
varlabels, rowlabels : StrDyneVec; varlabels, rowlabels : StrDyneVec;
Mean, stddev : double; Mean, stddev : double;
label cleanup; lReport: TStrings;
begin begin
Ncols := ListBox1.Items.Count; Ncols := SelList.Items.Count;
if (Ncols <= 0) then if (Ncols <= 0) then
begin begin
ShowMessage('ERROR! No variables selected to cluster.'); MessageDlg('No variables selected to cluster.', mtError, [mbOK], 0);
exit;
end;
if NoClustersEdit.Text = '' then
begin
NoClustersEdit.SetFocus;
MessageDlg('You must enter the desired number of clusters.', mtError, [mbOK], 0);
exit;
end;
if not TryStrToInt(NoClustersEdit.Text, K) or (K <= 0) then
begin
NoClustersEdit.SetFocus;
MessageDlg('You must enter the desired number of clusters as a positive value.', mtError, [mbOK], 0);
exit;
end;
if ItersEdit.Text = '' then
begin
ItersEdit.SetFocus;
MessageDlg('This field cannot be empty.', mtError, [mbOK], 0);
exit;
end;
if not TryStrToInt(ItersEdit.Text, ITER) or (ITER <= 0) then
begin
ItersEdit.SetFocus;
MessageDlg('Invalid input.', mtError, [mbOK], 0);
exit; exit;
end; end;
N := Ncols; N := Ncols;
M := NoCases; M := NoCases;
K := StrToInt(NoClustersEdit.Text);
IFAULT := 0; IFAULT := 0;
ITER := StrToInt(ItersEdit.Text);
SetLength(varlabels,Ncols); SetLength(varlabels,Ncols);
SetLength(rowlabels,NoCases); SetLength(rowlabels,NoCases);
@ -236,7 +255,6 @@ begin
SetLength(AN1,K+1); SetLength(AN1,K+1);
SetLength(AN2,K+1); SetLength(AN2,K+1);
SetLength(WSS,K+1); SetLength(WSS,K+1);
SetLength(DT,3);
SetLength(IC1,M+1); SetLength(IC1,M+1);
SetLength(IC2,M+1); SetLength(IC2,M+1);
SetLength(NC,K+1); SetLength(NC,K+1);
@ -244,12 +262,6 @@ begin
SetLength(ITRAN,K+1); SetLength(ITRAN,K+1);
SetLength(LIVE,K+1); SetLength(LIVE,K+1);
if (K <= 0) then
begin
ShowMessage('ERROR! You must enter the desired number of clusters.');
goto cleanup;
end;
// initialize arrays // initialize arrays
for i := 1 to K do for i := 1 to K do
begin begin
@ -272,7 +284,7 @@ begin
//Get labels and columns of selected variables //Get labels and columns of selected variables
for i := 0 to Ncols - 1 do for i := 0 to Ncols - 1 do
begin begin
cellstring := ListBox1.Items.Strings[i]; cellstring := SelList.Items.Strings[i];
for j := 0 to NoVariables - 1 do for j := 0 to NoVariables - 1 do
begin begin
if (cellstring = OS3MainFrm.DataGrid.Cells[j+1,0]) then if (cellstring = OS3MainFrm.DataGrid.Cells[j+1,0]) then
@ -284,12 +296,13 @@ begin
end; end;
// Get labels of rows // Get labels of rows
for i := 0 to NoCases - 1 do rowlabels[i] := OS3MainFrm.DataGrid.Cells[0,i+1]; for i := 0 to NoCases - 1 do
rowlabels[i] := OS3MainFrm.DataGrid.Cells[0,i+1];
// read the data // read the data
for i := 1 to M do for i := 1 to M do
begin begin
if (NOT GoodRecord(i,N,ColSelected)) then continue; if not GoodRecord(i, N, ColSelected) then continue;
for j := 1 to N do for j := 1 to N do
begin begin
col := ColSelected[j-1]; col := ColSelected[j-1];
@ -297,17 +310,17 @@ begin
end; end;
end; end;
OutputFrm.RichEdit.Clear; lReport := TStringList.Create;
OutputFrm.RichEdit.Lines.Add('K-Means Clustering. Adapted from AS 136 APPL. STATIST. (1979) VOL.28, NO.1'); try
OutputFrm.RichEdit.Lines.Add(''); lReport.Add('K-MEANS CLUSTERING');
outline := format('File := %s',[OS3MainFrm.FileNameEdit.Text]); lReport.Add('Adapted from AS 136 APPL. STATIST. (1979) VOL.28, NO.1');
OutputFrm.RichEdit.Lines.Add(outline); lReport.Add('');
outline := format('No. Cases := %d, No. Variables := %d, No. Clusters := %d',[M,N,K]); lReport.Add('File: %s', [OS3MainFrm.FileNameEdit.Text]);
OutputFrm.RichEdit.Lines.Add(outline); lReport.Add('No. Cases: %d, No. Variables: %d, No. Clusters: %d',[M, N, K]);
OutputFrm.RichEdit.Lines.Add(''); lReport.Add('');
// transform to z scores if needed // transform to z scores if needed
if (StdChkBox.Checked = true) then if StdChkBox.Checked then
begin begin
for j := 1 to N do for j := 1 to N do
begin begin
@ -316,24 +329,20 @@ begin
for i := 1 to M do for i := 1 to M do
begin begin
Mean := Mean + A[i,j]; Mean := Mean + A[i,j];
stddev := stddev + (A[i,j] * A[i,j]); stddev := stddev + sqr(A[i,j]);
end; end;
stddev := stddev - Mean * Mean / M; stddev := stddev - Mean * Mean / M;
stddev := stddev / (M - 1); stddev := stddev / (M - 1);
Mean := Mean / M; Mean := Mean / M;
if (DescChkBox.Checked) then if DescChkBox.Checked then
begin lReport.Add('Mean: %8.3f, Std.Dev.: %8.3f for %s', [Mean, stddev, varlabels[j-1]]);
outline := format('Mean := %8.3f, Std.Dev. := %8.3f for %s',[Mean,stddev,varlabels[j-1]]);
OutputFrm.RichEdit.Lines.Add(outline);
end;
for i := 1 to M do for i := 1 to M do
begin begin
A[i,j] := (A[i,j] - Mean) / stddev; A[i,j] := (A[i,j] - Mean) / stddev;
if (RepChkBox.Checked = true) then if RepChkBox.Checked then
begin begin
col := ColSelected[j-1]; col := ColSelected[j-1];
outline := format('%8.5f',[A[i,j]]); OS3MainFrm.DataGrid.Cells[col,i] := Format('%8.5f', [A[i,j]]);
OS3MainFrm.DataGrid.Cells[col,i] := outline;
end; end;
end; end;
end; end;
@ -342,8 +351,9 @@ begin
// Now enter initial points // Now enter initial points
for L := 1 to K do for L := 1 to K do
begin begin
center := 1 + (L-1) * (M div K); // initial cluster center center := 1 + (L-1) * (M div K); // initial cluster center // wp: why not ((L-1)*M) div K
for j := 1 to N do C[L,j] := A[center,j]; for j := 1 to N do
C[L, j] := A[center, j];
end; end;
// do analysis // do analysis
@ -352,81 +362,61 @@ begin
// show results // show results
// sort subjects by cluster // sort subjects by cluster
for i := 1 to M do IC2[i] := i; // store ids in here for i := 1 to M do
IC2[i] := i; // store ids in here
for i := 1 to M - 1 do for i := 1 to M - 1 do
begin begin
for j := i+1 to M do for j := i+1 to M do
begin begin
if (IC1[i] > IC1[j]) then // swap these clusters and ids if (IC1[i] > IC1[j]) then // swap these clusters and ids
begin begin
itemp := IC1[i]; Exchange(IC1[i], IC1[j]);
IC1[i] := IC1[j]; Exchange(IC2[i], IC2[j]);
IC1[j] := itemp;
itemp := IC2[i];
IC2[i] := IC2[j];
IC2[j] := itemp;
end; end;
end; end;
end; end;
OutputFrm.RichEdit.Lines.Add(''); lReport.Add('');
OutputFrm.RichEdit.Lines.Add('NUMBER OF SUBJECTS IN EACH CLUSTER'); lReport.Add('NUMBER OF SUBJECTS IN EACH CLUSTER');
for i := 1 to K do for i := 1 to K do
begin lReport.Add('Cluster %d with %d cases.', [i, NC[i]]);
outline := format('Cluster := %d with %d cases.',[i,NC[i]]);
OutputFrm.RichEdit.Lines.Add(outline);
end;
OutputFrm.RichEdit.Lines.Add(''); lReport.Add('');
OutputFrm.RichEdit.Lines.Add('PLACEMENT OF SUBJECTS IN CLUSTERS'); lReport.Add('PLACEMENT OF SUBJECTS IN CLUSTERS');
OutputFrm.RichEdit.Lines.Add('CLUSTER SUBJECT'); lReport.Add('CLUSTER SUBJECT');
for i := 1 to M do for i := 1 to M do
begin lReport.Add(' %3d %3d', [IC1[i], IC2[i]]);
outline := format(' %3d %3d',[IC1[i],IC2[i]]);
OutputFrm.RichEdit.Lines.Add(outline);
end;
OutputFrm.RichEdit.Lines.Add(''); lReport.Add('');
OutputFrm.RichEdit.Lines.Add('AVERAGE VARIABLE VALUES BY CLUSTER'); lReport.Add('AVERAGE VARIABLE VALUES BY CLUSTER');
outline := ' VARIABLES'; lReport.Add(' VARIABLES');
OutputFrm.RichEdit.Lines.Add(outline);
outline := 'CLUSTER'; outline := 'CLUSTER';
for j := 1 to N do for j := 1 to N do
begin outline := outline + Format(' %3d ',[j]);
strval := format(' %3d ',[j]); lReport.Add(outline);
outline := outline + strval; lReport.Add(' ');
end;
OutputFrm.RichEdit.Lines.Add(outline);
OutputFrm.RichEdit.Lines.Add(' ');
for i := 1 to K do for i := 1 to K do
begin begin
outline := format(' %3d ',[i]); outline := format(' %3d ',[i]);
for j := 1 to N do for j := 1 to N do
begin outline := outline + Format('%5.2f ', [C[i,j]]);
strval := format('%5.2f ',[C[i,j]]); lReport.Add(outline);
outline := outline + strval;
end; end;
OutputFrm.RichEdit.Lines.Add(outline); lReport.Add('');
end; lReport.Add('WITHIN CLUSTER SUMS OF SQUARES');
OutputFrm.RichEdit.Lines.Add('');
OutputFrm.RichEdit.Lines.Add('WITHIN CLUSTER SUMS OF SQUARES');
for i := 1 to K do for i := 1 to K do
begin lReport.Add('Cluster %d: %6.3f', [i, WSS[i]]);
outline := format('Cluster %d := %6.3f',[i,WSS[i]]);
OutputFrm.RichEdit.Lines.Add(outline);
end;
OutputFrm.ShowModal; DisplayReport(lReport);
// cleanup finally
cleanup: lReport.Free;
LIVE := nil; LIVE := nil;
ITRAN := nil; ITRAN := nil;
NCP := nil; NCP := nil;
NC := nil; NC := nil;
IC2 := nil; IC2 := nil;
IC1 := nil; IC1 := nil;
DT := nil;
WSS := nil; WSS := nil;
AN2 := nil; AN2 := nil;
AN1 := nil; AN1 := nil;
@ -437,6 +427,7 @@ cleanup:
rowlabels := nil; rowlabels := nil;
varlabels := nil; varlabels := nil;
end; end;
end;
procedure TKMeansFrm.KMNS(VAR A : DblDyneMat; M, N : integer; procedure TKMeansFrm.KMNS(VAR A : DblDyneMat; M, N : integer;
VAR C : DblDyneMat; K : integer; VAR IC1 : IntDyneVec; VAR C : DblDyneMat; K : integer; VAR IC1 : IntDyneVec;
@ -445,14 +436,17 @@ procedure TKMeansFrm.KMNS(VAR A : DblDyneMat; M, N : integer;
VAR NCP : IntDyneVec; VAR D : DblDyneVec; VAR NCP : IntDyneVec; VAR D : DblDyneVec;
VAR ITRAN : IntDyneVec; VAR LIVE : IntDyneVec; VAR ITRAN : IntDyneVec; VAR LIVE : IntDyneVec;
ITER : integer; VAR WSS : DblDyneVec; IFAULT : integer); ITER : integer; VAR WSS : DblDyneVec; IFAULT : integer);
const
BIG = 1.0E30;
ZERO = 0.0;
ONE = 1.0;
VAR VAR
DT: array[0..2] of double; DT: array[0..2] of double;
BIG : double;
ZERO : double;
ONE : double;
DA, DB, DC, TEMP, AA: double; DA, DB, DC, TEMP, AA: double;
L, II, INDX, I, J, IL, IJ: integer; L, II, INDX, I, J, IL, IJ: integer;
label cont50, cont40, cont150;
label
cont50, cont40, cont150;
begin begin
// SUBROUTINE KMNS(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D, // SUBROUTINE KMNS(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
@ -470,13 +464,10 @@ begin
// //
// DATA BIG /1.E30/, ZERO /0.0/, ONE /1.0/ // DATA BIG /1.E30/, ZERO /0.0/, ONE /1.0/
// //
BIG := 1.0e30;
ZERO := 0.0;
ONE := 1.0;
IFAULT := 3; IFAULT := 3;
if ((K <= 1) or (K >= M)) then if (K <= 1) or (K >= M) then
begin begin
ShowMessage('The no. of clusters must be less than the no. of variables.'); MessageDlg('The no. of clusters must be less than the no. of variables.', mtError, [mbOK], 0);
exit; exit;
end; end;
@ -496,6 +487,7 @@ begin
DT[IL] := DT[IL] + (DA * DA); //(squared difference for this comparison) DT[IL] := DT[IL] + (DA * DA); //(squared difference for this comparison)
end; // 10 CONTINUE end; // 10 CONTINUE
end; // 10 CONTINUE end; // 10 CONTINUE
if (DT[1] > DT[2]) then // THEN swap if (DT[1] > DT[2]) then // THEN swap
begin begin
IC1[I] := 2; IC1[I] := 2;
@ -504,6 +496,7 @@ begin
DT[1] := DT[2]; DT[1] := DT[2];
DT[2] := TEMP; DT[2] := TEMP;
end; // END IF end; // END IF
for L := 3 to K do // (remaining clusters) for L := 3 to K do // (remaining clusters)
begin begin
DB := ZERO; DB := ZERO;
@ -517,11 +510,15 @@ begin
DT[2] := DB; DT[2] := DB;
IC2[I] := L; IC2[I] := L;
goto cont50; goto cont50;
cont40: DT[2] := DT[1];
cont40:
DT[2] := DT[1];
IC2[I] := IC1[I]; IC2[I] := IC1[I];
DT[1] := DB; DT[1] := DB;
IC1[I] := L; IC1[I] := L;
cont50: end;
cont50:
end;
end; // 50 CONTINUE (next case) end; // 50 CONTINUE (next case)
// Update cluster centres to be the average of points contained // Update cluster centres to be the average of points contained
@ -567,6 +564,7 @@ cont50: end;
ITRAN[L] := 1; ITRAN[L] := 1;
NCP[L] := -1; NCP[L] := -1;
end; end;
INDX := 0; INDX := 0;
for IJ := 1 to ITER do for IJ := 1 to ITER do
begin begin
@ -577,8 +575,7 @@ cont50: end;
// //
OPTRA(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D, ITRAN, LIVE, INDX); OPTRA(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D, ITRAN, LIVE, INDX);
// //
// Stop if no transfer took place in the last M optimal transfer // Stop if no transfer took place in the last M optimal transfer steps.
// steps.
// //
if (INDX = M) then goto cont150; if (INDX = M) then goto cont150;
// //
@ -898,6 +895,13 @@ cont60:
goto cont10; goto cont10;
end; end;
procedure TKMeansFrm.UpdateBtnStates;
begin
VarInBtn.Enabled := AnySelected(VarList);
VarOutBtn.Enabled := AnySelected(SelList);
AllBtn.Enabled := VarList.Items.Count > 0;
end;
initialization initialization
{$I kmeansunit.lrs} {$I kmeansunit.lrs}