const
{$IFDEF PAIDVERS}
SDLVersionInfo = 'dendrogram_r1210_full';
IsLightEd = false;
{$ELSE}
SDLVersionInfo = 'dendrogram_r1210_lighted';
IsLightEd = true;
{$ENDIF}
Release = 1210;
type
ESDLDendrogramError = class(ESDLError);
TMarkedObjType = (motNone, motBoldFoot, motTriangle);
TDendroShowObjLblEvent = procedure (Sender: TObject; Obj: integer;
var Text: string; var Color: TColor) of object;
{$IFDEF GE_LEV29}
[ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidWin64x)]
{$ENDIF}
TDendrogram = class (TCustomControl)
private
FFrameStyle : TFrameStyle; { style of frame }
FColorDendroBG : TColor; { color of dendrogram background }
FColorDendro : TColor; { color of dendrogram lines }
FColorLabelsBG : TColor; { background color of dendrogram lables }
FColorEmptyArea : TColor; { color of empty area in corner }
FColBlackLine : TColor; { colors to draw the frame }
FColGrayLine : TColor; { -"- }
FColWhiteLine : TColor; { -"- }
FColorScheme : TColorScheme; { color scheme of frames }
FClassColor : array[0..255] of TColor;
FClustDist : TVector;
FClustResult : TIntMatrix;
FCrossHair : TCrossHair;
FDendroCoord : TVector;
FDistMeasure : TDistMode;
FClustMeth : TClusterMethod;
FClassnum : TIntVector;
FFlexAlpha : double;
FScaleDist_k : double;
FScaleDist_d : double;
FScaleObj_k : double;
FScaleObj_d : double;
FMarkedObj : integer;
FMarkedObjType : TMarkedObjType;
FObjLow : double;
FObjHigh : double;
FDistLow : double;
FDistHigh : double;
FObjMargin : integer;
FClPixelCoords : TMatrix;{ pixel coordinates of dendrogram lines }
FZoomState : TZoomState;
FMouseAction : TMouseActMode;
FIsTTFont : boolean;
FForceStaggLbls : boolean;
FMarginIsMoveable: boolean;
FOnZoomPan : TZoomPanEvent;
FOnProgress : TOnPercentDoneEvent;
FOnCalcDist : TOnCalcDistanceEvent;
FOnCrossHMove : TNotifyEvent;
FOnDendroDone : TNotifyEvent;
FOnDendroBegin : TNotifyEvent;
FOnShowObjLbl : TDendroShowObjLblEvent;
FLButWasDown : boolean; { global identifier to track
panning by left mouse button }
FMousePosObj : double;
FMousePosDist : double;
FWindAnchorX : integer;
FWindAnchorY : integer;
FWindOldCornX : integer;
FWindOldCornY : integer;
FMAnchorScrX : integer; { anchor mouse pos. on TRChart canvas }
FMAnchorScrY : integer;
FMAnchorObjLo : double;
FMAnchorDistLo : double;
FMAnchorObjHi : double;
FMAnchorDistHi : double;
FAnchorScaleDist_d: double;
FAnchorScaleObj_d : double;
FHorzScaleHgt : integer;
FVertScaleWid : integer;
FOrientation : TDirection;
FGrafBmp : TBitMap;
FScale : TScale;
FShowClassCols : boolean;
FSuppressPaint : boolean; { TRUE: suppress all paint calls }
FSuppressCA : boolean;
FIsProcessing : boolean;
procedure SetColorSclBg (Value: TColor);
procedure SetColorScl (Value: TColor);
function GetColorSclBg: TColor;
function GetColorScl: TColor;
function GetCrossHair: TCrossHair;
function GetClassColor(cl: integer): TColor;
procedure SetClassColor (cl: integer; color: TColor);
procedure SetShowClassCols (value: boolean);
procedure SetCrossHair (ch: TCrossHair);
procedure SetColorDendroBg (Value: TColor);
procedure SetColorDendro (Value: TColor);
procedure SetColorScheme (Value: TColorScheme);
procedure SetColorLabelsBg (Value: TColor);
procedure SetColorEmptyArea (Value: TColor);
procedure SetOrientation (Value: TDirection);
procedure SetDistMeasure (Value: TDistMode);
procedure SetFlexAlpha (Value: double);
procedure SetFrameStyle (value: TFrameStyle);
procedure SetForceStaggLbls (value: boolean);
procedure SetMarginIsMoveable (value: boolean);
procedure SetHorzScaleHgt (value: integer);
procedure SetVertScaleWid (value: integer);
procedure SetMarkedObj (value: integer);
procedure SetMarkedObjType (value: TMarkedObjType);
procedure SetObjMargin (value: integer);
procedure SetObjLow (value: double);
procedure SetObjHigh (value: double);
procedure SetDistLow (value: double);
procedure SetDistHigh (value: double);
procedure SetClusterMethod (value: TClusterMethod);
procedure SetSuppressPaint (supp: boolean);
procedure SetSuppressCA (supp: boolean);
function GetDecPlaces: integer;
procedure SetDecPlaces (value: integer);
function PosOnDendroArea (X, Y: integer): boolean;
protected
procedure CreateWnd; override;
procedure FontHasChanged (Sender: TObject);
procedure MouseMove (Shift: TShiftState; X,Y: integer); override;
procedure Paint; override;
procedure ConstructDendrogram (cv: TCanvas);
function RevScaleDist (DistPix: integer): double;
function RevScaleObj (ObjPix: integer): double;
function ScaleObj (Obj: double): integer;
function ScaleDist (Dist: double): integer;
procedure AdjustScalePars;
procedure MouseDown (Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp (Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure DoZoomPanEvent;
procedure DoClusterAnalysis;
procedure DoOnPercentDone (Sender: TObject; PercDone: double);
procedure SetClassSubTreeIntern (ClustIx, ClassNr: integer);
procedure StyleChanged (Sender: TObject);
procedure DataChanged (Sender: TObject);
procedure Loaded; override;
public
Data: TDataTable; // public access to data table
procedure AutoRange;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function CalcClasses (Threshold: double): boolean;
{$IFDEF DEVELOPVERS}
{$I intf_dendrogram_futurevers.pas}
{$ENDIF}
property ClassColors[cl: integer]: TColor
read GetClassColor write SetClassColor;
property ClustDist: TVector read FClustDist;
property ClustResult: TIntMatrix read FClustResult;
procedure CopyToClipboard (IncludeFrame: boolean);
procedure CopyToBMP (FName: string; IncludeFrame: boolean);
procedure CopyToBitmap (ABitmap: TBitmap; IncludeFrame: boolean);
function FindObject (ObjCoord: integer): integer;
function FindClusterAtPos (X,Y: integer): integer;
property IsProcessing: boolean read FIsProcessing;
property MarkedObject: integer read FMarkedObj write SetMarkedObj;
property MarkedObjType: TMarkedObjType
read FMarkedObjType write SetMarkedObjType;
property MousePosObj: double read FMousePosObj;
property MousePosDist: double read FMousePosDist;
procedure RetrieveClusterClasses;
procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
procedure SetClassSubTree (ClustIx, ClassNr: integer);
procedure SetRange (ObjLow, ObjHigh, DistLow, DistHigh: double);
procedure StoreProtocol (FName: string); overload;
property SuppressPaint: boolean
read FSuppressPaint write SetSuppressPaint;
property SuppressClustAnal: boolean
read FSuppressCA write SetSuppressCA;
property ZoomState: TZoomState read FZoomState;
published
property Align;
property Anchors;
property ClusterMethod: TClusterMethod
read FClustMeth write SetClusterMethod;
property ColorScale: TColor read GetColorScl write SetColorScl;
property ColorScaleBackGnd: TColor
read GetCOlorSclBG write SetColorSclBg;
property ColorDendrogram: TColor
read FColorDendro write SetColorDendro;
property ColorLabelsBG: TColor
read FColorLabelsBG write SetColorLabelsBg;
property ColorEmptyArea: TColor
read FColorEmptyArea write SetColorEmptyArea;
property ColorDendrogramBackGnd: TColor
read FColorDendroBG write SetColorDendroBg;
property ColorScheme: TColorScheme
read FColorScheme write SetColorScheme;
property CrossHair: TCrossHair read GetCrossHair write SetCrossHair;
property DecPlaces: integer read GetDecPlaces write SetDecPlaces;
property DistHigh: double read FDistHigh write SetDistHigh;
property DistLow: double read FDistLow write SetDistLow;
property DistMeasure: TDistMode
read FDistMeasure write SetDistMeasure;
property Enabled;
property FlexAlpha: double read FFlexAlpha write SetFlexAlpha;
property Font;
property ForceStaggeredLabels: boolean
read FForceStaggLbls write SetForceStaggLbls;
property FrameStyle: TFrameStyle
read FFrameStyle write SetFrameStyle;
property Margin: integer read FObjMargin write SetObjMargin;
property MarginIsMoveable: boolean
read FMarginIsMoveable write SetMarginIsMoveable;
property MouseAction: TMouseActMode
read FMouseAction write FMouseAction;
property ObjHigh: double read FObjHigh write SetObjHigh;
property ObjLow: double read FObjLow write SetObjLow;
property Orientation: TDirection
read FOrientation write SetOrientation;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ScaleWidth: integer
read FHorzScaleHgt write SetHorzScaleHgt;
property ScaleHeight: integer
read FVertScaleWid write SetVertScaleWid;
property ShowClassColors: boolean
read FShowClassCols write SetShowClassCols;
property ShowHint;
{$IFDEF GE_LEV17}
property StyleElements;
{$ENDIF}
property Visible;
property OnZoomPan: TZoomPanEvent read FOnZoomPan write FOnZoomPan;
property OnClick;
property OnDblClick;
property OnMouseMove;
property OnMouseDown;
property OnMouseUp;
property OnBeforeShowObjLabel: TDendroShowObjLblEvent
read FOnShowObjLbl write FOnShowObjLbl;
property OnCrossHairMove: TNotifyEvent
read FOnCrossHMove write FOnCrossHMove;
property OnDendroBegin: TNotifyEvent
read FOnDendroBegin write FOnDendroBegin;
property OnDendroDone: TNotifyEvent
read FOnDendroDone write FOnDendroDone;
property OnProgress: TOnPercentDoneEvent
read FOnProgress write FOnProgress;
property OnCalcDistance: TOnCalcDistanceEvent
read FOnCalcDist write FOnCalcDist;
end;
|