pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
b98f47bf19a2b896f78f7fc9cbeabd9a38d6e520
lazarus-ccr/applications/lazstats/source/forms/analysis/multivariate/kmeansunit.pas
wp_xxyyzz 128c037e14 LazStats: Some more improvements in RaschUnit. 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7898 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2020-11-22 22:29:04 +00:00

942 lines
26 KiB
ObjectPascal
Raw Blame History

// File for testing: cansas.laz, all variables
// In the help file example No of Desired Clusters is 4
unit KMeansUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Buttons, ExtCtrls,
MainUnit, Globals, BasicStatsReportFormUnit;
type
{ TKMeansForm }
TKMeansForm = class(TBasicStatsReportForm)
DescriptiveChk: TCheckBox;
Panel1: TPanel;
VarInBtn: TBitBtn;
VarOutBtn: TBitBtn;
AllBtn: TBitBtn;
StandardizeChk: TCheckBox;
ReplaceChk: TCheckBox;
GroupBox1: TGroupBox;
ItersEdit: TEdit;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
SelList: TListBox;
VarList: TListBox;
NoClustersEdit: TEdit;
Label1: TLabel;
procedure AllBtnClick(Sender: TObject);
procedure SelListDblClick(Sender: TObject);
procedure StandardizeChkChange(Sender: TObject);
procedure VarInBtnClick(Sender: TObject);
procedure VarListDblClick(Sender: TObject);
procedure VarListSelectionChange(Sender: TObject; {%H-}User: boolean);
procedure VarOutBtnClick(Sender: TObject);
private
procedure KMNS(VAR A : DblDyneMat; M, N : integer;
VAR C : DblDyneMat; K : integer; VAR IC1 : IntDyneVec;
VAR IC2 : IntDyneVec; VAR NC : IntDyneVec;
VAR AN1 : DblDyneVec; VAR AN2 : DblDyneVec;
VAR NCP : IntDyneVec; VAR D : DblDyneVec;
VAR ITRAN : IntDyneVec; VAR LIVE : IntDyneVec;
ITER : integer; VAR WSS : DblDyneVec; out IFAULT : integer);
procedure OPTRA(VAR A : DblDyneMat; M, N : integer;
VAR C : DblDyneMat; K : integer;
VAR IC1 : IntDyneVec; VAR IC2 : IntDyneVec;
VAR NC : IntDyneVec; VAR AN1 : DblDyneVec;
VAR AN2 : DblDyneVec; VAR NCP : IntDyneVec;
VAR D : DblDyneVec; VAR ITRAN : IntDyneVec;
VAR LIVE : IntDyneVec; INDX : integer);
procedure QTRAN(VAR A : DblDyneMat; M, N : integer;
VAR C : DblDyneMat; K : integer;
VAR IC1 : IntDyneVec; VAR IC2 : IntDyneVec;
VAR NC : IntDyneVec; VAR AN1 : DblDyneVec;
VAR AN2 : DblDyneVec; VAR NCP : IntDyneVec;
VAR D : DblDyneVec; VAR ITRAN : IntDyneVec;
INDX : integer);
protected
procedure AdjustConstraints; override;
procedure Compute; override;
procedure UpdateBtnStates; override;
function Validate(out AMsg: String; out AControl: TWinControl): Boolean; override;
public
constructor Create(AOwner: TComponent); override;
procedure Reset; override;
end;
var
KMeansForm: TKMeansForm;
implementation
{$R *.lfm}
uses
Math,
Utils, GridProcs, MatrixUnit;
{ TKMeansForm }
constructor TKMeansForm.Create(AOwner: TComponent);
begin
inherited;
end;
procedure TKMeansForm.AdjustConstraints;
begin
inherited;
ParamsPanel.Constraints.MinHeight := AllBtn.Top + AllBtn.Height +
VarList.BorderSpacing.Bottom + GroupBox1.Height +
ButtonBevel.Height + CloseBtn.BorderSpacing.Top + CloseBtn.Height;
ParamsPanel.Constraints.MinWidth := Max(
4*CloseBtn.Width + 3*CloseBtn.BorderSpacing.Left,
GroupBox1.Width + GroupBox1.BorderSpacing.Right +
Max(Label1.Width, Label2.Width) + Label1.BorderSpacing.Right +
NoClustersEdit.Width
);
end;
procedure TKMeansForm.AllBtnClick(Sender: TObject);
var
index: integer;
cellstring: string;
begin
for index := 0 to VarList.Items.Count - 1 do
begin
cellstring := VarList.Items[index];
SelList.Items.Add(cellstring);
end;
VarList.Clear;
UpdateBtnStates;
end;
procedure TKMeansForm.Compute;
var
i, j, L, Ncols, N, M, K,IFAULT, ITER, col : integer;
center: integer;
IC1: IntDyneVec = nil;
IC2: IntDyneVec = nil;
NC: IntDyneVec = nil;
NCP: IntDyneVec = nil;
ITRAN: IntDyneVec = nil;
LIVE: IntDyneVec = nil;
ColSelected: IntDyneVec = nil;
A: DblDyneMat = nil;
C: DblDyneMat = nil;
D: DblDyneVec = nil;
AN1: DblDyneVec = nil;
AN2: DblDyneVec = nil;
WSS: DblDyneVec = nil;
varlabels: StrDyneVec = nil;
rowlabels: StrDyneVec = nil;
Mean, stddev : double;
outline: string;
lReport: TStrings;
begin
Ncols := SelList.Items.Count;
K := StrToInt(NoClustersEdit.Text);
ITER := StrToInt(ItersEdit.Text);
IFAULT := 0;
N := NCols;
M := NoCases;
SetLength(A,M+1,N+1);
SetLength(C,K+1,N+1);
SetLength(D,M+1);
SetLength(AN1,K+1);
SetLength(AN2,K+1);
SetLength(WSS,K+1);
SetLength(IC1,M+1);
SetLength(IC2,M+1);
SetLength(NC,K+1);
SetLength(NCP,K+1);
SetLength(ITRAN,K+1);
SetLength(LIVE,K+1);
// Get labels and columns of selected variables
SetLength(ColSelected, nCols);
SetLength(varlabels, nCols);
for i := 0 to nCols - 1 do
begin
varLabels[i] := SelList.Items[i];
ColSelected[i] := GetVariableIndex(OS3MainFrm.DataGrid, varLabels[i]);
end;
// Get labels of rows
SetLength(rowlabels, noCases);
for i := 0 to noCases - 1 do
rowlabels[i] := OS3MainFrm.DataGrid.Cells[0, i+1];
// Read the data
for i := 1 to M do
begin
if not GoodRecord(OS3MainFrm.DataGrid, i, ColSelected) then continue;
for j := 1 to N do
A[i,j] := StrToFloat(OS3MainFrm.DataGrid.Cells[ColSelected[j-1],i]);
end;
lReport := TStringList.Create;
try
lReport.Add('K-MEANS CLUSTERING');
lReport.Add('Adapted from AS 136 APPL. STATIST. (1979) VOL.28, NO.1');
lReport.Add('');
lReport.Add('File: %s', [OS3MainFrm.FileNameEdit.Text]);
lReport.Add('No. Cases: %8d', [M]);
lReport.Add('No. Variables: %8d', [N]);
lReport.Add('No. Clusters: %8d', [K]);
lReport.Add('');
// transform to z scores if needed
if StandardizeChk.Checked then
begin
if DescriptiveChk.Checked then
begin
lReport.Add('DESCRIPTIVE STATISTICS');
lReport.Add(' Variable Mean StdDev ');
lReport.Add('------------ ------------ ------------');
end;
for j := 1 to N do
begin
Mean := 0.0;
stddev := 0.0;
for i := 1 to M do
begin
Mean := Mean + A[i,j];
stddev := stddev + sqr(A[i,j]);
end;
stddev := (stddev - sqr(Mean) / M) / (M - 1);
Mean := Mean / M;
if DescriptiveChk.Checked then
lReport.Add('%12s %12.3f %12.3f', [varLabels[j-1], mean, stdDev]);
for i := 1 to M do
begin
A[i,j] := (A[i,j] - Mean) / stddev;
if ReplaceChk.Checked then
begin
col := ColSelected[j-1];
OS3MainFrm.DataGrid.Cells[col,i] := Format('%.5f', [A[i,j]]);
end;
end;
end;
end;
// Now enter initial points
for L := 1 to K do
begin
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];
end;
// do analysis
KMNS(A,M,N,C,K,IC1,IC2,NC,AN1,AN2,NCP,D,ITRAN,LIVE,ITER,WSS,IFAULT);
// show results
// sort subjects by cluster
for i := 1 to M do
IC2[i] := i; // store ids in here
for i := 1 to M - 1 do
begin
for j := i+1 to M do
begin
if (IC1[i] > IC1[j]) then // swap these clusters and ids
begin
Exchange(IC1[i], IC1[j]);
Exchange(IC2[i], IC2[j]);
end;
end;
end;
lReport.Add('');
lReport.Add('NUMBER OF SUBJECTS IN EACH CLUSTER');
for i := 1 to K do
lReport.Add('Cluster %d with %d cases.', [i, NC[i]]);
lReport.Add('');
lReport.Add('PLACEMENT OF SUBJECTS IN CLUSTERS');
lReport.Add('CLUSTER SUBJECT');
for i := 1 to M do
lReport.Add(' %3d %3d', [IC1[i], IC2[i]]);
lReport.Add('');
lReport.Add('AVERAGE VARIABLE VALUES BY CLUSTER');
lReport.Add(' Variables');
outline := 'Cluster';
for j := 1 to N do
outline := outline + Format(' %3d ',[j]);
lReport.Add(outline);
lReport.Add(' ');
for i := 1 to K do
begin
outline := format(' %3d ',[i]);
for j := 1 to N do
outline := outline + Format('%5.2f ', [C[i,j]]);
lReport.Add(outline);
end;
lReport.Add('');
lReport.Add('WITHIN CLUSTER SUMS OF SQUARES');
for i := 1 to K do
lReport.Add('Cluster %d: %6.3f', [i, WSS[i]]);
FReportFrame.DisplayReport(lReport);
finally
lReport.Free;
LIVE := nil;
ITRAN := nil;
NCP := nil;
NC := nil;
IC2 := nil;
IC1 := nil;
WSS := nil;
AN2 := nil;
AN1 := nil;
D := nil;
C := nil;
A := nil;
ColSelected := nil;
rowlabels := nil;
varlabels := nil;
end;
end;
procedure TKMeansForm.KMNS(VAR A : DblDyneMat; M, N : integer;
VAR C : DblDyneMat; K : integer; VAR IC1 : IntDyneVec;
VAR IC2 : IntDyneVec; VAR NC : IntDyneVec;
VAR AN1 : DblDyneVec; VAR AN2 : DblDyneVec;
VAR NCP : IntDyneVec; VAR D : DblDyneVec;
VAR ITRAN : IntDyneVec; VAR LIVE : IntDyneVec;
ITER : integer; VAR WSS : DblDyneVec; out IFAULT : integer);
const
BIG = 1.0E30;
ZERO = 0.0;
ONE = 1.0;
VAR
DT: array[0..2] of double;
DA, DB, DC, TEMP, AA: double;
L, II, INDX, I, J, IL, IJ: integer;
label
cont50, cont40, cont150;
begin
// SUBROUTINE KMNS(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
// * ITRAN, LIVE, ITER, WSS, IFAULT)
//
// ALGORITHM AS 136 APPL. STATIST. (1979) VOL.28, NO.1
// Divide M points in N-dimensional space into K clusters so that
// the within cluster sum of squares is minimized.
//
// INTEGER IC1(M), IC2(M), NC(K), NCP(K), ITRAN(K), LIVE(K)
// REAL A(M,N), D(M), C(K,N), AN1(K), AN2(K), WSS(K), DT(2)
// REAL ZERO, ONE
//
// Define BIG to be a very large positive number
//
// DATA BIG /1.E30/, ZERO /0.0/, ONE /1.0/
//
IFAULT := 3;
if (K <= 1) or (K >= M) then
begin
MessageDlg('The no. of clusters must be less than the no. of variables.', mtError, [mbOK], 0);
exit;
end;
// For each point I, find its two closest centres, IC1(I) and
// IC2(I). Assign it to IC1(I).
//
for I := 1 to M do
begin
IC1[I] := 1;
IC2[I] := 2;
for IL := 1 to 2 do
begin
DT[IL] := ZERO;
for J := 1 to N do
begin
DA := A[I,J] - C[IL,J];
DT[IL] := DT[IL] + (DA * DA); //(squared difference for this comparison)
end; // 10 CONTINUE
end; // 10 CONTINUE
if (DT[1] > DT[2]) then // THEN swap
begin
IC1[I] := 2;
IC2[I] := 1;
TEMP := DT[1];
DT[1] := DT[2];
DT[2] := TEMP;
end; // END IF
for L := 3 to K do // (remaining clusters)
begin
DB := ZERO;
for J := 1 to N do // (variables)
begin
DC := A[I,J] - C[L,J];
DB := DB + DC * DC;
if (DB >= DT[2]) then goto cont50;
end;
if (DB < DT[1]) then goto cont40;
DT[2] := DB;
IC2[I] := L;
goto cont50;
cont40:
DT[2] := DT[1];
IC2[I] := IC1[I];
DT[1] := DB;
IC1[I] := L;
cont50:
end;
end; // 50 CONTINUE (next case)
// Update cluster centres to be the average of points contained
// within them.
//
for L := 1 to K do // (clusters)
begin
NC[L] := 0;
for J := 1 to N do C[L,J] := ZERO; //(initialize clusters)
end;
for I := 1 to M do // (subjects)
begin
L := IC1[I]; // which cluster the Ith case is in
NC[L] := NC[L] + 1; // no. in the cluster L
for J := 1 to N do C[L,J] := C[L,J] + A[I,J]; // sum of var. values in the cluster L
end;
// Check to see if there is any empty cluster at this stage
//
for L := 1 to K do
begin
if (NC[L] = 0) then
begin
IFAULT := 1;
exit;
end;
AA := NC[L];
for J := 1 to N do C[L,J] := C[L,J] / AA; // average the values in the cluster
// Initialize AN1, AN2, ITRAN & NCP
// AN1(L) := NC(L) / (NC(L) - 1)
// AN2(L) := NC(L) / (NC(L) + 1)
// ITRAN(L) := 1 if cluster L is updated in the quick-transfer stage,
// := 0 otherwise
// In the optimal-transfer stage, NCP(L) stores the step at which
// cluster L is last updated.
// In the quick-transfer stage, NCP(L) stores the step at which
// cluster L is last updated plus M.
//
AN2[L] := AA / (AA + ONE);
AN1[L] := BIG;
if (AA > ONE) then AN1[L] := AA / (AA - ONE);
ITRAN[L] := 1;
NCP[L] := -1;
end;
INDX := 0;
for IJ := 1 to ITER do
begin
//
// In this stage, there is only one pass through the data. Each
// point is re-allocated, if necessary, to the cluster that will
// induce the maximum reduction in within-cluster sum of squares.
//
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 steps.
//
if (INDX = M) then goto cont150;
//
// Each point is tested in turn to see if it should be re-allocated
// to the cluster to which it is most likely to be transferred,
// IC2(I), from its present cluster, IC1(I). Loop through the
// data until no further change is to take place.
//
QTRAN(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D, ITRAN, INDX);
//
// If there are only two clusters, there is no need to re-enter the
// optimal transfer stage.
//
if (K = 2) then goto cont150;
//
// NCP has to be set to 0 before entering OPTRA.
//
for L := 1 to K do NCP[L] := 0;
end;
//
// Since the specified number of iterations has been exceeded, set
// IFAULT := 2. This may indicate unforeseen looping.
//
IFAULT := 2;
//
// Compute within-cluster sum of squares for each cluster.
//
cont150:
for L := 1 to K do
begin
WSS[L] := ZERO;
for J := 1 to N do C[L,J] := ZERO;
end;
for I := 1 to M do
begin
II := IC1[I];
for J := 1 to N do C[II,J] := C[II,J] + A[I,J];
end;
for J := 1 to N do
begin
for L := 1 to K do C[L,J] := C[L,J] / (NC[L]);
for I := 1 to M do
begin
II := IC1[I];
DA := A[I,J] - C[II,J];
WSS[II] := WSS[II] + DA * DA;
end;
end; // 190 CONTINUE
end;
procedure TKMeansForm.OPTRA(VAR A : DblDyneMat; M, N : integer;
VAR C : DblDyneMat; K : integer;
VAR IC1 : IntDyneVec; VAR IC2 : IntDyneVec;
VAR NC : IntDyneVec; VAR AN1 : DblDyneVec;
VAR AN2 : DblDyneVec; VAR NCP : IntDyneVec;
VAR D : DblDyneVec; VAR ITRAN : IntDyneVec;
VAR LIVE : IntDyneVec; INDX : integer);
VAR
ZERO, ONE, BIG,DE, DF, DD, DC, DB, DA, R2, RR, AL1, AL2, ALT, ALW : double;
I, J, L, L1, L2, LL : integer;
label cont30, cont60, cont70, cont90;
begin
// SUBROUTINE OPTRA(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
// * ITRAN, LIVE, INDX)
//
// ALGORITHM AS 136.1 APPL. STATIST. (1979) VOL.28, NO.1
//
// This is the optimal transfer stage.
//
// Each point is re-allocated, if necessary, to the cluster that
// will induce a maximum reduction in the within-cluster sum of
// squares.
//
// INTEGER IC1(M), IC2(M), NC(K), NCP(K), ITRAN(K), LIVE(K)
// REAL A(M,N), D(M), C(K,N), AN1(K), AN2(K), ZERO, ONE
//
// Define BIG to be a very large positive number.
//
// DATA BIG /1.0E30/, ZERO /0.0/, ONE/1.0/
//
// If cluster L is updated in the last quick-transfer stage, it
// belongs to the live set throughout this stage. Otherwise, at
// each step, it is not in the live set if it has not been updated
// in the last M optimal transfer steps.
//
ZERO := 0.0;
ONE := 1.0;
BIG := 1.0e30;
for L := 1 to K do
begin
if (ITRAN[L] = 1) then LIVE[L] := M + 1;
end; // 10 CONTINUE
for I := 1 to M do
begin
INDX := INDX + 1;
L1 := IC1[I];
L2 := IC2[I];
LL := L2;
//
// If point I is the only member of cluster L1, no transfer.
//
if (NC[L1] = 1) then goto cont90; // GO TO 90
//
// If L1 has not yet been updated in this stage, no need to
// re-compute D(I).
//
if (NCP[L1] = 0) then goto cont30; // GO TO 30
DE := ZERO;
for J := 1 to N do
begin
DF := A[I,J] - C[L1,J];
DE := DE + DF * DF;
end;
D[I] := DE * AN1[L1];
//
// Find the cluster with minimum R2.
//
cont30:
DA := ZERO;
for J := 1 to N do
begin
DB := A[I,J] - C[L2,J];
DA := DA + DB * DB;
end;
R2 := DA * AN2[L2];
for L := 1 to K do
begin
//
// If I >:= LIVE(L1), then L1 is not in the live set. If this is
// true, we only need to consider clusters that are in the live set
// for possible transfer of point I. Otherwise, we need to consider
// all possible clusters.
//
if ((I >= LIVE[L1]) and (I >= LIVE[L]) or (L = L1) or (L = LL)) then goto cont60;
RR := R2 / AN2[L];
DC := ZERO;
for J := 1 to N do
begin
DD := A[I,J] - C[L,J];
DC := DC + DD * DD;
if (DC >= RR) then goto cont60;
end;
R2 := DC * AN2[L];
L2 := L;
cont60:
end; // 60 CONTINUE
if (R2 < D[I]) then goto cont70;
//
// If no transfer is necessary, L2 is the new IC2(I).
//
IC2[I] := L2;
goto cont90; // GO TO 90
//
// Update cluster centres, LIVE, NCP, AN1 & AN2 for clusters L1 and
// L2, and update IC1(I) & IC2(I).
//
cont70:
INDX := 0;
LIVE[L1] := M + I;
LIVE[L2] := M + I;
NCP[L1] := I;
NCP[L2] := I;
AL1 := NC[L1];
ALW := AL1 - ONE;
AL2 := NC[L2];
ALT := AL2 + ONE;
for J := 1 to N do
begin
C[L1,J] := (C[L1,J] * AL1 - A[I,J]) / ALW;
C[L2,J] := (C[L2,J] * AL2 + A[I,J]) / ALT;
end;
NC[L1] := NC[L1] - 1;
NC[L2] := NC[L2] + 1;
AN2[L1] := ALW / AL1;
AN1[L1] := BIG;
if (ALW > ONE) then AN1[L1] := ALW / (ALW - ONE);
AN1[L2] := ALT / AL2;
AN2[L2] := ALT / (ALT + ONE);
IC1[I] := L2;
IC2[I] := L1;
cont90:
// 90 CONTINUE
if (INDX = M) then exit;
end; // 100 CONTINUE
for L := 1 to K do
begin
//
// ITRAN(L) := 0 before entering QTRAN. Also, LIVE(L) has to be
// decreased by M before re-entering OPTRA.
//
ITRAN[L] := 0;
LIVE[L] := LIVE[L] - M;
end; // 110 CONTINUE
end;
{ SUBROUTINE QTRAN(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D, ITRAN, INDX)
ALGORITHM AS 136.2 APPL. STATIST. (1979) VOL.28, NO.1
This is the quick transfer stage.
IC1(I) is the cluster which point I belongs to.
IC2(I) is the cluster which point I is most likely to be transferred to.
For each point I, IC1(I) & IC2(I) are switched, if necessary, to
reduce within-cluster sum of squares. The cluster centres are
updated after each step.
INTEGER IC1(M), IC2(M), NC(K), NCP(K), ITRAN(K)
REAL A(M,N), D(M), C(K,N), AN1(K), AN2(K), ZERO, ONE
Define BIG to be a very large positive number
DATA BIG /1.0E30/, ZERO /0.0/, ONE /1.0/
In the optimal transfer stage, NCP(L) indicates the step at which
cluster L is last updated. In the quick transfer stage, NCP(L)
is equal to the step at which cluster L is last updated plus M. }
procedure TKMeansForm.QTRAN(VAR A : DblDyneMat; M, N : integer;
VAR C : DblDyneMat; K : integer;
VAR IC1 : IntDyneVec; VAR IC2 : IntDyneVec;
VAR NC : IntDyneVec; VAR AN1 : DblDyneVec;
VAR AN2 : DblDyneVec; VAR NCP : IntDyneVec;
VAR D : DblDyneVec; VAR ITRAN : IntDyneVec;
INDX : integer);
const
BIG = 1E304;
ZERO = 0.0;
ONE = 1.0;
var
DA, DB, DE, DD, R2, AL1, ALW, AL2, ALT: double;
I, J, ICOUN, ISTEP, L1, L2: integer;
label
cont10, cont30, cont60;
begin
ICOUN := 0;
ISTEP := 0;
cont10:
for I := 1 to M do
begin
ICOUN := ICOUN + 1;
ISTEP := ISTEP + 1;
L1 := IC1[I];
L2 := IC2[I];
//
// If point I is the only member of cluster L1, no transfer.
//
if (NC[L1] = 1) then goto cont60;
//
// If ISTEP > NCP(L1), no need to re-compute distance from point I to
// cluster L1. Note that if cluster L1 is last updated exactly M
// steps ago, we still need to compute the distance from point I to
// cluster L1.
//
if (ISTEP > NCP[L1]) then goto cont30;
DA := ZERO;
for J := 1 to N do
begin
DB := A[I,J] - C[L1,J];
DA := DA + DB * DB;
end;
D[I] := DA * AN1[L1];
//
// If ISTEP >:= both NCP(L1) & NCP(L2) there will be no transfer of
// point I at this step.
//
cont30:
if ((ISTEP >= NCP[L1]) and (ISTEP >= NCP[L2])) then goto cont60;
R2 := D[I] / AN2[L2];
DD := ZERO;
for J := 1 to N do
begin
DE := A[I,J] - C[L2,J];
DD := DD + DE * DE;
if (DD >= R2) then goto cont60;
end; // 40 CONTINUE
//
// Update cluster centres, NCP, NC, ITRAN, AN1 & AN2 for clusters
// L1 & L2. Also update IC1(I) & IC2(I). Note that if any
// updating occurs in this stage, INDX is set back to 0.
//
ICOUN := 0;
INDX := 0;
ITRAN[L1] := 1;
ITRAN[L2] := 1;
NCP[L1] := ISTEP + M;
NCP[L2] := ISTEP + M;
AL1 := NC[L1];
ALW := AL1 - ONE;
AL2 := NC[L2];
ALT := AL2 + ONE;
for J := 1 to N do
begin
C[L1,J] := (C[L1,J] * AL1 - A[I,J]) / ALW;
C[L2,J] := (C[L2,J] * AL2 + A[I,J]) / ALT;
end; // 50 CONTINUE
NC[L1] := NC[L1] - 1;
NC[L2] := NC[L2] + 1;
AN2[L1] := ALW / AL1;
AN1[L1] := BIG;
if (ALW > ONE) then AN1[L1] := ALW / (ALW - ONE);
AN1[L2] := ALT / AL2;
AN2[L2] := ALT / (ALT + ONE);
IC1[I] := L2;
IC2[I] := L1;
//
// If no re-allocation took place in the last M steps, return.
//
cont60:
if (ICOUN = M) then exit;
end; // 70 CONTINUE
goto cont10;
end;
procedure TKMeansForm.Reset;
begin
inherited;
CollectVariableNames(OS3MainFrm.DataGrid, VarList.Items);
SelList.Clear;
ReplaceChk.Checked := false;
StandardizeChk.Checked := true;
DescriptiveChk.Checked := false;
NoClustersEdit.Clear;
ItersEdit.Text := '100';
UpdateBtnStates;
end;
procedure TKMeansForm.SelListDblClick(Sender: TObject);
var
index: Integer;
begin
index := SelList.ItemIndex;
if index > -1 then
begin
VarList.Items.Add(SelList.Items[index]);
SelList.Items.Delete(index);
UpdateBtnStates;
end;
end;
procedure TKMeansForm.StandardizeChkChange(Sender: TObject);
begin
ReplaceChk.Enabled := StandardizeChk.Checked;
DescriptiveChk.Enabled := StandardizeChk.Checked;
end;
procedure TKMeansForm.UpdateBtnStates;
begin
inherited;
VarInBtn.Enabled := AnySelected(VarList);
VarOutBtn.Enabled := AnySelected(SelList);
AllBtn.Enabled := VarList.Items.Count > 0;
end;
function TKMeansForm.Validate(out AMsg: String; out AControl: TWinControl): Boolean;
var
n: Integer;
begin
Result := false;
if SelList.Items.Count <= 0 then
begin
AMsg := 'No variables selected to cluster.';
AControl := VarList;
exit;
end;
if NoClustersEdit.Text = '' then
begin
AControl := NoClustersEdit;
AMsg := 'You must enter the desired number of clusters.';
exit;
end;
if not TryStrToInt(NoClustersEdit.Text, n) or (n <= 0) then
begin
AControl := NoClustersEdit;
AMsg := 'You must enter the desired number of clusters as a positive value.';
exit;
end;
if ItersEdit.Text = '' then
begin
AControl := ItersEdit;
AMsg := 'This field cannot be empty.';
exit;
end;
if not TryStrToInt(ItersEdit.Text, n) or (n <= 0) then
begin
AControl := ItersEdit;
AMsg := 'Positive number required.';
exit;
end;
Result := true;
end;
procedure TKMeansForm.VarInBtnClick(Sender: TObject);
var
i: integer;
begin
i := 0;
while i < VarList.Items.Count do
begin
if VarList.Selected[i] then
begin
SelList.Items.Add(VarList.Items[i]);
VarList.Items.Delete(i);
i := 0;
end else
i := i + 1;
end;
UpdateBtnStates;
end;
procedure TKMeansForm.VarListDblClick(Sender: TObject);
var
index: Integer;
begin
index := VarList.ItemIndex;
if index > -1 then
begin
SelList.Items.Add(VarList.Items[index]);
VarList.Items.Delete(index);
UpdateBtnStates;
end;
end;
procedure TKMeansForm.VarListSelectionChange(Sender: TObject; User: boolean);
begin
UpdateBtnStates;
end;
procedure TKMeansForm.VarOutBtnClick(Sender: TObject);
var
i: integer;
begin
i := 0;
while i < SelList.Items.Count do
begin
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.
Reference in New Issue View Git Blame Copy Permalink