where : ibrtses delphi
Delphi - histogram
disclaimer
the source code of this page may not appear correctly in certain browsers
due to special characters. Have a look at the source of this HTML page
with notepad instead
A histogram is onedimensional statistical display. It displays a count
value against a parameter. The parameter here is integer. The counts are
also integer. This component relies on an external TImage, where it is
displayed. It uses a variable array for D3 compatibility.
Besides the defined number of slots, there are two addional ones,
one for lower and one for higher values than defined by min/max.
They can be included (includebound) and appear as red bars.
Use it as :
histimage:TImage; // is setup somewhere
myhist:=TIntHistogram.create(101,0,100,histimage); // 101 slots from 0..100, onto histimage
for i:=.. to .. do begin // loop over samples
myhist.addvalue(q); // q is the parameter of the histogram
end;
myhist.display;
myhist.movetomemo(memo1); // get the numbers as list
myhist.destroy;
the unit
unit Histogramm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,ExtCtrls,VArrays;
type
TIntHistogramm = class(tobject)
private
{ Private declarations }
hv:intarray;
fslots:integer;
fmin,fmax:integer;
fover,funder:integer;
fdx:double;
ft:TImage;
finclude:boolean;
protected
{ Protected declarations }
function getvalue(index:integer):integer;
function getpeak:integer;
function getsum:integer;
public
{ Public declarations }
property values[index:integer]:integer read getvalue; default;
constructor create(slots:integer;min,max:integer;T:TImage);
destructor destroy; override;
procedure addvalue(q:integer);
procedure addvalues(x,y:integer);
procedure display;
procedure MoveToMemo(m:TMemo);
procedure clear;
published
{ Published declarations }
property peak:integer read getpeak;
property sum:integer read getsum;
property includebound:boolean read finclude write finclude;
property under:integer read funder;
property over:integer read fover;
end;
procedure Register;
implementation
//............................................................................
function TIntHistogramm.getvalue(index:integer):integer;
begin
result:=hv[index];
end;
constructor TIntHistogramm.create(slots:integer;min,max:integer;T:TImage);
begin
inherited create;
fslots:=slots;
hv:=IntArray.create(slots);
hv.clear;
fmin:=min; fmax:=max;
fdx:=(fmax-fmin+1)/fslots;
ft:=t;
finclude:=true;
end;
destructor TIntHistogramm.destroy;
begin
hv.destroy;
end;
procedure TIntHistogramm.addvalue(q:integer);
var i:integer;
begin
if (q>fmax) then inc(fover);
if (q=fmin)and(q<=fmax) then begin
i:=round(fslots*(q-fmin)/(fmax-fmin+1));
hv[i]:=hv[i]+1;
end;
end;
procedure TIntHistogramm.addvalues(x,y:integer);
var i:integer;
begin
if (x>fmax) then inc(fover);
if (x=fmin)and(x<=fmax) then begin
i:=round(fslots*(x-fmin)/(fmax-fmin+1));
hv[i]:=hv[i]+round(y);
end;
end;
function TIntHistogramm.getpeak:integer;
var i,j:integer;
begin
j:=0;
for i:=0 to fslots-1 do begin
if (hv[i]>j) then j:=hv[i];
end;
if (finclude)and(fover>j) then j:=fover;
if (finclude)and(funder>j) then j:=funder;
result:=j;
end;
function TIntHistogramm.getsum:integer;
var i,j:integer;
begin
j:=0;
for i:=0 to fslots-1 do begin
j:=j+hv[i];
end;
if (finclude)then j:=j+fover;
if (finclude)then j:=j+funder;
result:=j;
end;
procedure TIntHistogramm.display;
var x,y,i,j:integer;
dx,dy:single;
begin
ft.canvas.pen.color:=clwhite;
ft.canvas.brush.color:=clwhite;
ft.canvas.rectangle(0,0,ft.width-1,ft.height-1);
ft.canvas.brush.color:=clblack;
ft.canvas.pen.color:=clblack;
j:=getpeak;
if j>0 then begin
dy:=ft.height/j;
if (finclude) then dx:=ft.width/(fslots+2)
else dx:=ft.width/fslots;
if (finclude) then begin
for x:=0 to fslots-1 do begin
y:=round(hv[x]*dy);
ft.canvas.rectangle(round((x+1)*dx),ft.height-y-1,round((x+2)*dx),ft.height-1);
end;
ft.canvas.brush.color:=clred;
ft.canvas.pen.color:=clred;
y:=round(funder*dy);
ft.canvas.rectangle(0,ft.height-y-1,round(dx),ft.height-1);
y:=round(fover*dy);
ft.canvas.rectangle(round(ft.width-dx-1),ft.height-y-1,ft.width-1,ft.height-1);
end
else begin
for x:=0 to fslots-1 do begin
y:=round(hv[x]*dy);
ft.canvas.rectangle(round(x*dx),ft.height-y,round((x+1)*dx),ft.height-1);
end;
end; // else
end;
end;
procedure TIntHistogramm.MoveToMemo(m:TMemo);
var i:integer;
s:string;
begin
m.clear;
m.lines.add(' ');
for i:=0 to fslots-1 do begin
s:=format('slot %4d %6d %6d %4d',[i,round(fmin+i*fdx),round(fmin+(i+1)*fdx),hv[i]]);
m.lines.add(s);
end;
end;
procedure TIntHistogramm.clear;
begin
hv.clear;
fover:=0;funder:=0;
end;
procedure Register;
begin
//RegisterComponents('Samples', [THistogramm]);
end;
end.
improvements
a mouse writing the values to a provided label could be handy.
integrating values inside a selectable window could also be thought of.
Feedback is welcome
sponsored links
Delphi
home
last updated: 11.dec.99
Copyright (99,2000) Ing.Büro R.Tschaggelar