pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
79a85d3e590f1e5d35b86bc6eb4c1103534b48db
lazarus-ccr/applications/lazstats/source/forms/analysis/multivariate/singlelinkunit.pas
wp_xxyyzz dcec975ab4 LazStats: Refactor SingleLinkUnit. 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7372 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2020-04-11 16:36:26 +00:00

673 lines
18 KiB
ObjectPascal
Raw Blame History

unit SingleLinkUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, Buttons, ExtCtrls,
MainUnit, Globals, OutputUnit;
type
{ TSingleLinkFrm }
TSingleLinkFrm = class(TForm)
Bevel1: TBevel;
Panel1: TPanel;
ResetBtn: TButton;
ComputeBtn: TButton;
CloseBtn: TButton;
StdChkBox: TCheckBox;
RepChkBox: TCheckBox;
DescChkBox: TCheckBox;
PlotChkBox: TCheckBox;
DendoChk: TCheckBox;
OptionsGroup: TGroupBox;
VarSelEdit: TEdit;
Label2: TLabel;
VarInBtn: TBitBtn;
VarOutBtn: TBitBtn;
Label1: TLabel;
VarList: TListBox;
procedure ComputeBtnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure VarListSelectionChange(Sender: TObject; User: boolean);
procedure ResetBtnClick(Sender: TObject);
procedure VarInBtnClick(Sender: TObject);
procedure VarOutBtnClick(Sender: TObject);
private
{ private declarations }
FAutoSized: Boolean;
procedure UpdateBtnStates;
procedure ScatPlot(const x, y: DblDyneVec; NoCases: Integer;
ATitleStr, XAxisStr, YAxisStr: string;
x_min, x_max, y_min, y_max : double; const VarLabels: StrDyneVec;
AReport: TStrings);
procedure TreePlot(const Clusters: IntDyneMat; const Lst: IntDyneVec;
NoPoints: integer; AReport: TStrings);
public
{ public declarations }
end;
var
SingleLinkFrm: TSingleLinkFrm;
implementation
uses
Math, Utils;
{ TSingleLinkFrm }
procedure TSingleLinkFrm.ResetBtnClick(Sender: TObject);
var
i: integer;
begin
VarList.Clear;
VarSelEdit.Text := '';
for i := 1 to NoVariables do
VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
RepChkBox.Checked := false;
StdChkBox.Checked := false;
DescChkBox.Checked := false;
PlotChkBox.Checked := false;
UpdateBtnStates;
end;
procedure TSingleLinkFrm.VarInBtnClick(Sender: TObject);
var
index: integer;
begin
index := VarList.ItemIndex;
if (index > -1) and (VarSelEdit.Text = '') then
begin
VarSelEdit.Text := VarList.Items.Strings[index];
VarList.Items.Delete(index);
end;
UpdateBtnStates;
end;
procedure TSingleLinkFrm.VarOutBtnClick(Sender: TObject);
begin
if VarSelEdit.Text <> '' then
begin
VarList.Items.Add(VarSelEdit.Text);
VarSelEdit.Text := '';
end;
UpdateBtnStates;
end;
procedure TSingleLinkFrm.FormActivate(Sender: TObject);
var
w: Integer;
begin
if FAutoSized then
exit;
w := MaxValue([ResetBtn.Width, ComputeBtn.Width, CloseBtn.Width]);
ResetBtn.Constraints.MinWidth := w;
ComputeBtn.Constraints.MinWidth := w;
CloseBtn.Constraints.MinWidth := w;
Constraints.MinWidth := OptionsGroup.Width * 2;
Constraints.MinHeight := Height;
FAutoSized := true;
end;
procedure TSingleLinkFrm.FormCreate(Sender: TObject);
begin
Assert(OS3MainFrm <> nil);
end;
procedure TSingleLinkFrm.FormShow(Sender: TObject);
begin
ResetBtnClick(self);
end;
procedure TSingleLinkFrm.VarListSelectionChange(Sender: TObject; User: boolean);
begin
UpdateBtnStates;
end;
procedure TSingleLinkFrm.ComputeBtnClick(Sender: TObject);
var
NoInGrp : IntDyneVec; // no. of subjects in a grouping
i, j, NoGroups, ID1, ID2, col, startAt, endAt: integer;
ColSelected : integer;
NoScores : integer;
varlabel : string;
// outline : array[1..501] of char;
// astring : array[0..5] of char;
outline : string;
Scores : DblDyneVec; // subject scores
Distance : DblDyneMat; // distance between objects
SubjectIDs : IntDyneVec; // subject ids - sorted with Distance
Groups : IntDyneMat; // subjects in each group
GrpErrors : DblDyneVec;
Smallest, Mean, Variance, StdDev : double;
clusters : IntDyneMat;
Lst : IntDyneVec;
done : boolean;
average : double;
XAxis, YAxis : DblDyneVec;
MaxError : double;
GrpLabels : StrDyneVec;
lReport: TStrings;
label
labels1, labels2;
begin
NoScores := NoCases;
Mean := 0.0;
Variance := 0.0;
varlabel := VarSelEdit.Text;
//Get selected variable
ColSelected := 0;
for j := 1 to NoVariables do
if (VarSelEdit.Text = OS3MainFrm.DataGrid.Cells[j,0]) then ColSelected := j;
if (ColSelected = 0) then
begin
MessageDlg('No variable selected to analyze.', mtError, [mbOK], 0);
exit;
end;
// Allocate memory
SetLength(Distance,NoCases+1,NoCases+1);
SetLength(SubjectIDs,NoCases+1);
SetLength(NoInGrp,NoCases+1);
SetLength(Groups,NoCases+1,NoCases+1);
SetLength(Scores,NoCases+1);
SetLength(GrpErrors,NoCases+1);
SetLength(clusters,NoCases+1,3);
SetLength(Lst,NoCases+1);
// initialize arrays
for i := 0 to NoCases-1 do
begin
NoInGrp[i] := 1;
SubjectIDs[i] := i+1;
for j := 0 to NoCases-1 do
begin
Groups[i,j] := 0;
Distance[i,j] := 0.0;
end;
for j := 0 to 2 do
clusters[i,j] := 0;
end;
NoGroups := 0;
// Get data into the distance matrix
for i := 0 to NoCases - 1 do
begin
col := ColSelected;
Scores[i] := StrToFloat(OS3MainFrm.DataGrid.Cells[col,i+1]);
Mean := Mean + Scores[i];
Variance := Variance + (Scores[i] * Scores[i]);
end;
Variance := Variance - ((Mean * Mean) / NoCases);
Variance := Variance / (NoCases - 1);
StdDev := sqrt(Variance);
Mean := Mean / NoCases;
// sort the scores and ids in distance and subjed ids
for i := 0 to NoCases - 2 do
begin
for j := i+1 to NoCases - 1 do
begin
if (Scores[i] > Scores[j]) then // swap
begin
Exchange(Scores[i], Scores[j]);
Exchange(SubjectIDs[i], SubjectIDs[j]);
end;
end;
end;
for i := 0 to NoCases - 1 do
Lst[i+1] := SubjectIDs[i];
// Show results
lReport := TStringList.Create;
try
lReport.Add('SINGLE LINKAGE CLUSTERING by Bill Miller');
lReport.Add('');
lReport.Add('FILE: %s', [OS3MainFrm.FileNameEdit.Text]);
lReport.Add('Variable: %s', [varlabel]);
lReport.Add('Number of cases: %8d', [NoCases]);
lReport.Add('Mean: %8.3f', [Mean]);
lReport.Add('Variance: %8.3f', [Variance]);
lReport.Add('Std.Dev.: %8.3f', [StdDev]);
lReport.Add('');
// Standardize the distance scores if elected
if StdChkBox.Checked then
begin
for i := 0 to NoCases - 1 do
Scores[i] := (Scores[i] - Mean) / StdDev;
if RepChkBox.Checked then // replace original values in DataGrid with z scores if elected
begin
for i := 0 to NoCases - 1 do
begin
col := ColSelected;
OS3MainFrm.DataGrid.Cells[col,i+1] := Format('%6.4f', [Scores[i]]);
end;
end;
end;
if DescChkBox.Checked then
begin
done := false;
startat := 0;
endat := NoScores;
if (endat > 20) then endat := 20;
while (not done) do
begin
outline := 'GROUP ID';
for i := startat to endat - 1 do
outline := outline + Format('%4d', [SubjectIDs[i]]);
lReport.Add(outline);
startat := endat;
if (startat >= NoScores) then done := true;
endat := startat + 20;
if (endat > NoScores) then endat := NoScores;
end;
end;
// calculate Distances and smallest Distance
labels1:
Smallest := abs(Scores[0] - Scores[1]); // initial values
for i := 0 to NoScores - 2 do
begin
for j := i+1 to NoScores - 1 do
begin
Distance[i,j] := abs(Scores[i] - Scores[j]);
Distance[j,i] := Distance[i,j];
if (Distance[i,j] <= Smallest) then
begin
Smallest := Distance[i,j];
ID1 := i;
ID2 := j;
end;
end;
end;
if (NoGroups < NoCases-1) then
begin
if DescChkBox.Checked then
begin
lReport.Add(' Group %d is combined with Group %d', [SubjectIDs[ID1], SubjectIDs[ID2]]);
lReport.Add('');
end;
end;
// eliminate second score and replace first with average
NoInGrp[ID1] := NoInGrp[ID1] + 1;
NoInGrp[ID2] := NoInGrp[ID2] - 1;
clusters[NoGroups+1,1] := SubjectIDs[ID1];
clusters[NoGroups+1,2] := SubjectIDs[ID2];
// record results for this grouping
labels2:
Groups[NoGroups,ID1] := 1; // set flags for those objects grouped
Groups[NoGroups,ID2] := 1;
if (NoGroups < NoCases-1) then // eliminate second score and replace first with average
begin
average := abs(Scores[ID1] + Scores[ID2]) / 2.0;
Scores[ID1] := average;
for i := ID2 to NoScores - 2 do
begin
Scores[i] := Scores[i+1];
SubjectIDs[i] := SubjectIDs[i+1];
end;
NoScores := NoScores - 1;
for i := 0 to NoScores - 1 do Groups[NoGroups,SubjectIDs[i]] := 1;
if DescChkBox.Checked then
begin
done := false;
startat := 0;
endat := NoScores;
if (endat > 20) then endat := 20;
while (not done) do
begin
outline := 'GROUP ID';
for i := startat to endat - 1 do
outline := outline + Format('%4d',[SubjectIDs[i]]);
lReport.Add(outline);
startat := endat;
if (startat >= NoScores) then done := true;
endat := startat + 20;
if (endat > NoScores) then endat := NoScores;
end;
end;
// get errors
GrpErrors[NoGroups] := GrpErrors[NoGroups] + Distance[ID1,ID2];
NoGroups := NoGroups + 1;
goto labels1;
end;
// show errors
if DescChkBox.Checked then
begin
lReport.Add('');
lReport.Add('GROUPING STEP ERROR');
lReport.Add('------------- --------');
for i := 0 to NoGroups - 1 do
lReport.Add('%8d %8.3f', [i+1, GrpErrors[i]]);
end;
lReport.Add('');
lReport.Add(DIVIDER);
lReport.Add('');
if PlotChkBox.Checked then
begin
MaxError := GrpErrors[NoGroups-1];
SetLength(XAxis,NoCases);
SetLength(YAxis,NoCases);
SetLength(GrpLabels,NoGroups+1);
for i := 0 to NoGroups - 1 do
begin
XAxis[i] := NoGroups - i;
YAxis[i] := GrpErrors[i];
GrpLabels[i] := IntToStr(i + 1);
end;
ScatPlot(XAxis, YAxis, NoGroups, 'Plot of Error vs No. of Groups',
'No. of Groups', 'Size of Error', 2.0, NoCases, 0.0, MaxError,GrpLabels, lReport);
GrpLabels := nil;
YAxis := nil;
XAxis := nil;
end;
lReport.Add('');
lReport.Add(DIVIDER);
lReport.Add('');
if DendoChk.Checked then
begin
TreePlot(clusters,Lst,NoGroups+1, lReport);
lReport.Add('');
lReport.Add(DIVIDER);
lReport.Add('');
end;
DisplayReport(lReport);
finally
lReport.Free;
Lst := nil;
clusters := nil;
GrpErrors := nil;
Scores := nil;
Groups := nil;
NoInGrp := nil;
SubjectIDs := nil;
Distance := nil;
end;
end;
procedure TSingleLinkFrm.TreePlot(const Clusters: IntDyneMat;
const Lst: IntDyneVec; NoPoints: integer; AReport: TStrings);
var
outline: array[0..501] of char;
aline: array[0..82] of char;
valstr: string;
tempstr: string;
plotline: string;
star: char;
blank: char;
col1, col2, colpos1, colpos2: integer;
noparts, startcol, endcol: integer;
Results: StrDyneVec;
ColPos: IntDyneVec;
i, j, k, L, linecount, newcol, howlong, count: integer;
begin
linecount := 1;
star := '*';
blank := ' ';
SetLength(ColPos,NoPoints+2);
SetLength(Results,NoPoints*2+3);
OutputFrm.RichEdit.Lines.Add('');
// store initial column positions of vertical linkages
for i := 1 to NoPoints do ColPos[Lst[i]] := 4 + (i * 5);
// create column heading indented 10 spaces
tempstr := 'UNIT ';
for i := 1 to NoPoints do
begin
valstr := format('%5d',[Lst[i]]);
tempstr := tempstr + valstr;
end;
Results[linecount] := tempstr;
linecount := linecount + 1;
// create beginning of vertical linkages
plotline := 'STEP ';
for i := 1 to NoPoints do plotline := plotline + ' *';
Results[linecount] := plotline;
linecount := linecount + 1;
// start dendoplot
for i := 1 to NoPoints - 1 do
begin
outline := '';
valstr := Format('%5d', [i]); // put step no. first
outline := valstr;
// clear remainder of outline
for j := 5 to (5 + NoPoints * 5) do outline[j] := ' ';
outline[6 + NoPoints * 5] := #0;
col1 := Clusters[i,1];
col2 := Clusters[i,2];
// find column positions for each variable
colpos1 := ColPos[col1];
colpos2 := ColPos[col2];
for k := colpos1 to colpos2 do outline[k] := star;
// change column positions 1/2 way between the matched ones
newcol := colpos1 + ((colpos2 - colpos1) div 2);
for k := 1 to NoPoints do
if ((ColPos[k] = colpos1) or (ColPos[k] = colpos2)) then ColPos[k] := newcol;
for k := 1 to NoPoints do
begin
L := ColPos[k];
if ((L <> colpos1) and (L <> colpos2)) then outline[L] := star;
end;
Results[linecount] := outline;
linecount := linecount + 1;
// add a line of connectors to next grouping
outline := ' ';
for j := 5 to (5 + NoPoints * 5) do outline[j] := blank;
for j := 1 to NoPoints do
begin
colpos1 := ColPos[j];
outline[colpos1] := star;
end;
Results[linecount] := outline;
linecount := linecount + 1;
end;
// output the Results in parts
// determine number of pages needed for whole plot
noparts := 0;
howlong := Length(Results[1]);
noparts := round(howlong / 80.0);
if (noparts <= 0) then
noparts := 1;
if (noparts = 1) then // simply print the list
for i := 0 to linecount - 1 do
AReport.Add(Results[i])
else // break lines into strings of 15 units
begin
startcol := 0;
endcol := 80;
for i := 1 to noparts do
begin
AReport.Add('PART %d OUTPUT', [i]);
for j := 0 to 80 do
aline[j] := blank;
for j := 0 to linecount - 1 do
begin
count := 0;
outline := Results[j];
for k := startcol to endcol do
begin
aline[count] := outline[k];
count := count + 1;
end;
aline[count+1] := #0;
AReport.Add(aline);
end;
AReport.Add('');
startcol := endcol + 1;
endcol := endcol + 80;
if (endcol > howlong) then endcol := howlong;
end;
end;
Results := nil;
ColPos := nil;
end;
procedure TSingleLinkFrm.ScatPlot(const x, y: DblDyneVec; NoCases: Integer;
ATitleStr, XAxisStr, YAxisStr: string; x_min, x_max, y_min, y_max: double;
const VarLabels: StrDyneVec; AReport: TStrings);
var
i, j, l, row, xslot : integer;
maxy: double;
incrementx, incrementy, rangex, rangey, swap : double;
plotstring: array[0..51,0..61] of char;
aheight: integer;
overlap: boolean;
valuestring: string[2];
howlong: integer;
outline: string;
Labels: StrDyneVec;
begin
SetLength(Labels,nocases);
for i := 1 to nocases do Labels[i-1] := VarLabels[i-1];
aheight := 40;
rangex := x_max - x_min ;
incrementx := rangex / 15.0;
rangey := y_max - y_min;
incrementy := rangey / aheight;
{ sort in descending order }
for i := 1 to (nocases - 1) do
begin
for j := (i + 1) to nocases do
begin
if y[i-1] < y[j-1] then
begin
swap := y[i-1];
y[i-1] := y[j-1];
y[j-1] := swap;
swap := x[i-1];
x[i-1] := x[j-1];
x[j-1] := swap;
outline := Labels[i-1];
Labels[i-1] := Labels[j-1];
Labels[j-1] := outline;
end;
end;
end;
AReport.Add(' SCATTERPLOT - ' + ATitleStr);
AReport.Add('');
AReport.Add(YAxisStr);
maxy := y_max;
for i := 1 to 60 do
for j := 1 to aheight+1 do plotstring[j,i] := ' ';
{ Set up the plot strings with the data }
row := 0;
while maxy > y_min do
begin
row := row + 1;
plotstring[row,30] := '|';
if (row = (aheight / 2)) then
for i := 1 to 60 do plotstring[row,i] := '-';
for i := 1 to nocases do
begin
if ((maxy >= y[i-1]) and (y[i-1] > (maxy - incrementy))) then
begin
xslot := round(((x[i-1] - x_min) / rangex) * 60);
if xslot < 1 then xslot := 1;
if xslot > 60 then xslot := 60;
overlap := false;
str(i:2,valuestring);
howlong := 1;
if (valuestring[1] <> ' ') then howlong := 2;
for l := xslot to (xslot + howlong - 1) do
if (plotstring[row,l] = '*') then overlap := true;
if (overlap) then
plotstring[row,xslot] := '*'
else
begin
if (howlong < 2) then
plotstring[row,xslot] := valuestring[2]
else for l := 1 to 2 do
plotstring[row,xslot + l - 1] := valuestring[l];
end;
end;
end;
maxy := maxy - incrementy;
end;
{ print the plot }
for i := 1 to row do
begin
outline := ' |';
for j := 1 to 60 do
outline := outline + Format('%1s', [plotstring[i,j]]);
outline := outline + Format('|-%6.2f-%.2f', [
y_max - i * incrementy,
y_max - i * incrementy + incrementy
]);
AReport.Add(outline);
end;
outline := '';
for i := 1 to 63 do outline := outline + '-';
AReport.Add(outline);
outline := '';
for i := 1 to 16 do outline := outline + ' | ';
outline := outline + XAxisStr;
AReport.Add(outline);
outline := '';
for i := 1 to 16 do
outline := outline + Format('%4.1f', [x_min + i * incrementx - incrementx]);
AReport.Add(outline);
AReport.Add('');
AReport.Add('Labels:');
for i := 1 to nocases do
AReport.Add('%4d: %s', [i, Labels[i-1]]);
Labels := nil;
end; { of scatplot procedure }
procedure TSingleLinkFrm.UpdateBtnStates;
begin
VarInBtn.Enabled := (VarList.ItemIndex > -1) and (VarSelEdit.Text = '');
VarOutBtn.Enabled := (VarSelEdit.Text <> '');
end;
initialization
{$I singlelinkunit.lrs}
end.
Reference in New Issue View Git Blame Copy Permalink